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

\n

User Guide to the\n

OpenCalphad software package\n

version 7.0\n

DRAFT\n

Bo Sundman, March 23, 2021\n

\n

Updates of OC User Guide\n

\n

Earlier versions of OC had no User Guide\n

\n \n \n

This page intentionally blank\n

\n \n \n

Contents

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

\n \n \n

1 Introduction

\n

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

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

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

\n

2 Some general features

\n

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

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

\n

2.1 Command line user interface

\n

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

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

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

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

\n

2.1.1 Command line editing and history
\n

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

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

\n

2.1.2 Popup window for read/save
\n

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

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

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

\n

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

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

\n

2.1.3 On-line help
\n

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

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

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

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

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

\n

2.1.4 Environment and startup macro file
\n

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

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

\n

2.1.5 Macro files
\n

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

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

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

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

\n

Comments, stops and questions in macro files\n \n \n
\n

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

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

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

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

\n

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

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

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

Macro files can be nested 5 levels deep.\n

\n

2.1.6 User interface feedback
\n

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

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

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

\n

2.2 Names and symbols

\n

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

\n

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

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

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

\n

2.3 Elements, species, components, constituents and system

\n

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

\n \n \n

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

\n
\n\"μH2O
\n
to set a condition on a sum of chemical potential of the elements.\n

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

\n

2.4 Phases, composition sets and phase tuples

\n

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

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

\n

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

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

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

\n

2.5 The use of wildcards for phase names

\n

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

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

\n

2.6 State variables

\n
\n \n \n

\n \n \n
Table 1: A preliminary table with the state variables and their internal representation. Some model\nparameter properties are also included. The ”z” used in some symbols like Sz means the optional\nnormalizing symbol M, W, V or F. There is some redundancy, for example NM(FE) is the same as\nX(FE).
\n
\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
Symbol 
Id
Index
Normalizing Meaning
A z 1 2 suffix
Intensive properties
\n
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
\n
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
\n
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
\n \n \n
\n
\n

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

2.6.1 Some pecularites of the state variable values
\n

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

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

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

\n

2.6.2 The driving force
\n

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

\n \n \n

2.7 Thermodynamic databases

\n

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

\n

2.8 Model parameters

\n

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

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

The basic syntax of a parameter is\n

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

These parts are explained in more detail below.\n

\n

2.8.1 Model Parameter Identifiers
\n

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

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

\n \n \n

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

\n \n \n

\n
\n

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

A slightly more detailed explanation of the identifiers are:\n

\n

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

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

2.8.2 Constituent array and degrees
\n

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

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

G(GAS,C1O2)\n

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

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

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

An interaction between vacancies and carbon in the austenite is\n

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

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

\n

2.8.3 Ternary extrapolations
\n

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

\n
\n\"
\n
where the degree, ν, of the interaction parameter is specified after a semicolon, L(phase,A,B;ν).\n

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

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

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

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

\n

2.8.4 The TPFUN expression and bibliographic reference
\n

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

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

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

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

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

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

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

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

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

\n

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

\n

2.9 The reference state of a component

\n

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

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

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

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

\n

2.10 Equilibrium calculations

\n

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

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

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

\n

2.11 Property diagrams

\n

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

\n

2.12 Phase diagrams

\n

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

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

\n

2.13 Diagrams simulating phase transformations

\n

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

\n

2.13.1 Scheil-Gulliver solidification model
\n

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

\n

2.13.2 Paraequilibrium calculation
\n

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

\n

2.13.3 Tzero calculation
\n

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

\n

2.14 Assessment of model parameters for databases

\n

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

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

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

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

\n

2.14.1 Entering coefficients to be assessed
\n

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

\n

2.14.2 Entering phases and model parameters
\n

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

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

\n

2.14.3 Entering experimental data
\n

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

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

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

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

\n

2.14.4 Saving the state of the assessment
\n

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

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

\n

2.14.5 Performing the assessment
\n

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

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

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

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

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

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

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

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

\n

2.15 Application software

\n

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

\n \n \n

\n

3 The command menu

\n

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

\n\n\n\n\n \n
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 *
\n

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

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

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

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

\n

3.1 Options

\n

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

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

list /out=equil5 result 2\n

Only a few options are implemented.\n

\n

\n

4 About

\n

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

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

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

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

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

\n

5 Amend

\n

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

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

The default selection is PHASE.\n

\n

5.1 Amend assessment result

\n

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

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

\n

\n

5.2 amend Bibliography

\n

Reference identifier:\n

The text for bibliographic reference identifier can be amended. The reference identifier is CASE\nINsensitive.\n

Reference text, end with “;”:\n

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

\n

5.3 amend Components

\n

Give all new components:\n

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

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

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

\n \n \n

5.4 amend Constitution

\n

Phase name:\n

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

Amount of phase:\n

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

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

Fraction of component:\n

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

\n

5.5 amend Element

\n

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

\n

5.6 amend Equilirium

\n

Not sure what could be amended and anyway not implemented.\n

\n

5.7 amend General

\n

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

\n

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

\n

5.8 amend Line

\n

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

Only excluded? /Y/:\n

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

Exclude this line? /N/:\n

For an included line you can exclude from the plot.\n

Include this line? /N/:\n

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

\n

5.9 amend All optimizing coefficients

\n

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

\n

5.10 amend Parameter

\n

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

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

\n

5.11 amend for Phase “phase-name”

\n

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

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

Phase name:\n

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

\n\n \n
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
\n

\n

5.11.1 amend phase “phase-name” Addition
\n

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

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

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

Per formula unit?\n

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

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

\n \n \n

amend phase ... addition Elastic_model_1\n
\n

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

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

\n

5.11.2 amend phase ... Gaddition
\n

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

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

\n

amend phase ... addition LowT_Cp_model\n
\n

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

\n

amend phase ... addition Magnetic_contrib\n
\n

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

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

Antiferromagnetic factor:\n

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

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

\n

amend phase ... addition Quit\n
\n

You did not really wanted to add any addition.\n

\n

amend phase ... addition Schottky_anomaly\n
\n

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

\n

amend phase ... addition Smooth-Cp-step\n
\n

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

\n

amend phase ... addition Twostate-liquid\n
\n

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

Is G2 composition dependent? /Y/:\n

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

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

The implementation of this addition is not finished.\n

\n

5.11.3 amend phase ... Aqueous-model
\n

A model with dilute configurational entropy. Not implemented yet.\n

\n

5.11.4 amend phase ... BCC-permutations
\n

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

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

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

\n

5.11.5 amend phase ... Composition set
\n

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

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

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

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

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

\n

5.11.6 amend phase ... Default Constitution
\n

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

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

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

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

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

\n

5.11.7 amend phase ... Diffusion
\n

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

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

\n

5.11.8 amend phase ... Disordered fraction sets
\n

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

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

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

\n

5.11.9 amend phase ... FCC_CVM_tetradrn
\n

This model is intended for the CVM tetrahedron model for FCC and HCP. Not implemented\nyet.\n

\n

5.11.10 amend phase ... FCC_permutations
\n

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

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

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

\n

5.11.11 amend phase ... Quasichemical
\n

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

None of them are yet implemented.\n

\n

5.11.12 amend phase ... Quit
\n

Do not amend anything for the phase.\n

\n \n \n

5.11.13 amend phase ... ternary-extrapolation
\n

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

Ternary extrapolation (K, T or Q to quit)\n

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

Second constituent: and
Third constituent\n

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

\n

5.11.14 amend phase ... UNIQUAC
\n

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

\n

5.12 amend Quit

\n

Do not amend anything (more).\n

\n

5.13 amend redundant-sets

\n

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

\n

5.14 amend for Species

\n

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

UNIQUAC surface area (q) /1/:\n

UNIQUAC segments (r) /1/:\n

These two parameters are necessary to calculate the configurational entropy of the UNIQUAC\nmodel.\n

\n

5.15 amend Symbol

\n

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

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

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

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

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/:\n

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

If you specify X you will be asked\n

Specify equilibrium number:\n

\n

5.16 amend Tpfunction

\n

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

\n

6 Back

\n

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

\n

7 Calculate

\n

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

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

\n

7.1 calculate All equilibria

\n

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

This command can be looped to measure calculation times.\n

\n

7.2 calculate Bosses-method or Carefully

\n

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

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

\n

7.3 calculate Equilibrium

\n

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

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

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

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

\n

7.4 calculate Global-Gridmin

\n

\n

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

\n

7.5 calculate No-Global

\n

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

\n

7.6 calculate Paraequilibrium

\n

The paraequilibrium is described in section 2.13.2.\n

Matrix phase:\n

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

Growing phase:\n

Fast diffusing element:\n

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

\n

7.7 calculate Phase “phase-name”

\n

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

Phase name:\n

Amount of phase:\n

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

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

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

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

\n

7.7.1 calculate phase ... All-Derivatives
\n

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

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

\n \n \n

7.7.2 calculate phase ... Constitution_Adjust
\n

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

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

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

\n

7.7.3 calculate phase ... Diffusion_Coefficients
\n

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

\n
\n\"
\n
for all components (see the documentation of the minimiser) and also all mobility values (if there are\nany).\n

\n

7.7.4 calculate phase ... G_and_dGdy
\n

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

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

\n \n \n
\n\"
\n
where G is the integral Gibbs energy and all Ni are independent variables. When we model the molar Gibbs\nenergy, Gm as a function of the constituent fractions, yi, these fractions are not independent and for a\nsubstitutional model, where yi = xi i.e. the mole fractions, the chemical potential is calculated from Gm\nusing:
\n
\n\"
\n
because the mole fractions, xi are not independent.\n

\n

7.7.5 calculate phase ... Only-G
\n

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

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

\n

7.7.6 calculate phase ... Quit
\n

Do not calculate anything for the phase.\n

\n \n \n

7.8 calculate Quit

\n

Do not calculate anything at all.\n

\n

7.9 calculate Symbol

\n

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

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

\n

7.10 calculate Tpfun-Symbols

\n

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

\n

7.11 calculate Transition

\n

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

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

\n

7.12 calculate Tzero point

\n

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

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

\n

7.13 calculate with check after

\n

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

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

\n

8 Debug

\n

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

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

\n

8.1 debug Elasticity

\n

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

\n

8.2 debug Free lists

\n

Only for experts.\n

\n

8.3 debug Map-startpoints

\n

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

\n \n \n

8.4 debug Symbol value

\n

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

\n

8.5 debug Stop_on_Error

\n

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

However, it is not implemented.\n

\n

9 Delete

\n

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

\n \n
COMPOSITION_SET EQUILIBRIUM QUIT STEP_MAP_RESULTS
ELEMENTS PHASE SPECIES 
\n

\n

9.1 delete Composition set

\n

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

\n

9.2 delete Element

\n

Dangerous and will probably never be implemented.\n

\n \n \n

9.3 delete Equilibrium

\n

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

\n

9.4 delete Phase

\n

Dangerous and will probably never be implemented.\n

\n

9.5 delete Quit

\n

Do not delete anything.\n

\n

9.6 delete Species

\n

Not implemented yet and will probably never be.\n

\n

9.7 delete Step_Map_Results

\n

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

\n

10 Enter

\n

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

A species have a fixed stoichiometry and possibly a charge. The species are the constituents of the\nphases.\n

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

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

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

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

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

The subcommands are:\n

\n\n\n\n
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
\n
\n

\n

10.1 enter Bibliography

\n

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

Reference identifier:\n

The text for bibliographic reference identifier can be amended. The reference identifier is case\ninsensitive.\n

Reference text, end with “;”:\n

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

\n

10.2 enter Comment

\n

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

\n

10.3 enter Constitution

\n

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

\n

10.4 enter Copy of equilibrium

\n

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

Must be used with care.\n

\n

10.5 enter Element

\n

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

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

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

\n

10.6 enter Equilibrium

\n

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

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

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

\n

10.7 enter Experiment

\n

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

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

\n

10.8 enter GNUPLOT Terminal

\n

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

The terminals listed in the table depend on your installation.\n

\n\n\n\n\n
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
\n
\n

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

\n

10.9 enter Many Equilibria

\n

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

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\n \n \nitalics.\n

\n

\n \n \n

For the rows in the table the user must first provide a unique name for each equilibrium (that is counted as\ncolumn 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
\n

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

\n

10.10 enter Material

\n

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

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

\nOC4:enter mat\nDatabase:steel7\nElements: C , MO, V , CR, FE, SI,\nMajor element or material:fe\nInput in mass percent? /Y/:\nInput expected in mass percent\n\nFirst alloying element:c\nMass percent: /1/:\nSecond alloying element:cr\nMass percent: /1/: 5\nThird alloying element:mo\nMass percent: /1/: 8\nNext alloying element:v\nMass percent: /1/:\nNext alloying element:\n 3E reading a TDB file\n 3D em:  W%(C)=1  W%(CR)=5  W%(MO)=8  W%(V)=1   N=1\nTemperature /1000/:\n 3Y Constitution of metastable phases set\n 3Y Composition set(s) created:            1\nGridmin:   18846 points   6.25E-02 s and      78 clockcycles, T= 1000.00\nPhase change: its/add/remove:     5    0   21\nEquilibrium calculation   19 its,   6.2500E-02 s and      94 clockcycles\n\n
\n

\n

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

\n

10.11 enter Optimizing coefficient

\n

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

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

\n

10.12 enter Parameter

\n

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

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

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

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

For phases with sublattices the constituents in each sublattice are separated by a colon, “:” and interacting\nconstituents 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\nphase.\n

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

\n

10.13 enter Phase

\n

The user must specify a unique phase name:\n

Phase name:\n

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

Phase model:\n

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

\n

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

Number of sublattices:\n

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

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

Number of sites on a sublattice\n

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

Models with bonds\n

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

\n

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

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

\n

10.14 enter Plot_data

\n

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

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

\n

10.15 enter Quit

\n

Quit entering things.\n

\n

10.16 enter Species

\n

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

\n

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

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

\n \n \n

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

Species symbol:\n

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

Species stoichiometry:\n

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

\n

10.17 enter Symbol

\n

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

The symbols are designed to handle relations between state variables, you can define expressions like\n
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.\n

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

enter symbol CP = H.T;\n

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

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

\n

10.18 enter Tpfun_Symbol

\n

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

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

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

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

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

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

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

\n
\n\"1.5*
\n
and first and second derivatives of that with respect to T. It is the Einstein heat capacity function integrated\nto a Gibbs energy. The argument THETA should the the Einsten themperature and must be a positive\nconstant.\n

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

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

\n

11 Exit

\n

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

\n

12 Fin

\n

Terminate the OC software in French, Au revoir.\n

\n \n \n

13 Help and ?

\n

Which command:\n

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

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

\n

14 HPcalc

\n

Start the reverse polish calculator.\n

\n

15 Information

\n

on the following topics:\n

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

This command is still not fully implemented.\n

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

Topic? /CHANGES/:\n

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

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

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

\n

16 List

\n

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

\n\n\n\n
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
\n
\n

\n

16.1 list active-equilibria

\n

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

\n

16.2 list Axis

\n

Lists the axis set by you.\n

\n

16.3 list Bibliography

\n

List the bibliographic references for the data.\n

\n

16.4 list Conditions

\n

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

\n

16.5 list Data

\n

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

The only format implemented at present is SCREEN.\n

\n

16.5.1 list data LaTeX
\n \n \n

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

\n

16.5.2 list data Macro
\n

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

\n

16.5.3 list data PDB
\n

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

\n

16.5.4 list data TDB
\n

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

\n

16.6 list Equilibria

\n

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

\n

16.7 list Error message

\n

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

\n

16.8 list Line equilibria

\n

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

\n \n \n

16.9 list Model parameter identifiers

\n

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

\n

16.10 list Model parameter value

\n

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

\n

16.11 list optimization

\n

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

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

This gives a list of the coefficients and their values.\n

\n

16.11.2 list optimization debug
\n

Not implemented yet.\n

\n

16.11.3 list optimization correlation_matrix
\n

Not implemented yet.\n

\n

16.11.4 list optimization experiments
\n \n \n

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

\n

16.11.5 list optimization graphics
\n

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

\n

16.11.6 list optimization long
\n

Not implemented yet\n

\n

16.11.7 list optimization macro
\n

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

\n

16.11.8 list optimization short
\n

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

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

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

\nListing of optimization results: date 2018.08.20 : 12h47\n\nList of coefficients with non-zero values\nName  Current value  Start value   Scaling factor RSD          Used in\nA11     3.46818E+02   4.00095E+02   4.00095E+02   1.25070E-06  _GFCCAB0\nA12    -5.66234E+01  -6.52871E+01  -6.52871E+01   1.33802E-06\nA13    -2.10028E-02  -1.30393E-02  -1.30393E-02   8.97167E-06  _GFCCAB0\n\nList of     4 equilibria with     8 experimental data values\n  No Equil name    Weight Experiment $ calculated                   Error\n   2 FCC1_ZA        1.00 SM=17:1 $ 17                               9.8995E-09\n   2                1.00 CP1=18:1 $ 17.28685                        7.1315E-01\n   3 FCC2_ZB        1.00 HDIFF=9000:500 $ 9997.813                 -1.9956E+00\n   3                1.00 CP1=20:DCP $ 22.55698                     -2.5570E-02\n   4 FCC3_ZC        1.00 HDIFF=15000:500 $ 14719.24                 5.6152E-01\n   4                1.00 CP1=22:DCP $ 24.65726                     -2.6573E-02\n   5 FCC4_ZD        1.00 HDIFF=20000:500 $ 19860.72                 2.7856E-01\n   5                1.00 CP1=24:DCP $ 26.75754                     -2.7575E-02\n\nFinal sum of squared errors:      4.88614E+00 using    8 experiments and\n  3 coefficient(s).  Degrees of freedom:    5, normalized error:    9.7723E-01\n
\n

\n

In the list of equilibria with non-zero weight the first column is a sequential equilibrium number assigned by\nthe software. Then the name of the equilibrium assigned by the user. The third column is the weight, only\nequilibria with nonzero weight are listed. Then comes a columm with the experimental property\nand value and after the dollar sign its calculated value with the present set of coefficients. The\nrightmost column gives the difference for each experiment i,qi that should be as close to zero as\npossible:\n
\n
\n\"
(3)
\n \n \n

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

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

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

\n

16.12 list Parameter

\n

List a specific parameter.\n

\n

16.13 list Phase “phase-name”

\n

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

\n

16.13.1 list phase ... Constitution
\n

List the constitution of the phase.\n

\n

16.13.2 list phase ... Data
\n

List the model and model parameter expressions.\n

\n

16.13.3 list phase ... Model
\n

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

\n

16.14 list Quit

\n

You did not really want to list anyting.\n

\n

16.15 list Results

\n

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

There are 9 options for the formatting:\n

\n

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

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

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

\n

16.16 list Short

\n

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

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

The C option lists one line for each component.\n

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

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

\n

16.17 list State_Variables

\n

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

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

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

\n

16.18 list Symbols

\n

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

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

\n

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

\n

16.19 list excell CSV file

\n

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

Independent variable:\n

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

Dependent variable(s):\n

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

Output file:\n

\n

16.20 list Tpfun Symbols

\n

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

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

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

\n

17 Macro

\n

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

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

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

\n

18 Map

\n

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

Reinitiate?\n

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

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

\n

19 New

\n

\n

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

The user must confirm with UPPER CASE Y.\n

\n \n \n

20 Optimize

\n

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

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

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

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

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

\n

21 Plot

\n

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

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

\n

21.1 plot Horizontal axis variable

\n

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

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

\n \n \n

21.2 plot xaxis Vertical axis variable

\n

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

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

\n

21.3 plot xaxis yaxis Options?/RENDER/

\n

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

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

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

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

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

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

A short summary:\n

\n

The EXTRA command provides less used options:\n

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

\n

21.4 plot xaxis yaxis Append

\n

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

\n

21.5 plot xaxis yaxis Axis_Labels

\n

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

For X or Y axis?\n \n \n

Specify the axis for which you want to enter the label\n

Axis label:\n

The default label is given in the question.\n

\n

21.6 plot xaxis yaxis Font

\n

\n

21.7 plot xaxis yaxis Graphics format

\n

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

Graphics format index:\n

The default terminal indices are:\n

\n\n\n\n\n
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
\n
\n

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

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

Plot file:\n

In addition to the GNUPLOT command file the graphics a file with the specified format will be\ngenerated.\n

\n

21.8 plot xaxis yaxis Output file

\n

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

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

\n

21.9 plot xaxis yaxis Position of keys

\n

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

\n

21.10 plot xaxis yaxis Quit

\n

No plot generated.\n

\n

21.11 plot xaxis yaxis Render

\n

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

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

\n

21.12 plot xaxis yaxis Scale_Range

\n

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

\n

21.13 plot xaxis yaxis Text

\n

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

\n

21.13.1 plot xaxis yaxis text Modify existing text?:
\n \n \n

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

\n

21.13.2 plot xaxis yaxis text Which text index?:
\n

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

For a new or changed text you must give:\n

\n

21.13.3 plot xaxis yaxis text X position
\n

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

\n

21.13.4 plot xaxis yaxis text Y position
\n

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

\n

21.13.5 plot xaxis yaxis text Fontscale
\n

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

\n

21.13.6 plot xaxis yaxis text Angle (degrees)
\n

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

\n

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

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

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

\n

21.13.8 plot xaxis yaxis text Text:
\n

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

\n

21.14 plot xaxis yaxis Title

\n

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

\n

21.15 plot xaxis yaxis Extra

\n

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

The EXTRA commands provides more obscure options:\n

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

\n

21.15.1 plot xaxis yaxis extra factor
\n

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

\n

21.15.2 plot xaxis yaxis extra color
\n

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

\n

21.15.3 plot xaxis yaxis extra Gibbs-triangle
\n

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

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

\n \n \n

21.15.4 plot xaxis yaxis extra line-with-symbols
\n

Not implemented yet\n

\n

21.15.5 plot xaxis yaxis extra logscale
\n

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

\n

21.15.6 plot xaxis yaxis extra manipulate lines
\n

This is not implemented. It is intended to allow specification of the color of the curves in the\nplot.\n

\n

21.15.7 plot xaxia yaxis extra lower left corner text
\n

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

\n

21.15.8 plot xaxia yaxis extra spawn
\n

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

\n

21.15.9 plot xaxia yaxis extra no heading
\n

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

\n

21.15.10 plot xaxis yaxis extra pause option
\n

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

\n

21.15.11 plot xaxis yaxis extra ratios XY
\n

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

\n

21.15.12 plot xaxis yaxis extra tie-line
\n

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

Tie-line plot increment?\n

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

\n

22 Quit

\n

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

\n

23 Read

\n

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

\n \n
DIRECT QUIT  TDB
PDB SELECTED-PHASESUNFORMATTED
\n

\n

23.1 read Direct

\n

File name:\n

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

\n \n \n

23.2 read PDB

\n

File name:\n

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

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

\n

23.3 read Quit

\n

You did not really want to read anything.\n

\n

23.4 read selected phases only

\n

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

Database format:\n

Can be TDB or PDB.\n

File name:\n

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

\n

23.5 read TDB

\n

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

File name:\n

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

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

Select elements /all/:\n

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

Select elements /no more/:\n

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

Error reading TDB file\n

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

\n

23.6 read Unformatted

\n

File name:\n

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

\n

24 Save

\n

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

\n
DIRECT SOLGAS UNFORMATTED
QUIT TDB PDB
\n
\n

\n

24.1 save Direct

\n

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

\n

24.2 save Quit

\n \n \n

You did not want to save anything.\n

\n

24.3 save PDB

\n

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

\n

24.4 save TDB

\n

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

\n

24.5 save SOLGAS

\n

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

\n

24.6 save Unformatted

\n

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

\n

25 Select

\n

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

\n

25.1 select Equilibrium

\n \n \n

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

\n

25.2 select Graphics

\n

Only GNUPLOT citegnuplot available.\n

\n

25.3 select Language

\n

Only English implemented (except a few French exclamations).\n

\n

25.4 select Minimizer

\n

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

\n

25.5 select Optimizer

\n

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

\n

26 Set

\n

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

\n\n\n\n\n
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
\n

\n

26.1 set Advanced

\n \n \n

A few options implemented\n

\n\n
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
\n
\n

\n

26.1.1 set advanced EEC-method
\n

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

This command will activate or deactivate this check.\n

\n

26.1.2 set advanced equilibrium transfer
\n

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

\n

26.1.3 set advanced global-min-onoff
\n

Turn on or off the use of the global gridminimizer.\n

\n

26.1.4 set advanced grid_density
\n

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

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

\n

26.1.5 set advanced help-popup-off
\n

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

Turn off popup help? /Y/:\n

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

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

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

\n

26.1.6 set advanced level
\n

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

\n

26.1.7 set advanced map-special
\n

Not implemented yet.\n

\n

26.1.8 set advanced no-macro-stop
\n

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

\n

26.1.9 set advanced open-popup-off
\n

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

\n

26.1.10 set advanced quit
\n \n \n

You did not want to set anything advanced.\n

\n

26.1.11 set advanced symbol
\n

Not implemented yet.\n

\n

26.1.12 set advanced working-directory
\n

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

\n

26.2 set As start equilibrium

\n

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

\n

26.3 set Axis

\n

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

Axis number:\n

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

Condition to vary along the axis:\n

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

Minimal/maximal value of the axis:\n

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

Increment:\n

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

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

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

\n

26.4 set Bit

\n

\n

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

\n

\n

26.5 set Condition

\n

Most of the text here also applies to enter experiment.\n

State variable:\n

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

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

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

Three cases of expressions can be used as conditions, for example a relation between mole fraction\nlike
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\nthe congruent melting of c1_mo2.\n

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.\n

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

Value:\n

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

\n

26.6 set Echo

\n

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

\n

26.7 set Fixed coefficient

\n

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

\n

26.8 set initial_T_and_P

\n

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

\n

26.9 set Input-Amounts

\n

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

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

An example:\n \n \n 

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

\n

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

\n--->OC5:set c t=1000 p=1e5\n--->OC5:l c\nConditions for equilibrium:   1, DEFAULT_EQUILIBRIUM\n  1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000\n Degrees of freedom are   0\n--->OC5:c e\n 3Y Constitution of metastable phases set\nGridmin:      85 points   1.56E-02 s and       0 clockcycles, T= 1000.00\nPhase change: its/add/remove:     5   11    0\nPhase change: its/add/remove:    12   12    0\nPhase change: its/add/remove:    17    0   12\nPhase change: its/add/remove:    53    0   11\nEquilibrium calculation   79 its,   7.8125E-02 s and      93 clockcycles\n--->OC5:l\nLIST what? /RESULTS/:\nResults output mode: /1/:\n\nOutput for equilibrium:   1, DEFAULT_EQUILIBRIUM          2018.08.21\nConditions .................................................:\n  1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000\n Degrees of freedom are   0\n\nSome global data, reference state SER ......................:\nT=   1000.00 K (   726.85 C), P=  1.0000E+05 Pa, V=  4.9872E+00 m3\nN=   1.5500E+02 moles, B=   1.8507E+03 g, RT=   8.3145E+03 J/mol\nGS= -2.80411E+07 J, GS/N=-1.8091E+05 J/mol, HS=-1.2914E+07 J, SS= 1.513E+04 J/K\n\nSome data for components ...................................:\nComponent name    Moles      Mole-fr  Chem.pot/RT  Activities  Ref.state\nC                 4.5000E+01  0.29032 -3.7354E+00  2.3863E-02  SER (default)\nH                 3.0000E+01  0.19355 -9.8098E+00  5.4910E-05  SER (default)\nO                 8.0000E+01  0.51613 -3.6377E+01  1.5911E-16  SER (default)\n\nSome data for phases .......................................:\nName                Status Moles      Volume    Form.Units Cmp/FU dGm/RT  Comp:\nGAS..................... E  1.550E+02  4.99E+00  6.00E+01    2.58  0.00E+00  X:\n O      5.16129E-01  C      2.90323E-01  H      1.93548E-01\n Constitution: There are    73 constituents:\n C1O2         4.54395E-01  C2H3         8.67456E-17  C4H10_1      2.73242E-23\n C1O1         2.95682E-01  C3H4_2       3.04922E-17  C4H10_2      1.38822E-23\n H2O1         1.29270E-01  C3H8         2.73523E-17  C4H2         8.16657E-24\n H2           1.20501E-01  C3H6O1       1.94895E-17  H1O2         4.37267E-24\n C1H4         1.52786E-04  C3H4_1       8.18695E-18  C4H6_5       1.44915E-24\n C1H2O2_CIS   4.04887E-08  C1H3O1_CH3O  3.87833E-18  C4H8         1.04297E-25\n C1H2O1       2.01368E-08  C2H4O1_OXIRA 1.64221E-19  C2H1         7.79712E-26\n C1H2O2_TRANS 5.82767E-09  C1H2         3.98656E-20  C4H8_4       6.39692E-26\n H            7.88542E-10  H2O2         3.27068E-20  C6H6O1       3.00598E-26\n C1H4O1       1.27636E-10  O            1.46838E-20  C1H1         1.81712E-27\n C2H4         1.05140E-10  C2H6O2       1.19305E-20  C3H1         1.68523E-28\n                                                                                            \n                                                                                            \n C2H6         3.44726E-11  O2           8.71930E-21  C4H4_1_3     7.73762E-29\n C1H3         1.83302E-11  C4H6_2       5.73533E-21  C1H2O2_DIOXI 4.04963E-30\n C1H1O1       7.24719E-12  C2O1         1.72590E-21  C4H1         1.00000E-30\n C2H4O1_ACETA 2.00054E-12  C4H8_5       9.38081E-22  C2H4O2_DIOXE 1.00000E-30\n H1O1         1.86354E-12  C4H8_3       5.91323E-22  C4           1.00000E-30\n C2H2         1.82837E-12  C4H8_1       4.75317E-22  C2H4O3_123TR 1.00000E-30\n C1H1O2       1.57298E-12  C4H8_2       4.17043E-22  C2H4O3_124TR 1.00000E-30\n C2H4O2_ACETI 7.65642E-13  C2H2O1       1.47405E-22  C2           1.00000E-30\n C1H3O1_CH2OH 1.64978E-15  C4H6_4       8.47392E-23  C60          1.00000E-30\n C3O2         1.11079E-15  C6H6         8.21607E-23  C3           1.00000E-30\n C3H6_2       7.21243E-16  C4H4         5.46648E-23  C5           1.00000E-30\n C3H6         7.13743E-16  C4H6_1       5.05773E-23  O3           1.00000E-30\n C2H6O1       6.22811E-16  C4H6_3       2.87604E-23\n C2H5         4.72671E-16  C4H10_1      2.73242E-23\n\n--->OC5:\n
\n

\n

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

\n

26.10 set Interactive

\n

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

\n

26.11 set Log-File

\n

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

\n

26.12 set Numeric-Options

\n

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

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

\n \n \n

26.13 set Optimizing conditions

\n

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

\n

26.14 set system variable

\n

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

\n

26.15 set Phase “phase-name”

\n

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

\n

26.15.1 set phase ... Amount
\n

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

\n

26.15.2 set phase ... Bits
\n

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

The bits that can be changed are:\n

\n

\n

\n

26.15.3 set phase ... Constitution
\n

\n

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

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

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

\n

26.15.4 set phase ... Default-constitution
\n

Same as amend phase default_constit.\n

\n

26.15.5 set phase ... Quit
\n

You did not want to set anything for the phase.\n

\n

26.15.6 set phase ... Status
\n

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

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

\n \n \n

26.16 set Quit

\n

You did not really want to set anything.\n

\n

26.17 set Range of experimental equilibria

\n

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

First equilibrium number: /2/:\n

Last equilibrium number:\n

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

\n

26.18 set Reference-State

\n

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

Component name:\n

Reference phase:\n

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

Temperature:\n

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

Pressure:\n

Example:\n

set reference O gas * 1e5\n

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

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

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

\n

26.19 set Scaled coefficient

\n

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

Not implemented yet.\n

\n

26.20 set Status

\n

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

\n

26.20.1 set status Constituent
\n

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

\n

26.20.2 set status Element
\n

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

Not yet implemented.\n

\n

26.20.3 set status Phases
\n

\n

Phase name(s):\n \n \n

A phase can have one of 4 different status\n

\n

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

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

\n

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

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

Amount: /0/:\n

\n

26.20.4 set status Species
\n

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

\n

26.21 set Units

\n \n \n

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

\n

26.22 set Variable coefficient

\n

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

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

\n

26.23 set Verbose

\n

Not implemented yet.\n

\n

26.24 set Weight

\n

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

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

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

\n

27 Show

\n

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

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

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

\n

27.1 property:

\n

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

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

\n

\n

28 Step

\n

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

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

\n
CONDITIONAL  NPLE QUI SEPARATE
NORMAL PARAEQUILIBRIUM  SCHEIL-GULLIVER  TZERO
\n
\n

Delete previous results?\n

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

\n

28.1 step Conditional

\n

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

\n

28.2 step Normal

\n

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

\n \n \n

28.3 step NPLE

\n

Step NPLE is similar to step paraequilibrium.\n

\n

28.4 step paraequilibrium

\n

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

Matrix phase:\n

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

Growing phase:\n

Fast diffusing element:\n

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

\n

28.5 step Quit

\n

You did not want to step.\n

\n

28.6 step Scheil-Gulliver

\n

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

\n

28.7 step Separate

\n

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

\n

28.8 step Tzero

\n

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

First phase:\n

Second phase:\n

Note all phases except the two phases should be suspended. You should provide name of the matrix\nphase\n

Release condition number:\n

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

\n

29 Summary

\n

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

\n

References

\n

\n

\n

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

\n

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

\n

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

\n

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

\n

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

\n

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

\n

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

\n

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

\n \n \n\n \n\n\n" }, { "path": "doc/manual/ochelp.tex", "content": "\\documentclass[11pt]{article}\n\\usepackage[utf8]{inputenc}\n% NEXT LINE is needed for generate a HTML file with targets (hyperref)\n\\usepackage{hyperref}\n%\n% This is a file for a printable PDF and HTML versions of the user guide\n% AND as on-line help, either directly or processed to remove LaTeX specials\n%\n% The PDF file is generated by pdflatex ochelp6.tex\n%\n% I have made this user guide also available for on-line help\n% as an HTML file. That is very nice but a bit complicated.\n%\n%=======================================================\n% To generate the HTML file use the program ``htlatex''\n%=======================================================\n%\n% the package \\usepackage{hyperref}\n% creates possibilities to find text inside the HTML file\n% using \\hypertarget{labeltext}{shown text} (the shown text can be empty)\n% written in the LaTeX file.\n%\n% I have written a program listhyper\n% extracts relevant hypertagets from the software to help entering these\n% in this user guide\n%\n% The idea is that the user can type a ? to have help at any question.\n% All questions by the OC software is asked by a GPARxyz routine and\n% in this routine the programmer (me) can provide a text for a hypertarget.\n% When the user types a ? this hypertarget is used to find a relevant\n% help text in the HTML version and this is displayed in a separate\n% browser window. The user can the scroll and search\n% the whole manual in this window\n%\n% Some additional problemns with this explained below ...\n%\n\\topmargin -5mm\n\\oddsidemargin -1mm\n\\evensidemargin -1mm\n\\textwidth 170mm\n\\textheight 225mm\n\\parskip 2mm\n\\parindent 3mm\n% THIS WATERMARK IS REMOVED AS IT IS NO LONGER SUPPORTED\n%\\usepackage[firstpage]{draftwatermark}\n%\\SetWatermarkScale{4}\n% this should allow \\subsubsubsection ...\n\\newcommand{\\subsubsubsection}[1]{\\paragraph{#1}\\mbox{}\\\\}\n\\setcounter{secnumdepth}{4}\n\\setcounter{tocdepth}{4}\n%\\pagestyle{empty}\n\n% LOOK for ALERT: for checks how the source code behaves!!\n%\n% HYPERTEXT provides browser access to ochelp HTML:\n% in a LaTeX file \\hypertarget{labeltext} \n% is written in the html file as: \n% NOTE: Case does not seem to matter, Enter or ENTER is OK\n% BUT NO TRAILING SPACES!!\n%\n% Problem when opening the HTML file inside OC to list the help text:\n% OLD: This is in the metlib3.F90 file, the q1help subroutine\n% This is in the metlib4.F90 file, the q4help subroutine\n% on WINDOWS: SPECIAL CHARACTER PROBLEM with \" (doublequote)\n% to find an labeltext from OC help file using system command:\n% \"C:\\program files\\mozilla firefox\\firefox.exe\" -file ./manual/ochelp/html/ochemp5.html#labeltext\n% the above does not work (on Windows 10) BUT the following command works:\n% \"C:\\program files\\mozilla firefox\\firefox.exe\" \"file://c:\\users\\bosse\\documents\\oc\\oc\\src\\manual\\ochelp\\html\\ochemp5.html#labeltext\"\n% BUT it does NOT work when called through execute_command_line(command)\n% It seems a problem having 4 doublequotes in the same line ... why?\n% BUT AGAIN, using ``8.3'' Windows file names for Explorer this works:\n% C:\\progra~1\\intern~1\\iexplore.exe ``file:/C:\\user\\bosse\\ochome\\ochemp.html#labeltext\n% on Linux using firefox this works:\n% /usr/bin/firefox \"file:/home/bosse/ochome/ochelp.html#labeltext\"\n%\n% USE OF HYPERTARGET\n% From OC version 5+ a modified online help system using \\hypertarget{}{}\n% Now the hypertaget is specified in PMON and the GPARxyz routinines\n% replacing the subroutine name!\n% This works very nicely. The only problem is with menu and submenu commands\n% because these should just list the menu when the user types ?\n% and display the user guide only when the user types ??\n% But this seems to work now using a special '?TOPHLP' as ``target''\n% when using a gparxyz routine to ask for a command or subcommand.\n%\n% I am not sure if the hypertext targets are case sensitve but I assume so\n% and thus this has to be standardized. First letter capitalm rest lower case\n% unless there is a reason, for example TDB is in upper case.\n% the listhyper will now detect missing targets in UG\n% but there are also questions with targets in the gtp routines ...\n%\n% NOTE: To make it easier to find all \\hypertargets{}{} used in the\n% source code I have added a question mark ? as first character of\n% the argument in the gparxyz file, for example:\n%\n% call gparcx('Symbol name: ',cline,last,1,name1,' ','?Amend something')\n%\n% which will search for the \\hypertarget{Amend symbol}{} in the HTML file\n% The ? will be stripped before searching. The ? is not mandatory, just\n% an attempt to simplify updates and maintaining the help system.\n%\n%---------------------------------------------------\n%\n% The current version of this guide is generated manually but maybe a\n% software program should be developed to update this automatically whenever\n% the software is changed\n%\n%---------------------------------------------------\n%\n% SOME IMPORTANT ADVICE:\n%\n% The commands and subcommands are arranged alphabetically\n%\n% It will be difficult to update the help text for the\n% questions after the commands and subcommands as they are sometimes\n% not part of the command monitor.\n%\n% The _ used in many commands should be replaced by \\_ or just -\n%\n%---------------------------------------------------\n%\n% GUIDE how to add searchable items in the help file for online help\n% ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n% The online help is based on using a browser like firefox or explorer\n% If the user types ``?'' as answer to a question the subroutine\n% asking the question, GPARxyz, has a character variable as its last\n% argument which is a ``hypertarget'' in the HTML version of\n% the user guide. The HTML file opened with this character as a hypertarget\n%\n% htmlhelp=trim(ochelp%browser)//' \"file:'//&\n% trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'\" &'\n%\n% where browser and htmlfile are set when the program starts. kk is used\n% to strip the target of irrelevant parts which may be set by the user.\n%\n% The user guide will open in a separate window at a text indicated by\n% the hypertarget which should be relevant for the question. The user can\n% scroll the guide in this window for other parts if he needs more help.\n%\n% Special care is taken for menu commands and for these a single ?\n% will just display the menu. Only a ?? will open the HTML file.\n% The hypertarget for menu help is the first 3 words of the promt for\n% the menu. Thus any variable part of the promt should be preceeded\n% by at lset 3 words, for example:\n%\n% Amend for phase LIQUID what? /COMPOSITION_SET/: ??\n%\n% will use as hypertarget ``Amend for phase'' ignoring the variable ``LIQUID''\n% \n% Updating the software and the user guide in parallel can be complicated.\n% To help with this I have added a ? at each searchable hypertarget in the\n% source code. Thus one can search for ``'?'' to find a hypertarget for\n% any question and check it is identical to the hypertarget in the\n% user guide. UPPER or lower case does not seem to matter.\n% But trailing spaces inside \\hypertarget matter!\n%\n%---------------------------------------------------\n%\n\\begin{document}\n\n\\begin{center}\n\n{\\Huge \\bf User Guide to the \n\nOpenCalphad software package\n\nversion 7.0\n\n}\n\n\\bigskip\n\n{\\Large DRAFT}\n\n\\bigskip\n\nBo Sundman, \\today\n\n\\end{center}\n\n\\vspace{25mm}\n\nUpdates of OC User Guide\n\\begin{itemize}\n\\item version 7, 2021-04-01 prerelease\n\\item version 6, 2019-11-11 prerelease\n\\item version 5, 2018-09-19 first use of hypertargets\n\\item version 4, 2016-10-06\n\\item version 3, 2016-01-01\n\\end{itemize}\n\nEarlier versions of OC had no User Guide\n\n\\newpage\n\nThis page intentionally blank\n\n\\newpage\n\n\\tableofcontents\n\n\\newpage\n\n\\section{Introduction}\n\nThe development of the OpenCalphad (OC) sofware was started by a small\ngroup of dedicated scientists who wanted to provide an open source\nmulticomponent thermodynamic software. It aims to provide a free high\nquality software for thermodynamic calculations, including property\nand phase diagrams, assessment of databases and a thermodynamic\nlibrary for simulations for inorganic systems i.e. gases. liquids,\nalloys and other materials using many different kinds of models for\nthe phases. There are three basic papers published about\nOC~\\cite{15Sun1,15Sun2,16Sun}. General information about\nthermodynamic models, calculations and assessments based on the\nCalphad technique can be found in the book by Lukas et\nal~\\cite{07Luk}. This software is provided free with a GNU GPL\nlicense.\n\nIn OC there is also a framework to store different kinds of materials\nproperties that depend on temperature, pressure and composition when\nsuch properties are related to the phases of the system and used in\nsimulations as described in~\\cite{20Her}. The OC software can also be\nused to assess model parameters for such properties from experimental\nand theoretical values.\n\nComplimentary (and maybe sometimes contradictory, I am not perfect)\ninformation about the OC software can be found in getting-started.pdf,\nnews-oc7.pdf and the other parts of the OC documentation.\n\n\\section{Some general features}\n\nThe different parts of the OC software are documented separately for\neach module: thermodynamic models (GTP), equilibrium calculations\n(HMS), step/map/plot routines (SMP) and the application software\ninterface (OCASI/TQ). With OC version 6 the old utility package\nmetlib, originally written in F77, has been converted completely to\nthe new Fortran standard and is included in the documentation. The\ndocumentation of the assessment module is not finished.\n\nOC uses the free numerics packages LAPACK and BLAS and two routines\nfrom MINPACK~\\cite{lmdif}, LMDIF and HYBRD developed at Argonne 1980.\nLMDIF is a least square minimizer used for assessments and\nHYBRD~\\cite{lmdif} solves systems of non-linear equations needed to\ncalculate $T_0$ and paraequilibria. For graphics OC generates a\ncommand file which can be plotted with the free GNUPLOT~\\cite{gnuplot}\nsoftware. If GNUPLOT is properly installed GNUPLOT is invoked\nautomatically by OC.\n\n\\subsection{Command line user interface}\n\nOC is operated by commands typed by the user or read from a macro\nfile. The command monitor has a menu of command and each of these\nusually has sub-menus and finally some questions may be asked like\nphase names, a value or an expression. In most cases a default answer\nis provided which can be selected by just pressing the RETURN key or\nby typing a comma, ``,'', on the same line as the command. At all\nlevels the user should be able to type a ? and get some help, usually\nan extract from this manual, sometimes just a menu or examples of\nanswers.\n\nA command line interface is superiour when it comes to enter complex\nequilibrium conditions for example to calculate the minimum of a\nliquidus line defined by the condition ``x(liq,cr)-x(bcc,cr)=0'' in\nthe Fe-Cr system. To follow a second order transition one can set the\ndifference between the site fractions of the same element, for example\n``y(bcc-B2,Al)-y(bcc-B2,Al\\#2)=0.01'' as condition.\n\nFor the menu commands a single ? will just display the menu, in order to\nobtain the User Guide type two, ??.\n\nIf you prefer a graphical user interface (GUI) there is at least two\nindependent efforts to provide a GUI to OC.\n\n\\subsubsection{Command line editing and history}\n\nOn Windows the OS provides history and on-line editing of commands but\non Linux and other OS this has to be provided by the software itself.\nThus a C routine with an iso-C interface written by Urban S Jost\n(2009) copied from\nhttp://www.urbanjost.altervista.org/LIBRARY/libCLI/Getkey/getkey.html\nhas been added and there is a seperate documentation of this if you\nwant to change anything.\n\nThe command history is saved inside OC and by typing ``upparrow''\n(normally ctrl-P but it can be different on different terminals)\nearlier command can be retrieved and also edited.\n\n\\subsubsection{Popup window for read/save}\\label{sc:popup}\n\nTo open a file for reading or saving one need a file browser and from\nOC version 5.018 I have included a routine ``TINYFILEDIALOGS''\ndeveloped by Guillaume Vareille (2014-2018) available at\nhttp://tinyfiledialogs.sourceforge.net. This will open a popup window\nto open a file (for a macro, a database or to save a calculation). In\nthis window you can browse your directories to find the file.\n\nThis has some consequencies for editing your macro files which you\nshould be aware of and which are explained below.\n\nYou can turn off the open file popup window feature with the command\n{\\bf set~advanced~open\\_popup\\_off~Y}. You can turn it on again with\nthe same command finishing with anything but Y.\n\n\\begin{itemize}\n\\item The directory where you start the session with OC is called the\n ``working directory''. On a linux system you can find this\n directory by typing ``pwd'' before starting OC (or if you type {\\em\n @pwd} inside OC). On a Windows system you can see the working\n directory and its files if you type {\\em @dir} inside OC.\n\n\\item When the popup window is opened the directories and files\n matching the ``filter'' in the working directory should be listed.\n If not you can select a directory inside the popup window. The\n filter when open a macro file is ``OCM'' and when opening a database\n file it is ``TDB'' which means only files with these extensions are\n listed. You can change the directory in the popup window to select\n the file you want and you can read a file with another extension.\n OC will save internally the directory where you start the macro.\n \n\\item Inside a macro file you normally read a TDB file and if you do\n not specify the name of the database on the same line as the command\n {\\em read tdb} the popup window will open so you can specify the\n file in this window.\n\n\\item But normally you know which database you want to use inside the\n macro and if you give the file name on the same line as the commad:\n {\\em read tdb filename} the popup window will not open and OC will\n search for the specified database file starting from the ``working\n directory''. But if the database file is in the same directory as\n the macro file you MUST prefix ``filename'' with ``./'', i.e. {\\em\n read tdb ./filename}. You may include directories in\n ``filename'', (including ``../'' to go to the directory above). OC\n will replace the ``./'' by the directory where you started the macro\n or prefix ``../'' by this directory.\n\n\\item In the macro file you can give the full path to the file to be\n opened but that is rather clumsy.\n\n\\item When you open a file for write inside a macro, like output from\n a plot, you can also specify the file name in the command prefixed\n by ``./'' if you want to save the file on the same directory as the\n macro file. Otherwise it will be saved at the working directory.\n\n\\item If you use the switch ``/output='' or ``/append='' after a\n command to redirect output from the command you can also use the\n popup window to specify the file name or use a filename with or\n without the prefix ``./''. The default extension in this case is ``DAT''.\n\n\\end{itemize}\n\nOpening files on different directories can be complicated inside OC.\nFor example during assessments you may use many different files for\ngenerating graphics and unformatted save files. Preferably you keep\nall of these on the same directory.\n\nYou are welcome to provide feedback on this popup feature and other\nparts of the user interface.\n\n\\hypertarget{Info helpsystem}{}\n\\subsubsection{On-line help}\\label{sc:on-line-help}\n\nA recent feature added to OC is providing on-line help using a browser\nwindow where this user guide is available as a searchable HMTL file.\n\nWhenever the user wants an explation of a question the OC software\nasks he can type a ? and the OC software will open a separate browser\nwindow positioned at the relevant text in the user guide. You can then\nsearch the whole user guide for related information.\n\nWhenever the user types ? at a menu level just the menu will be\ndisplayed but if you type ?? the user guide will be opened at the\nrelevant menu text with additional explanations.\n\nThis feature is new and is still under development. Feedback is\nhelpful. It can be turned off (or on again) by the command {\\bf\n set~advanced~help\\_popup\\_off~y} in section~\\ref{sc:help-popup}.\n\nFor installation of the help system please read the installation guide\nto create an environment variable OCHOME with a link to the directory\nwith the help file.\n\n\\subsubsection{Environment and startup macro file}\n\nThe OC program will look for an environment variable called OCHOME and\nif it finds this it will look for a file start.OCM which will be\nexecuted before the user gets control. This can typically be useful\nto set some variables like the plot terminals, see\nsection~\\ref{sc:gnuterm}. If there is no OCHOME environment variable\nthe current ``working directory'' will be searched.\n\nThe ochelp.tex and ochelp.html file should be copied from the\ndirectory ``manual'' in the installation directory to this OCHOME\ndirectory.\n\n\\subsubsection{Macro files}\\label{sc:macro}\n\nThe macro command is very useful for preparing complex calculations\nand to remember how you did them. A macro file is simplest to create\nstaring from a log file (created by the {\\bf SET LOG} command). See the\nmacros directory for examples.\n\nAfter a macro command the popup window will allow you to search for\nthe file on all your directories unless you type the name of the\nfile on the same line. In the latter case the macro file must be\non you ``working directory'', see section~\\ref{sc:popup}\n\nWhen you open files, such as databases, inside a macro file and you\ntype the file name on the same line as the command as ``read tdb\n./steel1'', you must prefix the file name, ``steel1'' with ``./'' if\nthe tdb file is on the same directory as the macro file. If your\ncommand line is just ``read tdb'' the popup window will be activated\nand you can specify the file there.\n\nIf you open another macro file inside a macro (typically when you do\nassessments) you must also prefix the name of the macro with ``./''\nunless you want to select the macro using the popup window.\n\n\\hypertarget{Macro comments}{}\n\\subsubsubsection{Comments, stops and questions in macro files}\\label{sc:macroadd}\n\nIt is useful to insert comments in the macro file to explain what it\ndoing. A line starting with ``@\\$'' is a comment and will be ignored\nby the OC software.\n\nYou can insert stops in the macro file with ``@\\&'' at the beginning\nof a line. This can be useful to have time to inspect the output.\nThe macro continues after pressing the ENTER/RETURN key. Depending on\nthe graphical driver you use the program will normally pause after\neach plot and you must click on the graphical window to continue.\n\nYou can also, inside the macro, ask the user for values needed for the\ncalculations. For example if you have a complicated calculation you\nwould like to use several times with different values of the\ncompositions or temperature you can, instead of editing the macro each\ntime, insert questions in the macro. The macro will then stop and ask\nthe user to input that value from the keyboard before continuing. In\nthe macro file you can ask for the condition on the temperature in\nthis way:\n\n\\begin{verbatim}\n @$ Ask user for the condition on the T\n set cond T\n @?Input-new-temperature\n\n\\end{verbatim}\n\nWhen the macro comes to this point the program will write the text\n``Input-new-temparature'' on the screen and wait for user input.\nAfter the value has been typed on the keyboard and ENTER/RETURN\npressed OC will set the value as the temperature and continue with the\nnext command in the macro file.\n\nThere is no way to insert loops or conditions in the macro file.\n\nA macro file should be terminated with the command {\\bf SET\n INTERACTIVE} which gives back control to the keyboard (or the\ncalling macro file) otherwise the program may terminate at the end of\nthe macro.\n\nMacro files can be nested 5 levels deep.\n\n\\subsubsection{User interface feedback}\n\nOC has grown organically and although the basic concepts has been\nquite clear the implementations of several of these has become rather\nconfusing. This will eventually require some cleaning up of the user\ninterface.\n\nA central part of any thermodynamic software is the modeling of the\nphases. A new PDB format for databases may help a little with the\nspecification of the models. An attempt has been made in this version\nto clean up the way a model is specified and used. At present you\nmust first ENTER the phase to give a name, basic model, sublattices\nand constituents. Then use the AMEND command to add magnetism, a\ndisordered fraction set and/or use BCC/FCC permutations. Originally\nsome of these things were set by the command SET PHASE ... BIT and\nthat was not very clear.\n\nSome computational options like for the grid minimizer are still set\nwith several different commands. It is useful for the developers to\nhave some feedback from users to organize this better.\n\n\\subsection{Names and symbols}\n\nThere are many symbols and names used in this package. A symbol or\nname MUST start with a letter A-Z. It usually can contain digits and\nthe underscore character after the initial letter. All names are CASE\nINSENSITIVE, i.e. fe, FE, fE and Fe is the same. Some special symbols\nare used:\n\n\\begin{itemize}\n\\item /- is used to denote the electron. /+ or /- -1 can be used for a\n positive charge.\n\\item * can be used to mean ``all'' or ``all stable''.\n\\item \\# are used to identify composition sets after a phase name or\n sublattice after a constituent name. It is also used as wildcard\n to obtain the DGM of all phases including metastable ones.\n\\item \\& are used in some parameter identifiers to specify the\n constituent for the parameter, like for mobilities, the mobility of\n Fe in the BCC phase is denoted MQ\\&FE(BCC).\n\\end{itemize}\n\nA name of an element is one or two characters, a species maximum 24\ncharacters (note that a species name does not have to be its\nstoichiometric formula). A phase name is 24 characters but can also\nhave a pre- and suffix 4 characters long and possibly a composition\nset number after a hash symbol, \\#.\n\nState variable symbols and TP-fun symbols can be 16 characters long.\nTP-funs are expressions used to describe the $T$ and $P$ dependence of\nmodel parameters.\n\nFor user input it is possible to use abbreviations of names but you\nmust be careful with names that have the same abbreviation and avoid\nphase names that are abbreviations of another phase!\n\n\\hypertarget{Info elements}{}\n\\hypertarget{Info species}{}\n\\subsection{Elements, species, components, constituents and system}\\label{sc:elements}\n\nMuch of the confusion using thermodynamics is due to the fact that the\nuser has no clear idea of the terms in the title of this section. A\nstrict definition used in OC is:\n\\begin{itemize}\n\\item An element is from the periodic chart. The user can also enter\n fictitious elements.\n\\item A species is a molecularlike aggregate of elements with fixed\n ratios. It can also have a charge and be called an ion. The\n vacancy, representing an empty lattice site, is also a species.\n\\item The constituents of a phase is a subset of the species.\n\\item The set of components limits the composition of the system. By\n default the elements are the components but the user can enter any\n orthogonal set of species as components by a command, see\n section~\\ref{sc:amendcomp}.\n\\end{itemize}\n\nA system is defined by its components. Conditions on the amounts or\nchemical potentials can only be set for the components, not for any\narbitrary species. But the chemical potential of a molecule is\nrelated to that of the elements at equilibrium. Thus one can use the\nrelation:\n\\begin{eqnarray}\n\\mu_{\\rm H_2O} &=& 2\\mu_{\\rm H}+\\mu_{\\rm O}\n\\end{eqnarray}\nto set a condition on a sum of chemical potential of the elements.\n\nThe phases can gave different models and sets of constituents to\ndescribe Long Range Ordering (LRO) and Short Range Orderng (SRO).\nSome phases can exist for a specific composition only or for a limited\nsubset of the components of a system.\n\n\\hypertarget{Info phases}{}\n\\subsection{Phases, composition sets and phase tuples}\n\nMany come across thermodynamic calculations the first time in\nchemistry writing chemical reactions. In such reactions the solid and\nliquid phases are usually treated as stoichiometric and only the gas\ncan have several constituents. In the Calphad approach most phases\nare treated as solutions with variable composition but with different\nmodels for their Gibbs energy functions. But some phases can exist\nonly for a specific or very restricted composition.\n\nEach phase in a system has a name and a thermodynamic model and set of\nconstituents, see section~\\ref{sc:elements}. The models are explained\nin a separate documentation. The phases can be entered interactivly\nor read from a database or a saved file together with the last\ncalculation.\n\n\\hypertarget{Info compset}{}\n\nIn some cases a phase can be stable with two ore more different\ncompositions for example inside miscibility gaps or when the phase has\norder/disorder transitions. In such a case you use a composition set\nindex to separate these. The composition set index is appended to the\nphase name preceeded by a hash ``\\#'' character, like liquid\\#2.\n\nComposition sets can be created manually, see the command {\\bf AMEND\n PHASE} in section~\\ref{sc:amend_phase_cs} or automatically by the\ngrid minimizer or application software.\n\nThe phase tuple has been introduced to have a single index for both\nphases and composition sets in application software. The tuple index\nthus contain both the phase number and the composition set index. The\narray of tuple indices is updated internally whenever a new\ncomposition set is created or deleted.\n\n\\subsection{The use of wildcards for phase names}\n\nIn many cases you can use an asterix ``*'' as a name and this normally\nmeans ``all''. For setting status of phases you can use the special\n``*S'' for all suspended phase, ``*D'' for all dormant phases. If you\nplot the composition of a phase, such as x(liquid,*), values will be\nlisted or plotted only in the range the liquid is stable.\n\nWhen using ``*'' for output, for example NP(*) for the amount of all\nphases it means ``all stable''. Thus to plot the driving force for\nmetastable phases, see section~\\ref{sc:dgm}, there is a special\nwildcard ``\\#'' which can be used in in DGM(\\#) for plotting the driving\nforce for all metastable phases. The driving force, DGM, is also\nincluded in listing of results for all phases.\n\n\\hypertarget{Info statevariables}{}\n\\subsection{State variables}\\label{sc:statevar}\n\n\\begin{table}[!ht]\n\\caption{A preliminary table with the state variables and their\n internal representation. Some model parameter properties are also\n included. The \"z\" used in some symbols like Sz means the optional\n normalizing symbol M, W, V or F. There is some redundancy, for\n example NM(FE) is the same as X(FE).}\\label{tab:statev} {\\small\n\\begin{tabular}{|lllcccl|}\\hline\nSymbol~&\\multicolumn{2}{c}{Id}&\\multicolumn{2}{c}{Index}&Normalizing~&Meaning\\\\\n & A & z & 1 & 2 & suffix & \\\\\\hline\n\\multicolumn{7}{|c|}{Intensive properties}\\\\\\hline\nT & 1 &- & - & - & - & Temperature\\\\\nP & 2 &- & - & - & - & Pressure\\\\\nMU & 3 &- & component & -/phase & - & Chemical potential\\\\\nAC & 4 &- & component & -/phase & - & Activity\\\\\nLNAC & 5 &- & component & -/phase & - & LN(activity)=MU/RT\\\\\\hline\n\\multicolumn{7}{|c|}{Extensive and normallized properties}\\\\\\hline\nU & 6 & 1 & -/phase\\#set & - & - & Internal energy for system\\\\\nUM & 6 & 2 & -/phase\\#set & - & M & Internal energy per mole\\\\\nUW & 6 & 3 & -/phase\\#set & - & W & Internal energy per mass\\\\\nUV & 6 & 4 & -/phase\\#set & - & V & Internal energy per m$^3$\\\\\nUF & 6 & 5 & phase\\#set & - & F & Internal energy per formula unit\\\\\nSz & 7 & * & -/phase\\#set & - & * & entropy\\\\\nVz & 8 & * & -/phase\\#set & - & * & volume\\\\\nHz & 9 & * & -/phase\\#set & - & * & enthalpy\\\\\nAz & 10 & * & -/phase\\#set & - & * & Helmholtz energy\\\\\nGz & 11 & * & -/phase\\#set & - & * & Gibbs energy\\\\\nNPz & 12 & * & phase\\#set & - & * & Moles of phase\\\\\nBPz & 13 & * & phase\\#set & - & * & Mass of phase\\\\\nQz & 14 & * & phase\\#set & - & * & Stability of phase\\\\\nDGz & 15 & * & phase\\#set & - & * & Driving force of phase\\\\\nNz & 16 & * & -/phase\\#set/comp & -/comp & * & Moles of component\\\\\nX & 17 & - & phase\\#set/comp & -/comp & 0 & Mole fraction\\\\\nX\\% & 17 & - & phase\\#set/comp & -/comp & 100 & Mole per cent\\\\\nBz & 18 & * & -/phase\\#set/comp & -/comp & * & Mass of component\\\\\nW & 19 & - & phase\\#set/comp & -/comp & 0 & Mass fraction\\\\\nW\\% & 19 & - & phase\\#set/comp & -/comp & 100 & Mass per cent\\\\\nY & 20 &- & phase\\#set & const\\#subl & -& Constituent fraction\\\\\\hline\n\\multicolumn{7}{|c|}{Some model parameter identifiers}\\\\\\hline\nTC & - &- &phase\\#set & - & - & Curie temperature\\\\\nBMAG & - &- & phase\\#set & - & - & Aver. Bohr magneton number\\\\\nMQ\\&A & - &- & phase\\#set & constituent A & - & Mobility of A\\\\\nTHET & - &- & phase\\#set & - & - & Debye temperature\\\\\\hline\n\\end{tabular}\n}\n\\end{table}\n\nA state variable in a thermodynamic system has a value which at\nequilibrium is independent of the way the system has reach its current\nstate, it depends only on its current state. All state variables\navailable in OC are listed in Table~\\ref{tab:statev}. They are used\nto set conditions and to obtain results from an equilibrium\ncalculation. It is possible to use state variables also when close to\nthe equilibrium state for example when simulating a phase\ntransformation.\n\n\\subsubsection{Some pecularites of the state variable values}\n\nOne has to be careful with the normalizing suffix, thus H means the\nenthalpy of a system for its current size. HM is the enthalpy for the\ncurrent system divided by the number of moles of atoms in of the\nsystem. This is one can expect but one may be surprised that H(phase)\nis the enthalpy of ``phase'' for the current amount of moles of atoms\nof the phase, which is zero if the phase is not stable. To obtain the\nvalue of the enthalpy of ``phase'' independently of its current amount\none must use HM(phase), the enthalpy per mole of atoms in the phase.\n\nThe value of a state variable also depend on the reference states of\nthe elements. The user may define this for each element with a\ncommand, see section~\\ref{sc:refstate}. The default refernce state is\nthe stable state of the elements at 298.15~K and 1~bar, called SER.\nWhenever necessary this is indicated by an final suffix ``S'', for\nexample ACS(C) indicate the activity of C using the reference state\nSER whereas AC(C) is always be the activity relative the current\nreference state, either the default or that set by the user.\n\nIf all elements have the same phase as reference then the integral\nproperties will also be refered to that phase, they wll represent an\n``excess''. If the elements in a system have different reference\nphases the integral value of the state variable will normally be\nrelative to SER because anything else would be meaningless.\n\n\\hypertarget{Info dgm}{}\n\\subsubsection{The driving force}\\label{sc:dgm}\n\nMost state variables have a welldefined thermodynamic meaning but the\ndriving force, DGM(phase), is a property related to the stability of\nthe phase at an equilibrium. All stable phases are on a common\ntangent planne of chemical potentials and have DGM=0. For a\nmetastable phase the value of the DGM variable is the distance in\nGibbs energy (normallized by dividing it by the value of $RT$) between\nthe stable tangent plane and the point on the Gibbs energy surface of\nthe metastable phase that is closest to the tangent plane of the\nstable phases. DGM is negative for a metastable phase and if is close\nto zero it means the phase is close to become stable. The only case a\nphase can have positive DGM is for phases which have the dormant\nstatus and it means the phase would be stable if its status is changed\nto be entered.\n\n\\hypertarget{Info databases}{}\n\\subsection{Thermodynamic databases}\\label{sc:databases}\n\nThe use of thermodynamic software depend on assessed model parameters\nfor phases and elements. With the OC software one can make\nassessments of such model parameters using experimental and\ntheoretical data, see section~\\ref{sc:assess}. However, this user\nguide does not describe the construction of such databases or how one\ncan obtain them.\n\n\\subsection{Model parameters}\n\nAll data is organized relative to a phase and the phase is identified\nby a name. Each phase can have a different model for the composition\ndependence but the way to enter model parameters is the same for all\nmodels. However, the meaning of a model parameter will depend on the\nmodel of the phase.\n\nMany types of data can be stored as explained in the section on\nparameter identifiers. The parameter also has a constituent\nspecification explained in the constituent array section and possibly\na degree, the meaning of which is model dependent and a bibliographic\nreference.\n\nThe basic syntax of a parameter is\n\n``identifier'' ( ``phase name'' , ``constituent array'' ; ``degree'' ) ``expression'' ``bibl.ref.''\n\nThese parts are explained in more detail below.\n\n\\subsubsection{Model Parameter Identifiers}\\label{sc:paramid}\n\nThe OC thermodynamic package can handle any phase property that depend\non $T, P$ and the constitution of the phase using the models\nimplemented. It is easy to extend the number of properties by\ndeclaring property identifiers in the source code. If the parameters\nshould have an influence on the Gibbs energy (like the Curie\ntemperature) or a diffusion coefficient (like the mobility) the\nnecessary code to calculate this must be added.\n\nA list of the model parameter identifiers as shown in\nTable~\\ref{tab:mpis} can be obtained by the command {\\bf LIST\n MODEL-PARAM-ID}\n\n\\begin{table}[!h]\n \\caption{Current set of model parameter identifiers}\\label{tab:mpis}\n {\\small\n\\begin{verbatim}\nIndx Ident T P Specification Status Note\n 1 G T P 0 Energy\n 2 TC - P 2 Combined Curie/Neel T\n 3 BMAG - - 1 Average Bohr magneton numb\n 4 CTA - P 2 Curie temperature\n 5 NTA - P 2 Neel temperature\n 6 IBM - P &; 12 Individual Bohr magneton num\n 7 THET - P 2 Debye or Einstein temp\n 8 V0 - - 1 Volume at T0, P0\n 9 VA T - 4 Thermal expansion\n 10 VB T P 0 Bulk modulus\n 11 VC T P 0 Alternative volume parameter\n 12 VS T P 0 Diffusion volume parameter\n 13 MQ T P &; 10 Mobility activation energy\n 14 MF T P &; 10 RT*ln(mobility freq.fact.)\n 15 MG T P &; 10 Magnetic mobility factor\n 16 G2 T P 0 Liquid two state parameter\n 17 THT2 - P 2 Smooth step function T\n 18 DCP2 - P 2 Smooth step function value\n 19 LPX T P 0 Lattice param X axis\n 20 LPY T P 0 Lattice param Y axis\n 21 LPZ T P 0 Lattice param Z axis\n 22 LPTH T P 0 Lattice angle TH\n 23 EC11 T P 0 Elastic const C11\n 24 EC12 T P 0 Elastic const C12\n 25 EC44 T P 0 Elastic const C44\n 26 UQT T P &; 10 UNIQUAC residual parameter\n 27 RHO T P 0 Electric resistivity\n 28 VISC T P 0 Viscosity\n 29 LAMB T P 0 Thermal conductivity\n 30 HMVA T P 0 Enthalpy of vacancy form.\n 31 TSCH - P 2 Schottky anomaly T\n 32 CSCH - P 2 Schottky anomaly Cp/R.\n 33 NONE T P 0 Unused\n\\end{verbatim}\n }\n\\end{table}\n \nSeveral of these identifiers have no supporting software implemented,\nthis is an ongoing project. The columns T P indicate if the parameter\nmay depend on $T$ or $P$. Some identifiers require additional\nspecification of the constituent and sublattice, like the mobility of\na constituent. Currently it is not yet clear if mobilities should\ndepend on the sublattice or not but the notation allows that.\n\nA slightly more detailed explanation of the identifiers are:\n\n\\begin{itemize}\n\\item G, the Gibbs energy parameter for an endmember or an\n interaction. G(LIQUID,FE;0) is the Gibbs energy for pure liquid Fe.\n Note that the parameter will be used also below the melting\n temperature of Fe for a liquid phase containing Fe. G(LIQUID,CR,FE;0)\n is the regular parameter for Cr and Fe in the liquid.\n\\item TC, a parameter for the critical temperature for ferro or\n antiferro magnetic ordering using the Inden model.\n\\item BMAG, a parameter for the average Bohr magneton number using\n the Inden model.\n\\item CTA, a parameter for the Curie temperature for ferromagnetic\n ordering using a modified Inden model.\n\\item NTA, a parameter for the Neel temperature for antiferromagnetic\n ordering using a modified Inden model.\n\\item IBM\\&C, a parameter for the individual Bohr magneton number for\n constituent C using a modified Inden model. For example\n IBM\\&FE(BCC,FE) is the Bohr magneton number for BCC Fe. The\n identifier IBM\\&FE(BCC,CR) means the Bohr magneton number of a\n single Fe atom in BCC Cr. An identifier IBM\\&FE(BCC,CR,FE) can be\n used to decribe the composition dependence of the Bohr magneton\n number for Fe in BCC.\n\\item THET, a parameter for the Debye or Einstein temperature.\n\\item V0, a parameter for the volume at 298.15~K and 1 bar.\n\\item VA, a parameter for the integrated thermal expansion.\n\\item VB, a parameter for the Bulk modulus.\n\\item G2, a parameter for the two-state liquid model.\n\\item LAMB, a parameter for the thermal conductivity.\n\\item MQ\\&C, a parameter for the logarithm of the frequency factor of\n the mobility of constituent C.\n\\item MF\\&C, a parameter for the activition energy of the mobility of\n constituent C.\n\\item MG\\&C, a parameter for the magnetic factor of the mobility of\n constituent C.\n\\item THT2, The T for a smooth change of C$_P$ \n\\item DCP2, The value of the smooth change in J/mol\n\\item VISC, a parameter for the viscosity.\n\\item LPX, a parameter the lattice parameter in X direction.\n\\item LPY, a parameter the lattice parameter in Y direction.\n\\item LPZ, a parameter the lattice parameter in Z direction.\n\\item LPTH, a parameter the angle between lattice directions.\n\\item EC11, a parameter for the elastic constant C11.\n\\item EC12, a parameter for the elastic constant C12.\n\\item EC44, a parameter for the elastic constant C44.\n\\item UQT\\&C, a parameter for the UNIQUAC residual energy for species C\n\\item RHO, a parameter for the electrical resistivity.\n\\item HMVA, a parameter for the enthalpy of vacancy formation.\n\\item TSCH, the T for a Schottky anomaly.\n\\item CSCH, the Schottky anomaly $\\Delta C_P$.\n\\item QCZ, the bond number in the FactSage quasichemical model.\n\\end{itemize}\n\nThe current value of any of these parameter identifiers can be obtaind\nby the command {\\bf LIST STATE\\_VARIABLE} using the identifier and\nappropriate phase and component specifiers, see\nsection~\\ref{sc:list_statevar}.\n\nFor details of the meaning of the model identifier refer to the model\ndocumentation. As already mentioned many of the identifiers, like the\nmobility, does not influence the Gibbs energy but as they depend on\nthe $T, P$ and constitution of the phase it is convenient to model\nthem in the same way as the thermodynamic data.\n\n\\subsubsection{Constituent array and degrees}\n\nA constituent array specifies one or more constituent in each\nsublattice. A constituent must be entered as a species with fixed\nstoichiometry. Between constituents in different sublattices you must\ngive a colon, \":\", between interacting constituents in the same\nsublattice you must give a comma, \",\" or a space. A constituent array\nwith exactly one constituent in each sublattice is also called an\n``endmember'' as it give the value for a ``compound'' with fixed\nstoichiometry. Constituent arrays with one or more interaction\nconstituents describe the composition dependence of the property.\nWithout such parameters the property will vary linearly between the\nendmembers.\n\nIf there are no sublattices, like in the gas, you just give the phase\nand the constituent\n\nG(GAS,C1O2)\n\nIf no degree is specified it is assumed to be zero. For endmembers\nthe degree must be zero but it may sometimes be useful to specify the\nzero in order to distinguish the parameter from the expression for the\ncalculated value of the property, like the chemical potential of a\ncomponent. In the gas phase you normally assumes there are no\ninteractions but it is possible to add such parameters. For an fcc\nphase with 4 sublattice for ordering and one for interstitials an\nendmember parameter is\n\nG(FCC,AL:NI:NI:NI:VA;0)\n\nThis would be the Gibbs energy of an fcc AL1NI3 ordered compound.\n\nAn interaction between vacancies and carbon in the austenite is\n\nG(FCC,FE:C,VA;0)\n\nFor an interaction parameter you should always specify a degree but\nalso in this case an omitted degree is interpreted as zero.\n\n\\subsubsection{Ternary extrapolations}\\label{sc:excessparameters}\n\nThe main binary excess model implemented in OC is the symmetric binary\nRedlish-Kister method combined with the Muggianu ternary\nextrapolation. Other binary methods, such a polynomial or Legendre\npolynom can always be converted to a set of Redlich-Kister parameters.\n\n\\begin{eqnarray*}\nL_{\\rm A,B} = \\sum_{\\nu=0}^n ~^{\\nu}L_{\\rm A,B} (y_{\\rm A} - y_{\\rm B})^{\\nu}\n\\end{eqnarray*}\nwhere the degree, $\\nu$, of the interaction parameter is specified\nafter a semicolon, L(phase,A,B;$\\nu$).\n\nFor ternary parameters and for reciprocal parameters the Hillert model\nfor composition dependence is implemented, see~\\cite{07Luk}.\n\nYou can store many different types of data in OC with different\nparameter identifier. Some of the parameters are not related to the\nthermodynamic properties but as they depend on the phase, T, P and\ncomposition it is convenient to store them together with the\nthermodynamic data. For example the mobility of Fe in BCC (including\nan empty interstitial sublattice) is specified as: MQ\\&FE(BCC,FE:VA).\n\nAn explanation of the identifiers implemented in OC can be found in\nsection~\\ref{sc:paramid}. The current list can be obtained by the\ncommand {\\bf LIST MODEL\\_PARAM\\_ID}. All of them can be composition\ndependent. Some cannot depend on $T$ or $P$ or neither. Many kinds\nof the parameters are available but in some cases the software for the\nmodels to handle them are not implemented. The value of a model\nparameter can be obtained using {\\bf LIST MODEL\\_PARAM\\_VAL} or simply\n{\\bf SHOW}. You must specify phase and endmember for the parameter.\n\nFrom OC version 7 it will be possible to specify differnt ternary\nextrapolation methods for each a ternary subsystem of a phase. A\nternary subsytem in a phase may be assigned a symmetric Kohler or\nassymetric Toop ternary method together with the Redlich-Kister binary\nmethod. See section~\\ref{sc:kohler-toop2}.\n\n\\subsubsection{The TPFUN expression and bibliographic reference}\\label{sc:tpfun}\n\nThe expression for a parameter can be a single value or a function of\n$T$ and $P$. It must start with a low temperature limit, usually\n298.15~K and must finish with a high temperature limit. These\nexpressions as well as their first an second derivatives will be\ncalculated by the TP-fun package. To simplify that there is a strict\nsyntax for the expression. A term in the expression is\n\n``numeric value'' * ``name of TP function'' *T** ``power'' *P** ``power'' \n\nYou can construct very complex expression by referring to other\nfunctions. If ``power'' is zero the corresponding *T** or *P** can be\nomitted. If it is negative it must be surrounded by parenthesis like\n(-1). If it is unity the **1 can be skipped.\n\nSeveral terms, seperated by signs, forms an expression and it must be\nterminated by a semicolon, ``;''. After the semicolon there must be a\nhigh temperature limit or a breakpoint in temperature. A breakpoint\nmust be followed by the letter ``Y'' and then a new expression for\ntemperatures above the breakpoint. \n\n{\\bf It is the responsability of the database manager to ensure the\n expression is continuous at the breakpoint. If there are jumps in\n the value at a breakpoint strange things will happen when\n calculating equilibria.}\n\nAfter the high temperature limit the letter ``N'' must be given\nfollowed by a bibliographic reference for the parameter. Use the\ncommands AMEND or ENTER BIBLIOGRAPHIC to give the reference.\n\n{\\bf The database manager should always add a bibliographic reference\n even if it is just his or her name and a date. This avoids people\n to mistake a value inspired by your experience for a carefully\n validated parameter.}\n\nA term can be used inside a natural logarithm, LN, or exponential,\nEXP. And the LN or EXP can be multiplied with a term. On the other\nhand you are not allowed to have any parenthesis, except around powers\nor arguments to LN and EXP. A valid expression is\n\n\\begin{verbatim}\n 298.15 -8856.94+157.48*T-26.908*T*LN(T)+.00189435*T**2\n -1.47721E-06*T**3+139250*T**(-1); 2180 Y \n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000 N 91Din\n\\end{verbatim}\n\nwhere 91Din is the bibliographic reference to the SGTE unary database.\n\n\\subsection{The reference state of a component}\\label{sc:refstate}\n\nThe values of most thermodynamic data must have a defined reference\nstate. By default the reference state for the components is SER\n(Stable Element Reference) which is the stable state of the element at\n298.15~K and 1~bar. (NOTE: the default reference state is defined by\nthe database but today almost all databases have SER as reference\nstate.)\n\nFor each component (also for other components than the elements) you\ncan specify a phase at a given temperature and pressure as reference\nstate, see section~\\ref{sc:setref}. The phase must exist for the\ncomponent as pure.\n\nA state variable like the chemical potential, MU(O), will refer to the\nuser defined reference state if set. To obtain the value for the SER\nstate you can use a suffix S, i.e. MUS(O) to obtain the chemical\npotential refered to SER. All state variables are listed in\nTable~\\ref{tab:statev}.\n\nNote that the value of integral properties like Gibbs energy, $G$,\nenthalpy, $H$, etc. may have mixed reference states unless all\ncomponents have the same phase as reference state. In order to have\nthe enthalpy of mixing of a phase all components must have that phase\nas reference state. For the volume, $V$, SER is always used as\nreference state unless all components have the same reference state.\n\n\\hypertarget{Info equilibrium}{}\n\\subsection{Equilibrium calculations}\n\nThe basic application of OC is to calculate the equilibrium of a\nsystem as described in section~\\ref{sc:calceq}. The user can\nspecifying the external conditions like $T, P$ and the composition,\nsee section~\\ref{sc:calceq}.. The minimizing algorithm~\\cite{15Sun2}\nuse Lagrangian multiplier so many different sets of state variables\ncan be used for specifying the external conditions. Each condition is\nset separately and it is possible to extract phase amounts and\ncompositions after the calculation. By changing the status of the\nphases it is possible to calculate metastable state.\n\nIn order to do any calculation the user must provide a database with\nthe model parameters for his system or enter these manually.\n\nThe conditions can also be set using the command {\\em\n set\\_input\\_amount}, see section~\\ref{sc:setinpuam}.\n\n\\hypertarget{Info propertydiagram}{}\n\\subsection{Property diagrams}\n\nA property diagram is calculate with the STEP command. First you must\nset conditions to calculate a single equilibrium and then set set one\nof the conditions as an axis. After the STEP command, see\nsection~\\ref{sc:step} you can plot how any state variable varies with\nthe selected axis variable. See the section~\\ref{sc:plot} and the OC\nmacros guide.\n\n\\hypertarget{Info phasediagram}{}\n\\subsection{Phase diagrams}\n\nA phase diagram show the regions of different sets of stable phases in\na system. It can have two or more axis variables, in OC the maximum\nnumber of axis is two at present. As for property diagrams you must\nfirst calculate a single equilibrium and then select two conditions as\naxis variables. The command MAP, see section~\\ref{sc:map}, will then\ntrace the lines in your systems where the set of stable phases\nchanges. There is no limit on the number of components for a phase\ndiagram calculation.\n\nAfter calculating a diagram you can plot it with many different types\nof axis, see section~\\ref{sc:plot} and the OC macros guide.\n\n\\subsection{Diagrams simulating phase transformations}\n\nThermodynamics is essential to simulate phase transformations but\nrequires good understanding also of the kinetics such as diffusion and\nkinetcs. For such applications OC has an Appication Software\nInterface (OCASI) with subroutines to calculate local driving forces\nand chemical potentials in various parts of a sample as described\nin~\\cite{16Sun,20Her}. However, there are a few cases when one can\nsimplify the kinetics sufficently to use the facilities of OC\ndirectly.\n\n\\subsubsection{Scheil-Gulliver solidification model}\\label{sc:scheil1}\n\nIn a Scheil-Gulliver solidification simulation the diffusion in the\nsolid phases are ignored and the liquid is considered as homogeneous.\nThat is a realistic model for the interdendric reqion during a normal\nsolidification. It can be calculated with a STEP calculation by using\nsmall time steps and modify the overall composition to be that of the\nliquid after each step. The solid formed is removed from the system.\nIn such a simulation the liquid will be stable until it reaches an\ninvariant equilibrium, usually very far from its initital composition,\nsee section~\\ref{sc:scheil2}.\n\n\\subsubsection{Paraequilibrium calculation}\\label{sc:paraeq1}\n\nIn some alloys, most particularly in steels, there are fast diffusing\nelements such as C or N which can maintain a constant chemical\npotential during the whole transformation, and thus change their\ncomposition in different phases. The other alloying elements may\ntransform to a new phase without changing their fractions. This can\nbe modelled as a paraequilibrium or a ``No Partitioning Local\nEquilibrium'' (NPLE) situation and it requires no kinetic data. In OC\nthe CALCUALATE or STEP PARAEQUILIBRIUM simulates such a\ntransformation, see sections~\\ref{sc:paraeq2}, \\ref{sc:paraeq3}.\n\n\\subsubsection{Tzero calculation}\\label{sc:tzero1}\n\nThe $T_0$ point, line or rather ``hypersurface'' between two phases\nare defined by $T$ where the Gibbs energy of the two phases are the\nsame. Such a point is the limit of a diffusionless transformation of\none phase to the other and it is useful to understand for example the\nmartensite transformation. How to calculate the ``Tzero'' point or\nline are explaned in sections~\\ref{sc:tzero2} and \\ref{sc:tzero3}.\n\n\\subsection{Assessment of model parameters for databases}\n\nOne of the important uses of the OC software is to assess model\nparameters in the phases of a system using experimental and\ntheoretical data. This is done by recalculating the experimental data\nfrom the model and by varying the model parameters a least square\nroutine, LMDIF developed at Argonne National Lab in 1981, is used to\nfind the best set.\n\nAssessments are a very difficult procedure as you must also take into\naccount the extrapolations of the model outside the range of\nexperimental data. So called ``First Principles Calculations'' or the\nsomewhat simpler ``Density Functional Theory'' (DFT) which are based\non the electronic structure of the elements can provide information\nfor metastable as well as for the stable state. But you must be\ncareful that the result from such calculations does not represent a\nmechanically unstable state with imaginary phonon frequencies.\n\nExperimental data can be direct measurements of thermodynamic data\nlike enthalpies, chemical potentials, heat capacities, activities, etc\nbut very important are also measurements of phase diagrams,\nsolubilities etc because they are also related to the equilibrium\nstate.\n\nThere are several commands related to the assessment procedure in OC\nbut during the assessment you will also use the basic facilities to\ncalculate equilibria for different kinds of conditions as well as many\ndifferent kinds of diagrams to verify the results.\n\n\\subsubsection{Entering coefficients to be assessed}\n\nThe command ``enter optimizing coefficients'', see\nsection~\\ref{sc:optcoeff} creates symbols A00 up to A99 that can be\nused as coefficients in the thermodynamic model parameters. Maximum\nnumber of coefficients are 100.\n\n\\subsubsection{Entering phases and model parameters}\n\nThe elements, species and phases with their appropriate models are\nentered using the appropriate commands. Normally this is on a macro\nfile in order to have proper documentation. Keep also in mind that an\nassessment is often revised after a few years when new data become\navailable or you find that the extrapolations of an assessment to a\nhigher order system is not reasonable.\n\nThe model parameters are entered using ``enter parameter'', see\nsection~\\ref{sc:enterparam} or ``enter tpfun'', see\nsection~\\ref{sc:entertpf} as many parameters may share some properties\nand a TP-function can be used in several parameters. The optimizing\ncoefficents A00 to A99 with different T and P dependence can be used\ninstead of numerical values as their values should be assessed.\n\n\\subsubsection{Entering experimental data}\n\nThis is done either by entering single equlibria with conditions and\nin addition using the command ``enter experiment'', see\nsection~\\ref{sc:enterexp} where the experimental data is given with an\nuncertainty. Each equilibrium with an experiment is given a unique\nname.\n\nOften there are tables with values and instead of entering each of\nthem there is a command ``enter many\\_equilibria'', see\nsection~\\ref{sc:entermany} with a simplified syntax.\n\nWhen all equilibria with experiental data has been entered you have to\ngive the command ``set range'', see section~\\ref{sc:setrange} to give\nthe first and last equilibrium number that should be used in the\nassessment. If necessary this range can be extended during the\nassessment.\n\nAll the experimental data should also be entered as a mcro file to\nkeep a documentation.\n\n\\subsubsection{Saving the state of the assessment}\n\nAny time during an assessment it is possible to save the values of all\nassessed parameters and the calculated experimental equilibria by the\ncommand ``save unform {\\em filename}'', see section~\\ref{sc:saveunf}.\nWith this command the data inside OC will be written as an unformatted\nFortran file and this can be saved and later read back into the OC\nsoftware by the command ``read unfomatted {\\em filename}'', see\nsection~\\ref{sc:readunf}. If these commands are inside a macro file\nprefix the filename with ``./'' to read and write on the same\ndirectory as the macro file.\n\nThese unformatted files are very convenient but beware that they may\nnot be portable to other operating systems or even other versions of\nOC compiled with different Fortran compilers. It may change in future\nreleases of the OC software. Thus keep printouts and macro files also\nif you later want to make modifications.\n\n\\subsubsection{Performing the assessment}\\label{sc:assess}\n\nThere are many decisions to make during the assessment and a general\ndescription how to perform an assessment can be found in the book by\nLukas et al~\\cite{07Luk}. It is never possible to try to assess all\nparameters using all experiments in a single step. Normally the user\nselects different sets of experimental data by the ``set weight''\ncommand, see section~\\ref{sc:setw} and fits a few model parameters to\nthese using the command ``set variable-coeff'', see\nsection~\\ref{sc:setvar}. This can typically an enthalpy of mixing or\na heat capacity function for a compound.\n\nThe command to run the least square fit is ``optimize'' followed by\nthe maximum number of iterations, see section~\\ref{sc:optim}. If zero\nis given a single loop is made through all equilibria with nonzero\nweights within the specified range is made. It is also possible to\nuse the command ``calculate all'', see section~\\ref{sc:calcall}, to\ncalculate all non-zero weight equilibria. With the latter command you\ncan turn on the grid minimizer, in the optimize command the grid\nminimizer is always turned off.\n\nWhen the optimize command is given with nonzero maximum there will be\noutput on the screen at regular intervals giving the current values of\nthe optimizing coefficients and the value of the sum of squares. When\nthe oprimization is finished there will also be a listing of the\nerrors for all experiments.\n\nWith the command ``list opt short'', see\nsection~\\ref{sc:listoptshort}, the current values of the optimizing\ncoefficients and all equiliria with the experimental data is listed\ntogether with the sum of squares. New selection of equilibria or\nweights can be made and the values obtained for the optimizing\ncoefficients must also be reasonable but to know what is reasonable is\nnot always easy. These steps are repeated until the user is satisfied\nor exhausted.\n\nMacro files to calculate and plot of the calculated properties\noverlayed with the experimental data should be preoared and run\nregularly as just looking at numbers is not sufficient.\n\nAt a later stage solubilities and phase diagram data are used but in\nmany cases reasonable guesses of the start values of model parameters\nmust be made to be able to calculate the equilibrium with the\nexperiment. Great care must be taken that the calculated equilibria\nfor the inital model parameters are reasonably close to the\nexperimental. Parts of the experimental phase diagram may have to be\nassessed separately and the metastable extrapolations of the different\nphases checked.\n\nSometimes a phase appears in a region where it should not be stable\nand additional fictitious experimental data may have to be added to\nprevent this to happen.\n\nAt the end the assessment should be written up and published.\n\n\\subsection{Application software}\n\nThere is a separate guide for using OpenCalphad Application Interface\n(OCASI) in application software. For such cases it is convenient to\nhave the source code which can be compiled together with the\napplications software. A special feature is also the possibility to\nuse OpenMP to calculate in parallel.\n\n\\newpage\n\n% below the commands are documented in alphabetical order\n\n\\hypertarget{All commands}{}\n\\section{The command menu}\n\nThe commands in alphabetical order as listed with the ?. The commands\nwith an * has subcommands.\n\n% NOTE the ~ used for the long commands needed for the HTML output\n\\begin{tabular}{llll}\nABOUT & EXIT & MAP & SELECT * \\\\\nAMEND * & FIN & NEW & SET * \\\\\nBACK & HELP & OPTIMIZE~ & SHOW \\\\\nCALCULATE *~ & HPCALC & PLOT * & STEP * \\\\\nDEBUG * & INFORMATION *~ & QUIT \\\\\nDELETE * & LIST * & READ * \\\\\nENTER * & MACRO & SAVE *\\\\\n\\end{tabular}\n\nMany of the commands have ``subcommands'' and usually OC will provide\na default answer (listed within slashes /default/) which is selected\nby pressing return. You can type commands, subcommands and other\nparameters (separated by a space) on the same line if you know the\norder.\n\nTo select a default when typing several commands and answers to\nquestions (command arguments) on the same line, you can use a\ncomma,``,'' to select the default answer. For example ``l,,,,'' will\nlist on the screen with the current list options.\n\nMany commands will ask additional questions, all of them are not\nincluded in this guide but those which are will be {\\bf shown in\n bold}. Examples and references to other commands are sometimes in\n{\\bf bold}, sometimes in {\\em italics}.\n\nWhenever the program asks a question you do not understand you can\ntype a question mark, ``?'', to obtain help. If the online help\nsystem is correctly installed, see section~\\ref{sc:on-line-help}, this\nwill open a browser window with this manual and hopefully position the\nmanual at the relevant part. You can browse the whole manual in this\nwindow if you need additional help.\n\n\\hypertarget{Command options}{}\n\\subsection{Options}\\label{sc:options}\n\nThere are some options that can be set for the whole session or for just a\nsingle command. The options are identified by a / in front like\n/output=myfile.dat.\n\nAn option must be specified directly after a command for example:\n\n{\\bf list /out=equil5 result 2}\n\nOnly a few options are implemented.\n\n\\begin{itemize}\n\\item /OUTPUT={\\em file name} open a file and write on it. Note that\n if you have popup windows enabled this will open unless you type the\n file name (with path) on the same line as the command. In a macro\n file must prefix the file name with ``./'' to have the output (or\n append) on the same directory as the macro file. See also\n section~\\ref{sc:popup} and \\ref{sc:macro}.\n\\item /APPEND={\\em file name} append output to a file, any previous\n content is kept.\n\\item /ALL apply for all.\n\\item /FORCE override normal restrictions.\n\\item /VERBOSE write information while executing.\n\\item /SILENT do not write anything except fatal error messages.\n\\end{itemize}\n%===================================================================\n% The online help will not print lines starting with % or \\\n\\hypertarget{About}{}\n\\section{About}\n\nThis is OpenCalphad (OC), a free software for thermodynamic calculations as\ndescribed in B Sundman, U R Kattner, M Palumbo and S G Fries, Integrating\nMaterials and Manuf. Innov. (2015) 4:1; B Sundman, X-G Lu and H Ohtani,\nComp Mat Sci, Vol 101 (2015) 127-137 and B Sundman et al., Comp Mat Sci,\nVol 125 (2016) 188-196\n\nIt is available for download at http://www.opencalphad.org or\nthe sundmanbo/opencalphad repository at http://www.github.com\n\nThis software is protected by the GNU General Public License\nYou may freely distribute copies as long as you also provide the source code\nand use the GNU GPL license also for your own additions and modifications.\n\nThe software is provided \"as is\" without any warranty of any kind, either\nexpressed or implied. The full license text is provided with the software\nor can be obtained from the Free Software Foundation http://www.fsf.org\n\nCopyright 2011-2021, Bo Sundman, Gif sur Yvette, France.\nContact person Bo Sundman, bo.sundman@gmail.com\n\n%===================================================================\n\\hypertarget{Amend}{}\n\\section{Amend}\n\nIntended to allow changes of already entered data. Only some\nof the subcommands are implemented.\n\n\\begin{tabular}{llll}\n ASSESSMENT\\_RESLT~ & ELEMENT & OPTIMIZING-COEFS~ & REDUNDANT\\_SETS \\\\\n BIBLIOGRAPHY~ & EQUILBRIUM~ & PARAMETER~ & SPECIES\\\\\n COMPONENTS & GENERAL & PHASE * & SYMBOL \\\\\n CONSTITUTION~ & LINES & QUIT & TPFUN-SYMBOL\\\\\n\n\\end{tabular}\n\nThe default selection is PHASE.\n%--------------------------------\n\n\\hypertarget{Amend assess result}{}\n\\subsection{Amend assessment result}\n\nAfter assessing a set of parameters for a system each of these has a\nRelative Standard Deviation (RSD) listed in the result. Using this\nRSD it is possible to modify one parameter and recalculate how much\nall the other parameters should change due to this modification\nwithout rerunning the actual assessment.\n\nThis command allows to calculate such a change and it can be tested be\nreassessing the parameters using the experiments.\n\n\n%--------------------------------\n\\hypertarget{Amend bibliography}{}\n\n\\subsection{{\\em amend} Bibliography}\n\n{\\bf Reference identifier:}\n\nThe text for bibliographic reference identifier can be amended. The\nreference identifier is CASE INsensitive.\n\n{\\bf Reference text, end with ``;'':}\n\nThe text for this reference will be set to the text supplied. It can be\nseveral lines terminated with a ``;''\n\n%--------------------------------\n\\hypertarget{Amend components}{}\n\\subsection{{\\em amend} Components}\\label{sc:amendcomp}\n\n{\\bf Give all new components:}\n\nBy default the elements are the components. This command can set any\northogonal set of species as components. The number of components\ncannot be changed by this command. The new components must exist as\nspecies and be orthogonal. For example in the system Ca-O-Si one can\ndefine CaO SiO2 and O as components.\n\nThe components are important as you can only use components to\nspecify compositions, such as x(cao)=.3 is possibly only if CaO\nis a component. See also {\\bf set input-amount}~\\ref{sc:setinpuam}.\n\nNote that when you have other components than the elements you may\nhave negative mole fractions and phase amounts (but never negative\nmass).\n\n%--------------------------------\n\\hypertarget{Amend constitution}{}\n\\subsection{{\\em amend} Constitution}\n\n% There will be several questions ``Phase name:'' in various part of the\n% software, the initial ``Amend const'' here is to locate THIS question\n\n\\hypertarget{Amend const phase name}{{\\bf Phase name:}}\n\nThe program will ask for a phase name and you can set the amount\nand constitution of the phase. This will be used as initial\nconstitution for a calculation unless the grid minimizer is used.\n\n\\hypertarget{Amend const amount}{{\\bf Amount of phase:}}\n\n% This command should be moved to AMEND PHASE ...\n\n{\\bf Current (Y), default (D) or new (N) constitution:}\n\nAnswer Y to keep current constituion, D to set a default constitution\n(if you have set such a constitution) or N to provide a new\nconstitution.\n\n{\\bf Fraction of component: }\n\nYou can specify a value between 0.0 and 1.0. The sum of all\nconstituents must be unity, values below 0.0 or 1.0 are not allowed.\nIf you want the fraction of a constituent the be 1.0-(all the other\nfractions) you can set its value to REST. Otherwise the last\nconstituent is set to the ``rest''.\n\n%--------------------------------\n\\hypertarget{Amend element}{}\n\\subsection{{\\em amend} Element}\n\nThe data for the element can be amended, not implemented yet.\n\n%--------------------------------\n\\hypertarget{Amend equilibrium}{}\n\\subsection{{\\em amend} Equilirium}\n\nNot sure what could be amended and anyway not implemented.\n\n%--------------------------------\n\\hypertarget{Amend general}{}\n\\subsection{{\\em amend} General}\n\nA number of general settings can be amended by the user:\n\n\\begin{itemize}\n\\item The name of the system.\n\\item The level of the user (beginner, frequent user, expert). This\n may affect the behavior of the program (not implemented yet).\n\\item If global minimization is allowed or not.\n\\item If the grid minimizer is allowed to merge gridpoints in the same\n phase after global minimization.\n\\item If the grid minimizer can automatic create composition sets is\n allowed or not.\n\\item If redundant composition sets can be deleted automatically after\n an equilibrium calculaion.\n\\end{itemize}\n\nNote that these and some other general feautures can also be changed\nby the command {\\bf SET BIT GLOBAL}\n\n%--------------------------------\n\\hypertarget{Amend line}{}\n\\subsection{{\\em amend} Line}\n\nAfter a STEP or MAP command it is possible to give the command LIST\nLINE to list all calculated equilibria or AMEND LINE which allows you\nto EXCLUDE lines or INCLUDE lines from the plotting.\n\n{\\bf Only excluded? /Y/:}\n\nSometimes a line may be excluded from plotting if there was an error\nwhile it was calculated. Answering Y will make it possble to restore\nsuch a line and also lines you have previously excluded.\n\n{\\bf Exclude this line? /N/:}\n\nFor an included line you can exclude from the plot.\n\n{\\bf Include this line? /N/:}\n\nFor an excluded lines you can include it in the plot.\n\n%--------------------------------\n\\hypertarget{Amend optim coeffs}{}\n\\subsection{{\\em amend} All optimizing coefficients}\n\nThe values of each optimizing coefficients, see\nsection~\\ref{sc:setrange} can be rescaled (start values set to current\nvalues) or recovered (current values set to previous start values).\n\n%--------------------------------\n\\hypertarget{Amend parameter}{} \n\\subsection{{\\em amend} Parameter}\n\nThe possible parameters that can be amended depend on the model of the\nphase. By specifying a parameter you can change its expression.\n\nThis is not yet implemented you must use the command {\\bf ENTER\n PARAMETER} to change the parameter expression.\n\n%--------------------------------\n% we need to add these for the seach on the help file ... suck\n\\hypertarget{Amend for phase}{}\n\\hypertarget{Amend phase}{}\n\\subsection{{\\em amend} for Phase ``phase-name''}\\label{sc:amendph}\n\nYou must first specify the phase name and then you can amend some of\nthe properties of the phase:\n\nIf you want to amend something for a composition set you must specify\nthe composition set number together with the phase name after a hash\ncharacter (\\#) (like liquid\\#2).\n\n{\\bf Phase name:}\n\nYou must specify the name of the phase you want to amend.\n\n{\\small\n\\begin{tabular}{llll}\nADDITION * & DEFAULT-CONSTIT & FCC-PERMUTATIONS~ & TERNARY-EXTRAPOL\\\\ \nAQUEUS-MODEL & DIFFUSION & QUASICHEM-MODEL~ & UNIQUAC-MODEL \\\\ \nBCC-PERMUTATIONS~ & DISORDERED-FRACS & QUIT \\\\ \nCOMPOSITION-SET & FCC-CVM-TETRAHDR~ & REMOVE-COMPSETS\\\\\n\\end{tabular}\n}\n\n%--------------------------------\n\\hypertarget{Amend addition}{}\n\\subsubsection{{\\em amend} phase ``phase-name'' Addition }\n\nAdditions are used to give a contribution to the Gibbs energy of a\nphase using more or less physically based model. Usually they require\nadditional model parameters, see section~ref{sc:paramid}. The\ndifference between addition and other things that can be amended may\nnot always be very clear. The possible additions are\n\n{\\small\n\\begin{tabular}{llll}\n ELASTIC-MODEL-1~ & MAGNETIC-CONTRIB~ & SMOOTH-CP-STEP \\\\\n GADDITION & QUIT & TWOSTATE-LIQUID\\\\\n LOWT-CP-MODEL & SCHOTTKY-ANOMALY~ & VOLUME-MODEL1\\\\\n\\end{tabular}\n}\n\nBEWHERE! The OC software allows you to mix many types of additions for\na phase but it is up to YOU as user to defend the physical reasons for\nthis!\n\n\\hypertarget{Add per formula unit}{{\\bf Per formula unit?}}\n\nThe theoretical equation for most additions usually gives the value\nper mole of atoms. As the Gibbs energy is calculated per mole formula\nunit of the phase in OC (as well as most thermodynamic software) the\naddition must be multiplied with the number of atoms per formula unit\nof the phase.\n\nSome of the additions, for example mobilities, are for properties that\ndoes not contribute to the thermodynamics but which depend on the\nphase, $T, P$ and phase constitution in the same way as the Gibbs\nenergy and it is thus convenient to model and store the data together\nwith the thermodynamic data.\n\n%. . . . . . . . . . . .\n\n\\hypertarget{Amend elastic-model-1}{}\n\\subsubsubsection{{\\em amend phase ... addition} Elastic\\_model\\_1}\n\nA contribution to the Gibbs energy due to elastic strain can be added.\nThis also requires values of the elastic constants and lattice\nparameters, see section~\\ref{sc:paramid}. \n\nThere is no code to calculate the elastic energy implemented yet.\n\n%.........................\n\\hypertarget{Amend Gaddition}{}\n\\subsubsection{{\\em amend phase} ... Gaddition}\n\nYou can add a constant value of the Gibbs energy to a phase in Joule\nper formula unit. This is a crude but simple way to implement a for\nexample a nucleation barrier.\n\n{\\bf Addition to G in J/FU (formula units)/0/:}\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend lowt-Cp-model}{}\n\\subsubsubsection{{\\em amend phase ... addition} LowT\\_Cp\\_model}\n\nThe Einstein model for heat capacities from 0~K has been implemented.\nIt requires a value of the property Einstein T as listed in\nsection~\\ref{sc:paramid}.\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend magnetism}{}\n\\subsubsubsection{{\\em amend phase ... addition} Magnetic\\_contrib}\n\nThe Inden-Hillert and the modified Inden-Qing-Xiong model for the\nmagnetic contribution to the Gibbs energy can be set by this command\nThis depends on model parameters describing the Curie and Neel\ntemperatures and the Bohr magneton number, as listed in model\nparameters identifiers~\\ref{sc:paramid}, for the phase.\n\nYou also must also enter model parameters for the constituents of the\nphase, see the documentation of the model or Lukas~\\cite{07Luk}.\n\n{\\bf Antiferromagnetic factor:}\n\nThe Qing-Xiong model is selected by giving zero (0) for the question\nabout the anti-ferromagnetic factor. For the original Inden-Hillert\nmodel -3 is used for FCC and HCP whereas -1 is used for BCC.\n\nThe Inden-Hillert model is described in Lukas et al~\\cite{07Luk}. The\nInden-Qing-Xiong modified model requires separate values of the Curie\nand Neel Temperatures and either an ``effective'' Bohr magneton number\nor individual Bohr magneton numbers for the constituents of the phase.\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend addition quit}{}\n\\subsubsubsection{{\\em amend phase ... addition} Quit}\n\nYou did not really wanted to add any addition.\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend Schottky-anomaly}{}\n\\subsubsubsection{{\\em amend phase ... addition} Schottky\\_anomaly}\n\nSome physical phenomena can create a ``bump'' in the heat capacity for\na phase at a certain $T$ and this addition can describe this. It uses\ntwo model parameter identifiers, TSCH and CSCH that may depend on the\ncomposition. TSCH specify the T for the anomaly and CSCH the maximum\ncontribution to the heat capacity (J/mol/formula unit) divided by $R$,\ni.e. as a factor of the gas constant, $R$.\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend smooth-Cp-step}{}\n\\subsubsubsection{{\\em amend phase ... addition} Smooth-Cp-step}\n\nThe 3rd generation thermodynamic databases extrapolate to 0~K and\nrequire that the heat capacity is zero at 0~K. This means it is\nimpossible to use $T*\\ln(T)$ terms (and also negative powers of\n$T^{-n}$) but there may be some physical phenomena that causes an\nincremental increase of the heat capacity at some temperature.\nIgnoring the physical reason for such an increase this\n``smooth\\_$C_P$\\_step'' addition will provide such this using two\nparameters, THT2 to specify $T$ and DCP2 to specify the increement in\nheat capacity. DCP2 is a factor of $R$. It uses the same\nmathematical expression as the Einstein heat capacity function but has\nno enthalpy contribution.\n\n%. . . . . . . . . . . .\n\\hypertarget{Amend twostate liquid}{}\n\\subsubsubsection{{\\em amend phase ... addition} Twostate-liquid}\n\nThe two-state model for the hear capacity for the undercooled liquids\ncan be added. It assumes a low T amorphous state modeled as an\nEinstein solid and requires an Einstein T. For the liquid transition\nit uses the model\\_parameter\\_ident {bf G2}, both of which are listed\nin section~\\ref{sc:paramid}.\n\n{\\bf Is G2 composition dependent? /Y/:}\n\nG2 parameters are usually evaluated for thr pure elemenents. Using\ninteraction parameters for the G2 parameter may create unexpected\nphenomena.\n\nYou must specify parameters for THET and G2 for all constituents of\nthe phase and possibly also interaction parameters to specify the\ncomposition dependence.\n\nThe implementation of this addition is not finished.\n\n%--------------------------------- end of amend phase ... addition\n\n\\hypertarget{Addition aqueus-model}{}\n\\subsubsection{{\\em amend phase} ... Aqueous-model}\n\nA model with dilute configurational entropy. Not implemented yet.\n\n%.........................\n\\hypertarget{Amend BCC-permutations}{}\n\\subsubsection{{\\em amend phase} ... BCC-permutations}\n\nThis is intended for the 4 sublattice CEF model for BCC ordering. Due\nto crystallographic symmetry several model parameters must be\nidentical such as\n\nG(BCC,AL:FE:FE:FE)=G(BCC,FE:AL:FE:FE)=G(BCC,FE:FE:AL:FE)=G(BCC,FE:FE:FE:AL)\n\nand this command means these parameters need to be entered only once.\nThis affects the data storage and the calculation of the Gibbs energy\nis slightly more efficient. The same applies for the\nFCC\\_permutations but the BCC tetrahedron is asymmetric which makes it\na bit more complicated than the FCC. There can be a 5th sublattice\nwith interstitials.\n\n%.........................\n\\hypertarget{Add new cs}{}\n\\subsubsection{{\\em amend phase} ... Composition set}\\label{sc:amend_phase_cs}\n\nEach phase has by default a single composition set. If the same phase\ncan exist as stable (or metastable) with two or more compositions\n(miscibility gaps or order/disorder transformations) you may have to\namend the phase by creating additional composition sets. \n\nComposition sets can also be created automatically by the grid\nminimizer during an equilibrium calculation. In such a case the\ncomposition set will have the suffix \\_AUTO,\n\nComposition sets of a phase can be created and deleted. Phases with\nmiscibility gaps or which can exist with different chemical ordering\nlike A2 and B2 must be treated as different composition sets. You can\nspecify a prefix and suffix for the composition set. Extra\ncomposition sets will always have a suffix \\#digit where digit is a\nnumber between 2 and 9. You cannot have more than 9 composition sets.\n\nThe composition set number is given after the phase name and preceeded\nby a hash character \\#. In the OCASI interface and some more cases\nphase tuples are used to identify a phase and a composition set by a\nsingle number. As composition sets can be created and deleted a phase\ntuple index for the 2nd or higher composition set may change between\ncalculations.\n\nIn some cases it may be interesting to calculate metastable states\ninside miscibility gaps and you can prevent the automatic creation of\ncomposition sets by turning off the global minimazation using {\\bf\n AMEND GENERAL} or for an individual phase by {\\bf SET PHASE ... BIT\n NO\\_AUTO\\_COMP\\_SET}\n\n%.........................\n\\hypertarget{Amend phase default constit}{}\n\\subsubsection{{\\em amend phase} ... Default Constitution}\n\nThe default constitution of a phase can be set. Unless the grid\nminimizer is used this will be used for the first calculation with the\nphase and sometimes if there are convergence problems. NOTE that if\nyou want to specify a default constitution for the second or higher\ncomposition set of a phase you must specify the composition set with\nthe phase name!\n\nDepending on the minimizing software used the initial constitution can\nbe important to find the correct equilibrium if the phase has ordering\nor a miscibility gap.\n\nFor each constituent you can specify a minimum $>$ or maximum $<$\nfraction or give NONE if there are no default.\n\nIf a phase has miscibility gaps and you have created composition\nsets with default constitutions the grid minimizer will try to select\nthe composition set with a composition closest to the default for a\nstable phase.\n\nTo temporarily set a new constitution of a phase use the command {\\bf\n AMEND CONSTITUTION} $<$phase$>$ or {\\bf CALCULATE PHASE ... }.\n\n%.........................\n% UNFINISHED\n\\hypertarget{Add diffusion}{}\n\\subsubsection{{\\em amend phase} ... Diffusion}\n\nThis is to specify how the diffusion coefficient matrix should be\ncalculated when simulating a phase transformation. Normally the\nmobilities for the constituents of the phase are read from the\ndatabase but you may use different ``depended'' and ``independent''\nconstituents in the diffusion model and also some other factors. This\ncommand is intended for such use. It is not implemeted yet.\n\nThere is no intention that OC itself should simulate diffusion but as\nthe diffusion coefficents are strongly dependent on the thermodynamic\nfactor (the Darken stability matrix) which represent the second\nderivatives of the Gibbs energy it is convenient to include some\nproperties used in a simulation in the thermodynamic software.\n\n%.........................\n\\hypertarget{Amend phase disordfrac}{}\n\\subsubsection{{\\em amend phase} ... Disordered fraction sets}\n\nFor phases with several sublattices the Gibbs energy of the phase can\nbe divided into two sets of fractions where the second or\n``disordered'' set have only one or two sublattices and the fractions\non these represent the sum of fraction on some or all of the first or\n``ordered'' set of sublattices.\n\nThere are two different ways to handle the disordered fraction set\ndepending on the fact if the phase can be totally disordered. The\nlatter is the case for phases like B2, L1$_2$ etc which can be totally\ndisordered as BCC/A2 or FCC/A1. The calculation of the Gibbs energy\nin the latter cas will subracted the contribution from the ordered\npart when the phase is disordered, see for example Lukas et\nal~\\cite{07Luk}.\n\nThis is particularly important to model the Gibbs energy for phases\nwith ordering like FCC, BCC and HCP and for intermediate phases like\nSIGMA, MU etc.\n\n%.........................\n% UNFINISHED no question?\n\\hypertarget{Amend FCC-CVM-tetradrn}{}\n\\subsubsection{{\\em amend phase} ... FCC\\_CVM\\_tetradrn}\n\nThis model is intended for the CVM tetrahedron model for FCC and HCP.\nNot implemented yet.\n\n%.........................\n\\hypertarget{Amend FCC-permutations}{}\n\\subsubsection{{\\em amend phase} ... FCC\\_permutations}\n\nThis is intended for the 4 sublattice CEF model for FCC ordering. Due\nto crystallographic symmetry several model parameters must be\nidentical such as\n\nG(FCC,AL:FE:FE:FE)=G(FCC,FE:AL:FE:FE)=G(FCC,FE:FE:AL:FE)=G(FCC,FE:FE:FE:AL)\n\nSetting this means that unique model parameters need to be entered\nonly once, the software will take care of all permutations. HCP\npermutations are also handled with this command as the HCP tetrahedron\nmodel is identical to the FCC. There can be a 5th interstitial\nsublattice.\n\n%.........................\n\\hypertarget{Amend quasichemical}{}\n\\subsubsection{{\\em amend phase} ... Quasichemical}\n\nThere are several quasichemical models for the liquid that only\ndescribes the short range ordering (SRO).\n\nNone of them are yet implemented.\n\n%.........................\n\\hypertarget{Amend phase ... quit}{}\n\\subsubsection{{\\em amend phase} ... Quit}\n\nDo not amend anything for the phase.\n\n%.........................\n\\hypertarget{Amend phase ternary extrapol}{}\n\\subsubsection{{\\em amend phase} ... ternary-extrapolation}\\label{sc:kohler-toop2}\n\nThe default ternary extrapolation is the symmetric Muggianu method\nwhich uses the binary excess Gibbs energy closeset to the overall\ncomposition, see section~\\ref{sc:excessparameters}. However, there is\nalso a symmetric Kohler method and an ansymmetric Toop method which\ncan be defined separately for each ternary. For this you must specity\n\n{\\bf Ternary extrapolation (K, T or Q to quit)}\n\nIf you specify T for Toop you must specify the Toop constituent,\nothewise just any of the three constituents as the {\\bf first\n constituent}. After that you will be asked for\n\n{\\bf Second constituent:} and\\\\\n{\\bf Third constituent}\n\nFor each ternary subsytem in the phase this can be specified. Those\nnot specified will use a Muggianu method, see\nsection~\\ref{sc:excessparameters}.\n\n%.........................\n\\hypertarget{Amend phase UNIQUAC}{}\n\\subsubsection{{\\em amend phase} ... UNIQUAC}\n\nThe UNIQUAC model for polymers has been implemented and there is a\nmacro ``uniquac'' showing how it can be used.\n\n%-------------------------------- end of amend phase\n\\hypertarget{Amend quit}{}\n\\subsection{{\\em amend} Quit}\n\nDo not amend anything (more).\n\n%--------------------------------\n\\hypertarget{Amend redundant-sets}{}\n\\subsection{{\\em amend} redundant-sets}\n\nSometimes a large number of composition sets are created for certain\nphases and they may create trouble at later calculations. This\ncommand will set all metastable composition sets as dormant which may\nsimplify convergence. A dormant compositon set may be set stable by\nthe gridminimizer. It is also possible to delete composition sets but\nthat is fragile and they may anyway be created again by the grid\nminimizer.\n\n%--------------------------------\n\\hypertarget{Amend species}{}\n\\subsection{{\\em amend} for Species}\n\nThis is implemented for UNIQUAC species which has a specific volume\nand area used in the configurational entropy.\n\n{\\bf UNIQUAC surface area (q) /1/:}\n\n{\\bf UNIQUAC segments (r) /1/:}\n\nThese two parameters are necessary to calculate the configurational\nentropy of the UNIQUAC model.\n\n%--------------------------------\n\\hypertarget{Amend symbol}{}\n\\subsection{{\\em amend} Symbol}\\label{sc:amendsym}\n\nFor a symbol that is a constant this command means changing the value\nof symbol.\n\nFor some other symbols it is very special. It is intended for use in\nassessments to specify that a particular symbol must not be evaluated\nexcept when specified explicity, or when calculating a specific\nequilibrium.\n\nThe main problem is that a symbol can have an expression using another\nsymbols and thus all symbols are normally evaluated whenever the value\nof a specific symbol is requested. This is to ensure that all symbol\nvalues are consistent and refer to the same calculated equilibrium.\nBut in certain cases you may want to enter a symbol that is only\nevaluted when referenced explicity or at a specific equilibrium and\nthis can be set with this command.\n\nSymbols representing ``dot derivatives'', for example ``H.T'' for the\nheat capacity are automatically set to be evaluated only when\nreferenced explicitly. For all other symbols except constants OC will\nask:\n\n{\\bf You can specify:\\\\\n V for a symbol evaluated only when referenced explicitly\\\\\n X for a symbol to be evaluated at a particular equilibrium\\\\\n Please specify V or X /X/:}\n\nWhen you want to compare the value of a thermodynamic property, like\nthe enthalpy, in two equilibria you must be able to store the\ncalculated enthalpy from one equilibrium in a symbol. For example if\nyou have experimental data on the heat difference for a compound at\nvarious $T$. In such a case the enthalpy at the reference $T$ can be\nstored in a symbol, which has been amended with this command to\nspecify at which equilibrium it should be evaluated. In all other\nequilibria the value of this symbol will have the value at the\nspecified equilibrium. See also the documentation on the assessment\nprocedure, section~\\ref{sc:assess}.\n\nIf you specify X you will be asked\n\n{\\bf Specify equilibrium number:}\n\n\n%--------------------------------\n\\hypertarget{Amend TPfun}{}\n\\subsection{{\\em amend} Tpfunction}\n\nYou can replace a TP function with a new expression. If it is a\nconstant you can give a new value.\n\n%ALERT: Check that this forces new calculation of all TP functions.\n\n%===================================================================\n\\hypertarget{Back}{}\n\\section{Back }\n\nReturn back from the command monitor to the application program. In\nthe OC software itself it means terminate the program.\n\n%===================================================================\n% Two calculate needed for help at command level ??\n\\hypertarget{Calculate}{}\n\\section{Calculate }\n\nMany different things can be calculated. The normal thing to calculate is\n{\\bf equilibrium}, the other things are special.\n\n{\\small\n\\begin{tabular}{llll}\n ALL-EQUILIBRIA~ & GLOBAL-GRIDMIN~ & PHASE * & TRANSITION \\\\\n BOSSES\\_METHOD & NO-GLOBAL~ & QUIT & TZERO-POINT \\\\\n CAREFULLY & ONLY\\_GRIDMIN & SYMBOL & WITH-CHECK-AFTER\\\\ \n EQUILIBRIUM & PARAEQUILIBRIUM~ & TPFUN-SYMBOLS~ \\\\\n\\end{tabular}\n}\n\n%--------------------------------\n\\hypertarget{Calculate all}{}\n\\subsection{{\\em calculate} All equilibria}\\label{sc:calcall}\n\nIntended for the assessment procedure. Calculates all equilibria with\nnon-zero weight as set by the command {\\bf SET RANGE}. It can also be\nused for other purposes, for example testing the parallelization. The\nequilibria can be entered by the command {\\bf ENTER MANY\\_EQUILIB}.\n\nThis command can be looped to measure calculation times.\n\n%--------------------------------\n\\hypertarget{Calculate Bosses-method}{}\n\\hypertarget{Calculate carefully}{}\n\\subsection{{\\em calculate} Bosses-method or Carefully}\\label{sc:calcbosse}\\label{sc:calccare}\n\n These two ways provide a fairly similar way to handle cases when\n there are convergence problems, in particulat for multicomponent\n systems. They require that the conditions are $T, P$ and mass\n balance so the grid minimizer can be used. The difference is that\n after the gridminimizer has founc a set of stable phases all other\n phases are set as suspended and the iterative calculation will just\n use those phases selected by the gridminimizer, this should normally\n be successful. Afterwards all suspended phases are set as dormant\n and a new iterative calculation is made. If no dormant phase has a\n positive driving force all phases are set as entered and the\n equilibrium has been calculated.\n\n If one or more dormant phases have a positive driving force these\n are set as entered one by one followed by an iterative calculation.\n Normally this will finish when all dormant phases have negative\n driving force and the equilibrium has been calculated. If it fails\n it may anyway be possible to identify the phases causing the\n convergence problems and maybe check its parameters.\n \n%--------------------------------\n\\hypertarget{Calculate equilibrium}{}\n\\subsection{{\\em calculate} Equilibrium}\\label{sc:calceq}\n\nThe normal command to calculate the equilibrium of a system for the\ncurrent set of conditions and phase status. You can calculate a\nmetastable equilibrium if some phases that should be stable have been\nset dormant or suspended or if automatic creation of composition sets\nis not allowed. If the conditions allow, the grid minimizer will be\nused to find start values unless the grid minimizer is explicitly\nturned of.\n\nBefore this command you must have entered thermodynamic data from a\ndatabase or interactivly and used the command {\\bf set condition},\nsection~\\ref{sc:setcond}, to set as many conditions as you have\ncomponents plus two. The commands {\\bf set status phase},\nsection~\\ref{sc:set-status-phase}, and {\\bf set input-amount},\nsection~\\ref{sc:setinpuam} can also be used to set conditions.\n\nFor the first equilibrium calculation it is recommended to set\nconditions on $T, P$ and the overall composition. Those conditions\nallow the grid minimizer to be used to find the best set of stable\nphases and their constitutions that should give the global minimum.\nHowever, the density of the grid may in some cases have to be\nincreased to ensure that.\n\nFor later equilibria you can use a very flexible set of conditions,\nsee section~\\ref{sc:setcond} and the gridminimizer may not be able to\nuse the grid minimizer. In such a case OC will use the current set of\nstable phases and their constitution as start values. If you want to\ncheck that such a calculation is the global you can use the command\n{\\em calculate with} which will call the grid minimizer called AFTER\nthe equilibrium calculation (if it has converged) to check that it is\nindeed a global equilibrium.\n\n%--------------------------------\n\\subsection{{\\em calculate} Global-Gridmin}\n\\hypertarget{Calculate global-gridmin}{}\n\nCalculate with the global grid minimizer without using this result as a\nstart point for the general minimizer. Used to debug the grid\nminimizer.\n\n%--------------------------------\n\\hypertarget{Calculate no-global}{}\n\\subsection{{\\em calculate} No-Global}\n\nCalculate the equilibrium without using a global grid minimizer to\ngenerate start constitutions. The current equilibrium is used as\nstart point. Can be quicker when only small changes of conditions\nmade since previous calculation and this is how equilibria is\ncalculated during STEP and MAP. It means no check of new miscibility\ngaps.\n\n%--------------------------------\n\\hypertarget{Calculate paraeq2}{}\n\\subsection{{\\em calculate} Paraequilibrium}\\label{sc:paraeq2}\n\nThe paraequilibrium is described in section~\\ref{sc:paraeq1}.\n\n%hypertarget{Calculate para2}{{\\bf Matrix phase:}}\n{\\bf Matrix phase:}\n \nNote all phases except the matrix and growing phase should be\nsuspended. You should provide name of the matrix phase\n\n%hypertarget{Calculate para2}{{\\bf Growing phase:}}\n{\\bf Growing phase:}\n\n%hypertarget{Calculate para2}{{\\bf Fast diffusing element:}}\n{\\bf Fast diffusing element:}\n\nThe element that diffuse so fast that its chemical potential is the\nsame in both phases. The other elements will have the same\ncomposition in both phases.\n\n%--------------------------------\n\\hypertarget{Calculate what for}{}\n\\hypertarget{Calculate phase}{}\n\\subsection{{\\em calculate} Phase ``phase-name''}\n\nThis is to calculate properties for a single phase independent of the\ncurrent conditions except the values of $T$ and $P$.\n\n%hypertarget{Calculate phase}{{\\bf Phase name:}}\n{\\bf Phase name:}\n\n%hypertarget{Calculate phase}{{\\bf Amount of phase:}}\n{\\bf Amount of phase:}\n\n%hypertarget{Calculate phase current constitution}{{\\bf Current (Y), default (D) or new (N) constitution?}}\n{\\bf Current (Y), default (D) or new (N) constitution?}\n\nYou must provide a phase name, the amount of the phase and if you\nshould use the current constitution or enter a new.\n\n%hypertarget{Calculate Phase}{}\n\nThe Gibbs energy of a phase and possible derivatives and some other\nthings can be calculated. Mainly for debugging the implementation of\nmodels and testing the software.\n\n{\\small\n\\begin{tabular}{lll}\nALL-DERIVATIVES & DIFFUSION-COEFF~ & ONLY-G \\\\\nCONSTITUTION-ADJ~ & G-AND-DGDY \\\\\n\\end{tabular}\n}\n\n\\hypertarget{Calculate phase ... all-derivatives}{}\n\\hypertarget{Calculate phase ... loop}{}\n\\subsubsection{{\\em calculate phase} ... All-Derivatives}\n\nThe Gibbs energy, all $T$ and $P$ derivatives and all first and second\nderivatives with respect to constituents for the specified phase for\ncurrent $T,P$ are calculated and listed.\n\nIt is possible to loop this calculation to measure calculation times.\n\n\\hypertarget{Calculate phase adjust}{}\n\\subsubsection{{\\em calculate phase} ... Constitution\\_Adjust}\n\nYou will be asked to enter a new composition of the phase (the current\nconstitution but the current is the default) and this command will\nthen calculate the Gibbs energy and all chemical potentials for the\ngiven composition.\n\nFor a phase with sublattices the constitution of the phase will be\nadjusted to have the minimum Gibbs energy for the given composition.\n\nIt is useful when one or more components are parts of several\nconstituents, for example in a gas and for phases with order/disorder\ntransitions, in particular when the corresponding subroutine is used\nin simulations.\n\n\\hypertarget{Calculate phase ... diffusion-coeff}{}\n\\subsubsection{{\\em calculate phase} ... Diffusion\\_Coefficients}\n\nYou will be asked to enter a new composition (default is current) of\nthe phase and this command will then calculate the Darken stability\nmatrix\n\\begin{eqnarray*}\n \\frac{\\partial^2 G}{\\partial N_{\\rm A}\\partial N_{\\rm B}}\n\\end{eqnarray*}\nfor all components (see the documentation of the minimiser) and also\nall mobility values (if there are any).\n\n\\hypertarget{calculate phase ... G-and-dGdy}{}\n\\subsubsection{{\\em calculate phase} ... G\\_and\\_dGdy}\n\nThe Gibbs energy, all $T$ and $P$ derivatives and all first derivatives\nwith respect to constituents for the specified phase for current $T,P$\nare calculated and listed.\n\nIMPORTANT NOTE: The value of $\\frac{\\partial G_m}{\\partial y_i}$ is\nNOT the chemical potential, $\\mu_i$ of component $i$. The\nunderstanding of thermodynamics is often poor and the user is reminded\nthat the chemical potential of a component $i$ is defined as:\n\\begin{eqnarray*}\n\\mu_i &=& \\left(\\frac{\\partial G}{\\partial N_i}\\right)_{T,P,N_{j\\ne i}}\n\\end{eqnarray*}\nwhere $G$ is the integral Gibbs energy and all $N_i$ are independent\nvariables. When we model the molar Gibbs energy, $G_m$ as a function\nof the constituent fractions, $y_i$, these fractions are not\nindependent and for a substitutional model, where $y_i=x_i$ i.e. the\nmole fractions, the chemical potential is calculated from $G_m$ using:\n\\begin{eqnarray*}\n \\mu_i &=& G_m + \\left(\\frac{\\partial G_m}{\\partial x_i}\\right)_{T,P,x_{j\\ne i}}\n - \\sum_j x_j \\left(\\frac{\\partial G_m}{\\partial x_j}\\right)_{T,P,N_{k\\ne j}}\n\\end{eqnarray*}\nbecause the mole fractions, $x_i$ are not independent.\n\n\\hypertarget{calculate phase ... only-G}{}\n\\subsubsection{{\\em calculate phase} ... Only-G}\n\nThe Gibbs energy and all $T$ and $P$ derivatives calculated and listed for\nthe specified phase for the current values of $T,P$.\n\nIf the phase has additions the Gibbs energy and its first derivatives\nand its second derivative of T of each addition are also listed\n\n\\hypertarget{Calculate phase ... quit}{}\n\\subsubsection{{\\em calculate phase} ... Quit}\n\nDo not calculate anything for the phase.\n\n%--------------------------------\n\\hypertarget{Calculate quit}{}\n\\subsection{{\\em calculate} Quit}\n\nDo not calculate anything at all.\n\n%--------------------------------\n\\hypertarget{Calculate symbol}{}\n\\subsection{{\\em calculate} Symbol}\n\nA state variable symbol or function is calculated using the results\nfrom the last equilibrium or grid minimizer calculation. It is used\nin particular for calculation of ``dot derivatives'' like $H.T$ for\nthe heat capacity.\n\nIf a wildcard, ``*'', is given as name all symbols, except dot\nderivatives and symbols that must be specified explicity and those\nthat should be calculated for another specified equilibria. See\nsection~\\ref{sc:amendsym}.\n\n\n%--------------------------------\n\\hypertarget{Calculate TPfun}{}\n\\subsection{{\\em calculate} Tpfun-Symbols}\n\nAll or a specific TPFUN symbol are calculated for current values of $T$\nand $P$.\n\n%--------------------------------\n\\hypertarget{Calculate transform}{}\n\\subsection{{\\em calculate} Transition}\n\nAfter calculating an equilibrium you can calculate directly when a\nphase will appear or disappear by releasing one of the conditions you\nhave specified. Typically this is used to calculate the melting\ntemperature of an alloy or a solubility limit. \n\nYou specify the phase name and the condition to be released. The\nprogram will set this phase as FIXED with zero amount and remove the\ncondition you specified and calculate the equilibrium. The\ncalculation may fail if the phase cannot be set stable with zero\namount. If successful the removed condition will be set to the value\ncalculated and the phase set stable with zero amount.\n\n%--------------------------------\n\\hypertarget{Tzero}{}\n\\subsection{{\\em calculate} Tzero point}\\label{sc:tzero2}\n\nThe T0 (or T zero) point is where two phases have the same Gibbs\nenergy. It is a limit of diffusionless transformation between these\nphases. This can be calculated by varying T (or a composition)\ncalculating the Gibbs energy for the two phases separatly using the\nsame overall composition. NOTE in many cases there are no such point!\n\nIt is particularly interesting in steels to predict the martensite\ntransformation which is normally some 100~K below the T0 point.\n\n%--------------------------------\n\\hypertarget{Calculate with check}{}\n\\subsection{{\\em calculate} with check after}\n\nWhen the conditions does not allow for the gridminimizer to be used to\nfind an initial set of phases this command can be used to call the\ngridminimizer after the iterative calculation. If the gridminimizer\nfinds a phase that should be stable the equilibrium will be\nautmatically recalculated.\n\nThis type of calculations is regularly done durig STEP and MAP\ncommands as such calculations normally have a phase as FIX which\nprevents use of the gridminimizer.\n\n%===================================================================\n\\hypertarget{Debug}{}\n\\section{Debug }\n\nSeveral possibilities to trace calculations will be implemented in\norder to find errors but very little is working yet. This command is\nmainly for the software development.\n\n{\\small\n\\begin{tabular}{llll}\nBROWSER & GRID & STOP-ON-ERROR~ & TRACE \\\\\nELASTICITY~ & MAP-STARTPOINTS~ & SYMBOL-VALUE \\\\\nFREE-LISTS & SPECIES & TPFUN~ \\\\\n\\end{tabular}\n}\n\n%---------------------------------------------------------------\n\\hypertarget{Debug elasticity}{}\n\\subsection{{\\em debug} Elasticity}\n\nIntended to test the model for strain and stress. Not implemented.\n\n%---------------------------------------------------------------\n\\hypertarget{Debug free_lists}{}\n\\subsection{{\\em debug} Free lists}\n\nOnly for experts.\n\n%---------------------------------------------------------------\n\\hypertarget{Debug map_startpoints}{}\n\\subsection{{\\em debug} Map-startpoints}\n\nAn attempt to generate automatic startpoints for mapping a phase diagram.\n\n%---------------------------------------------------------------\n\\hypertarget{Debug symbol value}{}\n\\subsection{{\\em debug} Symbol value}\n\nThis is used to in macro files to test if the software calculates the\nsame value of a symbol as when the macro was created. If not there is\nsome new bug introduced (or a bug corrected?). After the symbol the\nexpected value must be given and if the relative difference with the\ncalculated value differ more than $10^{-6}$ the program will abort.\n\n%---------------------------------------------------------------\n\\hypertarget{Debug stop-on-error}{}\n\\subsection{{\\em debug} Stop\\_on\\_Error}\n\nThe program will stop at the command level after printing the error\nmessage if an error has occurred when using macro file. This should\nmake it easier to to find errors occurring when running macro files.\n\nHowever, it is not implemented.\n\n%===================================================================\n\\hypertarget{Delete}{}\n\\section{Delete }\n\nIt is quite difficult to delete anything when the data structure is so\ninvolved. In many cases it may be better to enter the data again\nwithout the data that should be deleted. But there are a few things\nthat must occationally be deleted.\n\n{\\small\n\\begin{tabular}{llll}\n COMPOSITION\\_SET~ & EQUILIBRIUM~ & QUIT & STEP\\_MAP\\_RESULTS\\\\\n ELEMENTS & PHASE & SPECIES~\\\\\n\\end{tabular}\n}\n\n%------------------------------------------------------\n\\hypertarget{Delete composition set}{}\n\\subsection{{\\em delete} Composition set}\n\nThe first composition set of a phase cannot be deleted. Otherwise\nthere is usually no problem unless several equilibria are entered\nbecause the composition set must be deleted in all equilibria.\nComposition sets are created and deleted during normal equilibrium\ncalculations to detect miscibility gaps.\n\n%------------------------------------------------------\n\\hypertarget{Delete element}{}\n\\subsection{{\\em delete} Element}\n\nDangerous and will probably never be implemented.\n\n%------------------------------------------------------\n\\hypertarget{Delete equilibrium}{}\n\\subsection{{\\em delete} Equilibrium}\n\nDangerous but sometimes necessary. Done automatically at a second\nSTEP or MAP command if you specifies to delete previous results.\n\n%------------------------------------------------------\n\\hypertarget{Delete phase}{}\n\\subsection{{\\em delete} Phase}\n\nDangerous and will probably never be implemented.\n\n%------------------------------------------------------\n\\hypertarget{Delete quit}{}\n\\subsection{{\\em delete} Quit}\n\nDo not delete anything.\n\n%------------------------------------------------------\n\\hypertarget{Delete species}{}\n\\subsection{{\\em delete} Species}\n\nNot implemented yet and will probably never be.\n\n%------------------------------------------------------\n\\hypertarget{Delete step-map-results}{}\n\\subsection{{\\em delete} Step\\_Map\\_Results}\n\nThis removes all equilibria and saved equilibria associated with\nSTEP and MAP commands. It also deletes the axis.\n\n%===================================================================\n\\hypertarget{Enter}{}\n\\section{Enter }\n\nIn most cases data will be read from a database file. But it is\npossible to enter all thermodynamic data interactively. This should\nnormally start by entering all elements, then all species (the\nelements will automatically also be species) and then the phases.\n\nA species have a fixed stoichiometry and possibly a charge. The\nspecies are the constituents of the phases.\n\nA phase can have sublattices and constituents and also various\nadditions like magnetic, low T heat capacity etc. which are specified\nby the {\\bf AMEND} command efter entering the phase (but normally\nbefore any model parameters for the phase are entered).\n\nTPFUN symbols can be used to describe common parts of model\nparameters. See section~\\ref{sc:tpfun} for an explation.\n\nEach model parameter of a phase is entered separately. You may use\nTPFUN symbols which are already entered.\n\nAt present the multicomponent CEF model and the ionic 2-sublattice\nliquid model are the only basic models implemented. The CEF model\nincludes as special cases the gas phase, regular solutions with\nRedlich-Kister Muggianu model and phases with up to 9 sublattices and\nionic constituents. These models describe the basic configurational\nentropy contribution to the phase, models such as the magnetic\ncontribution and low T heat capacity can be added to a phase with the\n{\\bf AMEND} command.\n\nThe enter command is also used to enter bibliographic data, equilibria\nfor assessments and many other things.\n\nThe subcommands are:\n\n{\\small\n\\begin{tabular}{llll}\n BIBLIOGRAPHY & EQUILIBRIUM & OPTIMIZE-COEFF~ & SPECIES\\\\\n COMMENT & EXPERIMENT & PARAMETER & SYMBOL\\\\ \n CONSTITUTION & GNUPLOT-TERMINAL~ & PHASE & TPFUN-SYMBOL\\\\ \n COPY-OF-EQUILIB~ & MANY-EQUILIBRIA & PLOT-DATA\\\\\n ELEMENT & MATERIAL & QUIT\\\\\n\\end{tabular}\n}\n\n%--------------------------------\n\\hypertarget{Enter bibliography}{}\n\\subsection{{\\em enter} Bibliography}\\label{sc:bibref}\n\nEach model parameter must have a bibliographic reference to ensure\neveryone can find the origin of its value. When entering a parameter\na bibliographic reference symbol must be given and with this command\nyou can give a full reference text for that, for example a published\npaper, a report or simply a reason for the value together with the\ndate and your name so the origin of the parameter can be traced.\n\n{\\bf Reference identifier:}\n\nThe text for bibliographic reference identifier can be amended. The\nreference identifier is case insensitive.\n\n{\\bf Reference text, end with ``;'':}\n\nThe text for this reference will be set to the text supplied. It can be\nseveral lines terminated with a ``;''\n\n%--------------------------------\n\\hypertarget{Enter comment}{}\n\\subsection{{\\em enter} Comment}\n\nA line of comment text can be added to the current equilibrium. It is\nparticularly important when entering experimental data to give the\nreference to the data.\n\n%--------------------------------\n\\hypertarget{Enter constitution}{}\n\\subsection{{\\em enter} Constitution}\n\nThe constitution (fraction of all constituents) of a phase can be\nentered. This is a way to provide start values for an equilibrium\ncalculation (when not using grid minimizer). To calculate the Gibbs\nenergy for a specific phase at a specific constitution use the command\n{\\bf CALCULATE PHASE}.\n\n%--------------------------------\n\\hypertarget{Enter copyof}{}\n\\subsection{{\\em enter} Copy of equilibrium}\n\nThis command creates a copy of the current equilibrium with the same\nset of conditions and related data.\n\nMust be used with care.\n\n%--------------------------------\n\\hypertarget{Enter element}{}\n\\subsection{{\\em enter} Element}\n\nThe data for an element is entered. It consists of is symbol, name,\nreference phase, mass, H298-H0 and S298.\n\nThe element symbol must be one or two letters, they will be converted\nto UPPER case automatically. The element name and reference phase is\nnever used anywhere but included for completeness. The reference\nphase SER means the Stable Element Reference phase, the phase stable\nat 298.15~K and 1~bar. The mass is needed for input of amount (using\nstate variable B), mass fractions or mass percent of the element.\n\nThe values of H298-H0 and S298 are never used for any calculation but\nincluded for completeness.\n\n%--------------------------------\n\\hypertarget{Enter equilibrium}{}\n\\subsection{{\\em enter} Equilibrium}\n\nYou can have several equilibria each with a unique set of conditions\nincluding phase status (dormant, suspended, fix or entered) but all\nwith the same components and thermodynamic data. This is useful for\ncompare different states, to simulate transformations and to assess\nmodel parameters as each experimental or theoretical information\nrepresented as an equilibrium.\n\nAll equilibria use the same thermodynamic data but they have an\nindependent set of conditions and result data structure, also for TP\nfunctions and symbols, and they can be calculated in parallel.\n\nAfter entering the equilibrium you can select if your following\ncommands, such as {\\em enter condition} etc. will apply to the new\nequilibrium.\n\n%--------------------------------\n\\hypertarget{Enter experiment}{}\n\\subsection{{\\em enter} Experiment}\\label{sc:enterexp}\n\nThis is used for assessments, experimental data can be specified for\nan equilibrium. The experiment is a state variable or symbol which\ncan be set equal to the experimental value followed by a colon, ``:''\nand its uncertainty.\n\nIn some cases an experimental value can be an upper or lower limit.\nIn such cases the ``$>$'' or ``$<$'' can be used. The value of the\nuncertainty will then be interpreted as a penalty factor if the\ncalculated value is outside the specified limit.\n\n%--------------------------------\n\\hypertarget{Enter GNUTERM}{}\n\\subsection{{\\em enter} GNUPLOT Terminal}\\label{sc:gnuterm}\n\nFor plotting OC generates a command file for the\nGNUPLOT~\\cite{gnuplot} software. GNUPLOT can be downloaded free for\nmost OS but depending on your screen and other hardware you may prefer\nto specify your prefered set of terminals. On Windows the defaults\nare:\n\n% IMPORTANT if table changed here also change in\n% \\subsection{{\\em plot xaxis yaxis} Graphics format}\n\n{\\bf The terminals listed in the table depend on your installation.}\n\n\\begin{tabular}{rlcl}\n & Name &=~& GNUPLOT definition\\\\\n 1~& SCREEN & & set terminal wxt size 940,700 font \"arial,16\"\\\\\n 2~& PS & & set terminal postscript color solid fontscale 1.2\\\\\n 3~& PDF & & set terminal pdf color solid size 6,5 enhanced font \"arial,16\"\\\\\n 4~& GIF & & set terminal gif enhanced fontscale 0.7\\\\\n 5~& PNG & & set terminal png enhanced fontscale 0.7\\\\\n\\end{tabular}\n\nThe text after the $>$ is written on the GNU command file. You can\nchange these or add additional terminals. You can also change these\nin the source code (userif/pmon6.F90 file) or use a macro file\nOCHOME/start.OCM file to set them.\n\n%--------------------------------\n\\hypertarget{Enter many equil}{}\n\\subsection{{\\em enter} Many Equilibria}\\label{sc:entermany}\n\nThis command is intended for adding tables of experimental data of the\nsame type. It can also be used for calculation of many equilibria\nusing the {\\bf calculate all} command. The user first enters a TABLE\nHEAD giving the necessary phase status, conditions, experiments etc.\nIn this ``head'' some values of text can be referred to columns in the\nfollowing table using the ``@'' character followed by a digit 1 to 9,\nwhere the digit is the column number.\n\nThe prompt for input to the table head is ``table head::''\\\\ In the\nexamples below, taken from the parallel2.OCM macro file, user input is\n{\\bf in bold} and explanations {\\em in italics}.\n\n\\begin{itemize}\n\\item By default all phases are suspended so the user must forst specify the\n phases with dormant, entered of fixed status (including amount) like\\\\\n Table head: {\\bf entered 0 *} {\\em all phases should be entered}\\\\ \n Table head: {\\bf fix 0 liquid} {\\em liquid should be fix with 0 moles}\\\\ \n Table head: {\\bf fix 1 @2} {\\em the phase in column 2 should be fix\n with 1 moles}\n\n\\item The conditions can be given using the @ character to indicate vaules\n that are given in the specified column in table to follow.\\\\\n Table head: {\\bf condition t=@1 p=1e5 n=1 w(cr)=@3 w(mo)=@4 }\n\n\\item Optional calculations of entered symbols\\\\\n Table head: {\\bf calculate cp}\n\n\\item Optional listing of state variables\\\\\n Table head: {\\bf list HM tc(bcc)}\n\n\\item Optional experimental data\\\\\n Table head: {\\bf experiment x(liquid,cr)=@5:.01, x(bcc,cr)=@6:.02}\n \n\\item Optional reference state\\\\\n The reference state for a component can be set.\n\n Table head: {\\bf reference O gas * 1e5}\\\\ \n The reference state for the component O will be gas at the current\n $T$ and 1 bar.\n\n\\item Optional plot\\_data specifying a dataset number and coordinates\n to be plotted and a symbol. The coordinates can be table columns.\n Use the dataset numbers to have data of the same type together like\n enthalpies, phase diagram data etc.\\\\\n Table head: {\\bf plot 1 @1 @2 5}\n\n\\item Optional comment\\\\\n Table head: {\\bf comment experimental data from Kubaschewski 1955}\n\n\\item The table head is finished by an empty line or ``table\\_start''\n\\end{itemize}\n \n\\hypertarget{Enter table row}{}\n\nFor the rows in the table the user must first provide a unique name\nfor each equilibrium (that is counted as column 0 (zero)) and values\nfor all columns referenced in the table head like:\\\\\nTable row: {\\bf EQ1 1573 BCC 0.3 0.05 0.12 0.28}\\\\\nTable row: {\\bf EQ2 1623 BCC 0.3 0.10 0.18 0.24}\\\\\n\nThe table is finished by an empty line or\\\\\nTable row: {\\bf table\\_end}\n\n%--------------------------------\n\\hypertarget{Enter material}{}\n\\subsection{{\\em enter} Material}\n\nThe user will be asked for a name of the material and possibly a\ndatabase. Then he can give elements and their amount in mass percent\nor mole fraction. Finish with an empty line.\n\nFinally he can specify the temperature and the program will\nautomatically make a calculation at 1 bar with the given composition.\nFor example:\n\n\\begin{verbatim}\nOC4:enter mat\nDatabase:steel7\nElements: C , MO, V , CR, FE, SI,\nMajor element or material:fe\nInput in mass percent? /Y/:\nInput expected in mass percent\n\nFirst alloying element:c\nMass percent: /1/:\nSecond alloying element:cr\nMass percent: /1/: 5\nThird alloying element:mo\nMass percent: /1/: 8\nNext alloying element:v\nMass percent: /1/:\nNext alloying element:\n 3E reading a TDB file\n 3D em: W%(C)=1 W%(CR)=5 W%(MO)=8 W%(V)=1 N=1\nTemperature /1000/:\n 3Y Constitution of metastable phases set\n 3Y Composition set(s) created: 1\nGridmin: 18846 points 6.25E-02 s and 78 clockcycles, T= 1000.00\nPhase change: its/add/remove: 5 0 21\nEquilibrium calculation 19 its, 6.2500E-02 s and 94 clockcycles\n\n\\end{verbatim}\n\nThe user can use the same command to specify another composition of\nthe alloy or use other commands such as {\\bf SET CONDITION} and {\\bf\n CALCULATE} or calculate diagrams using {\\bf SET AXIS} and then {\\bf\n STEP} or {\\bf MAP}.\n\n%--------------------------------\n\\hypertarget{Enter coeffs}{}\n\\subsection{{\\em enter} Optimizing coefficient}\\label{sc:optcoeff}\n\nThe number of TP symbols for the coefficients to be optimized are\nentered. They have the names A00 to A99. They are used in model\nparameters and can be varied by the optimization procedure to minimize\nthe difference between the experimental data and the same property\ncalculated from the models of the phases.\n\nYou can also specify the size of the workspace needed for the\noptimization. The default value, 2500, is usually sufficient.\n\n%--------------------------------\n\\hypertarget{Enter parameter}{}\n\\subsection{{\\em enter} Parameter}\\label{sc:enterparam}\n\nA model parameter is defined by its identifier, the phase and\nconstituent array and the degree. A parameter can be a constant or\ndepend on T and P. The parameter will be multiplied with the\nfractions of the constituents given by its constituent array. See the\ndocumentation of the GTP model package or the book by Lukas et\nal\\cite{07Luk} for more information about thermodynamic models.\n\nFor example G(LIQUID,CR) is the Gibbs energy of liquid Cr relative to\nits reference state, normally the stable state of Cr at 298.15 K and 1\nbar, and called an endmember.\n\nFor a gas molecule the parameter G(GAS,C1O2) is also an endmember and\nrepresent the Gibbs energy of the C1O2 molecule relative to the\nreference states of C (carbon) and O (oxygen).\n\nFor interaction parameters the components are separated by a comma\n``,'' as in G(LIQUID,CR,FE).\n\nFor phases with sublattices the constituents in each sublattice are\nseparated by a colon, ``:'' and interacting constituents in the same\nsublattice by a comma, ``,''. For example:\\\\\nG(FCC,FE:C,VA) is the interaction between C (carbon) and VA (vacant\ninterstitial sites) in the FCC phase.\n\nDifferent ternary extrapolation methods can be used, see\nsection~\\ref{sc:excessparameters}.\n\n%--------------------------------\n\\hypertarget{Enter phase}{}\n\\hypertarget{enter phase name}{}\n\\subsection{{\\em enter} Phase}\n\nThe user must specify a unique phase name:\n\n{\\bf Phase name:}\n\nAll thermodynamic data are connected to a phase as defined by its\nparameters, see {\\bf enter parameter}. A phase has a name with can\ncontain letters, digits and the underscore character. It must start\nwith a letter.\n\n%...................................\n\\hypertarget{Enter phase model}{{\\bf Phase model:}}\n\nAfter the phase name you must specify a model. The model specfication\nis implemented in a rather rudimentary way. The only recognized models\nare\n\n\\begin{itemize}\n\\item IDEAL for a single lattice phase without interactions (like GAS)\n\\item RKM for a substitutional phase with interactions (like metallic\n liquid)\n\\item I2SL for the ionic liquid phase (2 sublattices with variable\n site ratios). If the phase name is IONIC\\_LIQUID this prompted as\n the default model.\n\\item CQC means the ``Corrected Quasichemical model'' for liquids.\n\\item CEF for any other phase with two or more sublattices\n\\end{itemize}\n\nThis list may be extended in a future version of OC. Many other model\nfeatures like magnetism, quasichemical etc are specified with the {\\bf\n AMEND PHASE} command, see section~\\ref{sc:amendph}. The AMEND PHASE\ncommand is also used to specify disordered fraction set, low\ntemperature CP model and many other things.\n\n%...................................\n\\hypertarget{Enter phase subl}{{\\bf Number of sublattices:}}\n\nFor a phase with Long Range Orderng (LRO) you must specify the number\nof sublattices. After that you have for each sublattice specify the\nnumber of sites and consttuents. Even if you have just one lattice\nyou must specify the number of atoms on that lattice per formula unit.\n\nFor most models OC will ask for the number of sublattices and a phase\ncan have 1 to 9 sublattices and you must specify the number of sites\non each. Preferably use small integer values, if fractions are used\nat least 6 digits should be provided.\n\n\\hypertarget{Enter phase sites}{{\\bf Number of sites on a sublattice }}\n\nFor some models, like the ionic liquid model, the number of sites may\nchange with the composition of the phase so the number specified is\nirrelevant. See the book by Lukas et al~\\cite{07Luk} for more details\non models.\n\n\\hypertarget{Enter phase bonds}{Models with bonds}\n\nSome models depend on the number of nonds between atoms, such as the\nquasichemical model. The modified quasichemical model have a single\nsublattice and include additional species to decribe the Short Range\nOrdering (SRO).\n\n%...................................\n\n\\hypertarget{Enter phase constituents}{}\n\nFor each sublattice you must specify the constituents on the\nsublattice. A constituent that is not an element must already have\nbeen entered as a species, see section~\\ref{sc:entersp}.\n\nYou may have to use the {\\bf AMEND PHASE} command, see\nsection~\\ref{sc:amendph}, for some additional model features like\nmagnetism, low $T$ heat capacity or permutations.\n\n%--------------------------------\n\\hypertarget{Enter plot data}{}\n\\subsection{{\\em enter} Plot\\_data}\n\nThis is when entering experimental data for assessments when combining\nexperimental data in single equilibria with those entered in tables\nusing the command ``MANY\\_EQUILIBRIA''.\n\nYou can add points to a dataset 1 to 9 to be plotted the current\nequilibrum. The dataset must already have created by a PLOT command\ninside a {\\bf ENTER MANY\\_EQUILIB} command, see\nsection~\\ref{sc:entermany}.\n\n%--------------------------------\n\\hypertarget{Enter quit}{}\n\\subsection{{\\em enter} Quit}\n\nQuit entering things.\n\n%--------------------------------\n\\hypertarget{Enter species}{}\n\\subsection{{\\em enter} Species}\\label{sc:entersp}\n\nA species consists of a name and a stoichiometric formula. It can have\na valence or charge. The name is often the stoichiometric formula\nbut it does not have to be that. Examples:\n\n\\begin{itemize}\n\\item enter species water h2o\n\\item enter species c2h2cl2\\_trans c2h2cl2\n\\item enter species c2h2cl2\\_cis c2h2cl2\n\\item enter species h+ h1/- -1\n\\end{itemize}\n\nSingle letter element names must be followed by a stoichiometric\nfactor unless it is the last element when 1 is assumed. Two-letter\nelement names have by default the stoichiometric factor~1.\n\nThere can be a problem with ambiguity with a species name like h2o if\nthere is also a species h2o2. In such cases use a final unity, i.e.\nh2o1.\n\n\\begin{itemize}\n\\item enter species carbonmonoxide c1o1\n\\item enter species cobaltoxide coo\n\\item enter species carbondioxide c1o2\n\\item DO NOT USE enter species co c1o1\n\\end{itemize}\n\nThe species name is important as it is the name, not the\nstoichiometry, that is used when referring to the species elsewhere\nlike as a phase constituent. It is of course convenient to choose a\nspecies name similar to its stoichiometric formula but as shown above,\nthat is not always sufficient.\n\n{\\bf Species symbol:}\n\nThe symbol must start with a letter, A-Z, and contain just letters,\ndigits and the special characters ``\\_'' (underscore), ``-'' (minus),\n ``+'' (plus) and ``/'' (slash).\n\n{\\bf Species stoichiometry:}\n\nThe stoichiometry must contain element symbols followed by a\nstoichiometry factor. The stoichiometry factor 1 can be omitted for\ntwo-letter element symbols. The charge is given as ``/-'' or ``/+''\nfollowed by a stoichiometric factor.\n\n%--------------------------------\n\\hypertarget{Enter symbol}{}\n\\subsection{{\\em enter} Symbol}\n\nThe OC package has both ``symbols'' and ``tpfun\\_symbols'', the latter\nhas a very special syntax and can be used when entering parameters.\n\nThe symbols are designed to handle relations between state variables,\nyou can define expressions like \\\\\n{\\bf enter symbol KLBCR = X(LIQUID,CR)/X(BCC,CR);}\\\\\nwhere KLBCR is set to the partition of the Cr mole fractions between\nliquid and bcc.\n\nThe symbols also include ``dot derivatives'' like $H.T$ which is the\nsecond derivative of the Gibbs energy with respect to the for the\ncurrent system at the given set of conditions.\n\n{\\bf enter symbol CP = H.T;}\n\nIf $T$ and $P$ are conditions and all other conditions are mass\nbalance conditions CP is the heat capacity. It also takes account of\nthe change of configurational entropy.\n\nCurrently $H.T$ is the only dot derivatives allowed but more will be\nadded as soon as possible.\n\n%--------------------------------\n\\hypertarget{Enter TPfun}{}\n\\subsection{{\\em enter} Tpfun\\_Symbol}\\label{sc:entertpf}\n\nThis symbol is a special type of expression depending on $T$ and $P$\nthat can be used when entering parameters. A TPfun can refer to\nanother TPfun but not any other state variable or symbol.\n\nThe program requests a name and if the symbol should be a FUNCTION,\nCONSTANT or a TABLE (tables not implemented).\n\nIf it is a FUNCTION you must specify a low $T$ limit, and expression\nconsisting of simple terms (signed coefficients multiplied with $T$\nand $P$ possibly raised to powers).\n\nA term may also be multiplied with another TP function or with LN(FX)\nfor the natural logarithm of ``FX'' or EXP(FX) for the exponential of\nthe expression of function ``FX''.\n\nThe ``FX'' inside the parenthesis of an LN or EXP may refer to another\nTP function or it can be a coefficient multiplied with powers of T or\nP.\n\nIt is not allowed to use parenthesis except around arguments of LN and\nEXP or around negative powers such as $T**(-1)$.\n\nA very special unary function is INTEIN(THETA) which calculates\n\\begin{eqnarray}\n1.5*R*FX + 3*R*T*LN(EXP(-THETA/T) + 1) \n\\end{eqnarray}\nand first and second derivatives of that with respect to $T$. It is\nthe Einstein heat capacity function integrated to a Gibbs energy. The\nargument THETA should the the Einsten themperature and must be a\npositive constant.\n\nThe expression must be terminated by a semicolon followed by an upper\n$T$ limit. After the upper $T$ limit you must specify either N or Y.\nIf you give Y it means there is another expression above this T limit.\nThe last T-range limit must be followed by N and a bibliographic\nreference, see section~\\ref{sc:bibref}.\n\nTPFUNs have a strict syntax because the software must be able\ncalculate not only its value but also its first and second derivatives\nwith respect to $T$ and $P$ millions of times during a phase diagram\ncalculations, see section~\\ref{sc:tpfun}.\n\n%===================================================================\n\\hypertarget{Exit}{}\n\\section{Exit}\n\nTerminate the OC software in Swedish, Ha en bra dag.\n\n%===================================================================\n\\hypertarget{Fin}{}\n\\section{Fin}\n\nTerminate the OC software in French, Au revoir.\n\n%===================================================================\n\\hypertarget{Help}{}\n\\hypertarget{Help for which *}{}\n\\section{Help and ?}\n\n{\\bf Which command:}\n\nCan give a list if commands or subcommands or parts of this help text.\nThe user guide is also available as a searchable HMTL file.\n\nFor a submenu question a single ? will give the menu and two ?? will\ngive an extract of this user guide. Then the question will be asked\nagain.\n\n%===================================================================\n\\section{HPcalc }\n\nStart the reverse polish calculator.\n\n%===================================================================\n\\hypertarget{Info}{}\n% this hypertarget is because changes is the default ...\n\\hypertarget{Topic?changes}{}\n% This hypertaget when answering ?? for Topic?/QUIT/:\n\\hypertarget{Topic?quit}{}\n\\section{Information }\n\non the following topics:\n\n\\begin{tabular}{llll}\n CHANGES & ELEMENTS & PHASE-DIAGRAM~ & STATE-VARIABLES\\\\ \n COMPOSITION-SET~& EQUILIBRIUM~ & PROPERTY-DIAGRAM~\\\\\n CONDITIONS & HELP-SYSTEM & QUIT-INFO\\\\\n DATABASES & PHASE & SPECIES\\\\\n\\end{tabular}\n\nThis command is still not fully implemented.\n\nThe intention is to provide the on-line help to users who does not\nlike to read manuals. But it is not yet implemented.\n\n{\\bf Topic? /CHANGES/:}\n\nWill list the most recent changes in the OC software from the\nchanges.txt file (if it can be found). Stop listing by a q.\n\nYou can explore different parts of this User Guide online by selecting\nother topics.\n\nGive QUIT or press return to go back to top\nlevel.\n\n%===================================================================\n\\hypertarget{List}{}\n\\section{List }\n\nMany things can be listed. Output is normally on the screen unless it\nis redirected by the /output={\\em file name} or /append={\\em file\n name} option, see~\\ref{sc:options}.\n\n{\\small\n\\begin{tabular}{llll}\n ACTIVE\\_EQUILIBR~ & EQUILIBRIA & OPTIMIZATION & STATE\\_VARIABLES~\\\\\n AXIS & ERROR-MESSAGE & PARAMETER~ & SYMBOLS\\\\ \n BIBLIOGRAPHY~ & EXCELL-CSV-FILE & PHASE & TPFUN\\_SYMBOLS\\\\\n CONDITIONS & LINE-EQUILIBRIA~ & QUIT \\\\\n DATA & MODEL-PARAM-ID & RESULTS \\\\\n ELEMENTS & MODEL-PARAM-VAL~ & SHORT \\\\ \n\\end{tabular}\n}\n\n%--------------------------------\n\\hypertarget{List active}{}\n\\subsection{{\\em list} active-equilibria}\n\nThis is used during assessment to list equilibria with non-zero weights.\n\n%--------------------------------\n\\hypertarget{List axis}{}\n\\subsection{{\\em list} Axis}\n\nLists the axis set by you.\n\n%--------------------------------\n\\hypertarget{List biblio}{}\n\\subsection{{\\em list} Bibliography}\n\nList the bibliographic references for the data.\n\n%--------------------------------\n\\hypertarget{List conditions}{}\n\\subsection{{\\em list} Conditions}\n\nLists the current set of conditions set by you. If the degrees\nof freedoms are zero you can calculate an equilibrium.\n\n%--------------------------------\n\\hypertarget{Output format for screen}{}\n\\hypertarget{Output format}{}\n\\hypertarget{List data}{}\n\\subsection{{\\em list} Data}\n\nLists all thermodynamic data. The default is on SCREEN but you can\nalso choose among the formats: LaTeX, MACRO, PDB and TDB.\n\nThe only format implemented at present is SCREEN.\n\n%...............................\n\\hypertarget{List data LaTeX}{}\n\\subsubsection{{\\em list data} LaTeX}\n\nThe thermodynamic data will be formatted according to LaTeX for later\ninclusion in publications. Not implemented.\n\n%....................................\n\\hypertarget{List data macro}{}\n\\subsubsection{{\\em list data} Macro}\n\nThe thermodynamic data will be written as a macro file that can later\nbe read back into the OC software. Not implemented.\n\n%....................................\n\\hypertarget{List data PDB}{}\n\\subsubsection{{\\em list data} PDB}\n\nA ``Phase related Data Format'' similar to the TDB file\nformat adapted for OC. Not yet implemented.\n\n%....................................\n\\hypertarget{List data TDB}{}\n\\subsubsection{{\\em list data} TDB}\n\nA variant of the TDB file format with Thermo-Calc flavor. Not implemented.\n\n%--------------------------------\n\\hypertarget{list equilibria}{}\n\\subsection{{\\em list} Equilibria}\n\nLists the equilibria entered. To list the results of the calculation\nof an equilibrium use {\\bf list result}.\n\n%--------------------------------\n\\hypertarget{List error msg}{}\n\\subsection{{\\em list} Error message}\n\nThe message associated with an error code generated by OC can be listed\n\n%--------------------------------\n\\hypertarget{List line-equilibria}{}\n\\subsection{{\\em list} Line equilibria}\n\nLists the equilibria calculated during STEP or MAP commands. See also\nthe command {\\bf AMEND LINE-EQUILIBRIA}.\n\n%--------------------------------\n\n\\hypertarget{List model parameter id}{}\n\\subsection{{\\em list} Model parameter identifiers}\n\nLists the model parameter identifiers available in the current version\nof OC, see section~\\ref{sc:paramid}.\n\n%--------------------------------\n\\hypertarget{List model parameter val}{}\n\\subsection{{\\em list} Model parameter value}\n\nThe current value of a model parameter identifier can be listed. Note\nthat the value is always phase dependent and may also depend on the\ncomposition set.\n\n%--------------------------------\n\\hypertarget{List Optimization}{}\n\\subsection{{\\em list} optimization}\n\nLists results of an optimization, several sub-options will be\nimplemented but currently there is a short version only. To save this\non a file use the option /output= or /append=, see~\\ref{sc:options}.\n\n{\\small\n \\begin{tabular}{llll}\nCOEFFICIENTS & DEBUG & GRAPHICS~ & MACRO \\\\\nCORRELATION\\_MTRX~ & EXPERIMENTS~ & LONG & SHORT \\\\\n \\end{tabular}\n }\n%.....................................\n\\hypertarget{List optimization coefficiets}{}\n\\subsubsection{{\\em list optimization} coefficients}\n\nThis gives a list of the coefficients and their values.\n\n%.....................................\n\\hypertarget{list optimization debug}{}\n\\subsubsection{{\\em list optimization} debug}\n\nNot implemented yet.\n\n%.....................................\n\\hypertarget{List Optimization correlation-mtrx}{}\n\\subsubsection{{\\em list optimization} correlation\\_matrix}\n\nNot implemented yet.\n\n%.....................................\n\\hypertarget{list optimization experiments}{}\n\\subsubsection{{\\em list optimization} experiments}\n\nList of experiments in the equilibria with non-zero weights.\n\n%.....................................\n\\hypertarget{List optimization graphics}{}\n\\subsubsection{{\\em list optimization} graphics}\n\nA figure with the experimental values on the X axis and calculated values\non the Y axis for all experiments. Not implemented yet.\n\n%.....................................\n\\hypertarget{List optimization long}{}\n\\subsubsection{{\\em list optimization} long}\n\nNot implemented yet\n\n%.....................................\n\\hypertarget{List optimization macro}{}\n\\subsubsection{{\\em list optimization} macro}\n\nA listing of all thermodynamic data and current values of model\nparameter and experimental data with current weight. This can be read\nback as a start of a re-assessment and an important documentation of\nthe current state of the assessment. But not yet implemented.\n\n%.....................................\n\\hypertarget{List optimization short}{}\n\\subsubsection{{\\em list optimization} short}\\label{sc:listoptshort}\n\nThis specifies tha data and hour of the listing and first a table with\nthe optimizing coefficents with name, current value, start value,\nscaling factor and its relative standard deviation.\n\nIn the first table all the optimizing coefficents with non-zero values\nare listed together with the current values, the start values and\ntheir scaling factor (usually ths same as the start value). In the\ncolumn ``RSD'' the Relative Standard Deviation'' should appear but it\nis not yet calculated correctly. Last column is the name of the TP\nsymbol(s) where the coefficient is used.\n\nAfter that all equilibria with non-sero weights are listed together\nwith their experimental data, both the prescribed value, the\nuncertainy and the currently calculated one. In the last column the\nerror is listed.\n\n\\begin{verbatim}\nListing of optimization results: date 2018.08.20 : 12h47\n\nList of coefficients with non-zero values\nName Current value Start value Scaling factor RSD Used in\nA11 3.46818E+02 4.00095E+02 4.00095E+02 1.25070E-06 _GFCCAB0\nA12 -5.66234E+01 -6.52871E+01 -6.52871E+01 1.33802E-06\nA13 -2.10028E-02 -1.30393E-02 -1.30393E-02 8.97167E-06 _GFCCAB0\n\nList of 4 equilibria with 8 experimental data values\n No Equil name Weight Experiment $ calculated Error\n 2 FCC1_ZA 1.00 SM=17:1 $ 17 9.8995E-09\n 2 1.00 CP1=18:1 $ 17.28685 7.1315E-01\n 3 FCC2_ZB 1.00 HDIFF=9000:500 $ 9997.813 -1.9956E+00\n 3 1.00 CP1=20:DCP $ 22.55698 -2.5570E-02\n 4 FCC3_ZC 1.00 HDIFF=15000:500 $ 14719.24 5.6152E-01\n 4 1.00 CP1=22:DCP $ 24.65726 -2.6573E-02\n 5 FCC4_ZD 1.00 HDIFF=20000:500 $ 19860.72 2.7856E-01\n 5 1.00 CP1=24:DCP $ 26.75754 -2.7575E-02\n\nFinal sum of squared errors: 4.88614E+00 using 8 experiments and\n 3 coefficient(s). Degrees of freedom: 5, normalized error: 9.7723E-01\n\\end{verbatim}\n\nIn the list of equilibria with non-zero weight the first column is a\nsequential equilibrium number assigned by the software. Then the name\nof the equilibrium assigned by the user. The third column is the\nweight, only equilibria with nonzero weight are listed. Then comes a\ncolumm with the experimental property and value and after the dollar\nsign its calculated value with the present set of coefficients. The\nrightmost column gives the difference for each experiment $i, q_i$\nthat should be as close to zero as possible:\n\\begin{equation}\nq_i = \\frac{z^{\\rm exp}_i - z^{\\rm calc}}{\\sigma_i} w_i\n\\end{equation}\nwhere $i$, $z_i^{\\rm exp}$ is the experimental property, $z_i^{\\rm\n calc}$ is the same property calculated from the model and $\\sigma_i$\nis the experimental uncertanty and $w_i$ is the weight assigned to\nequilibria with the experiment. If $w_i = 1$ and $q_i$ is between -1\nand 1 the experiment has been fitted within the experimental\nuncertanty.\n\nThe least square routine tries to determine coefficients to make the\nsum of all $q_i^2$ as small as possible.\n\nAt the end of the listing $\\sum_i q_i^2$ is listed. The degrees of\nfreedom is the number of experiments minus the number of coefficients.\n\n%--------------------------------\n\\hypertarget{List parameter}{}\n\\subsection{{\\em list} Parameter}\n\nList a specific parameter.\n\n%--------------------------------\n\\hypertarget{List phase}{}\n\\hypertarget{List what for}{}\n\\subsection{{\\em list} Phase ``phase-name''}\n\nYou must first specify the phase name. Then you can specify if you\nwant the phase CONSTITUTION, DATA or some MODEL information. To write\non a file use the options /output= or /append=, see~\\ref{sc:options}.\n\n%...................\n\\subsubsection{{\\em list phase} ... Constitution}\n\nList the constitution of the phase.\n\n%...................\n\\subsubsection{{\\em list phase} ... Data}\n\nList the model and model parameter expressions.\n\n%...................\n\\subsubsection{{\\em list phase} ... Model}\n\nList some model data for example if there is a disordered fraction set.\n\n%--------------------------------\n\\subsection{{\\em list} Quit}\n\nYou did not really want to list anyting.\n\n%--------------------------------\n\\hypertarget{List results}{}\n% when user asks ?? on command level the help system will search\n% for command and default in UPPER CASE\n\\hypertarget{LIST RESULTS}{}\n\\subsection{{\\em list} Results}\n\nList the results of an equilibrium calculation. This is the most\nfrequent list command. The listing will contain the current set of\nconditions, a table with global data, a table with component specific\ndata and then a list of stable phases with amounts, compositions and\npossibly constitutions. It is possible to list also unstable phases.\n\nThere are 9 options for the formatting:\n\\begin{itemize}\n\\item 1 Output in mole fractions, phase constituents in value order\n (constituent with highest fraction first).\n\\item 2 as 1 but include also the phase constitution (sublattices and\n their fractions) in value order.\n\\item 3 as 1 with the phase composition in alphabetical order\n\\item 4 Output in mass fractions, phase composition in value order.\n\\item 5 as 4 with the phase composition in alphabetical order.\n\\item 6 as 4 and also include the phase constitutions in value order.\n\\item 7 Output all phases will with composition in mass fractions and\n in value order. Unstable phases will have a negative driving force.\n\\item 8 Output all phases will with composition in mole fraction and\n constitution in alphabetic order. Unstable phases will have a\n negative driving force.\n\\item 9 as 8 but in in value order.\n\\end{itemize}\n\nFor each phase the name, its status\n(S=suspended/D=dormant/E=entered/F=fix), moles (or mass), volume,\nnumber of formula units, atoms per formula units and driving force (in\ndimensionless units) is given on one line.\n\nThe moles of a phase is the number of formula unit multiplied with\natoms per formula units. The gas phase and phases with interstitials\nand vacancies have a varying amount of moles of atoms per formula\nunits. The composition of the phase can be in value order or\nalphabetical order.\n\nTo write the output on a file use /output= or /append=,\nsee~\\ref{sc:options}.\n\n%--------------------------------\n\\hypertarget{List short}{}\n\\subsection{{\\em list} Short}\n\nThere are 4 options: A/C/M/P\n\nThe A option lists a single line for each element, species and phases\nwith some essential data.\n\nThe C option lists one line for each component.\n\nThe M option lists the models and constitution for all phases.\n\nThe P option lists one line for each stable phase and then one line\nfor some of the remaining phases in decreasing order of stability.\n\n%--------------------------------\n\\hypertarget{List state variables}{}\n\\subsection{{\\em list} State\\_Variables}\\label{sc:list_statevar}\n\nValues of individual state variables like G, HM(LIQUID), X(LIQUID,CR)\netc. can be listed. Terminate the command by an empty line. Note\nthat the values of symbols and TP functions cannot be listed here,\nthey are calculated by the CALCULATE SYMBOL or CALCULATE TP command.\n\nThe current values of parameter identifiers, see\nsection~\\ref{sc:paramid} can be listed with the command, like TC(BCC)\nwill give the calculated Curie temperature for BCC. A symbol like\nMQ\\&FE(FCC) will give the logarithm of the mobility of Fe in the FCC\nphase.\n\nThis command is the same as the SHOW command, section~\\ref{sc:show}.\n\n%--------------------------------\n\\hypertarget{List symbols}{}\n\\subsection{{\\em list} Symbols}\n\nAll state variable symbols listed but not their values, they are\ncalculated by the CALCULATE SYMBOL command.\n\n\\begin{verbatim}\nList of all state variable symbols\n No Special Name= expression ;\n 1 R= 8.31451;\n 2 RT= R*T;\n 3 T_C= T-273.15;\n 4 D CP= HM.T;\n 5 C DCP= 1\n 6 7X H298= HM;\n\\end{verbatim}\n\nIn the ``special'' column the ``D'' means the symbol that is a ``dot\nderivative'' which is calculated only when explicitly specified, ``C''\nmeans a numeric value that can be amended. The special 7X means a\nsymbol that is evaluated only at equilibrium 7 which means you can\nrefer to the value of this symbol calculated at the specified\nequilibrium in other equilibria. See also section~\\ref{sc:amendsym}.\n\n%--------------------------------\n\\hypertarget{List excell CSV}{}\n\\subsection{{\\em list} excell CSV file}\n\nThe result from a STEP calculation can be listed in a file using the\nCommma Separated Value (CSV) format. This can be read by Excell or\nsimilar software for later processing. One may use other state\nvariables for the table than used for the step command as one can do\nfor plotting.\n\n{\\bf Independent variable:}\n\nThe independent variable must be a single valued state variable, for\nexample $T$.\n\n{\\bf Dependent variable(s):}\n\nThe dependent variable may have multiple values, for example phase\namounts, NP(*), or the driving force, DGM(\\#).\n\n{\\bf Output file:}\n\n%--------------------------------\n\\hypertarget{List TPfun}{}\n\\subsection{{\\em list} Tpfun Symbols}\n\nAll or some TPFUN expressions listed. By giving * all are listed,\nbu giving the g* all TP functions starting with G are listed.\n\nNote that all parameters are also TP functions, they can be listed by\ngiving ``\\_*'' as name. The abbreviation ``\\_g*'' will list the\nfunction for all parameters with identifiers starting with G.\n\nTo obtain the values of TP functions use the {\\bf calculate TP}\ncommand.\n\n%===================================================================\n\\hypertarget{Macro}{}\n\\section{Macro }\n\nBy specifying a file name commands will be read from that file. The\ndefault extension is OCM. A macro file can open another macro file\n(max 5 levels). When a macro file finish with SET INTERACTIVE the\ncalling macro file will continue or the user can continue\ninteractively. See section~\\ref{sc:macro}.\n\nWhen you start OC you can give a macro file name on the same line and\nthe program will drictly start reading from this file.\n\nWith the popup window facility there are some special things. If you\nopen the macro file with the popup window OC will save the directory\nwhere the macro file was found. If there are references to other\nfiles such as datbases or other macro files inside the macro and these\nfile names are on the same line as the command {\\bf read tdb ./steel1}\nthe file name must be preceeded by a ``./'', otherwise OC will try to\nopen the file on its ``working directory'', see\nsection~\\ref{sc:popup}.\n\n%===================================================================\n\\hypertarget{Map}{}\n\\hypertarget{Map old data}{}\n\\section{Map }\\label{sc:map}\n\nFor phase diagram calculations. You must first set two axis with\nstate variables which are already set as conditions.\n\n{\\bf Reinitiate?}\n\nIf you give several MAP commands you can choose to erase or keep the\nprevious results at each command.\n\nDuring mapping each calculated equilibria is saved and for plotting\nany state variable can be used.\n\n%===================================================================\n\\section{New }\n\\hypertarget{New}{}\n\nTo remove all data and calculated results to enter a new system. It\nis fragile.\n\nThe user must confirm with UPPER CASE Y.\n\n%===================================================================\n\\hypertarget{Optimize}{}\n\\section{Optimize}\\label{sc:optim}\n\nThe command is part of the facility to assess model parameters for\nthermodynamic databases. You have already entered elements, phases\nand model parameters with coefficients to be assessed and all the\nexperimental data yu can find. Estimated and theoretical data\ncalculated by DFT can also be entered as experimental data.\n\nThe model parameters to optimized are selected by SET VARIABLE\\_COEFF\nand there is a least square routine LMDIF which will vary these to\nobtain the best least fit the experimental data provided.\n\nAs already state you must have entered the thermodynamic descriptions\nof the phases with model parameters depending on optimizing\ncoefficients and the experimental data before this command. You must\nalso set the weights of the experiments and which coefficents to be\nvariable.\n\nYou provide a maximum number of iterations allowed. If you give zero\na ``dry run'' will be made with the current values of the optimizing\ncoefficients. This is useful to check that there are no problems\ncalculating the equilibria. Usually you have to change the set of\nmodel parameters, weights of the experimental data and other criteria\nmany times before you get a satisfactory result.\n\nDeveloping better assessment software is one of the main aspects of\nthe OC software. There will be more options to this and related\ncommands.\n\n%===================================================================\n\\hypertarget{Plot command}{}\n\\section{Plot }\\label{sc:plot}\n\nPlot the result from a STEP or MAP calculation. A simple interface to\nGNUPLOT~\\cite{gnuplot} has been implemented in OC. This generates a\ncommand file which is automatically plotted using GNUPLOT after the\n``render'' command.\n\nIn OC you must first specify the state variable on the horizontal\n(x-axis) and vertical (y-axis) axis. Then you can give several of the\noptions below, finish with RENDER or QUIT.\n\n%----------------------------------------------------\n\\hypertarget{Horizontal axis variable}{}\n\\subsection{{\\em plot} Horizontal axis variable}\n\nSpecify the state variable or symbol to be plotted on the horizontal axis.\n\nNote that if you plot a phase diagram with \"tie-lines in the plane\"\nyou should specify a fraction variable as X(*,C) and not X(C)\nbecause you want the carbon content in all stable phases.\n\n%----------------------------------------------------\n\\hypertarget{Vertical axis variable}{}\n\\subsection{{\\em plot xaxis} Vertical axis variable}\n\nSpecify the state variable or symbol to be plotted on the vertical axis.\n\nNote that if you plot a phase diagram with \"tie-lines in the plane\"\nyou should specify a fraction variable as X(*,C) and not X(C) because\nyou want the carbon content in all stable phases.\n\n%----------------------------------------------------\n\\hypertarget{Plot}{}\n\\hypertarget{Plot options}{}\n\\subsection{{\\em plot xaxis yaxis} Options?/RENDER/}\n\nYou can choose various options before plotting. Typing a ? gives a\nmenu, typing ?? will give this text of the online help is correctly\ninstalled. The menu here is not very clear and will be reorganized.\nThe default option is RENDER meaning to plot when you specified all\nyour options.\n\nThe simplest way to generate a complex plot to be saved as PDF or PNG\nformat is to first select the approriate axis and then set a few\noptions like scaling, axis texts and text labels and plot on the\nscreen. If you are not satified you can plot again (without changing\nthe axis variables, if you change these all options you have set will\nbe cleared) and add or modify the options. When you are satisfied\nwith the plot on the screen you plot a final time and set the\nGRAPHICS-FORMAT option and plot in the desired format on a file. Or\nyou can select to plot on a file in the GNUPLOT window. Note that\nsome texts and formats may not be exactly identical to those you see\non the screen.\n\nDefault plotfile is ``ocgnu.plt''. On this file all the GNUPLOT\ncommands and data will be written to be executed by GNUPLOT. If\nGNUPLOT is correctly installed then OC will start GNUPLOT and generate\nthe graphics output when you RENDER the plot.\n\nYou can change the name of the plotfile before plotting with the\ncommand ``output file''. Whenever you set a new terminal you can also\nset the output file name. Or you can rename the file after the RENDER\ncommand and before you generate a new plot.\n\nGNUPLOT is a very powerful graphics software, only a few of its\nfacilities are available within OC. The gnuplot command file\ngenerated by OC can be edited to exploit additional facilities in\nGNUPLOT.\n\n\\bigskip\n\n{\\small\n\\begin{tabular}{llll}\n APPEND & FONT & POSITION\\_OF\\_KEYS~ & SCALE\\_RANGES~ \\\\\n AXIS\\_LABELS~ & GRAPHICS\\_FORMAT~ & QUIT & TEXT\\_LABEL \\\\\n EXTRA & OUTPUT\\_FILE & RENDER & TITLE\\\\ \n\\end{tabular}\n}\n\nA short summary:\n\n\\begin{itemize}\n\\item APPEND means overlay the current plot with another GNUPLOT file\n\\item AXIS-LABELS you can specify the label on X or Y axis\n\\item EXTRA provides less frequent plot options\n\\item FONT select the font for all texts, depend on what GNUPLOT has istalled\n\\item GRAPHICS-FORMAT to select the GNUPLOT output device (PS, PDF, PNG etc)\n In GNUPLOT plot window there is also an option to save on file.\n\\item OUTPUT-FILE the GNUPLOT file is saved on this file (default ocgnu.plt)\n\\item POSITION\\_OF\\_KEYS, the identification labels for the curves\n\\item QUIT no plot generated\n\\item RENDER finally plot\n\\item SCALE-RANGES for X and Y axis you can specify min and max value plotted\n\\item TEXT-LABEL you can place a text inside the plot\n\\item TITLE the heading of the plot (can be suppressed, see EXTRA)\n\\end{itemize}\n\nThe EXTRA command provides less used options:\n\n{\\small\n\\begin{tabular}{llll}\nAXIS\\_FACTOR & LINE\\_TYPE & NO\\_HEADING & SPAWN \\\\\nCOLOR & LOGSCALE & PAUSE\\_OPTION & TIE\\_LINES \\\\\nGIBBS\\_TRIANGLE~ & LOWER\\_LEFT\\_TEXT~ & QUIT \\\\\nGRID & MANIPULATE\\_LINES~ & RATIOS\\_XY \\\\\n\\end{tabular}\n}\n\n%----------------------------------------------------\n\\hypertarget{Plot append}{}\n\\subsection{{\\em plot xaxis yaxis} Append}\n\nA GNUPLOT file prevously generated by OC with possible manually\nchanges or any file following the GNUPLOT standard can be specified to\nbe overlayed on the current plot.\n\n%----------------------------------------------------\n\\hypertarget{Plot axis labels}{}\n\\subsection{{\\em plot xaxis yaxis} Axis\\_Labels}\n\nYou specify for the X or Y axis the axis labels. By default the state\nvariable or symbol plotted will be used as label.\n\n{\\bf For X or Y axis?}\n\nSpecify the axis for which you want to enter the label\n\n{\\bf Axis label:}\n\nThe default label is given in the question.\n\n%----------------------------------------------------\n\\hypertarget{Plot fonts}{}\n\\subsection{{\\em plot xaxis yaxis} Font}\n\n%----------------------------------------------------\n\\hypertarget{Plot formats}{}\n\\subsection{{\\em plot xaxis yaxis} Graphics format}\n\nThe GNUPLOT terminals entered in section~\\ref{sc:gnuterm} can be used.\nFor other formats than SCREEN you can also specify an output file\nwhich will be written for the specified format.\n\nGraphics format index:\n\nThe default terminal indices are:\n\n% IMPORTANT if table changed here also change in\n% \\subsection{{\\em enter} GNUPLOT Terminal}\\label{sc:gnuterm}\n\\begin{tabular}{rlcl}\n & Name &=~ & GNUPLOT definition\\\\\n 1~& SCREEN & & set terminal wxt size 940,700 font \"arial,16\"\\\\\n 2~& PS & & set terminal postscript color solid fontscale 1.2\\\\\n 3~& PDF & & set terminal pdf color solid size 6,5 enhanced font \"arial,16\"\\\\\n 4~& GIF & & set terminal gif enhanced fontscale 0.7\\\\\n 5~& PNG & & set terminal png enhanced fontscale 0.7\\\\\n\\end{tabular}\n\nYou can change these or enter more graphics formats with the {\\bf\n enter gnuplot} command. \\ref{sc:gnuterm}. The SCREEN driver is\nusually ``wxt'' for Windows and ``Qt'' for Linux but can be selected in\nthe Makefile for the pmon6.F90 file.\n\nIf SCREEN is not selected the you can specify the name of the file\nwhere OC will save the commandfile for GNUPLOT as well as the final\ngraphics file created by GNUPLOT. It will have the appropriate\nextention depending on the format. By default OC saves the GNUPLOT\ncommand file on the file ``ocgnu.plt''. This can be renamed and\nedited if you want to keep it for later processing.\n\nPlot file:\n\nIn addition to the GNUPLOT command file the graphics a file with the\nspecified format will be generated.\n\n%----------------------------------------------------\n\\hypertarget{Plot file}{}\n\\subsection{{\\em plot xaxis yaxis} Output file}\n\nBy default plotting will generate a ocgnu.plt file for GNUPLOT. You\ncan specify other name here. If you plot on other terminals than\nSCREEN there will be an additional file with extension ``.ps'' for\nPostscript, ``.pdf'' for Adobe PDF or ``.gif'' for GIF format.\n\nIf the file already exists the user must confirm it it should be\noverwritten.\n\n%----------------------------------------------------\n\\hypertarget{Plot keys}{}\n\\subsection{{\\em plot xaxis yaxis} Position of keys}\n\nThe identification (labels) of the curves in the plot can be\npositioned with this command. See the GNUPLOT manual~\\cite{gnuplot}\nfor information.\n\n%----------------------------------------------------\n\\hypertarget{Plot quit}{}\n\\subsection{{\\em plot xaxis yaxis} Quit}\n\nNo plot generated.\n\n%----------------------------------------------------\n\\hypertarget{Plot render}{}\n\\hypertarget{Render}{}\n\\subsection{{\\em plot xaxis yaxis} Render}\n\nPress return to plot using all the option set. Otherwise you\ncan select any of these options:\n\n{\\small\n\\begin{tabular}{llll}\n APPEND & FONT & POSITION\\_OF\\_KEYS~ & SCALE\\_RANGES~ \\\\\n AXIS\\_LABELS~ & GRAPHICS\\_FORMAT~ & QUIT & TEXT\\_LABEL \\\\\n EXTRA & OUTPUT\\_FILE & RENDER & TITLE\\\\ \n\\end{tabular}\n}\n\n%----------------------------------------------------\n\\hypertarget{Plot limits}{}\n\\subsection{{\\em plot xaxis yaxis} Scale\\_Range}\n\nYou specify for the X or Y axis the minimum and maximum range. The\nautomatic (default) scaling range can always be restored.\n\n%----------------------------------------------------\n\\hypertarget{Plot texts}{}\n\\subsection{{\\em plot xaxis yaxis} Text}\n\nThis is a facility to add a text to a plot at an arbitrary position.\n\n\\subsubsection{{\\em plot xaxis yaxis text} Modify existing text?:}\n\nIf there is already a text item you must first answer if you wants\nmodify an already existing one. If so all the texts are listed and\nyou can select which one you wants to change.\n\n\\subsubsection{{\\em plot xaxis yaxis text} Which text index?:}\n\nYou must provide the index of an existing text to change.\n\nFor a new or changed text you must give:\n\n\\subsubsection{{\\em plot xaxis yaxis text} X position}\n\nThe X coordinate of the text (in the plot scale)\n\n\\subsubsection{{\\em plot xaxis yaxis text} Y position}\n\nThe Y coordinate of the text (in the plot scale)\n\n\\subsubsection{{\\em plot xaxis yaxis text} Fontscale}\n\nA relative size factor, default is 0.8. The size of the text will be\nscaled accordingly.\n\n\\subsubsection{{\\em plot xaxis yaxis text} Angle (degrees)}\n\nThe text will be written with the specified angle. Zero means\nhorisontally, negative valus slopes downward, positive upwards. An\nange of 180 means the text will be upside down.\n\n\\subsubsection{{\\em plot xaxis yaxis text} Do you want to calculate the\nequilibrium?/Y/}\n\nIf you are plotting a phase diagram you can select to calculate an\nequilibrium at the specified coordinates. The names of the stable\nphases will be proposed as text.\n\nThe calculation may fail and you can anyway add a text. Note that the\naxis values you sepcified will refer to the axis used when calculating\nthe diagram. If you are plotting using other variables there may be\nsome surprises.\n\n\\subsubsection{{\\em plot xaxis yaxis text} Text: }\n\nThe text to be added to the plot. The text will start at the\ncoordinates given. On Postscript and PDF a greek character can be\ngiven as ``{/Symbol m}'' for $\\mu$.\n\n%----------------------------------------------------\n\\hypertarget{Plot title}{}\n\\subsection{{\\em plot xaxis yaxis} Title}\n\nThe default is the date and the conditions. You can add a text of\nyour own here. You can remove the title altogether with EXTRA\nNO\\_HEADING. That will make the figure slightly larger.\n\n%----------------------------------------------------\n\\hypertarget{Extra}{}\n\\hypertarget{Plot extra}{}\n\\hypertarget{Extra Gibbs_triangle}{}\n\\subsection{{\\em plot xaxis yaxis} Extra }\n\nLess common options for the plotting is available here. For really\nnice plotting it is recommended to edit the output file from\nOC as GNUPLOT has too many facilities to be made available here.\n\n\\hypertarget{Extra options}{}\nThe EXTRA commands provides more obscure options:\n\n{\\small\n\\begin{tabular}{llll}\nAXIS\\_FACTOR & LOGSCALE & PAUSE\\_OPTION & TIE\\_LINES \\\\\nCOLOR & LOWER\\_LEFT\\_TEXT~ & QUIT \\\\\nGIBBS\\_TRIANGLE~ & MANIPULATE\\_LINES~ & RATIOS\\_XY \\\\\nLINE\\_TYPE & NO\\_HEADING & SPAWN \\\\\n\\end{tabular}\n}\n\n\\begin{itemize}\n\\item AXIS\\_FACTOR means all values on an axis will be multiplied with\n this. For example it can be useful to plot in kJ rather than the default J.\n\\item COLOR you can select some colors\n\\item GIBBS-TRIANGLE means an equilateral triangular diagram\n\\item LINE-TYPE means dashed lines or lines with symbols\n\\item LOGSCALE you can specify that X or Y axis is logaritmic\n\\item LOWER-LEFT-TEXT you can set a text in the lower left corner\n\\item MANIPULATE-LINES does not work\n\\item NO-HEADING means remove title all text above the plot\n\\item PAUSE-OPTION to select how GNUPLOT should behave after plotting\n\\item QUIT no extra option selected\n\\item RATIOS-XY will change the relative length of X and Y axis\n\\item SPAWN will allow you to contine calculating with the plot window open\n\\item TIE-LINES if you have tie-lines in the plane you can plot some of them\n\\end{itemize}\n\n%----------------------------------------------------\n\\hypertarget{Plot extra factor}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} factor}\n\nYou can select a factor for each plot axis to convert from J to kJ for\nexample.\n\n%----------------------------------------------------\n\\hypertarget{Plot color}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} color}\n\nYou can select color of monovariant equilibria and tie-lines.\n\n%----------------------------------------------------\n\\hypertarget{Plot Gibbs triangle}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} Gibbs-triangle}\n\nGibbs triangle plots should only be used for isothermal sections. A\ntrial implementation is available which can generate equiaxial\ntriangular isothermal diagrams.\n\nIf you already set this option you can set it again to plot on a square.\n\n%----------------------------------------------------\n\\hypertarget{Plot line symbols}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} line-with-symbols}\n\nNot implemented yet\n\n%----------------------------------------------------\n\\hypertarget{Plot logax}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} logscale}\n\nYou can set logarithimic scale on X or Y axis (or both).\n\n%----------------------------------------------------\n\\hypertarget{Extra line-colors}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} manipulate lines}\n\nThis is not implemented. It is intended to allow specification of the\ncolor of the curves in the plot.\n\n%----------------------------------------------------\n\\hypertarget{Extra lower-left-corner}{}\n\\subsubsection{{\\em plot xaxia yaxis extra} lower left corner text}\n\nYou can set a short text in the lower left corner of the plot\n\n%----------------------------------------------------\n\\hypertarget{Plot spawn}{}\n\\subsubsection{{\\em plot xaxia yaxis extra} spawn}\n\nYou can spawn the plot window and continue working looking at it.\n\n%----------------------------------------------------\n\\hypertarget{Plot no heading}{}\n\\subsubsection{{\\em plot xaxia yaxis extra} no heading}\n\nRemove the text above the plot with date and title. The plot is\nslightly larger this way.\n\n%----------------------------------------------------\n\\hypertarget{Plot pause}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} pause option}\n\nWhen you plot on the screen the last command on the file to GNUPLOT\nis ``pause mouse''. You can change this with this command.\n\n%----------------------------------------------------\n\\hypertarget{Plot ratios}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} ratios XY}\n\nThe relative ratios of the X and Y axis can be specied.\n\n%----------------------------------------------------\n\\hypertarget{Plot tieline}{}\n\\subsubsection{{\\em plot xaxis yaxis extra} tie-line}\n\nTie-lines in isothermal ternary phase diagram can be plotted. You\ncan specify the density of the tie-lines by\n\nTie-line plot increment?\n\nThe increment is related to the actual equilibria calculated. 0 means\nno tie-lines plotted, 3 means to plot a tie-line at every 3rd\ncalculated equilibria and so on.\n\n%===================================================================\n\\hypertarget{Quit}{}\n\\section{Quit }\n\nTerminate the OC software in English, have a nice day.\n\n%===================================================================\n\\hypertarget{Read}{}\n\\section{Read }\n\nIt is possible to read a (non-encrypted) TDB file but it should be not\ntoo different from what is normally generated by the LIST\\_DATA\ncommand in TC.\n\n\\begin{tabular}{lll}\n DIRECT~ & QUIT~ & TDB\\\\\n PDB & SELECTED-PHASES & UNFORMATTED \\\\\n\\end{tabular}\n\n%--------------------------------\n\\hypertarget{Read direct}{}\n\\subsection{{\\em read} Direct}\n\n{\\bf File name:}\n\nIn the future it will be possible to save results on a random access\n(DIRECT) file.\n\n%--------------------------------\n\\hypertarget{Read PDB}{}\n\\subsection{{\\em read} PDB}\n\n{\\bf File name:}\n\nA PDB file (with extension PDB) should be specified. The file\nshould be un the Portable phase dependent Data Base format.\n\nThe user can select to read the whole file or select elements.\n\n%--------------------------------\n\\hypertarget{Read quit}{}\n\\subsection{{\\em read} Quit}\n\nYou did not really want to read anything.\n\n%--------------------------------\n\\hypertarget{Read select phase}{}\n\\subsection{{\\em read} selected phases only}\n\nThis is to select a subset of elements and phases from a database.\nNormally all phases which can be formed by the elements are included.\nWith this command one can first select the elements and after that one\ncan specify the phases to be included. If one specifies an\nabbreviation of a phase name all phases which fit this abbreviation\nwill be selected.\n\n{\\bf Database format:}\n\nCan be TDB or PDB.\n\n{\\bf File name:}\n\nIt is also possible to read all phases and later suspend those which\nare not interesting.\n\n%--------------------------------\n\\hypertarget{Read TDB}{}\n% on command level the subcommand may be lower case!!\n\\hypertarget{Read tdb}{}\n\\subsection{{\\em read} TDB}\n\nA TDB file (with extension TDB) should be specified. The TDB file\nmust not deviate very much from the standard output from Thermo-Calc.\n\n\\hypertarget{File name:}{{\\bf File name:}}\n\nIf you do not use the popup window for opening files you must specify\nthe database file name. The file must be on the working directory\n(where you started the OC program, see section~\\ref{sc:popup}) or you\nmust provide the path.\n\n\\hypertarget{Select element}{}\nAfter opening the file the program will list the elements and ask:\n\n{\\bf Select elements /all/:}\n\nIf you give RETURN the data for all elements will be read. If you\nanswer q or quit nothing will be read. If you specify one or more\nelements the data for those will be read and if you selected a subset\nyou will have the question:\n\n{\\bf Select elements /no more/:}\n\nAnd you can select some more or just give RETURN (or type quit). All\nphases that can be formed by the elements selected will be read, you\ncannot select the phases here but inside OC you can suspend those\nphases you are not interested in.\n\n\\hypertarget{Read TDB error}{{\\bf Error reading TDB file}}\n \nIn some cases there non-fatal errors or warnings reading TDB files\ncreated by different groups because the TDB format varies a lot. The\nuser should carefully check if there are any data missing but can\ncontinue using the data he read if he is confident it is correct. The\nTDB file should be corrected manually.\n\n%--------------------------------\n\\hypertarget{Read unformatted}{}\n\\subsection{{\\em read} Unformatted}\\label{sc:readunf}\n\n{\\bf File name:}\n\nFor use to read a file created with a SAVE UNFORMATTED command. It\nmay not always work to read an old unformatted file as the data\nstructure is still changing.\n\n%===================================================================\n\\hypertarget{Save}{}\n\\section{Save }\n\nThere are several forms of save, three forms write a text file that\ncan be read and modified with a normal editor. Two forms are\nunformatted, either on a sequential file or a direct (random access)\nfile.\n\n\\begin{tabular}{llll}\n DIRECT~ & SOLGAS~ & UNFORMATTED\\\\\n QUIT & TDB & PDB \\\\\n\\end{tabular}\n\n%--------------------------------\n\\hypertarget{Save direct}{}\n\\subsection{{\\em save} Direct}\n\nIt will eventually be possible to save the result of STEP and MAP\ncommands on a random access file for later processing.\n\n%--------------------------------\n\\hypertarget{Save quit}{}\n\\subsection{{\\em save} Quit}\n\nYou did not want to save anything.\n\n%--------------------------------\n\\hypertarget{Save PDB}{}\n\\subsection{{\\em save} PDB}\n\nSaves current set of model parameters and functions on a file in the\nPortable phase dependant Data Base format. \n\n%--------------------------------\n\\hypertarget{Save TDB}{}\n\\subsection{{\\em save} TDB}\n\nSaves current set of model parameters and functions on a file in TDB\nformat. Same as the command {\\bf list data tdb}.\n\n%--------------------------------\n\\hypertarget{Save SOLGAS}{}\n\\subsection{{\\em save} SOLGAS}\n\nSaves current set of model parameters and functions on a file in a\nformat that (hopefully) can be read by the FactSage software.\n\n%--------------------------------\n\\hypertarget{Save unformatted}{}\n\\subsection{{\\em save} Unformatted}\\label{sc:saveunf}\n\nWith this command you can save the current status of the calculations\non a file and then resume the calculations by reading this file. Note\nthat the Fortran unformatted files may not be portable, they depend on\nthe compiler, the operating system and the hardware.\n\n%===================================================================\n\\hypertarget{Select}{}\n\\section{Select }\n\nThere are a few things that can be selected, most important which\nequilibrium the following commands will operate on.\n\n%--------------------------------\n\\hypertarget{Select equilibrium}{}\n\\subsection{{\\em select} Equilibrium}\n\nAs you can enter several equilibria with different conditions\nthis command allows him to select the current eqilibria.\n\n%--------------------------------\n\\hypertarget{Select graphics}{}\n\\subsection{{\\em select} Graphics}\n\nOnly GNUPLOT~cite{gnuplot} available.\n\n%--------------------------------\n\\hypertarget{Select language}{}\n\\subsection{{\\em select} Language}\n\nOnly English implemented (except a few French exclamations).\n\n%--------------------------------\n\\hypertarget{Select minimizer}{}\n\\subsection{{\\em select} Minimizer}\n\nOnly Hillert's algorithm implemented in matsmin~\\cite{15Sun2} available.\n\n%--------------------------------\n\\hypertarget{Select optimizer}{}\n\\subsection{{\\em select} Optimizer}\n\nThe LMDIF~\\cite{lmdif} least square fitting software is the only one\nimplemented.\n\n%######### >>> edit limit 2018.01.10\n\n%===================================================================\n\\hypertarget{Set}{}\n\\section{Set }\n\nMany things can be set. Things to be ``set'' and ``amended''\nsometimes overlap.\n\n{\\small\n\\begin{tabular}{llll}\n ADVANCED & FIXED\\_COEFF & OPTIMIZING\\_COND~ & STATUS\\\\\n AS\\_START\\_EQUILIB~&INITIAL\\_T\\_AND\\_P~ & PHASE & SYSTEM\\_VARIABLE\\\\\n AXIS & INPUT\\_AMOUNTS & QUIT & UNITS\\\\ \n BIT & INTERACTIVE & RANGE\\_EXP\\_EQUIL~ & VARIABLE\\_COEFF\\\\\n CONDITION & LOG\\_FILE & REFERENCE\\_STATE & VERBOSE\\\\\n ECHO & NUMERIC\\_OPTIONS~ & SCALED\\_COEFF & WEIGHT\\\\\\\\\n\\end{tabular}\n}\n\n%--------------------------------\n\\hypertarget{Advanced command}{}\n\\subsection{{\\em set} Advanced}\n\nA few options implemented\n\n{\\small\n\\begin{tabular}{llll}\n EEC\\_METHOD & HELP-POPUP-OFF~& OPEN-POPUP-OFF~ & WORKING-DIRECTRY\\\\ \n EQUILIB-TRANSF~ & LEVEL & QUIT\\\\\n GLOBAL-MIN-ONOFF~& MAP-SPECIALS & SMALL-GRID-ONOFF~\\\\\n GRID-DENSITY & NO-MACRO-STOP & SYMBOL \\\\\n\\end{tabular}\n}\n\n%.............................................................\n\\hypertarget{Set adv EEC-method}{}\n\\subsubsection{{\\em set advanced} EEC-method}\\label{sc:eec-method}\n\nIn a recent paper\\cite{20Sun} a method the compare the entropy of\nthe liquid and a solid phase can be used to supress the formation of a\nsolid phase at high $T$ if its entropy is higher than the liquid, the\nEqui-Entropy Criteria (EEC). This simplifies the extrapolation of the\nGibbs energy of solids at high $T$.\n\nThis command will activate or deactivate this check.\n\n%.............................................................\n\\hypertarget{Set adv transfer}{}\n\\subsubsection{{\\em set advanced} equilibrium transfer}\n\nThis is only for experts who know what they are doing.\n\n%.............................................................\n\\hypertarget{Set adv global onoff}{}\n\\subsubsection{{\\em set advanced} global-min-onoff}\n\nTurn on or off the use of the global gridminimizer.\n\n%.............................................................\n\\hypertarget{Set adv grid-density}{}\n\\subsubsection{{\\em set advanced} grid\\_density}\n\nAt present the grid density cannot be fine tuned. For some phases it\nis fixed for others you can select a more or less dense grid.\n\nNote that phases with option F or B (4 sublattice order/disorder)\nthere is a special grid minimizer and also for solids with ionic\nconstituents and for the 2-sublattice ionic liquid.\n\n%.............................................................\n\\hypertarget{Set adv help popup}{}\n\\subsubsection{{\\em set advanced} help-popup-off}\\label{sc:help-popup}\n\nThe user can turn off or on the HTML popup help feature. He can also\nchange the browser and help file.\n\n{\\bf Turn off popup help? /Y/:}\n\nIf the user answers N he will be asked for the browser and HTML file.\nThese are normally set when compiling the OC software and their\ncurrent values are proposed as default within slashes /../.\n\n{\\bf Browser including full path //usr/local/firefox/:}\n\n{\\bf HTML help file includig full path //home/user/.ochelp/ochelp.html/:}\n\n%.............................................................\n\\hypertarget{Set adv level}{}\n\\subsubsection{{\\em set advanced} level}\n\nYou can specify if you are beginner or expert. You may have to\ndeclare youself as expert to execute some commands. The intention of\nthe beginners status is to provide more help but that is not yet\nimplemented.\n\n%.............................................................\n%\\hypertarget{SET Advanced map-special}{}\n\\subsubsection{{\\em set advanced} map-special}\n\nNot implemented yet.\n\n%.............................................................\n\\hypertarget{Set adv no-macro-stop}{}\n\\subsubsection{{\\em set advanced} no-macro-stop}\n\nThis command makes it possible to ignore the ``@\\&'' used to stop the\nexecution of a macro file. Used when testing the software.\n\n%.............................................................\n\\hypertarget{Set adv open popup}{}\n\\subsubsection{{\\em set advanced} open-popup-off}\n\nAny other answer than Y will turn off popup windows for opening files.\nBy answering Y you turn on popup windows for opening files (the\ndefault) provided the program is linked with this facility.\n\n%.............................................................\n\\hypertarget{Set adv quit}{}\n\\subsubsection{{\\em set advanced} quit}\n\nYou did not want to set anything advanced.\n\n%.............................................................\n\\hypertarget{Set adv symbol}{}\n\\subsubsection{{\\em set advanced} symbol}\n\nNot implemented yet.\n\n%.............................................................\n\\hypertarget{Set adv workdir}{}\n\\subsubsection{{\\em set advanced} working-directory}\n\nThe name of the working directory (where OC was started) is listed.\nIt cannot be changed at present. It is related to the popup windows\nfor opening files, see section~\\ref{sc:popup}.\n\n%--------------------------------\n\\hypertarget{Set as start equil}{}\n\\subsection{{\\em set} As start equilibrium}\n\nThe current equilibrium will be copied to the list of start equilibria\nfor STEP and MAP commands.\n\n%--------------------------------\n\\hypertarget{Set axis}{}\n\\subsection{{\\em set} Axis}\\label{sc:setaxis}\n\nTo set an axis you must first has set the conditions necessary to\ncalculate an equilibrium and also calculated this.\n\n{\\bf Axis number:}\n\nThe axis are numbered 1, 2 etc and you must set them in sequential\norder. To change an axis variable just give the number of the axis to\nchange.\n\n{\\bf Condition to vary along the axis:}\n\nYou can set select one of the condition to vary between a min and max\nvalue along the axis. If you has just one axis you can use STEP to\ncalculate a property diagram, i.e. how the system properties varies\nwith a single variable. Typically a phase fraction plot or how the\nheat capacity varies with the independent axis variable.\n\n{\\bf Minimal/maximal value of the axis:}\n\nThe calculation will start with the current value and calculate in\nboth directions.\n\n{\\bf Increment:}\n\nBy default the increment is 1/40 of the difference beteen max and min.\n\nIf you set two or more axis (current limit is 2) the OC software will\nmap the phase diagram, i.e. follow the lines where the set of phases\nchanges. This means OC will replace one axis condition with a condition\nthat a phase should be stable with zero amount.\n\nTo calculate a diagram you must then give a STEP command (if you have\none axis) or a MAP command (if you have 2 or more axis). For the STEP\ncommand~\\ref{sc:step}, there are several options.\n\n%--------------------------------\n\\hypertarget{Set which status}{}\n\\subsection{{\\em set} Bit}\n\n%%% ???\n\\hypertarget{helphere}{}\n%%% ???\n\\hypertarget{Set status bit}{}\n\\hypertarget{Global status bits}{}\n\nMany records have status words where the bits are used to signify\ndifferent things. An advanced user can set these bits for the global,\nequilibrium and phase records, but only if you know what it means.\n\\begin{itemize}\n\\item The GLOBAL record bits are listed below. Most of them are\n set or reset automatically by the software or by other commands.\n \\begin{itemize}\n \\item 0 you are a beginner\n \\item 1 you are experienced (default)\n \\item 2 you are an expert\n \\item 3 gridminimizer must not be used\n \\item 4 gridminimizer must not merge comp.sets.\n \\item 5 there are no data (cleread automatically)\n \\item 6 there are no phases (cleared automatically)\n \\item 7 comp.sets must not be created automatically\n \\item 8 comp.sets must not be deleted automatically\n \\item 9 data has changed since last save (set automtically)\n \\item 10 means verbose is on (not implemented)\n \\item 11 means verbose is permanently on (not implemented)\n \\item 12 means be silent (supress warnings)\n \\item 13 no cleanup after an equilibrium calculation\n \\item 14 use denser grid in grid minimizer (see also SET ADVANCED)\n \\item 15 calculations in parallel is not allowed\n \\item 16 no global test at node point during STEP/MAP\n \\item 17 the components are not the elements\n \\item 18 global test of equilibrium AFTER calculation\n \\item 19 use old (less dense) grid minimizer\n \\item 20 do not recalculate if global test AFTER fails\n \\item 21 use old MAP algorithm\n \\item 22-31 not yet used\n \\end{itemize}\n%--------------------------------------------------------------\n\\item The EQUILIBRIUM record bits are listed below\n \\begin{itemize}\n \\item 0 No threads allowed (no parallel calculation)\n \\item 1 No global minimization allowed for this equilibrium\n \\item 2 No equilibrium has been calculated (there are no results)\n \\item 3 Conditions and results not consistent\n \\item 4 Last equilibrium calculation failed\n \\item 5 No automatic generation of composition sets\n \\item 6 Equilibrium tested by grid minimizer\n \\item 7 Current results are from a grid minimization\n \\end{itemize}\n%--------------------------------------------------------------\n\\item To change the phase status word use SET PHASE ... bit\n\\end{itemize}\n%--------------------------------\n% the default is set condition\n\\hypertarget{Info conditions}{}\n\\hypertarget{Set condition}{}\n\\subsection{{\\em set} Condition}\\label{sc:setcond}\n\nMost of the text here also applies to {\\bf enter experiment}.\n\n{\\bf State variable:}\n\nA condition is a value assigned to a state variable or an expression\nof state variables. All state variables are listed in\nTable~\\ref{tab:statev} in section~ref{sc:statevar}\n\nBy setting the status of a phase to fix you have\nalso set a condition. For example\n\n{\\em set cond t=1273 p=1e5 n=1 x(cr)=0.1 w\\%(c)=1}\n\nThree cases of expressions can be used as conditions, for example a\nrelation between mole fraction like\\\\\n{\\bf set condition x(liq,o)-x(c1\\_mo2,o)=0}\\\\\nmeans that the oxygen content in liquid and c1\\_mo2 phases should be the\nsame. That is useful to calculate the congruent melting of c1\\_mo2.\n\nAnother case is if the total anount if some components has a relation,\nfor example:\\\\ \n{\\bf set condition n(u)+n(zr)=1}\\\\ \nmeans that the total number of moles of the components U and Zr should\nbe unity.\n\nA third case is {\\bf y(B2,Al)-y(B2,Al\\#2)=0.01} to calculate a send\norder transition line when the B2 ordered phase is on the limit of\ndisorder as the fractions of Al on the two sublattices are almost\nequal.\n\n%subsubsection{value}\n{\\bf Value:}\n\nA numeric value or a symbol representing a constant value is expected.\n\n%--------------------------------\n\\hypertarget{Set echo}{}\n\\subsection{{\\em set} Echo}\n\nThis is useful command in macro files or when demonstrating the program.\n\n%--------------------------------\n\\hypertarget{Set fix coeff}{}\n\\subsection{{\\em set} Fixed coefficient}\n\nOne or more optimizing coefficients are assigned a fixed value. The\nindex 0 to 99 is used to indicate the coefficients A00 to A99. One\ncan use a range as 15-19 to set all variable cofficients in the range\nto their current values.\n\n%--------------------------------\n\\hypertarget{Set initial TP}{}\n\\subsection{{\\em set} initial\\_T\\_and\\_P}\n\nLocal values of T and P can be set. These are not conditions but are\nused for commands like {\\bf CALCULATE PHASE ...}.\n\n%--------------------------------\n\\hypertarget{Set input amounts}{}\n\\subsection{{\\em set} Input-Amounts}\\label{sc:setinpuam}\n\nThis command allows you to specify a system by giving a redundant\namount of various species in the system. The software will transform\nthis to conditions on the amounts of the components.\n\n\\hypertarget{Species and amounts}{}\nSpecies and amount as N(..)= or B(...)= :\n\nAn example:\n\n{\\small\n\\begin{verbatim}\n--->OC5:read tdb cho-gas\n--->OC5:set input \nSpecies and amount as N(..)= or B(...)= : n(c1o2)\nAmount: 10\n--->OC5:set input n(c1h4)=5\n--->OC5:l c\nConditions for equilibrium: 1, DEFAULT_EQUILIBRIUM\n 1:N(C)=45, 2:N(O)=80, 3:N(H)=30\n Degrees of freedom are 2\n\\end{verbatim}\n}\n\nThe amounts of the species has been split on the components. Setting\ninput amounts is just another way to set these directly. If we set a\n$T$ and $P$ we can calculate the equilibrium fraction of all the\nspecies.\n\n{\\small\n\\begin{verbatim}\n--->OC5:set c t=1000 p=1e5\n--->OC5:l c\nConditions for equilibrium: 1, DEFAULT_EQUILIBRIUM\n 1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000\n Degrees of freedom are 0\n--->OC5:c e\n 3Y Constitution of metastable phases set\nGridmin: 85 points 1.56E-02 s and 0 clockcycles, T= 1000.00\nPhase change: its/add/remove: 5 11 0\nPhase change: its/add/remove: 12 12 0\nPhase change: its/add/remove: 17 0 12\nPhase change: its/add/remove: 53 0 11\nEquilibrium calculation 79 its, 7.8125E-02 s and 93 clockcycles\n--->OC5:l\nLIST what? /RESULTS/:\nResults output mode: /1/:\n\nOutput for equilibrium: 1, DEFAULT_EQUILIBRIUM 2018.08.21\nConditions .................................................:\n 1:N(C)=45, 2:N(O)=80, 3:N(H)=30, 4:T=1000, 5:P=100000\n Degrees of freedom are 0\n\nSome global data, reference state SER ......................:\nT= 1000.00 K ( 726.85 C), P= 1.0000E+05 Pa, V= 4.9872E+00 m3\nN= 1.5500E+02 moles, B= 1.8507E+03 g, RT= 8.3145E+03 J/mol\nGS= -2.80411E+07 J, GS/N=-1.8091E+05 J/mol, HS=-1.2914E+07 J, SS= 1.513E+04 J/K\n\nSome data for components ...................................:\nComponent name Moles Mole-fr Chem.pot/RT Activities Ref.state\nC 4.5000E+01 0.29032 -3.7354E+00 2.3863E-02 SER (default)\nH 3.0000E+01 0.19355 -9.8098E+00 5.4910E-05 SER (default)\nO 8.0000E+01 0.51613 -3.6377E+01 1.5911E-16 SER (default)\n\nSome data for phases .......................................:\nName Status Moles Volume Form.Units Cmp/FU dGm/RT Comp:\nGAS..................... E 1.550E+02 4.99E+00 6.00E+01 2.58 0.00E+00 X:\n O 5.16129E-01 C 2.90323E-01 H 1.93548E-01\n Constitution: There are 73 constituents:\n C1O2 4.54395E-01 C2H3 8.67456E-17 C4H10_1 2.73242E-23\n C1O1 2.95682E-01 C3H4_2 3.04922E-17 C4H10_2 1.38822E-23\n H2O1 1.29270E-01 C3H8 2.73523E-17 C4H2 8.16657E-24\n H2 1.20501E-01 C3H6O1 1.94895E-17 H1O2 4.37267E-24\n C1H4 1.52786E-04 C3H4_1 8.18695E-18 C4H6_5 1.44915E-24\n C1H2O2_CIS 4.04887E-08 C1H3O1_CH3O 3.87833E-18 C4H8 1.04297E-25\n C1H2O1 2.01368E-08 C2H4O1_OXIRA 1.64221E-19 C2H1 7.79712E-26\n C1H2O2_TRANS 5.82767E-09 C1H2 3.98656E-20 C4H8_4 6.39692E-26\n H 7.88542E-10 H2O2 3.27068E-20 C6H6O1 3.00598E-26\n C1H4O1 1.27636E-10 O 1.46838E-20 C1H1 1.81712E-27\n C2H4 1.05140E-10 C2H6O2 1.19305E-20 C3H1 1.68523E-28\n C2H6 3.44726E-11 O2 8.71930E-21 C4H4_1_3 7.73762E-29\n C1H3 1.83302E-11 C4H6_2 5.73533E-21 C1H2O2_DIOXI 4.04963E-30\n C1H1O1 7.24719E-12 C2O1 1.72590E-21 C4H1 1.00000E-30\n C2H4O1_ACETA 2.00054E-12 C4H8_5 9.38081E-22 C2H4O2_DIOXE 1.00000E-30\n H1O1 1.86354E-12 C4H8_3 5.91323E-22 C4 1.00000E-30\n C2H2 1.82837E-12 C4H8_1 4.75317E-22 C2H4O3_123TR 1.00000E-30\n C1H1O2 1.57298E-12 C4H8_2 4.17043E-22 C2H4O3_124TR 1.00000E-30\n C2H4O2_ACETI 7.65642E-13 C2H2O1 1.47405E-22 C2 1.00000E-30\n C1H3O1_CH2OH 1.64978E-15 C4H6_4 8.47392E-23 C60 1.00000E-30\n C3O2 1.11079E-15 C6H6 8.21607E-23 C3 1.00000E-30\n C3H6_2 7.21243E-16 C4H4 5.46648E-23 C5 1.00000E-30\n C3H6 7.13743E-16 C4H6_1 5.05773E-23 O3 1.00000E-30\n C2H6O1 6.22811E-16 C4H6_3 2.87604E-23\n C2H5 4.72671E-16 C4H10_1 2.73242E-23\n\n--->OC5:\n\\end{verbatim}\n}\n\nThe calculation shows that mixing 10 moles of CO$_2$ with 5 moles of\nCH$_4$ at 1000~K and 1~bar gives a gas with 45\\% CO$_2$, 30\\% CO, 13\\%\nH$_2$O and the rest H$_2$\n\n%--------------------------------\n\\hypertarget{Set interactive}{}\n\\subsection{{\\em set} Interactive}\n\nThe last command on a macro file. Gives command back to the keyboard\nof the user, or to the calling macro file. Without this the program\nwill just terminate when the macro is finished.\n\n%--------------------------------\n\\hypertarget{Set logfile}{}\n\\subsection{{\\em set} Log-File}\n\nA useful command to save all interactive input while running OC. The\nlog file can easily be transformed to a macro file. All bug reports\nshould be accompanied by a log file which reproduces the bug.\n\n%--------------------------------\n\\hypertarget{Set numeric}{}\n\\subsection{{\\em set} Numeric-Options}\n\nThe default number of iterations and accuracy can be specified.\nDefault values are 500 and 10$^{-6}$.\n\nSome more obscure values may also be asked for, they should never be\nchanged.\n\n%--------------------------------\n\\hypertarget{Set optimizer conditions}{}\n\\subsection{{\\em set} Optimizing conditions}\n\nA few variables used to guide the optimization of model parameters can\nbe set.\n\n%--------------------------------\n\\hypertarget{Set system variable}{}\n\\subsection{{\\em set} system variable}\n\nThis is a new idea to have global variables. No idea how to use it\nyet.\n\n%--------------------------------\n\\hypertarget{Set phase}{}\n\\hypertarget{Set for phase}{}\n\\subsection{{\\em set} Phase ``phase-name''}\n\nYou must specify a phase name. Some phase specific things can be set,\nalso for the model. Some subcommands allow wildcard ``*'' as name.\n\n%....................\n\\hypertarget{Set phase amount}{}\n\\subsubsection{{\\em set phase} ... Amount}\n\nYou can specify the amount of the phase which is used as initial value\nfor an equilibrium calculation.\n\n%....................\n\\hypertarget{Set phase bits}{}\n\\subsubsection{{\\em set phase} ... Bits}\n\nSome of the models and use of data storage depend on the bits of the\nphase. Most of them are set automatically by the software and other\ncommands like AMEND PHASE. Changing them with this command will not\nhave the expected effect and may cause the program to fail.\n\nThe bits that can be changed are:\n\n\\hypertarget{Extra-dense-grid}{}\n\\begin{itemize}\n\\item EXTRA\\_DENSE\\_GRID makes it possible to have a larger number of\n gridpoints calculated by the gridminimizer for the specified phase.\n\n%. . . . . . . . . .\n\\hypertarget{No-auto-comp-set}{}\n\\item NO\\_AUTO\\_COMP\\_SET. This makes it possible to prevent that the\nspecific phase has automatic composition set created during\ncalculations.\n\n%. . . . . . . . . .\n\\hypertarget{Set bit quit}{}\n\\item QUIT, do not set any more bits.\n\\end{itemize}\n\n%....................\n\\subsubsection{{\\em set phase} ... Constitution}\n\\hypertarget{Amend phase constit}{}\n\\hypertarget{Set phase constitution}{}\n\nThis is the same as {\\bf amend phase constitution}. The amount of the\nphase can also be set. You can specify the constituent fraction of\neach constituent. A fraction must be larger than zero and less than\nunity.\n\nAs the sum of fractions must be unity the last constituent in each\nsublattice will not be asked for unless you specify the fraction for\none of the constitents as ``rest''. The fraction of that will then be\nset as ``the rest'' i.e. one minus the sum of the other fractions.\n\nThis is also be used for the command {\\bf\n calculate phase} to calculate properties for a single phase.\n\n%....................\n\\hypertarget{Set phase ... default-constitu}{}\n\\subsubsection{{\\em set phase} ... Default-constitution}\n\nSame as {\\bf amend phase default\\_constit}.\n\n%....................\n\\hypertarget{Set phase ... quit}{}\n\\subsubsection{{\\em set phase} ... Quit}\n\nYou did not want to set anything for the phase.\n\n%....................\n\\hypertarget{Set phase status}{}\n\\subsubsection{{\\em set phase} ... Status}\\label{sc:setphstat}\n\nUse the SET STATUS PHASE command to set the status of one or several\nphases. The different status are explained for that command,\nsection~\\ref{sc:set-status-phase}.\n\nA phase with the status FIX must also have an amount specified. For a\nphase with the status ENTERED the amount is also requested but\nnormally it should be set to zero. A nonzero value means the user\nassumes the phase should be stable.\n\n%--------------------------------\n\\hypertarget{Set quit}{}\n\\subsection{{\\em set} Quit}\n\nYou did not really want to set anything.\n\n%--------------------------------\n\\hypertarget{Set range}{}\n\\subsection{{\\em set} Range of experimental equilibria}\\label{sc:setrange}\n\nFor an assessment several consequtive equilibria with experimental\ndata must be entered. This command specifies the first and last of\nthose equilibria. It possible to add more equilibria later one by\none (not yet though). \n\n\\hypertarget{First equilibrium number:}{{\\bf First equilibrium number: /2/:}}\n\n{\\bf Last equilibrium number:}\n\nThe equilibria are assigned the weight one by default. The weight can\nbe changed with the SET WEIGHT command. The weight zero means the\nequilibrium is not calculated.\n\n%--------------------------------\n\\hypertarget{Set reference phase}{}\n\\subsection{{\\em set} Reference-State}\\label{sc:setref}\n\nBy default the reference state for the components is SER (Stable\nElement Reference) which is the stable state of the element at\n298.15~K and 1~bar. (NOTE: in principle SER is defined by the database\nbut today almost all databases have SER as reference state.)\n\n{\\bf Component name:}\n\n{\\bf Reference phase:}\n\nFor each component (also for other components than the elements) you\ncan specify a phase at a given temperature and pressure as reference\nstate. The phase must exist for the component as pure.\n\n{\\bf Temperature:}\n\nInstead of a fixed $T$ you can give a *, indicating current $T$, if\nyou calculates at different values of $T$.\n\n{\\bf Pressure:}\n\nExample:\n\n{\\em set reference O gas * 1e5}\n\nNote that state variables like the chemical potential, MU(O), will\nrefer to the user defined reference state. To obtain the value for\nthe SER state you can use the suffix S, i.e. MUS(O) will give the\nchemical potential refered to SER.\n\nIMPORTANT NOTE: the value of integral properties like Gibbs energy,\n$G$, enthalpy, $H$, etc. will also be affected by the change of the\nreference state of an element. If all elements have the same phase as\nreference state the value of the enthalpy obtained by $H$ for that\nphase will be the enthalpy of mixing. If not it is only confusing.\n\nIn order to have use SER as reference state use a suffix S. The\nenthalpy relative to SER is $HS$ independent of any reference state\nset for the elements by the user.\n\n%--------------------------------\n\\hypertarget{Set scaled coefficient}{}\n\\subsection{{\\em set} Scaled coefficient}\n\nA coefficient for optimization can be specified with a start value,\nscaling factor and a minimum and maximum value. The {\\em set} VARIABLE\ncommand sets the scaling factor equal to the start value and have no\nmin or max values.\n\nNot implemented yet.\n\n%--------------------------------\n\\hypertarget{Set status}{}\n\\subsection{{\\em set} Status}\n\nThe status of elements, constituents, species or phases can be\nchanged. Only phases are implemented.\n\n%....................\n\\hypertarget{Set status constituent}{}\n\\subsubsection{{\\em set status} Constituent}\n\nA constituent of a phase can be suspended. Not yet implemented.\n\n%....................\n\\hypertarget{Set status element}{}\n\\subsubsection{{\\em set status} Element}\n\nAn element can be ENTERED or SUSPENDED. If an element is suspended\nall species with this element is automatically suspended. If such a\nspecies is the single constituent of a phase that phase is also\nsuspended.\n\nNot yet implemented.\n\n%....................\n\\subsubsection{{\\em set status} Phases}\\label{sc:set-status-phase}\n\\hypertarget{Set status phase}{}\n\n\\hypertarget{Status phase}{{\\bf Phase name(s):}}\n\nA phase can have one of 4 different status\n\n\\begin{itemize}\n\\item ENTERED, this is the default. The phase will be stable if that\n would give the most stable state for the current conditions. The user\n can give a tentative amount.\n\\item SUSPENDED, the phase will not be included in any calculations.\n\\item DORMANT, the phase will be included in the calculations but will\n not be allowed to become stable even if that would give the most\n stable equilibrium. In such a case the phase will have a positive\n driving force.\n\\item FIXED means that it is a condition that the phase is stable with\n the specified amount. Note that for solution phases the composition\n is not known.\n\\end{itemize}\n\nYou can use a list of phase names or a wildcard for the phase name and\nthe must give an equal sign, ``='', before the new status. You can\nalso use the special ``*S'' for all suspended phase, ``*D'' for all\ndormant phases.\n\nChanging the phase status does not affect anything except the phase\nitself. For a single phase you can use SET PHASE ... STATUS $<$status$>$.\n\n\\hypertarget{Set status phase amount}{}\n\nSetting a stable phase as dormant or suspended and calculate the\nequilibrium will give you a metastable equilibrium.\n\nSetting a phase status as FIXED means it is a condition that this\nphase should be stable. Setting the liquid fix with the amount zero\nis a quick way to calculate the melting temperature of a system if\nthere is no condition on the T. For entered phases the amount is used\nas a start value.\n\n{\\bf Amount: /0/}:\n\n%....................\n\\hypertarget{Set status species}{}\n\\subsubsection{{\\em set status} Species}\n\nA species can be ENTERED or SUSPENDED. If a species is suspended\nall phases that have this as single constituent in a sublattice\nwill be automatically suspended. Not yet implemented.\n\n%--------------------------------\n\\hypertarget{Set units}{}\n\\subsection{{\\em set} Units}\n\nFor each property the unit can be specified like Kelvin, Farenheit or\nCelsius for temperature. Not implemented yet.\n\n%--------------------------------\n\\hypertarget{Set variable coeff}{}\n\\subsection{{\\em set} Variable coefficient}\\label{sc:setvar}\n\nOne or more coefficients for optimization, A00 to A99, can be set as\nvariable to be optimized against the selected experimental data.\n\nA single variable index, 0 to 99, can be used with a start value\nprovided. Or a range such as 15-19 which will set all nonzero\nvariables A15 to A19 as variable.\n\n%--------------------------------\n\\hypertarget{Set verbose}{}\n\\subsection{{\\em set} Verbose}\n\nNot implemented yet.\n\n%--------------------------------\n\\hypertarget{Set weight}{}\n\\subsection{{\\em set} Weight}\\label{sc:setw}\n\nIntended for assessments. A weight is zero or a positive value.\nEquilibria with weight zero will be ignored in an optimization. \n\nYou can specify the current equilibrium or give an abbreviation that\nwill set the weight of all equilibria with a name for which the\nabbreviation fits. Or you can give a range of equilibria by giving\ntwo numbers separated by a hyphen like 63-106.\n\nIf an abbreviation or a range is given the software will list how many\nequilibra that had the weight set to the new value.\n\n%===================================================================\n\\hypertarget{Show property}{}\n\\section{Show }\\label{sc:show}\n\nThis command shows a value of a property, the property can be a state\nvariable like T, G etc or a user detfined symbol containing several\nstate variable or a model parameter identifier (which must always have\na phase specification) like the Curie temperature.\n\nThe state variables can contain wildcards like X(FCC,*) means all mole\nfractions of the FCC phase. Several properties can be specified on\nthe same line, SEPARATED BY A SPACE CHARACTER, do not use ``,''.\n\nIt is the same as the command {\\em LIST state-variables}, see\nsection~\\ref{sc:list_statevar}\n\n\\hypertarget{property:}{}\n\\subsection{property:}\n\nThe value of one or more properties or symbols can be shown:\nDO NOT USE ``,'' between the properties!\n\n{\\small\n\\begin{verbatim}\n--->OC5:show t g tc(bcc) x(bcc,cr) mu(cr) cp\n T= 1.2000000E+03\n G= -5.9565761E+04\n TC(BCC_A2)= 1.0272646E+03\n X(BCC_A2,CR)= 3.100000E-2\n MU(CR)= -7.2489667E+04\nCP= 4.08487869E+01\n\\end{verbatim}\n}\n\n%===================================================================\n\\hypertarget{Step}{}\n\\section{Step }\\label{sc:step}\n\nRequires that a single axis is set. If a second step command is given\nyou have the choice of deleting or keeping the previous results.\n\nThere are 5 variants of the STEP command, CONDITIONS and NPLE are not\nimplemented:\n\n\\begin{tabular}{llll}\n CONDITIONAL~~ & NPLE & QUI & SEPARATE\\\\\n NORMAL & PARAEQUILIBRIUM~~ & SCHEIL-GULLIVER~~& TZERO\n\\end{tabular}\n\n\\hypertarget{Step old data}{{\\bf Delete previous results?}}\n\nAny previous results from the STEP or MAP commands can be deleted or\nkept. If kept the previous results can be plotted together with the\nresults from the new STEP command. The PLOT command also allows\nappending previous diagams calculated and plotted by OC.\n\n%--------------------------------\n\\hypertarget{Step conditional}{}\n\\subsection{{\\em step} Conditional}\n\nA specified symbol is evaluated at each step, not implemented.\n\n%--------------------------------\n\\hypertarget{Step normal}{}\n\\subsection{{\\em step} Normal}\n\nCalculates equilibria from the low axis limit to the high at each\nincrement. The exact axis value for any phase changes is calculated.\n\n%--------------------------------\n\\hypertarget{Step NPLE}{}\n\\subsection{{\\em step} NPLE}\n\nStep NPLE is similar to step paraequilibrium.\n\n%--------------------------------\n\\hypertarget{Step paraequilibrium}{}\n\\subsection{{\\em step} paraequilibrium}\\label{sc:paraeq3}\n\nParaequilibrium describes a metastable equilibrium with a fast\ndiffusing element. It is described in section~\\ref{sc:paraeq1}. You\nshould make a calculate paraequilibrium command, see\nsection~\\ref{sc:paraeq2}, before this step command and you must again\nspecify a matrix phase and a growing phase and the fast diffusing\nelement.\n\n{\\bf Matrix phase:}\n \nNote all phases except the matrix and growing phase should be\nsuspended. You should provide name of the matrix phase\n\n{\\bf Growing phase:}\n\n{\\bf Fast diffusing element:}\n\nThe element that diffuse so fast that its chemical potential is the\nsame in both phases. The other alloying elements will have the same\ncomposition in both phases.\n\n\n%--------------------------------\n\\hypertarget{Step Quit}{}\n\\subsection{{\\em step} Quit}\n\nYou did not want to {\\em step}.\n\n%--------------------------------\n\\hypertarget{Step Scheil}{}\n\\subsection{{\\em step} Scheil-Gulliver}\\label{sc:scheil2}\n\nThe Scheil-Gulliver solidification simulation is described in\nsection~\\ref{sc:scheil1}. It simulates a solidification with no\ndiffusion in the solid phases and a homogeneous liquid.\n\n%--------------------------------\n\\hypertarget{Step separate}{}\n\\subsection{{\\em step} Separate}\n\nThis command calculates equilibria for each phase separately along the\naxis. It is typically used to separately calculate and plot together\nthe Gibbs energy curves for a number of phases across a composition\nrange.\n\n%--------------------------------\n\\hypertarget{Step Tzero}{}\n\\subsection{{\\em step} Tzero}\\label{sc:tzero3}\n\nThis will calculate a line with the fraction of the selected element\non one axis and the $T$ on the other and the line is defined by the\nfact that the two phases have the same Gibbs energy with the same\ncomposition and at the same $T$. This is the limit of a diffusionless\ntransformation. $T_0$ or Tzero lines are described in\nsection~\\ref{sc:tzero1} and \\ref{sc:tzero2}. Before this step command\nyou must have calculated a Tzero point.\n\n{\\bf First phase:}\n \n{\\bf Second phase:}\n\nNote all phases except the two phases should be suspended. You should\nprovide name of the matrix phase\n\n{\\bf Release condition number:}\n\nNormally the step axis is the fast diffusing element and the condition\nreleased is the $T$. The fast diffusing element will have the same\nchemical potential is both phases, the other alloying elements will\nhave the same composition in both phases.\n\n\n%===================================================================\n\n% Using this file for on-line help there must be a section after last command\n\\hypertarget{Summary}{}\n\\section{Summary }\n\nThat's all and I hope enough (when all is implemented). Have fun and\nreport all errors or problems providing a macro file and the necessary\ndata.\n\n\\begin{thebibliography}{77zzz}\n\\bibitem{15Sun1} B Sundman, U R Kattner, M Palumbo and S G\n Fries, {\\em OpenCalphad - a free thermodynamic software}, in\n Integrating Materials and Manufacturing Innovation, {\\bf 4:1}\n (2015), open access\n\\bibitem{15Sun2} B Sundman, X-L Liu and H Ohtani, {\\em The\n implementation of an algorithm to calculate thermodynamic equilibria\n for multi-component systems with non-ideal phases in a free\n software}, Computational Materials Science, {\\bf 101} (2015) 127--137\n\\bibitem{16Sun} B Sundman, U R Kattner, C Sigli, M Stratmann, R\n Le Tellier, M Palumbo and S G Fries, {\\em The OpenCalphad\n thermodynamic software interface}, Comp Mat Sci, {\\bf 125} (2016)\n 188--196\n\\bibitem{07Luk} H L Lukas, S G Fries and B Sundman, {\\em\n Computational Thermodynamics, the CALPHAD method}, Cambridge Univ\n Press 2007.\n\\bibitem{20Her} J Herrnring, B Sundman and B Klusemann, {\\em\n Diffusion-driven microstructure evolution in OpenCalphad},\n Computational Materials Science, {\\bf 175}, (2020) 109236\n\\bibitem{lmdif}\n https://www.math.utah.edu/software/minpack/minpack/lmdif.html\n\\bibitem{gnuplot} http://www.gnuplot.info/documentation.html\n\\bibitem{20Sun} B Sundman, U R Kattner, M Hillert, M Selleby, J\n {\\AA}gren, S Bigdeli, Q Chen, A Dinsdale, B Hallstedt, A Khvan, H\n Mao and R Otis, {\\em A Method for handling the extrapolation of\n solid crystalline phases to temperatures far above their melting\n point}, Calphad, {\\bf 68} 101737\n\\end{thebibliography}\n\n\\end{document}\n\nOld state variable table\n\n\\begin{table}[!ht]\n\\caption{A preliminary table with the state variables and their\n internal representation. Some model parameter properties are also\n included. The \"z\" used in some symbols like Sz means the optional\n normalizing symbol M, W, V or F.}\\label{tab:statevold}\n{\\small\n\\begin{tabular}{|llcccl|}\\hline\nSymbol~ & Id & \\multicolumn{2}{c}{Index} & Normalizing~ & Meaning\\\\\n & & 1 & 2 & suffix & \\\\\\hline\n\\multicolumn{6}{|c|}{Intensive properties}\\\\\\hline\nT & 1 & - & - & - & Temperature\\\\\nP & 2 & - & - & - & Pressure\\\\\nMU & 3 & component & -/phase & - & Chemical potential\\\\\nAC & 4 & component & -/phase & - & Activity\\\\\nLNAC & 5 & component & -/phase & - & LN(activity)\\\\\\hline\n\\multicolumn{6}{|c|}{Extensive and normallized properties}\\\\\\hline\nU & 10 & -/phase\\#set & - & - & Internal energy for system\\\\\nUM & 11 & -/phase\\#set & - & M & Internal energy per mole\\\\\nUW & 12 & -/phase\\#set & - & W & Internal energy per mass\\\\\nUV & 13 & -/phase\\#set & - & V & Internal energy per m$^3$\\\\\nUF & 14 & phase\\#set & - & F & Internal energy per formula unit\\\\\nSz & 2z & -/phase\\#set & - & - & entropy\\\\\nVz & 3z & -/phase\\#set & - & - & volume\\\\\nHz & 4z & -/phase\\#set & - & - & enthalpy\\\\\nAz & 5z & -/phase\\#set & - & - & Helmholtz energy\\\\\nGz & 6z & -/phase\\#set & - & - & Gibbs energy\\\\\nNPz & 7z & phase\\#set & - & - & Moles of phase\\\\\nBPz & 8z & phase\\#set & - & - & Mass of phase\\\\\nQz & 9z & phase\\#set & - & - & Stability of phase\\\\\nDGz & 10z & phase\\#set & - & - & Driving force of phase\\\\\nNz & 11z & -/phase\\#set/comp & -/comp & - & Moles of component\\\\\nX & 111 & phase\\#set/comp & -/comp & 0 & Mole fraction\\\\\nX\\% & 111 & phase\\#set/comp & -/comp & 100 & Mole per cent\\\\\nBz & 12z & -/phase\\#set/comp & -/comp & - & Mass of component\\\\\nW & 122 & phase\\#set/comp & -/comp & 0 & Mass fraction\\\\\nW\\% & 122 & phase\\#set/comp & -/comp & 100 & Mass per cent\\\\\nY & 130 & phase\\#set & const\\#subl & -& Constituent fraction\\\\\\hline\n\\multicolumn{6}{|c|}{Some model parameter identifiers}\\\\\\hline\nTC & - & phase\\#set & - & - & Curie temperature\\\\\nBMAG & - & phase\\#set & - & - & Aver. Bohr magneton number\\\\\nMQ\\&X & - & phase\\#set & constituent & - & Mobility of X\\\\\nTHET & - & phase\\#set & - & - & Debye temperature\\\\\\hline\n\\end{tabular}\n}\n\\end{table}\n\n" }, { "path": "examples/TQ4lib/Cpp/Makefile", "content": "all:\n# Example written in C++ using ISO-C-Binding\n\tmake -C ./Matthias\n\nclean:\n\tmake -C ./Matthias clean\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/FECRMNC.TDB", "content": "\n$ Database file written 14- 5-11\n$\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01!\n\n SPECIES CR+2 CR1/+2!\n SPECIES CR+3 CR1/+3!\n SPECIES FE+2 FE1/+2!\n SPECIES FE+3 FE1/+3!\n SPECIES FE+4 FE1/+4!\n SPECIES MN+2 MN1/+2!\n SPECIES MN+3 MN1/+3!\n SPECIES MN+4 MN1/+4!\n\n FUNCTION GHSERCR 2.98140E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GHSERBB 2.98140E+02 -7735.284+107.111864*T-15.6641*T*LN(T)\n -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1.10000E+03 Y\n -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3\n +1748270*T**(-1); 2.34800E+03 Y\n -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2\n +1.34719E-07*T**3+11205883*T**(-1); 3.00000E+03 Y\n -21530.653+222.396264*T-31.4*T*LN(T); 6.00000E+03 N !\n FUNCTION GCRM23B6 2.98150E+02 -460000+23*GHSERCR#+6*GHSERBB#; \n 6.00000E+03 N !\n FUNCTION GHSERFE 2.98140E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GFEM23B6 2.98150E+02 -490000+134*T+23*GHSERFE#+6*GHSERBB#; \n 6.00000E+03 N !\n FUNCTION GHSERMN 2.98140E+02 -8115.28+130.059*T-23.4582*T*LN(T)\n -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y\n -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GMNM23B6 2.98150E+02 +23*GHSERMN#+6*GHSERBB#; 6.00000E+03 N \n !\n FUNCTION GHSERNI 2.98140E+02 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N \n !\n FUNCTION GNIM23B6 2.98150E+02 +23*GHSERNI#+6*GHSERBB#; 6.00000E+03 N \n !\n FUNCTION GBHCP 2.98150E+02 +50208-9.706*T+GHSERBB#; 6.00000E+03 N \n !\n FUNCTION UALFE 2.98150E+02 -4000+T; 6.00000E+03 N !\n FUNCTION GALFE3 2.98150E+02 +3*UALFE#-4000; 6.00000E+03 N !\n FUNCTION GAL2FE2 2.98150E+02 +4*UALFE#; 6.00000E+03 N !\n FUNCTION GAL3FE 2.98150E+02 +3*UALFE#+9000; 6.00000E+03 N !\n FUNCTION SROALFE 2.98150E+02 +UALFE#; 6.00000E+03 N !\n FUNCTION LFALFE0 2.98150E+02 -104700+30.65*T; 6.00000E+03 N !\n FUNCTION LFALFE1 2.98150E+02 22600; 6.00000E+03 N !\n FUNCTION LFALFE2 2.98150E+02 +29100-13*T; 6.00000E+03 N !\n FUNCTION UKALFEC 2.98150E+02 -1600-16.8*T; 6.00000E+03 N !\n FUNCTION GKALFE3C 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N !\n FUNCTION GKAL2FE2 2.98150E+02 +4*UKALFEC#-5200; 6.00000E+03 N !\n FUNCTION GKAL3FEC 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N !\n FUNCTION SROKALFE 2.98150E+02 +UKALFEC#; 6.00000E+03 N !\n FUNCTION B2ALVA 2.98150E+02 +10000-T; 6.00000E+03 N !\n FUNCTION LB2ALVA 2.98150E+02 100000; 6.00000E+03 N !\n FUNCTION GB2ALFE 2.98150E+02 -10876+2.6*T; 6.00000E+03 N !\n FUNCTION DGBALFE 2.98150E+02 -4530+2.5*T; 6.00000E+03 N !\n FUNCTION DT0ALFE 2.98150E+02 -250; 6.00000E+03 N !\n FUNCTION DB0ALFE 2.98150E+02 -1.2; 6.00000E+03 N !\n FUNCTION ZERO 298.15 0.0; 6000.00 N !\n FUNCTION RTLN25 2.98150E+02 -.562335*R#*T; 6.00000E+03 N !\n FUNCTION GHSERCU 2.98140E+02 -7770.458+130.485235*T-24.112392*T*LN(T)\n -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y\n -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); \n 3.20000E+03 N !\n FUNCTION GHSERSS 2.98140E+02 -5228.956+55.417762*T-11.007*T*LN(T)\n -.026529*T**2+7.754333E-06*T**3; 3.68300E+02 Y\n -6513.769+94.692922*T-17.941839*T*LN(T)-.010895125*T**2\n +1.402558E-06*T**3+39910*T**(-1); 1.30000E+03 N !\n FUNCTION GDIGENIT 2.98150E+02 -62053-105.461*T+8.1715*T*LN(T)+2*GHSERCU#\n +GHSERSS#; 6.00000E+03 N !\n FUNCTION F10383T 2.98150E+02 +211801.621+24.4989821*T-20.78611*T*LN(T); \n 6.00000E+03 N !\n FUNCTION F10711T 2.98140E+02 +130854.682+30.5267876*T-34.25937*T*LN(T)\n +.00583824*T**2-1.79746E-06*T**3-33304.895*T**(-1); 7.00000E+02 Y\n +133769.365-23.7043906*T-25.65337*T*LN(T)-.0042003385*T**2\n +2.51694667E-07*T**3-174588.25*T**(-1); 2.20000E+03 Y\n +140179.423-26.622816*T-25.86682*T*LN(T)-.00276017*T**2\n +9.24508333E-08*T**3-3805126*T**(-1); 6.00000E+03 N !\n FUNCTION F10784T 2.98140E+02 -9522.9741+78.5273879*T-31.35707*T*LN(T)\n +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y\n +180.108664-15.6128256*T-17.84857*T*LN(T)-.00584168*T**2\n +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y\n -18840.1663+92.3120255*T-32.05082*T*LN(T)-.0010728235*T**2\n +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N !\n FUNCTION F11002T 2.98140E+02 -28637.4628-29.7124458*T-25.37431*T*LN(T)\n -.012230205*T**2+6.62201E-07*T**3-86459.2*T**(-1); 9.00000E+02 Y\n -38442.2654+51.1969052*T-36.54058*T*LN(T)-.007461545*T**2\n +4.40338167E-07*T**3+1395975*T**(-1); 2.20000E+03 Y\n -65256.7666+203.938596*T-56.66161*T*LN(T)-6.40182E-04*T**2\n +2.14147833E-09*T**3+8250950*T**(-1); 6.00000E+03 N !\n FUNCTION F11007T 2.98140E+02 -1716.28163+84.8441289*T-51.37952*T*LN(T)\n -.00808767*T**2+210246*T**(-1); 1.00000E+03 N !\n FUNCTION F14852T 2.98140E+02 +269797.373+2.2810296*T-25.70471*T*LN(T)\n +.003751372*T**2-5.48887167E-07*T**3+3450.3165*T**(-1); 1.00000E+03 Y\n +273925.002-38.4958652*T-19.81748*T*LN(T)-2.300353E-04*T**2\n -1.18709967E-08*T**3-570436.5*T**(-1); 3.40000E+03 Y\n +257401.532-.943966729*T-24.05931*T*LN(T)-5.98546E-07*T**2\n +2.02961167E-09*T**3+9368165*T**(-1); 1.00000E+04 N !\n FUNCTION F14964T 2.98140E+02 +117374.548+2.98629624*T-34.09678*T*LN(T)\n -.002325464*T**2+1.85480167E-07*T**3+128593.6*T**(-1); 1.00000E+03 Y\n +117352.438+2.50383325*T-34.04744*T*LN(T)-.0021150245*T**2\n +9.16602333E-08*T**3+175718.45*T**(-1); 3.40000E+03 Y\n +124361.091+14.5182901*T-36.1923*T*LN(T)-5.930925E-04*T**2\n -7.54259333E-09*T**3-7484105*T**(-1); 6.00000E+03 N !\n FUNCTION F15022T 2.98140E+02 +126744.315+83.8435689*T-52.94561*T*LN(T)\n -.0043385055*T**2+6.68300333E-07*T**3+276938.3*T**(-1); 1.00000E+03 Y\n +123958.871+118.720436*T-58.16242*T*LN(T)-7.29079E-06*T**2\n +2.42566833E-10*T**3+558805*T**(-1); 6.00000E+03 N !\n FUNCTION F15041T 2.98140E+02 +109847.438+203.904963*T-72.67966*T*LN(T)\n -.009041155*T**2+1.47148883E-06*T**3+505278*T**(-1); 9.00000E+02 Y\n +104526.08+272.793563*T-83.05028*T*LN(T)-1.828101E-05*T**2\n +6.19803333E-10*T**3+1023588.5*T**(-1); 6.00000E+03 N !\n FUNCTION F15047T 2.98140E+02 +106276.072+170.263399*T-74.99022*T*LN(T)\n -.035336475*T**2+5.76872833E-06*T**3+227070.6*T**(-1); 9.00000E+02 Y\n +75139.8847+544.891054*T-130.537*T*LN(T)+.007879015*T**2\n -4.32610333E-07*T**3+3425257*T**(-1); 2.80000E+03 Y\n +114904.753+339.945759*T-103.9801*T*LN(T)+2.25877E-05*T**2\n -7.925025E-10*T**3-7832715*T**(-1); 6.00000E+03 N !\n FUNCTION F15052T 2.98140E+02 +57214.7948+523.24074*T-130.1838*T*LN(T)\n -4.152356E-04*T**2-4.27131667E-07*T**3+779118.5*T**(-1); 1.60000E+03 Y\n +8925.72335+728.509037*T-155.3363*T*LN(T)+.002031178*T**2\n -1.776135E-08*T**3+14908280*T**(-1); 4.20000E+03 Y\n +43158.7838+657.511854*T-147.3935*T*LN(T)+.0015928905*T**2\n -3.34608333E-08*T**3-8046775*T**(-1); 6.00000E+03 N !\n FUNCTION F15057T 2.98140E+02 +59623.0027+634.182529*T-153.2939*T*LN(T)\n -.003102847*T**2+3.66153167E-07*T**3+940068*T**(-1); 1.50000E+03 Y\n +56671.3245+666.288106*T-157.9591*T*LN(T)-2.441417E-06*T**2\n +7.28532E-11*T**3+1284129.5*T**(-1); 6.00000E+03 N !\n FUNCTION F15061T 2.98140E+02 +45619.0277+695.996674*T-166.1987*T*LN(T)\n -.0109886*T**2-1.38875683E-06*T**3+753634*T**(-1); 8.00000E+02 Y\n +22301.584+822.41812*T-181.0091*T*LN(T)-.020252625*T**2\n +3.04543E-06*T**3+4785936*T**(-1); 1.50000E+03 Y\n +28125.3352+992.470207*T-208.7199*T*LN(T)+.006139635*T**2\n -2.57977667E-07*T**3-2943090*T**(-1); 3.90000E+03 Y\n +82396.4096+766.112131*T-180.3439*T*LN(T)-2.580219E-04*T**2\n +5.17172833E-09*T**3-21845450*T**(-1); 6.00000E+03 N !\n FUNCTION GCLIQ 2.98150E+02 +117369-24.63*T+GHSERCC#; 6.00000E+03 \n N !\n FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N !\n FUNCTION GCRLIQ 2.98140E+02 +24339.955-11.420225*T+2.37615E-21*T**7\n +GHSERCR#; 2.18000E+03 Y\n -16459.984+335.616316*T-50*T*LN(T); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98140E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10838.83+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GMNLIQ 2.98140E+02 +17859.91-12.6208*T-4.41929E-21*T**7\n +GHSERMN#; 1.51900E+03 Y\n +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GMNBCC 2.98140E+02 -3235.3+127.85*T-23.7*T*LN(T)\n -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y\n -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98140E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -1713.815+.94001*T+4.9251E+30*T**(-9)+GHSERFE#; 6.00000E+03 N !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GMNFCC 2.98140E+02 -3439.3+131.884*T-24.5177*T*LN(T)\n -.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N !\n FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; \n 6.00000E+03 N !\n FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T)\n -.126431*T**2; 6.00000E+03 N !\n FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920\n -40*T; 6.00000E+03 N !\n FUNCTION GMNM23C6 2.98150E+02 -308065+50.966*T+23*GHSERMN#+6*GHSERCC#; \n 6.00000E+03 N !\n FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T)\n -.0301188*T**2; 6.00000E+03 N !\n FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T)\n -.0578207*T**2; 6.00000E+03 N !\n FUNCTION GS_NIVNI 2.98140E+02 -161645.05+3532.8443*T-671.032*T*LN(T)\n -.1382502*T**2+4.87E-07*T**3+277840*T**(-1); 7.90000E+02 Y\n -161794.7+3572.6245*T-678.096*T*LN(T)-.1256082*T**2-2.72E-06*T**3; \n 1.72800E+03 N !\n FUNCTION GS_NIVV 2.98140E+02 -663330.65+4012.7719*T-707.716*T*LN(T)\n -.1068816*T**2+2.6785E-06*T**3+1528120*T**(-1); 7.90000E+02 Y\n -664153.72+4231.5628*T-746.568*T*LN(T)-.0373506*T**2-1.496E-05*T**3; \n 1.72800E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N !\n FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N !\n FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N !\n FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N !\n FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N !\n FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N !\n FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N !\n FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N !\n FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N !\n FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 \n N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N !\n FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 \n N !\n FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N !\n FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 \n N !\n FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N !\n FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N !\n FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N !\n FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N !\n FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N !\n FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N !\n FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N !\n FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n\n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT SPECIE 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :C,CR,FE,MN : !\n\n PARAMETER G(LIQUID,C;0) 2.98150E+02 +GCLIQ#+GPCLIQ#; 6.00000E+03 N \n REF:279 !\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +GCRLIQ#+GPCRLIQ#; 6.00000E+03 \n N REF:279 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF:279 !\n PARAMETER G(LIQUID,MN;0) 2.98140E+02 +GMNLIQ#; 2.00000E+03 N REF:279 !\n PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 \n N REF:97 !\n PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF:97 !\n PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF:97 !\n PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -514037; 6.00000E+03 N \n REF:322 !\n PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 73286; 6.00000E+03 N \n REF:322 !\n PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 66921; 6.00000E+03 N \n REF:322 !\n PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 \n N REF:186 !\n PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF:186 !\n PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N \n REF:186 !\n PARAMETER G(LIQUID,C,FE,MN;0) 2.98150E+02 -45675; 6.00000E+03 N \n REF:263 !\n PARAMETER G(LIQUID,C,FE,MN;1) 2.98150E+02 -12379; 6.00000E+03 N \n REF:263 !\n PARAMETER G(LIQUID,C,FE,MN;2) 2.98150E+02 -12379; 6.00000E+03 N \n REF:263 !\n PARAMETER G(LIQUID,C,MN;0) 2.98150E+02 -168240+35.635*T; 6.00000E+03 \n N REF:263 !\n PARAMETER G(LIQUID,C,MN;1) 2.98150E+02 -91760+50*T; 6.00000E+03 N \n REF:263 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -17737+7.996546*T; \n 6.00000E+03 N REF:322 !\n PARAMETER G(LIQUID,CR,FE;1) 2.98150E+02 -1331; 6.00000E+03 N \n REF:322 !\n PARAMETER G(LIQUID,CR,FE,MN;0) 2.98150E+02 2378; 6.00000E+03 N \n REF:323 !\n PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 \n N REF:323 !\n PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N \n REF:323 !\n PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N \n REF:257 !\n PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF:257 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE%,MN : C,VA% : !\n\n PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC#\n +3*GPCGRA#+416000; 6.00000E+03 N REF:97 !\n PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF:97 !\n PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF:97 !\n PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +GHSERFE#+GPFEBCC#+3*GHSERCC#\n +3*GPCGRA#+322050+75.667*T; 6.00000E+03 N REF:186 !\n PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF:186 !\n PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF:186 !\n PARAMETER G(BCC_A2,MN:C;0) 2.98150E+02 +10000+30*T+GHSERMN#+3*GHSERCC#; \n 6.00000E+03 N REF:263 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF:279 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF:277 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF:277 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF:279 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N \n REF:277 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF:277 !\n PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N \n REF:279 !\n PARAMETER TC(BCC_A2,MN:VA;0) 2.98140E+02 -580; 2.00000E+03 N REF:277 !\n PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98140E+02 -.27; 2.00000E+03 N \n REF:277 !\n PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF:314 !\n PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF:98 !\n PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N \n REF:98 !\n PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N \n REF:98 !\n PARAMETER G(BCC_A2,CR,MN:C;0) 2.98150E+02 -20328+18.7339*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(BCC_A2,CR,MN:C;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 \n N REF:324 !\n PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF:97 !\n PARAMETER G(BCC_A2,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; \n 6.00000E+03 N REF:263 !\n PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF:186 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF:103 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF:103 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF:103 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF:103 !\n PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -5996; 6.00000E+03 N \n REF:323 !\n PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; \n 6.00000E+03 N REF:323 !\n PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; \n 6.00000E+03 N REF:323 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 \n N REF:323 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 \n N REF:323 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 \n N REF:323 !\n PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N \n REF:323 !\n PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N \n REF:323 !\n PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N \n REF:323 !\n PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N \n REF:323 !\n PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 \n N REF:257 !\n PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N \n REF:257 !\n\n\n PHASE CEMENTITE % 2 3 1 !\n CONSTITUENT CEMENTITE :CR,FE%,MN : C : !\n\n PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000\n -9.2888*T; 6.00000E+03 N REF:314 !\n PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N \n REF:186 !\n PARAMETER G(CEMENTITE,MN:C;0) 2.98150E+02 -40379+3.524*T+3*GHSERMN#\n +GHSERCC#; 6.00000E+03 N REF:263 !\n PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(CEMENTITE,CR,MN:C;0) 2.98150E+02 9000; 6.00000E+03 N \n REF:324 !\n PARAMETER G(CEMENTITE,FE,MN:C;0) 2.98150E+02 +10434-14.281*T; \n 6.00000E+03 N REF:263 !\n\n\n PHASE CR3MN5 % 2 3 5 !\n CONSTITUENT CR3MN5 :CR : MN : !\n\n PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550\n +21.1732*T; 6.00000E+03 N REF:323 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE%,MN : C,VA% : !\n\n PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC#\n +GPCFCC#; 6.00000E+03 N REF:186 !\n PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF:186 !\n PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF:186 !\n PARAMETER G(FCC_A1,MN:C;0) 2.98150E+02 +502+15.261*T+GHSERMN#+GHSERCC#; \n 6.00000E+03 N REF:263 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF:277 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF:277 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF:277 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF:279 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N \n REF:277 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF:277 !\n PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N \n REF:279 !\n PARAMETER TC(FCC_A1,MN:VA;0) 2.98140E+02 -1620; 2.00000E+03 N REF:277 !\n PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98140E+02 -1.86; 2.00000E+03 N \n REF:277 !\n PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(FCC_A1,CR,MN:C;0) 2.98150E+02 -19088+17.5423*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(FCC_A1,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; \n 6.00000E+03 N REF:263 !\n PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF:186 !\n PARAMETER G(FCC_A1,MN:C,VA;0) 2.98150E+02 -43433; 6.00000E+03 N \n REF:263 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF:103 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF:103 !\n PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 +6715-10.3933*T; \n 6.00000E+03 N REF:323 !\n PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; \n 6.00000E+03 N REF:323 !\n PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 \n N REF:257 !\n PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N \n REF:257 !\n PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N \n REF:257 !\n PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N \n REF:257 !\n\n\n PHASE M23C6 % 3 20 3 6 !\n CONSTITUENT M23C6 :CR%,FE%,MN : CR%,FE%,MN : C : !\n\n PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N \n REF:97 !\n PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.130435*GCRM23C6#\n +.869565*GFEM23C6#; 6.00000E+03 N REF:98 !\n PARAMETER G(M23C6,MN:CR:C;0) 2.98150E+02 +.869565*GMNM23C6#\n +.130435*GCRM23C6#; 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.869565*GCRM23C6#\n +.130435*GFEM23C6#; 6.00000E+03 N REF:98 !\n PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N \n REF:98 !\n PARAMETER G(M23C6,MN:FE:C;0) 2.98150E+02 +.869565*GMNM23C6#\n +.130435*GFEM23C6#; 6.00000E+03 N REF:263 !\n PARAMETER G(M23C6,CR:MN:C;0) 2.98150E+02 +.869565*GCRM23C6#\n +.130435*GMNM23C6#; 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,FE:MN:C;0) 2.98150E+02 +.869565*GFEM23C6#\n +.130435*GMNM23C6#; 6.00000E+03 N REF:263 !\n PARAMETER G(M23C6,MN:MN:C;0) 2.98150E+02 +GMNM23C6#; 6.00000E+03 N \n REF:263 !\n PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(M23C6,CR,MN:CR:C;0) 2.98150E+02 -173680+160*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,CR,MN:CR:C;1) 2.98150E+02 -286614; 6.00000E+03 N \n REF:324 !\n PARAMETER G(M23C6,FE,MN:CR,FE:C;0) 2.98150E+02 -100000; 6.00000E+03 \n N REF:324 !\n PARAMETER G(M23C6,FE,MN:CR,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 \n N REF:324 !\n PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF:314 !\n PARAMETER G(M23C6,CR,MN:FE:C;0) 2.98150E+02 -173680+160*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,CR,MN:FE:C;1) 2.98150E+02 -286614; 6.00000E+03 N \n REF:324 !\n PARAMETER G(M23C6,FE,MN:FE,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 \n N REF:263 !\n PARAMETER G(M23C6,CR,FE:MN:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,CR,MN:MN:C;0) 2.98150E+02 -173680+160*T; \n 6.00000E+03 N REF:324 !\n PARAMETER G(M23C6,CR,MN:MN:C;1) 2.98150E+02 -286614; 6.00000E+03 N \n REF:324 !\n\n\n PHASE M3C2 % 2 3 2 !\n CONSTITUENT M3C2 :CR : C : !\n\n PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N \n REF:314 !\n\n\n PHASE M5C2 % 2 5 2 !\n CONSTITUENT M5C2 :FE,MN : C : !\n\n PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852\n -33.7518*T; 6.00000E+03 N REF:314 !\n PARAMETER G(M5C2,MN:C;0) 2.98150E+02 -76849+8.517*T+5*GHSERMN#\n +2*GHSERCC#; 6.00000E+03 N REF:263 !\n PARAMETER G(M5C2,FE,MN:C;0) 2.98150E+02 -42056+3.5*T; 6.00000E+03 N \n REF:314 !\n\n\n PHASE M7C3 % 2 7 3 !\n CONSTITUENT M7C3 :CR%,FE,MN : C : !\n\n PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N \n REF:314 !\n PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000\n -48.2168*T; 6.00000E+03 N REF:314 !\n PARAMETER G(M7C3,MN:C;0) 2.98150E+02 -111765+13.092*T+7*GHSERMN#\n +3*GHSERCC#; 6.00000E+03 N REF:263 !\n PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N \n REF:314 !\n PARAMETER G(M7C3,CR,MN:C;0) 2.98150E+02 +72737-56.4964*T; 6.00000E+03 \n N REF:324 !\n PARAMETER G(M7C3,FE,MN:C;0) 2.98150E+02 -43057+4.0625*T; 6.00000E+03 \n N REF:314 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n 279 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report \n DMA(A)195 \n Rev. August 1990'\n 97 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR'\n 322 'Byeong-Joo Lee, Calphad (1993), revison of Fe-Cr \n Fe-Ni liquid'\n 186 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 \n TRITA 0237 (1984); C-FE'\n 263 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, \n TRITA-MAC 411 (Rev 1989); C-FE-MN'\n 323 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1919-1933; Cr-Mn \n Fe-Cr-Mn'\n 257 'W. Huang, Calphad Vol 13 (1989) pp 243-252, \n TRITA-MAC 388 (rev 1989); FE-MN'\n 277 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report \n DMA(A)195 \n September 1989'\n 314 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni'\n 98 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 \n TRITA 0207 (1986); C-CR-FE'\n 324 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1017-1025; Fe-Cr-Mn-C'\n 103 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n 338 'Caian Qiu, ISIJ International 32 (1992) 1117-1127; C-Cr-Fe-Mo'\n 203 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, \n TRITA-MAC 348, (1987); C-CR-FE-W'\n 122 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, \n TRITA 0409 (1989); CR-FE-N'\n 341 'Caian Qiu, Metall. Trans. A, 24A (1993) 2393-2409; Cr-Fe-Mn-N'\n 342 'K. Frisk, Calphad 17 (1993) 335-349; Cr-Mn-N'\n 325 'Byeong-Joo Lee, KRISS, unpublished research, during 1993-1995'\n ! \n\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/FENI.TDB", "content": "$ Database file written 2014- 1-15\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n \n \n FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6000 N !\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N !\n FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N !\n FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N !\n FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N !\n FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N !\n FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N !\n FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N !\n$ this is 1/RT\n FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N !\n\n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :FE,NI : !\n\n PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 !\n PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T\n -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y\n -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 !\n PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 !\n PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n$ PHASE BCC_A2 %& 2 1 3 !\n$ CONSTITUENT BCC_A2 :FE%,NI : VA% : !\n\n PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 !\n PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 !\n PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 !\n PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 !\n PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS !\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :FE%,NI% : VA% : !\n\n PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 !\n PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 !\n PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 !\n PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !\n PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n BOS 'Invented mobilities and molar volumes'\n ! \n \n" }, { "path": "examples/TQ4lib/Cpp/Matthias/Makefile", "content": "EXE=cpptest\nLIBS=../../..\nCFLAGS=-lstdc++\n#UNCOMMENT THE NEXT LINE IF YOU WANT TO COMPILE OPENCALPHAD IN PARALLEL\n#CFLAGS+=-fopenmp\n\n#==============================================================================#\n\n#Available compilation flags: all, clean\n\n.PHONY : all clean\n\n#Compiles OpenCalphad's OCASI examples as standalone binary executable\n#software.\n\nall:\n\tmake $(EXE)\n\n#Removes all binary files that were created in the compiling step.\n\nclean:\n\trm -f *.o *.mod $(EXE)\n\n#==============================================================================#\n\n$(EXE): $(OBJS)\n\tg++ -o $(EXE) $(CFLAGS) $(EXE).cpp -L$(LIBS) ../../../liboctq-isoc.a -lgfortran -lm\n\tg++ -c -I../.. $(EXE).cpp\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/Makefile-parallel", "content": "OBJS=liboctq.o liboctqisoc.o\nEXE=tqintf\nLIBS=../..\n\n.PHONY : all clean\n\nall:\n\tmake $(EXE)\n\nclean:\n\trm -f *.o *.mod $(EXE)\n\nliboctq.o:\t../liboctq.F90\n\tgfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../liboctq.F90\n\nliboctqisoc.o:\t../isoC/liboctqisoc.F90\n\tgfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../isoC/liboctqisoc.F90\n\n$(EXE): $(OBJS)\n\tgcc -o $(EXE) -fopenmp -lstdc++ $(EXE).cpp liboctqisoc.o liboctq.o ../../liboceq.a -lgfortran -lm\n\tgcc -c -I../.. $(EXE).cpp\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/OC-isoC.h", "content": "#if !defined __OCASI__\n#define __OCASI__\n\n/* Modification history\n160829 Bo Sundman Update\n2015-2016 Matthias Stratmann and Cristophe Sigli Modifications\n2014 Teslos? First version\n\nThis contains the structure of TYPE variables in OC needed for the OC/TQ OCASI interface \n\nNOTE there is also a c_gtp_equilibrium_data structure defined in liboctqisoc.F90 */\n\ntypedef struct {\n int forcenewcalc;\n double tpused[2];\n double results[6];\n} tpfun_parres;\n\ntypedef struct {\n int splink, phlink, status;\n char refstate[16];\n int *endmember;\n double tpref[2];\n double chempot[2];\n double mass, molat;\n} gtp_components;\n\ntypedef struct {\n int lokph, compset, ixphase, lokvares, nextcs;\n} gtp_phasetuple;\n\ntypedef struct {\n int statevarid, norm, unit, phref, argtyp;\n int phase, compset, component, constituent;\n double coeff;\n int oldstv;\n} gtp_state_variable;\n\ntypedef struct {\n int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis;\n char id;\n double *dsites;\n int *nooffr;\n int *splink;\n int *y2x;\n double *dxidyj;\n double fsites;\n} gtp_fraction_set;\n\n//struct gtp_fraction_set;\n\ntypedef struct {\n int nextfree, phlink, status2, phstate,phtupx;\n double abnorm[3];\n char prefix[4], suffix[4];\n int *constat;\n double *yfr;\n double *mmyfr;\n double *sites;\n double *dpqdy;\n double *d2pqdvay;\n //struct gtp_fraction_set disfra;\n double amfu, netcharge, dgm;\n int nprop;\n int *listprop;\n double **gval;\n double ***dgval;\n double **d2gval;\n double curlat[3][3];\n double **cinvy;\n double *cxmol;\n double **cdxmol;\n} gtp_phase_varres;\n\ntypedef struct gtp_condition {\n int noofterms, statev, active, iunit, nid, iref, seqz, experimenttype;\n int symlink1, symlink2;\n int **indices;\n double *condcoeff;\n double *prescribed, current, uncertainity;\n // should this be a struct ??\n gtp_state_variable *statvar;\n struct gtp_condition *next, *previous;\n} gtp_condition;\n\ntypedef struct {\n int status, multiuse, eqno, next;\n char eqname[24], comment[72];\n double tpval[2], rtn;\n double weight;\n double *svfunres;\n gtp_condition *lastcondition, *lastexperiment;\n gtp_components *complist;\n double **compstoi, **invcompstoi;\n gtp_phase_varres *phase_varres;\n tpfun_parres *eq_tpres;\n double *cmuval;\n double xconv;\n double gmindif;\n int maxiter;\n char eqextra[80];\n int sysmatdim, nfixmu, nfixph;\n int *fixmu;\n int *fixph;\n double **savesysmat;\n} gtp_equilibrium_data; \n \n#endif\n\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/crfe/crfe.TDB", "content": "\n$ Database file written 2012- 9- 7\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n \n \n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :CR,FE : !\n\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE% : VA% : !\n\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE% : VA% : !\n\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE : CR : CR,FE : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n ! \n \n" }, { "path": "examples/TQ4lib/Cpp/Matthias/crfe/tqex1.cpp", "content": "#include \"../liboctqcpp.h\"\nusing namespace std;\n\nint main(int argc, char *argv[])\n{\n /* Bugtracker:\n 1) OCASI.tqgetv(\"MUS\", -1, 0, nel, &ceq)[i] returns error:\n Unknown state variable: MUS >: 0.0)\n {\n cout << \"Stable phase: \" << OCASI.tqgpn(i+1, &ceq) << \", amount: \"\n << OCASI.PhaseFractions(&ceq)[i] << \", mole fractions:\" << endl;\n\n for(int j = 0; j < nel; j++)\n {\n cout << OCASI.tqgcom(&ceq)[j] << \": \"\n << OCASI.tqgetv(\"X\", i+1, -1, 4, &ceq)[j];\n if(j < nel-1)\n {\n cout << \", \";\n }\n }\n cout << endl;\n cout << endl;\n }\n\n cout << \"Component, mole fraction, chemical potential (SER) BCC\" << endl;\n for(unsigned int i = 0; i < nel; i++)\n {\n cout << OCASI.tqgcom(&ceq)[i] << \" \"\n << OCASI.tqgetv(\"X\", -1, 0, nel, &ceq)[i] << \" \"\n << OCASI.tqgetv(\"MU\", -1, 0, nel, &ceq)[i] << \" \"\n << OCASI.tqgetv(\"MU\", -1, 0, nel, &ceq)[i] << endl;\n }\n cout << endl;\n\n cout << \"Mole fractions of all components in stable phases:\" << endl;\n cout << \"X(*,*):\";\n for(unsigned int i = 0; i < 4; i++)\n {\n cout << \" \" << OCASI.tqgetv(\"X(*,*)\", -1, -1, 4, &ceq)[i];\n }\n cout << endl;\n cout << \"Mole fraction of a component in all phases, also those unstable:\" << endl;\n cout << \"in phase tuple order!\" << endl;\n cout << \"X(*,CR):\";\n for(unsigned int i = 0; i < 4; i++)\n {\n cout << \" \" << OCASI.tqgetv(\"X(*,*)\", -1, 1, 4, &ceq)[i];\n }\n cout << endl;\n OCASI.tqlr(0, &ceq);\n cout << endl;\n cout << \"Any more calculations? /N/:\" << endl;\n cout << endl;\n cout << \"Auf wiedersehen\" << endl;\n return 0;\n}\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/feni/FENI.TDB", "content": "$ Database file written 2014- 1-15\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n \n \n FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6000 N !\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N !\n FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N !\n FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N !\n FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N !\n FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N !\n FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N !\n FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N !\n$ this is 1/RT\n FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N !\n\n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :FE,NI : !\n\n PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 !\n PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T\n -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y\n -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 !\n PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 !\n PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n$ PHASE BCC_A2 %& 2 1 3 !\n$ CONSTITUENT BCC_A2 :FE%,NI : VA% : !\n\n PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 !\n PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 !\n PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 !\n PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 !\n PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS !\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :FE%,NI% : VA% : !\n\n PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 !\n PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 !\n PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 !\n PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !\n PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n BOS 'Invented mobilities and molar volumes'\n ! \n \n" }, { "path": "examples/TQ4lib/Cpp/Matthias/feni/tqex2.cpp", "content": "#include \"../liboctqcpp.h\"\n#include \nusing namespace std;\n\nint main(int argc, char *argv[])\n{\n /* Bugtracker:\n 1) No equilph1d(phtup,ceq%tpval,xknown,mu,.TRUE.,nend,mugrad,mobilities,ceq)\n function in liboctq.F90\n */\n\n liboctqcpp OCASI;\n void * ceq = 0;\n string filename = \"TQ4lib/Cpp/Matthias/feni/FENI.TDB\";\n\n cout << endl;\n cout << \"Calculation of equilibria and mobility data in Fe-Ni system\" << endl;\n cout << endl;\n\n cout << \"Fictitious ln(mobility data) in the TDB file:\" << endl;\n cout << \"PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !\" << endl;\n cout << \"PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !\" << endl;\n cout << endl;\n\n OCASI.tqini(0,&ceq);\n\n vector Elements;\n Elements.push_back(\"FE\");\n Elements.push_back(\"NI\");\n vector elnames =\n\n OCASI.tqrpfil(\"TQ4lib/Cpp/Matthias/feni/FENI.TDB\", Elements, &ceq);\n\n int nel = OCASI.tqgcom(&ceq).size();\n cout << \"System with \" << nel << \" elements: \";\n for(int i = 0; i < nel; i++)\n {\n cout << OCASI.tqgcom(&ceq)[i];\n if(i < nel-1)\n {\n cout << \", \";\n }\n }\n cout << endl;\n\n\n int phasetuples = OCASI.tqgnp(&ceq);\n\n cout << \"and \" << phasetuples << \" phases: \";\n for(int i = 0; i < phasetuples; i++)\n {\n cout << OCASI.tqgpn(i+1, &ceq);\n if(i < phasetuples-1)\n {\n cout << \", \";\n }\n }\n cout << endl;\n cout << endl;\n cout << \"Give conditions:\" << endl;\n\n cout << \"Temperature: /1000/:\" << endl;\n OCASI.tqsetc(\"T\", 0, 0, 1000, &ceq);\n cout << \"Pressure: /100000/:\" << endl;\n OCASI.tqsetc(\"P\", 0, 0, 100000, &ceq);\n cout << \"Mole fractions for FE: /0.5/:\" << endl;\n OCASI.tqsetc(\"X\", 1, 0, 0.5, &ceq);\n OCASI.tqsetc(\"N\", 0, 0, 1.0, &ceq);\n\n OCASI.tqce(&ceq);\n\n cout << endl;\n cout << \"Successfull calculation\" << endl;\n cout << endl;\n\n\n int equphasetuples = OCASI.tqgnp(&ceq);\n cout << \"Amount of \" << equphasetuples << \" phases: \";\n for(int i = 0; i < equphasetuples; i++)\n {\n cout << OCASI.PhaseFractions(&ceq)[i];\n if(i < equphasetuples-1)\n {\n cout << \", \";\n }\n }\n cout << endl;\n\n for(unsigned int i = 0; i < equphasetuples; i++)\n if(OCASI.PhaseFractions(&ceq)[i] > 0.0)\n {\n cout << \"Stable phase: \" << OCASI.tqgpn(i+1, &ceq) << \", amount: \"\n << OCASI.PhaseFractions(&ceq)[i] << \", mole fractions:\" << endl;\n\n for(int j = 0; j < nel; j++)\n {\n cout << OCASI.tqgcom(&ceq)[j] << \": \"\n << OCASI.tqgetv(\"X\", i+1, -1, 4, &ceq)[j];\n if(j < nel-1)\n {\n cout << \", \";\n }\n }\n cout << endl;\n cout << endl;\n }\n\n cout << \"System volume: \" << OCASI.tqgetv(\"V\", 0, 0, &ceq) << endl;\n cout << endl;\n\n cout << \"Component, mole fraction, chemical potentials, lnac = mu/RT\"\n << endl;\n for(int i = 0; i < elnames.size(); i++)\n {\n cout << OCASI.tqgcom(&ceq)[i] << \" \"\n << OCASI.tqgetv(\"X\", i+1, 0, &ceq) << \" \"\n << OCASI.tqgetv(\"MU\", i+1, 0, &ceq) << \" \"\n << OCASI.tqgetv(\"MU\", i+1, 0, &ceq)/8.31451\n /OCASI.tqgetv(\"T\", 0, 0, &ceq) << endl;\n }\n cout << endl;\n\n cout << \"LN(mobility of component in phase) and exp(..):\" << endl;\n for(int i = 0; i < equphasetuples; i++)\n for(int j = 0; j < nel; j++)\n {\n string temp = \"MQ&\" + OCASI.tqgcom(&ceq)[j];\n cout << temp << \"(\" << OCASI.tqgpn(i+1, &ceq) << \") = \"\n << OCASI.tqgetv(temp, i+1, j+1, &ceq) << \" \"\n << exp(OCASI.tqgetv(temp, i+1, j+1, &ceq)) << endl;\n }\n\n cout << endl;\n cout << \"Calculating Darken stability matrix, dG_A/dN_B for phase 2:\" << endl;\n\n /*Calculating Darken stability matrix, dG_A/dN_B for phase 2:\n Calculation required 6 its\n\n Chemical potential derivative matrix, dG_I/dN_J for 2 endmembers\n 1 2\n 1 1.2100E+04 -1.2100E+04\n 2 -1.2100E+04 1.2100E+04\n\n LN(mobility) values for 2 components\n 1 -3.4728E+01 -3.4988E+01*/\n\n cout << endl;\n cout << \"Any more calculations? /N/:\" << endl;\n cout << endl;\n cout << \"Auf wiedersehen\" << endl;\n\n return 0;\n}\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/liboctqcpp.cpp", "content": "#include \"liboctqcpp.h\"\nusing namespace std;\n\n#define MAXEL 24;\n#define MAXPH 20\n\nvoid liboctqcpp::tqini(int n, void * ceq)\n{\n //==============\n c_tqini(n, ceq);\n //==============\n};\n\nvector liboctqcpp::tqrfil(string fname, void * ceq)\n{\n char *filename = strcpy((char*)malloc(fname.length()+1),fname.c_str());\n //======================\n c_tqrfil(filename, ceq);\n //======================\n\n ntup = c_ntup;\n nel = c_nel;\n cnam.resize(nel);\n for(int i = 0; i < nel; i++)\n cnam[i] = c_cnam[i];\n free(filename);\n\n //=================\n return tqgcom(ceq);\n //=================\n};\n\nvector liboctqcpp::tqrpfil(string fname, vector elnames, void * ceq)\n{\n char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str());\n char *selel[elnames.size()];\n char *tempchar;\n for(int i = 0; i < elnames.size(); i++)\n {\n tempchar\n = strcpy((char*)malloc(elnames[i].length()+1), elnames[i].c_str());\n selel[i] = tempchar;\n }\n //==============================================\n c_tqrpfil(filename, elnames.size(), selel, ceq);\n //==============================================\n\n ntup = c_ntup;\n nel = c_nel;\n cnam.resize(nel);\n for(int i = 0; i < nel; i++)\n cnam[i] = c_cnam[i];\n free(filename);\n free(tempchar);\n //free(selel);\n vector asdf = tqgcom(ceq);\n //=================\n return tqgcom(ceq);\n //=================\n};\n\nint liboctqcpp::tqgcn(void * ceq)\n{\n int n = MAXEL;\n char elnames[24];\n //=========================\n c_tqgcom(&n, elnames, ceq);\n //=========================\n return n;\n};\n\nvector liboctqcpp::tqgcom(void * ceq)\n{\n int n = MAXEL;\n char elnames[24];\n vector result;\n //=========================\n c_tqgcom(&n, elnames, ceq);\n //=========================\n result.resize(n);\n for(int i = 0; i < n; i++)\n {\n char temp[3];\n for(int j = 0; j < 2; j++)\n {\n temp[j] = elnames[j+i*2];\n if(temp[j] == ' ')\n temp[j] = 0;\n }\n temp[2] = 0;\n string temp2(temp);\n result[i] = temp2;\n }\n return result;\n};\n\nint liboctqcpp::tqgnp(void * ceq)\n{\n int n;\n //===============\n c_tqgnp(&n, ceq);\n //===============\n return n;\n};\n\nstring liboctqcpp::tqgpn(int i, void * ceq)\n{\n char phname[24];\n string result;\n //======================\n c_tqgpn(i, phname, ceq);\n //======================\n result = phname;\n return result;\n};\n\nint liboctqcpp::tqgpi(string pname, void * ceq)\n{\n char *phasename = strcpy((char*)malloc(pname.length()+1), pname.c_str());\n int i;\n //=========================\n c_tqgpi(&i, phasename, ceq);\n //=========================\n free(phasename);\n return i;\n};\n\nstring liboctqcpp::tqgpcn2(int phidx, int i, void * ceq)\n{\n //---------------------------\n return tqgpcn(phidx, i, ceq);\n //---------------------------\n};\n\nstring liboctqcpp::tqgpcn(int phidx, int i, void * ceq)\n{\n char constituentname[24];\n string result;\n //=======================================\n c_tqgpcn(phidx, i, constituentname, ceq); //TODO: c_tqgpcn is not implemented in liboctq.F90!!\n //=======================================\n result = constituentname;\n return result;\n};\n\nint liboctqcpp::tqgpci(int phidx, string cname, void * ceq)\n{\n int c;\n char *constituent = strcpy((char*)malloc(cname.length()+1), cname.c_str());\n //====================================\n c_tqgpci(phidx, &c, constituent, ceq); //TODO: c_tqgpci is not implemented in liboctq.F90!!\n //====================================\n free(constituent);\n return c;\n};\n\nvector liboctqcpp::tqgpcs(int phidx, int con, double& mass, void * ceq)\n{\n vector result;\n double * stoi;\n c_tqgpcs(phidx, con, stoi, &mass, ceq);\n free(stoi);\n return result;\n};\n\nvoid liboctqcpp::tqgccf(int comp, void * ceq)\n{\n int nel;\n char * elnames;\n double stoi;\n double mass;\n //===============================================\n c_tqgccf(comp, &nel, elnames, &stoi, &mass, ceq); //TODO: c_tqgccf is not implemented in liboctq.F90\n //===============================================\n free(elnames);\n};\n\nint liboctqcpp::tqgnpc(int phidx, void * ceq)\n{\n int nc;\n //========================\n c_tqgnpc(phidx, &nc, ceq); //TODO: c_tqgnpc is not implemented in liboctq.F90\n //========================\n return nc;\n};\n\nvoid liboctqcpp::tqphtupsts(int phidx, int newstatus, double val, void * ceq)\n{\n // phidx < 0 means \"all phases\"\n // newstatus -4 hidden\n // newstatus -3 suspended\n // newstatus -2 dormant\n // newstatus -1 TODO: entered?\n // newstatus 0 TODO: entered?\n // newstatus 1 entered\n // newstatus 2 fix\n\n //=====================================\n c_tqphtupsts(phidx, newstatus, val, ceq);\n //=====================================\n};\n\nvoid liboctqcpp::tqsetc(string par, int n1, int n2, double val, void * ceq)\n{\n int cnum;\n char *name = strcpy((char*)malloc(par.length()+1), par.c_str());\n //======================================\n c_tqsetc(name, n1, n2, val, &cnum, ceq);\n //======================================\n free(name);\n};\n\nvoid liboctqcpp::tqce(void * ceq)\n{\n char target[60] = \" \";\n double val;\n //==============================\n c_tqce(target, 0, 0, &val, ceq);\n //==============================\n};\n\ndouble liboctqcpp::tqgetv(string par, int n1, int n2, void * ceq)\n{\n char *name = strcpy((char*)malloc(par.length()+1), par.c_str());\n double val;\n int cnum;\n //=======================================\n c_tqgetv(name, n1, n2, &cnum, &val, ceq);\n //=======================================\n free(name);\n return val;\n};\n\nvector liboctqcpp::tqgetv(string par, int n1, int n2, int n3, void * ceq)\n{\n vector results(n3);\n char *name = strcpy((char*)malloc(par.length()+1), par.c_str());\n double val[n3];\n //====================================\n c_tqgetv(name, n1, n2, &n3, val, ceq);\n //====================================\n for(int i = 0; i < n3; i++)\n results[i] = val[i];\n free(name);\n return results;\n};\n\nvector liboctqcpp::tqgphc1(int phIdx, vector& ncons,\n vector& sites, double& moles,\n void * ceq)\n{\n int nlat;\n int nlatc[MAXPH];//TODO: MAXPH is misleading\n int conlista[MAXPH];\n double yfr[MAXPH];\n double site[MAXPH];\n double extra[MAXPH];\n //==============================================================\n c_tqgphc1(phIdx, &nlat, nlatc, conlista, yfr, site, extra, ceq);\n //==============================================================\n ncons.resize(nlat);\n sites.resize(nlat);\n int nc = 0;\n for(unsigned int i = 0; i < ncons.size(); i++)\n {\n ncons[i] = nlatc[i];\n sites[i] = site[i];\n nc += nlatc[i];\n }\n vector y(nc, 0);\n for(unsigned int i = 0; i < nc; i++)\n y[i] = yfr[i];\n moles = extra[0];\n return y;\n};\n\nvoid liboctqcpp::tqsphc1(int phidx, vector y, void * ceq)\n{\n double extra[MAXPH];\n double yfr[y.size()];\n for(int i = 0; i < y.size(); i++)\n yfr[i] = y[i];\n //================================\n c_tqsphc1(phidx, yfr, extra, ceq);\n //================================\n};\n\ndouble liboctqcpp::tqcph1(int phidx, vector& G_TP,\n vector& G_Y, vector& G_YT,\n vector& G_YP, vector& G_YY,\n void * ceq)\n{\n int n2 = 2;\n int n3;\n double gtp[6];\n double dgdy[100];\n double d2gdydt[100];\n double d2gdydp[100];\n double d2gdy2[100];\n //=================================================================\n c_tqcph1(phidx, n2, &n3, gtp, dgdy, d2gdydt, d2gdydp, d2gdy2, ceq);\n //=================================================================\n double G = gtp[0];\n G_TP.resize(5);\n G_Y.resize(n3);\n G_YT.resize(n3);\n G_YP.resize(n3);\n int yy = n3*(n3+1.)/2.;\n G_YY.resize(yy);\n for(int i = 0; i < 5; i++)\n G_TP[i] = gtp[i+1];\n //GibbsEnergy_TP[0] G.T\n //GibbsEnergy_TP[1] G.P\n //GibbsEnergy_TP[2] G.T.T\n //GibbsEnergy_TP[3] G.T.P\n //GibbsEnergy_TP[4] G.P.P\n\n for(int i = 0; i < n3; i++)\n {\n G_Y[i] = dgdy[i];\n //GibbsEnergy_Y[0] G.Y0\n //GibbsEnergy_Y[1] G.Y1\n\n G_YT[i] = d2gdydt[i];\n //GibbsEnergy_YT[0] G.Y0.T\n //GibbsEnergy_YT[1] G.Y1.T\n\n G_YP[i] = d2gdydp[i];\n //GibbsEnergy_YP[0] G.Y0.P\n //GibbsEnergy_YP[1] G.Y1.P\n }\n\n for(int i = 0; i < yy; i++)\n G_YY[i] = d2gdy2[i];\n //GibbsEnergy_YY[0] G.Y0.Y0\n //GibbsEnergy_YY[0] G.Y0.Y1\n //GibbsEnergy_YY[0] G.Y1.Y1\n //GibbsEnergy_YY[0] G.Y1.Y2\n //GibbsEnergy_YY[0] G.Y2.Y2\n //GibbsEnergy_YY[0] G.Y2.Y3\n\n return G;\n};\n\nint liboctqcpp::tqcph2(int phidx, int type, void * ceq)\n{\n int lokres; //ceq%phase_varres(lokres)% with all results\n int n3;\n //=======================================\n c_tqcph2(phidx, type, &n3, &lokres, ceq);\n //=======================================\n return lokres;\n};\n\nvoid liboctqcpp::tqdceq(string name)\n{\n char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str());\n //================\n c_tqdceq(ceqname);\n //================\n free(ceqname);\n};\n\nint liboctqcpp::tqcceq(string name, void * newceq, void * ceq)\n{\n char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str());\n int n1;\n //==================================\n c_tqcceq(ceqname, &n1, newceq, ceq);\n //==================================\n return n1;\n};\n\nvoid liboctqcpp::tqselceq(string name, void * ceq)\n{\n char *ceqname = strcpy((char*)malloc(name.length()+1), name.c_str());\n //=======================\n c_tqselceq(ceqname, ceq);\n //=======================\n free(ceqname);\n};\n\nvoid liboctqcpp::reset_conditions(string condition, double newval, void * ceq)\n{\n char *cond = strcpy((char*)malloc(condition.length()+1), condition.c_str());\n //============================\n c_reset_conditions(cond, ceq); //TODO: send newval to liboctq.F90\n //============================\n free(cond);\n};\n\nvoid liboctqcpp::Change_Status_Phase(string phname, int newstatus, double val, void * ceq)\n{\n //--------------------------------------------------\n tqphtupsts(tqgpi(phname, ceq), newstatus, val, ceq);\n //--------------------------------------------------\n};\n\nvoid liboctqcpp::tqlr(int lut, void * ceq)\n{\n //===============\n c_tqlr(lut, ceq);\n //===============\n};\n\nvoid liboctqcpp::tqlc(int lut, void * ceq)\n{\n //===============\n c_tqlc(lut, ceq);\n //===============\n};\n\nvector liboctqcpp::PhaseFractions(void *ceq)\n{\n vector results =\n //----------------------------\n tqgetv(\"NP\", -1, 0, tqgnp(ceq), ceq);\n //----------------------------\n return results;\n};\n\nvector liboctqcpp::ConstituentFractions(int phase, void *ceq)\n{\n vector results =\n //-------------------------------\n tqgetv(\"X\", phase, -1, tqgcn(ceq), ceq);\n //-------------------------------\n return results;\n};\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/liboctqcpp.h", "content": "#include \n#include \n#include \n#include \n#include \n#include \n\nextern\"C\" int c_nel;\nextern\"C\" int c_maxc;\nextern\"C\" int c_maxp;\nextern\"C\" char * c_cnam[24];\nextern\"C\" char * cnames[25];\nextern\"C\" int c_ntup;\nextern\"C\" int c_noofcs(int);\nextern\"C\" int c_ierr(void);\nextern\"C\"\n{\n void c_tqini(int, void *);\n void c_tqrfil(char *, void *);\n void c_tqrpfil(char *, int, char **, void *);\n void c_tqgcom(int *, char *, void *);\n void c_tqgnp(int *, void *);\n void c_tqgpn(int, char *, void *);\n void c_tqgpi(int *, char *, void *);\n void c_tqgpcn2(int, int, char *, void *);\n void c_tqgpcn(int, int, char *, void *);\n void c_tqgpci(int, int *, char *, void *);\n void c_tqgpcs(int, int, double *, double *, void *);\n void c_tqgccf(int, int *, char *, double *, double *, void *);\n void c_tqgnpc(int, int *, void *);\n void c_tqphtupsts(int, int, double, void *);\n void c_tqsetc(char *, int, int, double, int *, void *);\n void c_tqce(char *, int, int, double *, void *);\n void c_tqgetv(char *, int, int, int *, double *, void *);\n void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, void *);\n void c_tqsphc1(int, double *, double *, void *);\n void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *);\n void c_tqcph2(int, int, int *, int *, void *);\n void c_tqdceq(char *);\n void c_tqcceq(char *, int *, void *, void *);\n void c_tqselceq(char *, void *);\n void c_reset_conditions(char *, void *);\n void c_Change_Status_Phase(char *, int, double, void *);\n void c_tqlr(int, void *);\n void c_tqlc(int, void *);\n}\n\nclass liboctqcpp\n{\n public:\n void * ceq2;\n int ntup;\n int nel;\n std::vector cnames;\n std::vector cnam;\n void tqini(int n, void * ceq);\n std::vector tqrfil(std::string fname, void * ceq);\n std::vector tqrpfil(std::string fname, std::vector elnames, void * ceq);\n int tqgcn(void * ceq);\n std::vector tqgcom(void * ceq);\n int tqgnp(void * ceq);\n std::string tqgpn(int i, void * ceq);\n int tqgpi(std::string pname, void * ceq);\n std::string tqgpcn(int phidx, int i, void * ceq);\n std::string tqgpcn2(int phidx, int i, void * ceq);\n int tqgpci(int phidx, std::string cname, void * ceq);\n void tqgpcs(int, int, double *, double *, void *);\n std::vector tqgpcs(int phidx, int con, double& mass, void * ceq);\n void tqgccf(int comp, void * ceq);\n int tqgnpc(int phidx, void * ceq);\n void tqphtupsts(int, int, double, void *);\n void tqsetc(std::string, int, int, double, void *);\n void tqce(void *);\n double tqgetv(std::string, int, int, void *);\n std::vector tqgetv(std::string, int, int, int, void *);\n std::vector tqgphc1(int phIdx, std::vector& ncons, std::vector& sites, double& moles, void * ceq);\n void tqsphc1(int phidx, std::vector y, void * ceq);\n double tqcph1(int phidx, std::vector& G_TP,\n std::vector& G_Y, std::vector& G_YT,\n std::vector& G_YP, std::vector& G_YY,\n void * ceq);\n int tqcph2(int phidx, int type, void * ceq);\n void tqdceq(std::string);\n int tqcceq(std::string name, void * newceq, void * ceq);\n void tqselceq(std::string, void *);\n void reset_conditions(std::string condition, double newval, void * ceq);\n void Change_Status_Phase(std::string phname, int newstatus, double val, void * ceq);\n void tqlr(int, void *);\n void tqlc(int, void *);\n std::vector PhaseFractions(void *);\n std::vector ConstituentFractions(int phase, void *ceq);\n};\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/liboctqisoc.F90", "content": "module cstr\n\n contains\n\n function c_to_f_string(s) result(str)\n use iso_c_binding\n implicit none\n character(kind=c_char,len=1), intent(in) :: s(*)\n character(len=:), allocatable :: str\n integer i, nchars\n i = 1\n do\n if (s(i) == c_null_char) exit\n i = i + 1\n end do\n nchars = i - 1\n allocate(character(len=nchars) :: str)\n str = transfer(s(1:nchars), str)\n end function c_to_f_string\n\n subroutine f_to_c_string(fstring, cstr)\n use iso_c_binding\n implicit none\n character(len=24) :: fstring\n character(kind=c_char, len=1), intent(out) :: cstr(*)\n integer i\n do i = 1, len(fstring)\n cstr(i) = fstring(i:i)\n cstr(i+1) = c_null_char\n end do\n end subroutine f_to_c_string\n\nend module cstr\n\nmodule liboctqisoc\n use iso_c_binding\n use cstr\n use liboctq\n implicit none\n integer(c_int), bind(c) :: c_nel\n integer(c_int), bind(c) :: c_maxc=20\n integer(c_int), bind(c) :: c_maxp=100\n type(c_ptr), bind(c), dimension(maxc) :: c_cnam\n character(len=25), dimension(maxc), target :: cnames\n integer(c_int), bind(c) :: c_ntup\n\n TYPE, bind(c) :: c_gtp_equilibrium_data\n integer(c_int) :: status,multiuse,eqno,next\n character(c_char) :: eqname*24\n character(c_char) :: comment*72\n real(c_double) :: tpval(2)\n real(c_double) :: rtn\n real(c_double) :: weight\n real(c_double) :: svfunres\n TYPE(c_ptr) :: lastcondition\n TYPE(c_ptr) :: lastexperiment\n TYPE(c_ptr) :: complist\n real(c_double) :: compstoi\n real(c_double) :: invcompstoi\n TYPE(c_ptr) :: phase_varres\n TYPE(c_ptr) :: eq_tpres\n real(c_double) :: cmuval\n real(c_double) :: xconv\n real(c_double) :: gmindif=-5.0D-2\n integer(c_int) :: maxiter\n character(c_char) :: eqextra*80\n integer(c_int) :: sysmatdim=0\n integer(c_int) :: nfixmu=0\n integer(c_int) :: nfixph=0\n integer(c_int) :: fixmu\n integer(c_int) :: fixph\n real(c_double) :: savesysmat\n END TYPE c_gtp_equilibrium_data\n\n contains\n\n integer function c_noofcs(iph) bind(c, name='c_noofcs')\n integer(c_int), value :: iph\n c_noofcs = noofcs(iph)\n return\n end function c_noofcs\n\n integer function c_ierr() bind(c, name='c_ierr')\n c_ierr=gx%bmperr\n return\n end function c_ierr\n\n subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini')\n integer(c_int), intent(in) :: n\n type(c_ptr), intent(out) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n !=================\n call tqini(n, ceq)\n !=================\n c_ceq = c_loc(ceq)\n end subroutine c_tqini\n\n subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil')\n character(kind=c_char,len=1), intent(in) :: filename(*)\n character(len=:), allocatable :: fstring\n type(gtp_equilibrium_data), pointer :: ceq\n type(c_ptr), intent(inout) :: c_ceq\n integer :: i\n integer :: j\n integer :: l\n character(kind=c_char, len=1),dimension(24), target :: f_pointers\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(filename)\n !========================\n call tqrfil(fstring, ceq)\n !========================\n c_ntup = ntup\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(cnam(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n end do\n c_ceq = c_loc(ceq)\n end subroutine c_tqrfil\n\n subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil')\n character(kind=c_char), intent(in) :: filename\n integer(c_int), intent(in), value :: nel\n type(c_ptr), intent(in), dimension(nel), target :: c_selel\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=:), allocatable :: fstring\n character, pointer :: selel(:)\n integer :: i\n character elem(nel)*2\n fstring = c_to_f_string(filename)\n call c_f_pointer(c_ceq, ceq)\n do i = 1, nel\n call c_f_pointer(c_selel(i), selel, [3])\n elem(i) = c_to_f_string(selel)\n end do\n !====================================\n call tqrpfil(fstring, nel, elem, ceq)\n !====================================\n c_ntup = ntup\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(cnam(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n end do\n c_ceq = c_loc(ceq)\n end subroutine c_tqrpfil\n\n subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom')\n integer(c_int), intent(inout) :: n\n type(c_ptr), intent(inout) :: c_ceq\n character(kind=c_char, len=1), intent(out) :: components(maxel*3)\n integer, target :: nc\n character(len=24) :: fcomponents(maxel)\n type(gtp_equilibrium_data), pointer :: ceq\n integer :: i,j,l\n call c_f_pointer(c_ceq, ceq)\n !================================\n call tqgcom(nc, fcomponents, ceq)\n !================================\n l = 1\n do i = 1, nc\n do j = 1, 2\n components(l)(1:1) = fcomponents(i)(j:j)\n l=l+1\n end do\n end do\n ! null termination\n components(i*2-1) = c_null_char\n c_ceq = c_loc(ceq)\n n = nc\n end subroutine c_tqgcom\n\n subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp')\n integer(c_int), intent(inout) :: n\n type(c_ptr), intent(inout) :: c_ceq\n integer, target :: nc\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=================\n call tqgnp(n, ceq)\n !=================\n c_ceq = c_loc(ceq)\n\n end subroutine c_tqgnp\n\n subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn')\n integer(c_int), intent(in), value :: n\n character(kind=c_char, len=1), intent(inout) :: phasename(36)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n !==========================\n call tqgpn(n, fstring, ceq)\n !==========================\n do i=1,len(trim(fstring))\n phasename(i)(1:1) = fstring(i:i)\n phasename(i+1)(1:1) = c_null_char\n end do\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpn\n\n subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi')\n integer(c_int), intent(out) :: n\n character(c_char), intent(in) :: phasename(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(phasename)\n !==========================\n call tqgpi(n, fstring, ceq)\n !==========================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpi\n\n subroutine c_tqgpcn2(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn2')\n integer(c_int), intent(in), value :: n\n integer(c_int), intent(in), value :: c\n character(c_char), intent(out) :: constituentname(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character fstring*(24)\n double precision mass\n call c_f_pointer(c_ceq, ceq)\n !==================================================\n call get_constituent_name(n,c,fstring,mass)\n !==================================================\n call f_to_c_string(fstring, constituentname)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpcn2\n\n subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn')\n integer(c_int), intent(in), value :: n\n integer(c_int), intent(in), value :: c\n character(c_char), intent(out) :: constituentname(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character fstring*(24)\n double precision mass\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n !==========================================\n call get_constituent_name(n,c,fstring,mass)\n !==========================================\n !call f_to_c_string(fstring, constituentname)\n do i=1,len(trim(fstring))\n constituentname(i)(1:1) = fstring(i:i)\n constituentname(i+1)(1:1) = c_null_char\n end do\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpcn\n\n subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci')\n integer(c_int), intent(in) :: n\n integer(c_int), intent(out) :: c\n character(c_char), intent(in) :: constituentname(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n fstring = c_to_f_string(constituentname)\n call c_f_pointer(c_ceq, ceq)\n !==============================\n call tqgpci(n, c, fstring, ceq)\n !==============================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpci\n\n subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs')\n integer(c_int), intent(in) :: n\n integer(c_int), intent(in) :: c\n real(c_double), intent(out) :: stoi(*)\n real(c_double), intent(out) :: mass\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=============================\n call tqgpcs(n,c,stoi,mass,ceq)\n !=============================\n c_ceq=c_loc(ceq)\n end subroutine c_tqgpcs\n\n subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) bind(c, name='c_tqgccf')\n integer(c_int), intent(in) :: n1\n integer(c_int), intent(out) :: n2\n character(c_char), intent(out) :: elnames(2)\n real(c_double), intent(out) :: stoi(*)\n real(c_double), intent(out) :: mass\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=========================================\n call tqgccf(n1,n2,elnames,stoi, mass, ceq)\n !=========================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgccf\n\n subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc')\n integer(c_int), intent(in) :: n\n integer(c_int), intent(out) :: c\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq,ceq)\n !===================\n call tqgnpc(n,c,ceq)\n !===================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgnpc\n\n subroutine c_tqphtupsts(phtupx,newstat,val,c_ceq) &\n bind(c, name='c_tqphtupsts')\n integer(c_int), intent(in), value :: phtupx\n integer(c_int), intent(in), value :: newstat\n real(c_double), intent(in), value :: val\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq,ceq)\n !======================================\n call tqphtupsts(phtupx,newstat,val,ceq)\n !======================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqphtupsts\n\n subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) &\n bind(c, name='c_tqsetc')\n integer(c_int), intent(in),value :: n1\n integer(c_int), intent(in),value :: n2 !\n integer(c_int), intent(out) :: cnum\n character(c_char), intent(in) :: statvar\n real(c_double), intent(in), value :: mvalue\n type(gtp_equilibrium_data), pointer :: ceq\n type(c_ptr), intent(inout) :: c_ceq\n call c_f_pointer(c_ceq, ceq)\n !==============================================\n call tqsetc(statvar, n1, n2, mvalue, cnum, ceq)\n !==============================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqsetc\n\n subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce')\n integer(c_int), intent(in),value :: n1\n integer(c_int), intent(in),value :: n2\n type(c_ptr), intent(inout) :: c_ceq\n character(c_char), intent(inout) :: mtarget\n real(c_double), intent(inout) :: mvalue\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq,ceq)\n fstring = c_to_f_string(mtarget)\n !==================================\n call tqce(fstring,n1,n2,mvalue,ceq)\n !==================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqce\n\n subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv')\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(in), value :: n2\n integer(c_int), intent(inout) :: n3\n character(c_char), intent(in) :: statvar\n real(c_double), intent(inout) :: values(*)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n !integer :: n\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(statvar)\n !========================================\n call tqgetv(fstring, n1,n2,n3,values,ceq)\n !========================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgetv\n\n subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq) &\n bind(c,name='c_tqgphc1')\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(out) :: nsub\n integer(c_int), intent(out) :: cinsub(*)\n integer(c_int), intent(in) :: spix(*)\n real(c_double), intent(in) :: sites(*)\n real(c_double), intent(in) :: yfrac(*)\n real(c_double), intent(in) :: extra(*)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !======================================================\n call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n !======================================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqgphc1\n\n subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1')\n integer(c_int), intent(in), value :: n1\n real(c_double), intent(in) ::yfra(*)\n real(c_double), intent(out) :: extra(*)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=====================================================================\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset, &\n yfra,extra,ceq)\n !=====================================================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqsphc1\n\n subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) &\n bind(c,name='c_tqcph1')\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(in), value :: n2\n integer(c_int), intent(out) :: n3\n real(c_double), intent(out) :: gtp(6)\n real(c_double), intent(out) :: dgdy(*)\n real(c_double), intent(out) :: d2gdydt(*)\n real(c_double), intent(out) :: d2gdydp(*)\n real(c_double), intent(out) :: d2gdy2(*)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !========================================================\n call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n !========================================================\n c_ceq = c_loc(ceq)\n end subroutine c_tqcph1\n\n subroutine c_tqcph2(n1,n2,n3,n4,c_ceq) bind(c,name='c_tqcph2')\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(in), value :: n2\n integer(c_int), intent(out) :: n3\n integer(c_int), intent(out) :: n4\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !===========================\n call tqcph2(n1,n2,n3,n4,ceq)\n !===========================\n c_ceq = c_loc(ceq)\n end subroutine c_tqcph2\n\n subroutine c_tqdceq(ceqname) bind(c,name='c_tqdceq')\n character(c_char), intent(in) :: ceqname(24)\n character(len=24) :: fstring\n fstring = c_to_f_string(ceqname)\n !================\n call tqdceq(fstring)\n !================\n end subroutine c_tqdceq\n\n subroutine c_tqcceq(ceqname,n1,c_newceq,c_ceq) bind(c,name='c_tqcceq')\n character(c_char), intent(in) :: ceqname(24)\n integer(c_int), intent(out) :: n1\n type(c_ptr), intent(inout) :: c_newceq\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n type(gtp_equilibrium_data), pointer :: newceq\n character(len=24) :: fstring\n call c_f_pointer(c_newceq, newceq)\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(ceqname)\n !=================================\n call tqcceq(fstring,n1,newceq,ceq)\n !=================================\n c_newceq = c_loc(newceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqcceq\n\n subroutine c_tqselceq(ceqname,c_ceq) bind(c,name='c_tqselceq')\n character(c_char), intent(in) :: ceqname(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(ceqname)\n !=========================\n call tqselceq(fstring,ceq)\n !=========================\n c_ceq = c_loc(ceq)\n end subroutine c_tqselceq\n\n subroutine c_reset_conditions(cline,c_ceq) bind(c,name='c_reset_conditions')\n character(c_char), intent(in) :: cline(24)\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(cline)\n !=================================\n call reset_conditions(fstring,ceq)\n !=================================\n c_ceq = c_loc(ceq)\n end subroutine c_reset_conditions\n\n subroutine c_Change_Status_Phase(myname,nystat,myval,c_ceq) &\n bind(c,name='c_Change_Status_Phase')\n character(c_char), intent(in) :: myname(24)\n integer(c_int), intent(in), value :: nystat\n real(c_double), intent(in), value :: myval\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(myname)\n !=================================================\n call Change_Status_Phase(fstring,nystat,myval,ceq)\n !=================================================\n c_ceq = c_loc(ceq)\n end subroutine c_Change_Status_Phase\n\n subroutine c_tqlr(lut,c_ceq) bind(c,name='c_tqlr')\n integer(c_int), intent(in), value :: lut\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=================\n call tqlr(lut,ceq)\n !=================\n c_ceq = c_loc(ceq)\n end subroutine c_tqlr\n\n subroutine c_tqlc(lut,c_ceq) bind(c,name='c_tqlc')\n integer(c_int), intent(in), value :: lut\n type(c_ptr), intent(inout) :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !=================\n call tqlc(lut,ceq)\n !=================\n c_ceq = c_loc(ceq)\n end subroutine c_tqlc\n\nend module liboctqisoc\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/linkmake", "content": "REM 160926 Bo Sundman update\nREM 151210 Mathias original\n\nREM You must have compiled the OC software without parallelization\nREM to obtain liboceq.a and liboceqplus.mod\nREM These files are copied here together with\nREM the F90 source library liboctq.F90 \nREM liboctqisoc.F90 is the OC/TQ library that can be called from C++\n\nREM The copy commands assume we are at \nREM TQ4lib/Cpp/isoC-matthias/ below OC\ncopy ..\\..\\..\\liboceq.a .\ncopy ..\\..\\..\\liboceqplus.mod .\n\nREM This is the Fortran part of TQ library for C++\ncopy ..\\liboctq.F90 .\ngfortran -c liboctq.F90\n\nREM This the C++ TQ library which calls the F90 library\ngfortran -c liboctqisoc.F90\n\nREM This is linking all together\ng++ -o tqcpptest1 -lstdc++ tqcpptest1.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm\n\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/steel1.TDB", "content": "\n$ Database file written 2012- 2-11\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01!\n ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01!\n \n SPECIES C1 C!\n SPECIES C2 C2!\n SPECIES C3 C3!\n SPECIES C4 C4!\n SPECIES C5 C5!\n SPECIES C6 C6!\n SPECIES C7 C7!\n SPECIES V1C1 V1C1!\n \n FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N !\n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2.89600E+03 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); \n 5.00000E+03 N !\n FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N !\n FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T)\n -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y\n -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); \n 3.60000E+03 N !\n FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 2.18300E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 4.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N !\n FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N !\n FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; \n 6.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N !\n FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N !\n FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 4.00000E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 6.00000E+03 N !\n FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N !\n FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T)\n -.126431*T**2; 6.00000E+03 N !\n FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920\n -40*T; 6.00000E+03 N !\n FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T)\n +5003425*T**(-1); 6.00000E+03 N !\n FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T)\n -.0301188*T**2; 6.00000E+03 N !\n FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T)\n -.0578207*T**2; 6.00000E+03 N !\n FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N !\n FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N !\n FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N !\n FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N !\n FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N !\n FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N !\n FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N !\n FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N !\n FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N !\n FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N !\n FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N !\n FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N !\n FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N !\n FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N !\n FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N !\n FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N !\n FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N !\n FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N !\n FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N !\n FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N !\n FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 \n N !\n FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N !\n FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N !\n FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N !\n FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 \n N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 \n N !\n FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N !\n FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N !\n FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N !\n FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N !\n FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N !\n FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 \n N !\n FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N !\n FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 \n N !\n FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N !\n FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N !\n FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N !\n FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N !\n FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N !\n FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N !\n FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N !\n FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N !\n FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P\n +1.2675E-19*T**2*P; 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : !\n\n PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; \n 6.00000E+03 N REF283 !\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T\n +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y\n +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; \n 5.00000E+03 N REF283 !\n PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T\n +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y\n +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N \n REF283 !\n PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T\n -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y\n +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y\n +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 !\n PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 \n N REF101 !\n PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 !\n PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 \n N REF190 !\n PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 !\n PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N \n REF113 !\n PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 \n N REF104 !\n PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N \n REF10 !\n PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 \n N REF10 !\n PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : !\n\n PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC#\n +3*GPCGRA#+416000; 6.00000E+03 N REF101 !\n PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF101 !\n PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE#\n +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 !\n PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#;\n 6.00000E+03 N REF104 !\n PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC#\n +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; \n 6.00000E+03 N REF256 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF322 !\n PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N \n REF102 !\n PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N \n REF102 !\n PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF102 !\n PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF325 !\n PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N \n REF104 !\n PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N \n REF104 !\n PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N \n REF99 !\n PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 !\n PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N \n REF256 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 \n N REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N \n REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N \n REF10 !\n PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; \n 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N \n REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 \n N REF98 !\n PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 \n N REF98 !\n PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N \n REF269 !\n PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N \n REF111 !\n PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N \n REF111 !\n\n\n TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %' 2 1 1 !\n CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE CEMENTITE % 2 3 1 !\n CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : !\n\n PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000\n -9.2888*T; 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N \n REF190 !\n PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000\n -57.4*T; 6.00000E+03 N REF104 !\n PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T\n -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N \n REF316 !\n PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; \n 6.00000E+03 N REF270 !\n\n\n PHASE CHI_A12 % 3 24 10 24 !\n CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : !\n\n PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR#\n +109000+123*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GCRFCC#-26000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR#\n +57300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO#\n +305210-270*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GMOFCC#+100000; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 !\n\n\n PHASE CR2VC2 % 3 2 1 2 !\n CONSTITUENT CR2VC2 :CR : V : C : !\n\n PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR#\n +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 !\n\n\n PHASE CR3SI % 2 3 1 !\n CONSTITUENT CR3SI :CR%,SI : CR,SI% : !\n\n PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR#\n +3*GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR#\n +GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; \n 6.00000E+03 N REF90 !\n\n\n PHASE CR5SI3 % 2 5 3 !\n CONSTITUENT CR5SI3 :CR : SI : !\n\n PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T\n -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N \n REF90 !\n\n\n PHASE CRSI % 2 1 1 !\n CONSTITUENT CRSI :CR : SI : !\n\n PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T\n -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 !\n\n\n PHASE CRSI2 % 2 1 2 !\n CONSTITUENT CRSI2 :CR%,SI : CR,SI% : !\n\n PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T\n -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE DIAMOND_A4 % 1 1.0 !\n CONSTITUENT DIAMOND_A4 :C,SI% : !\n\n PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T\n -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)\n +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 !\n PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N \n REF283 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : !\n\n PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC#\n +GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T)\n -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N \n REF113 !\n PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N \n REF99 !\n PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N \n REF270 !\n PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N \n REF220 !\n PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N \n REF104 !\n PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N \n REF256 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF269 !\n\n\n PHASE FE1SI1 % 2 .5 .5 !\n CONSTITUENT FE1SI1 :FE : SI : !\n\n PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381\n +2.22*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE2SI % 2 .666667 .333333 !\n CONSTITUENT FE2SI :FE : SI : !\n\n PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE#\n +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE4N % 2 4 1 !\n CONSTITUENT FE4N :FE : C,VA : !\n\n PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF319 !\n PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N \n REF319 !\n\n\n PHASE FE5SI3 % 2 .625 .375 !\n CONSTITUENT FE5SI3 :FE : SI : !\n\n PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI#\n -30143+.27*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE8SI2C % 3 8 2 1 !\n CONSTITUENT FE8SI2C :FE : SI : C : !\n\n PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI#\n +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 !\n\n\n PHASE FECN_CHI % 2 5 2 !\n CONSTITUENT FECN_CHI :FE : C : !\n\n PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T\n -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 !\n\n\n PHASE FESI2_H % 2 .3 .7 !\n CONSTITUENT FESI2_H :FE : SI : !\n\n PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649\n -.92*T; 6.00000E+03 N REF98 !\n\n\n PHASE FESI2_L % 2 .333333 .666667 !\n CONSTITUENT FESI2_L :FE : SI : !\n\n PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE#\n +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :C : !\n\n PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 \n N REF283 !\n\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : !\n\n PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504\n +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 !\n PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC#\n +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1)\n +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T)\n -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y\n -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N \n REF283 !\n PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N \n REF316 !\n PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N \n REF207 !\n PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 \n N REF113 !\n PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N \n REF319 !\n PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N \n REF104 !\n PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF117 !\n PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF117 !\n PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n\n\n PHASE KSI_CARBIDE % 2 3 1 !\n CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : !\n\n PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060\n -47.2519*T; 6.00000E+03 N REF316 !\n PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 \n N REF113 !\n\n\n PHASE LAVES_PHASE % 2 2 1 !\n CONSTITUENT LAVES_PHASE :CR,FE : MO : !\n\n PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000\n -6*T; 6.00000E+03 N REF214 !\n PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC#\n +GHSERMO#; 6.00000E+03 N REF10 !\n\n\n PHASE M23C6 % 3 20 3 6 !\n CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : !\n\n PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6#\n +.8695652*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GCRM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6#\n +.1304348*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GFEM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO#\n +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO#\n +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N \n REF323 !\n PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n\n\n PHASE M3C2 % 2 3 2 !\n CONSTITUENT M3C2 :CR,MO,V : C : !\n\n PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; \n 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF324 !\n PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 !\n\n\n PHASE M3SI % 2 3 1 !\n CONSTITUENT M3SI :FE : SI : !\n\n PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T;\n 6.00000E+03 N REF42 !\n\n\n PHASE M5C2 % 2 5 2 !\n CONSTITUENT M5C2 :FE,V : C : !\n\n PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852\n -33.7518*T; 6.00000E+03 N REF322 !\n PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T)\n +1453274*T**(-1); 6.00000E+03 N REF275 !\n\n\n PHASE M6C % 4 2 2 2 1 !\n CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : !\n\n PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR#\n +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 !\n PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO#\n +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO#\n +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO#\n +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 !\n PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N \n REF113 !\n\n\n PHASE M7C3 % 2 7 3 !\n CONSTITUENT M7C3 :CR%,FE,MO,V : C : !\n\n PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000\n -48.2168*T; 6.00000E+03 N REF322 !\n PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415\n +24.24*T; 6.00000E+03 N REF316 !\n PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T)\n +2148691*T**(-1); 6.00000E+03 N REF324 !\n PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N \n REF324 !\n PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N \n REF316 !\n PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N \n REF324 !\n\n\n PHASE MC_ETA % 2 1 1 !\n CONSTITUENT MC_ETA :MO% : C%,VA : !\n\n PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N \n REF104 !\n\n\n PHASE MC_SHP % 2 1 1 !\n CONSTITUENT MC_SHP :MO : C : !\n\n PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; \n 6.00000E+03 N REF104 !\n\n\n PHASE MONI_DELTA % 3 24 20 12 !\n CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+50000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+100000; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF132 !\n\n\n PHASE MU_PHASE % 3 7 2 4 !\n CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC#\n +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO#\n +130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC#\n +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 \n N REF115 !\n\n\n PHASE P_PHASE % 3 24 20 12 !\n CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+111361; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +95573-200*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +362525-332.7*T; 6.00000E+03 N REF132 !\n\n\n PHASE R_PHASE % 3 27 14 12 !\n CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERCR#-20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO#\n +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC#\n +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 !\n PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO#\n -20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T\n +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 !\n\n\n PHASE SIC % 2 1 1 !\n CONSTITUENT SIC :SI : C : !\n\n PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T\n -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); \n 7.00000E+02 Y\n -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2\n +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y\n -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2\n +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC#\n +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC#\n +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC#\n +22*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERMO#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC#\n +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERVV#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321\n -60.967*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N \n REF323 !\n PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N \n REF10 !\n PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N \n REF269 !\n\n\n PHASE V3C2 % 2 3 2 !\n CONSTITUENT V3C2 :FE,V : C : !\n\n PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T)\n +779485*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF256 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR'\n REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 \n TRITA 0237 (1984); C-FE'\n REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C\n -MO'\n REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si'\n REF256 'W. Huang, TRITA-MAC 431 (1990); C-V'\n REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, \n TRITA-MAC 411 (Rev 1989); C-FE-MN'\n REF177 'NPL, unpublished work (1989); C-Mn-Si'\n REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *'\n REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni'\n REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W'\n REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 \n TRITA 0322 (1986); CR-FE-MO'\n REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V'\n REF90 'I Ansara, unpublished work (1991); Cr-Si'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF319 'H. Du and M. Hillert, revision; C-Fe-N'\n REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) \n pp 2211-2223; C-Fe-Si'\n REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo'\n REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 \n TRITA 0321 (1986); C-FE-MO'\n REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W'\n REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 \n (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO'\n REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 \n TRITA 0207 (1986); C-CR-FE'\n REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V'\n REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si'\n REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of \n 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 -N, \n FE-MO-N, CR-N-W, CR-TI-N'\n REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI'\n REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI'\n REF286 'SGTE Substance database, AUG 1989.'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V'\n REF136 'Unassessed parameter, linear combination of unary data. (MU, \n SIGMA)'\n REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO'\n REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni'\n REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V'\n REF58 'B. Sundman, TEST'\n REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, \n TRITA-MAC 348, (1987); C-CR-FE-W'\n REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, \n TRITA 0409 (1989); CR-FE-N'\n REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO'\n REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters \n revised \n 1986 due to new decription of V) TRITA 0201 (1982); FE-V'\n ! \n \n" }, { "path": "examples/TQ4lib/Cpp/Matthias/tqcpptest1.cpp", "content": "#include \"tqintf.h\"\n\nvoid example_1(string fname, double t, double p, double n, vector x);\nvoid example_2(string fname, int phidx, double t, double p, double n,\n vector x, vector y);\nvoid example_3(string fname, int phidx, double t, double p, double n,\n vector y);\n\n\nint main(int argc, char **argv)\n{\n\n /******************* EXAMPLE 1 *******************\n\n Similar to /C/cexample1:\n calls the TQ-Interface for any given thermodynamic\n database file {FILENAME}, sets conditions specified\n in this function {T}, {P}, {N} and {X[*]} and prints\n the output of the thermodynamic equilibrium calculation.\n\n string FILENAME = \"FENI.TDB\"; // Name of the thermodynamic database file (*.TDB, *.tdb)\n int I = 1; // Number of Phase\n double T = 778.0; // Temperature in K\n double P = 1.0e5; // Pressure in Pa\n double N = 1.0; // Number of moles\n vector X; // Concentration array for phase I\n X.push_back(0.6); // manual override of X[0]\n X.push_back(0.4); // manual override of X[1]\n //X.push_back(0.3); // .. and so on .. X[2]\n\n example_1(FILENAME, T, P, N, X); // Call to Example 1\n\n /**************************************************/\n\n\n\n\n /******************* EXAMPLE 2 *******************\n\n Similar to /F90/test4::\n calls the TQ-Interface for any given thermodynamic\n database file {FILENAME}, suspends all phases except\n phase {I}, sets conditions for this single phase as\n specified in this function {T}, {P}, {N} and {X[*]}\n and prints the output of the thermodynamic values\n like the Gibbs energy, the partial derivative of the\n Gibbs energy with respect to every single site fraction\n without doing a thermodyamic equilibrium calculation.*/\n\n string FILENAME = \"steel1.TDB\"; // Name of the thermodynamic database file (*.TDB, *.tdb)\n int I = 2; // Number of Phase\n double T = 8.0e2; // Temperature in K\n double P = 1.0e5; // Pressure in Pa\n double N = 1.0; // Number of moles\n vector X; // Concentration array for the system\n X.push_back(0.3); // manual override of X[0]\n vector Y; // Constituents array for phase I\n Y.push_back(0.197577); // manual override of Y[0]\n Y.push_back(0.802423); // manual override of Y[1]\n Y.push_back(1); // manual override of Y[2]\n\n example_2(FILENAME, I, T, P, N, X, Y); // Call to Example 2\n\n /**************************************************/\n\n\n\n\n\n /******************* EXAMPLE 3 *******************\n\n experimental - work in progress\n\n *************************************************\n \n string FILENAME = \"steel1.TDB\"; // Name of the thermodynamic database file (*.TDB, *.tdb)\n int I = 2; // Number of Phase\n double T = 8.0e2; // Temperature in K\n double P = 1.0e5; // Pressure in Pa\n double N = 1.0; // Number of moles\n vector X; // Concentration array for the system\n X.push_back(0.3); // manual override of X[0]\n\n example_3(FILENAME, I, T, P, N, X); // Call to Example 3\n\n /**************************************************/\n\n return 0;\n}\n\n/********************************** EXAMPLE 1 *********************************/\n\nvoid example_1(string fname, double t, double p, double n, vector x)\n{\n void *ceq = 0; // Pointer to the OpenCalphad storage\n vector > elfract; // Array including all equilibrium compositions\n vector phnames; // Array including all phase names\n vector phfract; // Array including all phase fractions\n\n //-----------------------Initialize and read TDB data-----------------------\n\n Initialize(&ceq); // Initialize OpenCalphad and allocate memory\n ReadDatabase(fname, &ceq); // Define TDB-file and read elements\n ReadPhases(phnames, &ceq); // Read Phases data\n SetTemperature(t, &ceq); // Set Temperature\n SetPressure(p, &ceq); // Set Pressure\n SetMoles(n, &ceq); // Set Number of moles\n SetComposition(x, &ceq); // Set Composition of the system\n\n //---------------------------Calculate Equilibrium--------------------------\n \n CalculateEquilibrium(&ceq); // Calculate a phase equilibrium\n\n //-------------------------------List Results-------------------------------\n\n ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases\n ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase\n\n}\n\n/********************************** EXAMPLE 2 *********************************/\n\nvoid example_2(string fname, int phidx, double t, double p, double n,\n vector x, vector y)\n{\n void *ceq = 0; // Pointer to the OpenCalphad storage\n vector elnames; // Array including selected elements\n elnames.push_back(\"CR\");\n elnames.push_back(\"FE\");\n vector phnames; // Array including all phase names\n vector phfract; // Array including all phase fractions\n vector > elfract; // Array including all equilibrium compositions\n\n //-----------------------Initialize and read TDB data-----------------------\n\n Initialize(&ceq); // Initialize OpenCalphad and allocate memory\n ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements\n ReadPhases(phnames, &ceq); // Read Phases data\n SetTemperature(t, &ceq); // Set Temperature\n SetPressure(p, &ceq); // Set Pressure\n SetMoles(n, &ceq); // Set Number of moles\n SetComposition(x, &ceq); // Set Composition of the system\n\n //---------------------------Calculate Equilibrium--------------------------\n \n CalculateEquilibrium(&ceq); \n\n //-------------------------------List Results-------------------------------\n\n ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases\n ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase\n ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase\n\n //----------------------------Change Parameters-----------------------------\n\n SetConstituents(phidx, y, &ceq); // Set Constituents of the phase\n\n //-------------------------------List Results-------------------------------\n\n GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters\n};\n\n/********************************** EXAMPLE 3 *********************************/\n\nvoid example_3(string fname, int phidx, double t, double p, double n,\n vector x)\n{\n void *ceq = 0; // Pointer to the OpenCalphad storage\n vector elnames; // Array including selected elements\n elnames.push_back(\"CR\");\n elnames.push_back(\"FE\");\n vector phnames; // Array including all phase names\n vector phfract; // Array including all phase fractions\n vector > elfract; // Array including all equilibrium compositions\n\n //-----------------------Initialize and read TDB data-----------------------\n\n Initialize(&ceq); // Initialize OpenCalphad and allocate memory\n ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements\n ReadPhases(phnames, &ceq); // Read Phases data\n SetTemperature(t, &ceq); // Set Temperature\n SetPressure(p, &ceq); // Set Pressure\n SetMoles(n, &ceq); // Set Number of moles\n SetComposition(x, &ceq); // Set Composition of the system\n\n //---------------------------Calculate Equilibrium--------------------------\n \n CalculateEquilibrium(&ceq); \n\n //-------------------------------List Results-------------------------------\n\n ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases\n ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase\n ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase\n\n for(int i = 0; i < 10; i++)\n {\n cout << \"========== \" << i << \" / 10 ==========\" << endl;\n double constit = i/10.0;\n vector y; // Constituents array for phase I\n y.push_back(constit); // manual override of Y[0]\n y.push_back(1-constit); // manual override of Y[1]\n y.push_back(1); // manual override of Y[2]\n\n //--------------------------Change Parameters---------------------------\n\n SetConstituents(phidx, y, &ceq); // Set Constituents of the phase\n\n //-----------------------------List Results-----------------------------\n\n GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters\n }\n};\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/tqex3.cpp", "content": "#include \"liboctqcpp.h\"\nusing namespace std;\n\n/*******************************************************************************\n * The following routine is for testing the interface functionality and produces\n * debug output. However it also demonstrates a usecase and can be used as a\n * starting point for a new implementation of OpenCalphad C++ interface.\n*******************************************************************************/\n\nint main(int argc, char *argv[])\n{\n /* Bugtracker:\n 1) OCASI.tqgetv(\"N\", 0, 0, &ceq) returns 0 even though it was set to 1.0\n 2) OCASI.tqgetv(\"X\", 1, 0, &ceq) returns 0 even though it was set to 0.3\n 3) OCASI.tqgpci(4, \"CR\", &ceq) breaks, when phase 4 is BCC_A2_AUTO#2\n 4) OCASI.tqgccf only returns \"tqgccf not implemented yet\"\n 5) OCASI.tqgnpc only returns \"tqgnpc not implemented yet\"\n 6) OCASI.tqgpci only returns \"tqgpci not implemented yet\"\n 7) OCASI.tqgpcs only returns \"tqgpcs not implemented yet\"\n 8) OCASI.reset_conditions only resets a single condition, even though its\n name implies different. Additionally it uses the console!!! to ask for a\n new value for the condition.\n 9) OCASI.tqcph2 breaks with an error\n 10) OCASI.tqcceq(\"test\", &newceq, &ceq) seems to copy ceq, but not all\n information! OCASI.tqgpn(1, &newceq) seems to have no information, and\n OCASI.tqlc(0,&newceq) crashes.\n 11) tqdceq, tqcceq and tqselceq require a CEQ-name! Where is it set?\n */\n\n liboctqcpp OCASI;\n void * ceq = 0;\n\n //=================\n OCASI.tqini(0,&ceq);\n //=================\n\n cout << \"-> Adress of ceq-Storage: [\" << &ceq << \"]\" << endl;\n\n/* uncomment this for reading full database with all elemens\n\n //=====================================================\n vector elnames\n = OCASI.tqrfil(\"TQ4lib/Cpp/Matthias/FECRMNC.TDB\", ceq);\n //=====================================================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < elnames.size(); i++)\n {\n cout << elnames[i];\n if(i < elnames.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" << endl;*/\n\n vector Elements;\n Elements.push_back(\"CR\");\n Elements.push_back(\"FE\");\n vector elnames2 =\n\n //===============================================================\n OCASI.tqrpfil(\"TQ4lib/Cpp/Matthias/FECRMNC.TDB\", Elements, &ceq);\n //===============================================================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < elnames2.size(); i++)\n {\n cout << elnames2[i];\n if(i < elnames2.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" << endl;\n vector elnames3 =\n\n //=================\n OCASI.tqgcom(&ceq);\n //=================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < elnames3.size(); i++)\n {\n cout << elnames3[i];\n if(i < elnames3.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" << endl;\n int phasetuples =\n\n //================\n OCASI.tqgnp(&ceq);\n //================\n\n cout << \"-> Number of phasetuples: [\" << phasetuples << \"]\" << endl;\n vector PhNames(phasetuples);\n cout << \"-> Phase Data: [\";\n for(int i = 0; i < phasetuples; i++)\n {\n PhNames[i] =\n\n //=====================\n OCASI.tqgpn(i+1, &ceq);\n //=====================\n\n cout << PhNames[i] << \"[\" <<\n\n //==================\n OCASI.tqgpi(PhNames[i], &ceq)\n //==================\n\n << \"]\";\n if(i < phasetuples-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n\n double T = 800;\n double P = 100000;\n double N = 1.0;\n double XCR = 0.3;\n\n //===================================\n OCASI.tqsetc(\"T\", 0, 0, T, &ceq);\n OCASI.tqsetc(\"P\", 0, 0, P, &ceq);\n OCASI.tqsetc(\"N\", 0, 0, N, &ceq);\n OCASI.tqsetc(\"X\", 1, 0, XCR, &ceq);\n //===================================\n\n cout << \"-> Set Temperature to: [\" << T << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> Set Ambient Pressure to: [\" << P << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> Set Moles to: [\" << N << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> Set X(1) to: [\" << XCR << \"]\" << \" [\" << &ceq << \"]\" << endl;\n\n //=========================================\n T = OCASI.tqgetv(\"T\", 0, 0, &ceq);\n P = OCASI.tqgetv(\"P\", 0, 0, &ceq);\n N = OCASI.tqgetv(\"N\", 0, 0, &ceq);\n XCR = OCASI.tqgetv(\"X\", 1, 0, &ceq);\n //=========================================\n\n cout << \"-> Temperature set to: [\" << T << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> Ambient Pressure set to: [\" << P << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> Moles set to: [\" << N << \"]\" << \" [\" << &ceq << \"]\" << endl;\n cout << \"-> X(1) set to: [\" << XCR << \"]\" << \" [\" << &ceq << \"]\" << endl;\n\n //===============\n OCASI.tqce(&ceq);\n //===============\n\n cout << \"-> Calculated Equilibrium [\" << ceq << \"]\" << endl;\n vector EquPhFr =\n\n //===========================\n OCASI.PhaseFractions(&ceq);\n //===========================\n\n phasetuples =\n\n //================\n OCASI.tqgnp(&ceq);\n //================\n\n cout << \"-> Number of phasetuples: [\" << phasetuples << \"]\" << endl;\n PhNames.resize(phasetuples);\n cout << \"-> Phase Data: [\";\n for(int i = 0; i < phasetuples; i++)\n {\n PhNames[i] =\n\n //=====================\n OCASI.tqgpn(i+1, &ceq);\n //=====================\n\n cout << PhNames[i] << \"[\" <<\n\n //===========================\n OCASI.tqgpi(PhNames[i], &ceq)\n //===========================\n\n << \"]\";\n if(i < phasetuples-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n\n cout << \"-> Phase Fractions: [\";\n for (unsigned int i = 0; i < EquPhFr.size(); i++)\n {\n cout << PhNames[i] << \": \" << EquPhFr[i];\n if(i < EquPhFr.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n\n for(unsigned int phase = 0; phase < EquPhFr.size(); phase++)\n if(EquPhFr[phase] > 0.0)\n {\n cout << \"-> Constituent Fractions for \" << PhNames[phase] << \" [\";\n vector ConFr =\n\n //==========================================\n OCASI.ConstituentFractions(phase+1, &ceq);\n //==========================================\n\n for(unsigned int i = 0; i < ConFr.size(); i++)\n {\n cout << elnames3[i] << \": \" << ConFr[i];\n if(i < elnames3.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n }\n\n vector ncons;\n vector sites;\n double moles;\n\n for(int k = 0; k < phasetuples; k++)\n {\n if(k == phasetuples-1)\n {\n cout << \"TQGPCN CANNOT BE CALLED FOR PHASE BCC_A2_AUTO#2, BECAUSE IT WILL BREAK!\" << endl;\n break;\n }\n vector y = OCASI.tqgphc1(k+1, ncons, sites, moles, &ceq);\n\n cout << \"-> Extended Constituent Fractions for \" << PhNames[k]\n << \" [\" << moles << \" moles of atoms/formula unit]\";\n int consti = 0;\n for(unsigned int i = 0; i < ncons.size(); i++)\n {\n cout << \" [\";\n for(int j = 0; j < ncons[i]; j++)\n {\n string cname =\n //==============================\n OCASI.tqgpcn(k+1, consti+1, &ceq);\n //==============================\n\n cout << cname << \"[\" <<\n\n //============================\n //OCASI.tqgpci(k+1, cname, &ceq) // TODO: not yet implemented\n j+1\n //============================\n\n << \"]: \" << y[consti];\n if(j < ncons[i]-1)\n {\n cout << \", \";\n }\n consti += 1;\n }\n cout << \"]_(\" << sites[i] << \")\";\n }\n cout << endl;\n }\n\n cout << \"-> For Phase \" << PhNames[1] << \":\" << endl;\n\n vector Y2;\n Y2.push_back(0.197577);\n Y2.push_back(0.802423);\n Y2.push_back(1);\n\n //=========================\n OCASI.tqsphc1(2, Y2, &ceq);\n //=========================\n\n cout << \"-> Set Constituents to: [\";\n for(int i = 0; i < Y2.size(); i++)\n {\n cout << i << \": \" << Y2[i];\n if(i < Y2.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n vector G_TP;\n vector G_Y;\n vector G_YT;\n vector G_YP;\n vector G_YY;\n\n double G =\n //=================================================\n OCASI.tqcph1(2, G_TP, G_Y, G_YT, G_YP, G_YY, &ceq);\n //=================================================\n\n cout << \"-> Read Gibbs Energy G: [\" << G << \"]\" << endl;\n cout << \"-> Read Gibbs Data G: [\";\n for(int i = 0; i < 5; i++)\n {\n cout << G_TP[i];\n if(i < 4)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data dGdY: [\";\n for(unsigned int i = 0; i < G_Y.size(); i++)\n {\n cout << G_Y[i];\n if(i < G_Y.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdT: [\";\n for(unsigned int i = 0; i < G_YT.size(); i++)\n {\n cout << G_YT[i];\n if(i < G_YT.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdP: [\";\n for(unsigned int i = 0; i < G_YP.size(); i++)\n {\n cout << G_YP[i];\n if(i < G_YP.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n int kk=G_Y.size()*(G_Y.size()+1)/2;\n\n cout << \"-> Read Gibbs Data d2GdY2: [\";\n for(int i = 0; i < kk; i++)\n {\n cout << G_YY[i];\n if(i < kk-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n OCASI.tqgccf(1, &ceq);\n OCASI.tqgnpc(1, &ceq);\n OCASI.tqgpci(1, \"CR\", &ceq);\n OCASI.tqphtupsts(1, -2, 0.0, &ceq);\n double mass;\n OCASI.tqgpcs(1, 1, mass, & ceq);\n //OCASI.tqcph2(1, 0, &ceq);\n OCASI.tqlr(0, &ceq);\n OCASI.tqlc(0, &ceq);\n OCASI.reset_conditions(\"T\", 1000.0, &ceq);\n OCASI.tqlc(0, &ceq);\n\n\n\n int * newceq = 0;\n //==================================\n OCASI.tqcceq(\"test\", &newceq, &ceq);\n //==================================\n\n cout << \"-> Copy CEQ@\" << &ceq << \" to NEWCEQ@\" << &newceq << endl;\n vector elnames4 =\n\n //=================\n OCASI.tqgcom(&newceq);\n //=================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < elnames4.size(); i++)\n {\n cout << elnames4[i];\n if(i < elnames4.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &newceq << \"]\" << endl;\n phasetuples =\n\n //================\n OCASI.tqgnp(&newceq);\n //================\n\n cout << \"-> Number of phasetuples: [\" << phasetuples << \"]\" << endl;\n PhNames.resize(phasetuples);\n cout << \"-> Phase Data: [\";\n for(int i = 0; i < phasetuples; i++)\n {\n PhNames[i] =\n\n //=====================\n OCASI.tqgpn(i+1, &newceq);\n //=====================\n\n cout << PhNames[i] << \"[\" <<\n\n //===========================\n OCASI.tqgpi(PhNames[i], &newceq)\n //===========================\n\n << \"]\";\n if(i < phasetuples-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &newceq << \"]\" <<\n endl;\n\n return 0;\n}\n" }, { "path": "examples/TQ4lib/Cpp/Matthias/tqintf.h", "content": "#define MAXEL 10\n#define MAXPH 20\n//#include \"octqc.h\"\n#include \"OC-isoC.h\"\n#include \n#include \n#include \n#include \n#include \n#include \n\n/* 160829 Bo Sundman revision \nThis is the C++ connection to the Fortran libocisoc.F90 library \n\nThe declarations here have corresponing F08 source code in liboctqisoc.F90 */\n\nextern\"C\"\n{\n void c_tqini(int, void *); // initiates the OC package\n void c_tqrfil(char *, void *); // read all elements from a TDB file\n //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements\n void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements\n //void c_tqgnp(int *, void **); // get total number of phases and composition sets\n void c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx \n void c_tqgetv(char *, int, int, int *, double *, void *); // get equilibrium results using state variables\n void c_tqsetc(char *, int, int, double, int *, void *); // set condition\n void c_tqce(char *, int, int, double *, void *); // calculate quilibrium with possible target\n //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets\n void examine_gtp_equilibrium_data(void *); //\n //void c_getG(int, void *);\n //void c_calcg(int, int, int, int, void *);\n void c_tqgphc1(int, int * , int *, int *, double *, double *, double *,\n void *);\n void c_tqsphc1(int, double *, double *, void *);\n void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *);\n}\n\nextern\"C\" int c_ntup; //\nextern\"C\" int c_nel; // number of elements\nextern\"C\" int c_maxc; //\nextern\"C\" char *c_cnam[24]; // character array with all element names\nextern\"C\" double c_gval[24];\nextern\"C\" int c_noofcs(int);\n\nusing namespace std;\n\nvoid Initialize(void *ceq)\n{\n int n = 0;\n\n //===============\n c_tqini(n, ceq);\n //===============\n\n cout << \"-> Adress of ceq-Storage: [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid ReadDatabase(string fname, void *ceq)\n{\n char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str());\n\n //======================\n c_tqrfil(filename, ceq);\n //======================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n cout << c_cnam[i];\n if(i < c_nel-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid ReadDatabaseLimited(string fname, vector elnames, void *ceq)\n{\n char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str());\n char *selel[elnames.size()];\n for(int i = 0; i < elnames.size(); i++)\n {\n char *tempchar\n = strcpy((char*)malloc(elnames[i].length()+1), elnames[i].c_str()); \n selel[i] = tempchar; \n }\n\n //==============================================\n c_tqrpfil(filename, elnames.size(), selel, ceq);\n //==============================================\n\n cout << \"-> Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n cout << c_cnam[i];\n if(i < c_nel-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n\n\n};\n\nvoid ReadPhases(vector &phnames, void *ceq)\n{\n phnames.clear();\n\n for(int i = 1; i < c_ntup+1; i++)\n {\n char phn[24];\n\n //==========================\n c_tqgpn(i, phn, ceq);\n //==========================\n\n phnames.push_back(phn);\n }\n\n cout << \"-> Phase Data: [\";\n for(int i = 0; i < phnames.size(); i++)\n {\n cout << phnames[i];\n if(i < phnames.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid SetTemperature(double T, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"T\";\n if (T < 1.0) T = 1.0;\n\n //=========================================\n c_tqsetc(par, n1, n2, T, &cnum, ceq);\n //=========================================\n\n cout << \"-> Set Temperature to: [\" << T << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid SetPressure(double P, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"P\";\n if (P < 1.0) P = 1.0;\n\n //=========================================\n c_tqsetc(par, n1, n2, P, &cnum, ceq);\n //=========================================\n\n cout << \"-> Set Pressure to: [\" << P << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid SetMoles(double N, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"N\";\n\n //=========================================\n c_tqsetc(par, n1, n2, N, &cnum, ceq);\n //=========================================\n\n cout << \"-> Set Moles to: [\" << N << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid SetComposition(vector X, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"X\";\n\n for (int i = 0; i < c_nel; i++)\n {\n if (X[i] < 1.0e-6) X[i] = 1.0e-6; // Check and fix, if composition is below treshold\n\n if(i < c_nel - 1)\n { // Set and print composition, if element 'i' is not the reference/(last) element\n //==================================================\n c_tqsetc(par, i+1, n2, X[i], &cnum, ceq);\n //==================================================\n\n cout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n X[i] << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n }\n else\n { // Print composition, if element 'i' is the reference/(last) element\n double X_ref = 1;\n for(int j = 0; j < i; j++)\n {\n X_ref -= X[j];\n }\n\n cout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n X_ref << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n }\n }\n};\n\nvoid SetConstituents(int phidx, vector y, void *ceq)\n{\n int stable1 = phidx;\n double extra[MAXPH];\n double yfr[y.size()];\n for(int i = 0; i < y.size(); i++)\n {\n yfr[i] = y[i];\n }\n\n //===============================\n c_tqsphc1(stable1,yfr,extra,ceq);\n //===============================\n\n cout << \"-> Set Constituents to: [\";\n for(int i = 0; i < y.size(); i++)\n {\n cout << i << \": \" << yfr[i];\n if(i < y.size()-1)\n {\n cout << \", \"; \n }\n }\n cout << \"]\" << endl;\n};\n\n\nvoid SelectSinglePhase(int PhIdx, void *ceq)\n{\n //\n};\n\nvoid CalculateEquilibrium(void *ceq)\n{\n char target[60] = \" \";\n int null1 = 0;\n int null2 = 0;\n double val;\n\n //======================================\n c_tqce(target, null1, null2, &val, ceq);\n //======================================\n\n cout << \"-> Calculated Equilibrium [\" << ceq << \"]\"\n << endl;\n};\n\nvoid GetGibbsData(int phidx, void *ceq)\n{\n int n2 = 2;\n int n3;\n double gtp[6];\n double dgdy[100];\n double d2gdydt[100];\n double d2gdydp[100];\n double d2gdy2[100];\n\n //=================================================================\n c_tqcph1(phidx, n2, &n3, gtp, dgdy, d2gdydt, d2gdydp, d2gdy2, ceq);\n //=================================================================\n\n cout << \"-> Read Gibbs Data G: [\";\n for(int i = 0; i < 6; i++)\n {\n cout << gtp[i];\n if(i < 5)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data dGdY: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << dgdy[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdT: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << d2gdydt[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdP: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << d2gdydp[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n int kk=n2*(n2+1)/2;\n\n cout << \"-> Read Gibbs Data d2GdY2: [\";\n for(int i = 0; i < kk; i++)\n {\n cout << d2gdy2[i];\n if(i < kk-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n};\n\nvoid ListPhaseFractions(vector phnames, vector& phfract,\n void *ceq)\n{\n double npf[MAXPH];\n char statevar[60] = \"NP\";\n int n1 = -1;\n int n2 = 0;\n int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]);\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\n for(int i = 0; i < n3; i++)\n phfract.push_back(npf[i]);\n\n cout << \"-> Phase Fractions: [\";\n for (int i = 0; i < n3; i++)\n {\n cout << phnames[i] << \": \" << phfract[i]; \n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n};\n\nvoid ListConstituentFractions(vector phnames, vector phfract,\n vector > elfract, void *ceq)\n{\n elfract.clear();\n elfract.resize(phnames.size());\n double pxf[10*MAXPH];\n for (int i = 1; i < c_ntup+1; i++)\n {\n if (phfract[i-1] > 0.0)\n {\n char* statevar = \"X\";\n int n1 = 0;\n int n2 = -1; //composition of stable phase n2 = -1 means all fractions\n int n4 = sizeof(pxf)/sizeof(pxf[0]);\n\n //=======================================\n c_tqgetv(statevar, i, n2, &n4, pxf, ceq);\n //=======================================\n\n for (int k = 0; k < n4; k++)\n {\n elfract[i-1].push_back(pxf[k]);\n }\n cout << \"-> Constituent Fractions for \" << phnames[i-1] <<\n \" [\";\n\n for (int k = 0; k < n4; k++)\n {\n cout << c_cnam[k] << \": \" << elfract[i-1][k];\n if(k < n4-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n }\n }\n};\n\nvoid ListExtConstituentFractions(int phidx, vector phnames, void *ceq)\n{\n int stable1 = phidx;\n int nlat;\n int nlatc[MAXPH];\n int conlista[MAXPH];\n double yfr[MAXPH];\n double sites[MAXPH];\n double extra[MAXPH];\n\n //======================================================================\n c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq);\n //======================================================================\n\n cout << \"-> Extended Constituent Fractions for \" << phnames[stable1-1]\n << \" [\" << extra[0] << \" moles of atoms/formula unit]\";\n int consti = 0;\n for(int i = 0; i < nlat; i++)\n {\n cout << \" [\";\n for(int j = 0; j < nlatc[i]; j++)\n {\n cout << \"Const. \" << consti << \": \" << yfr[consti];\n if(j < nlatc[i]-1)\n {\n cout << \", \";\n }\n consti += 1;\n }\n cout << \"]_(\" << sites[i] << \")\";\n }\n cout << endl;\n};\n" }, { "path": "examples/TQ4lib/Cpp/Scheil/Compile_OCASI_win32.bash", "content": "#!/bin/bash\n#\n# You must adjust this command file to your local environment\n#\nCOMPILER=i686-w64-mingw32\nGFORTRAN=${COMPILER}-gfortran\nGCPP=${COMPILER}-g++\n\nset -x\n\nrm *.o\n\n# Copy the libraries from OC (compiled with parallel)\ncp ../F90/{liboceq.a,liboceq.mod,/liboceqplus.mod} .\n\n${GFORTRAN} -c -fopenmp liboctq.F90\n${GFORTRAN} -c -fopenmp liboctqisoc.F90\n${GCPP} -o scheil.exe -static -fopenmp -lstdc++ example_OCASI.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm -lquadmath \n" }, { "path": "examples/TQ4lib/Cpp/Scheil/Example_OCASI.cpp", "content": "#define CTEC 0// should be 0 for non CTEC users\n\n# if CTEC<1\n#include \"ocasiintf.h\"\n#define OCVERSION \"Open CalPhad Software Interface July 2016\"\n#endif\n#if CTEC>0\n#include \"CTEC.h\"\n#define OCVERSION \"OC_Prophase July 2016\"\n#endif\n#include \n\n/*\n\tCTEC = 0 Compilation Open Source\n\tCTEC = 1 Compilation Constellium Unix Server\n\tCTEC = 2 Compilation Constellium Windows 7 PC\n*/\n\n\n\n\n\nusing namespace std;\nint main(int argc, char **argv)\n{\n\tint ncpu=1;\n\tvector Store_Equilibria;\n\tStore_Equilibria.resize(0);\n\tvector Store_Equilibria_compo_unit;\n\tvector Suspended_phase_list;\n\tSuspended_phase_list.resize(0);\n\tStore_Equilibria_compo_unit.resize(0);\n\tvector eldatabase;\n\tstring el_ref;\n\tbool compo_in_percent=false;\n\tstring compo_unit=\"W\";\n\tstring temp_unit=\"C\";\n\tvector Compo_all_el;\n vector Compo_all_el_old;\n\tint i_ref=0;\n\tvector W;\n\tvector MU;\n\tvector el_reduced_names;\n\tel_reduced_names.resize(0);\t// Array including selected elements\n\tW.resize(0);\n\tsize_t i_compo=0;\n\tstring strcompo=\"Compo\";\n\tstring strcomponb=\"\";\n\n\tsize_t i_eq=0;\n\tstring strEqui=\"Equilibrium\";\n\tstring strEquinb=\"\";\n\n\tstring myequi=\"\";\n\tstring element_file=\"elements.txt\";\n\n\n\tint i_error=0;\n\tvoid *ceq =0; // Pointer to the OpenCalphad storage\n\tdouble TK=2000;\n\tdouble TC=2000;\n\tdouble TK_Liquidus=10;\n\tvector phnames; // Array including all phase names\n\tvector phfract; // Array including all phase fractions\n\tvector< vector > elfract; // Array including all equilibrium compositions\n\tstruct timeval start1, end1;\n\tofstream file;\n long seconds, useconds;\n\tdouble elapsed_time;\n\n\n\tchar command[255];\n\tomp_set_num_threads(ncpu);\n\t//cout <<\" name of the input file :\"< month;\n\tmonth.resize(13,\"\");\n\tmonth[1]=\"January\";\n\tmonth[2]=\"February\";\n\tmonth[3]=\"March\";\n\tmonth[4]=\"April\";\n\tmonth[5]=\"May\";\n\tmonth[6]=\"June\";\n\tmonth[7]=\"July\";\n\tmonth[8]=\"August\";\n\tmonth[9]=\"September\";\n\tmonth[10]=\"October\";\n\tmonth[11]=\"November\";\n\tmonth[12]=\"December\";\n\tstring strLIQUID=\"LIQUID\";\n\tstring strSOLSOL=\"FCC_A1\";\n\n\t#if CTEC==2\n\t{\n\t\tright_to_use=InitInstance();\n\t}\n\t#endif\n\n\n\n\n\n\twhile (!inputfile.eof() ){\n\t\tstring strmyline;\n\t\tstd::getline(inputfile, strmyline);\n\t\tcout<strmyline.size())) {\n\t\t\tsout<<\" error in command line < not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<0\n\t\t\t{\n\t\t\t\tCTECGetAllElementsFromDatabase(TDBFILE);\n\t\t\t}\n\t\t\t#endif\n\t\t\t//end *************************** applicable for CTEC only\n\n\t\t\tsout<<\" the following elements are in the database:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" 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;\n\t\t\tfile<tm_mday<<\" \"<tm_mon]<<\" \"<<1900 + ltm->tm_year<<\" , \"<< ltm->tm_hour << \"h:\"<< ltm->tm_min << \"mn:\"<< ltm->tm_sec<<\"s\"<< endl;\n\t\t\tsout<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line > not found in line:\"<strcharname.size()))){\n\t\t\t\t\tstring element_name=strcharname.substr(0,i);\n\t\t\t\t\tint j=strcharname.find(\"/\");\n\t\t\t\t\tstring strcompo=strcharname.substr(i+1,j-i-1);\n\t\t\t\t\tAll_Capital_Letters(element_name);\n\t\t\t\t\tstrcharname.erase(0,j+1);\n\t\t\t\t\tif (j<0) strcharname=\"\";\n\t\t\t\t\ti=strcharname.find(\"=\");\n\t\t\t\t\tbool found_el=false;\n\t\t\t\t\tif (not data_base_already_read){\n\t\t\t\t\t\tfor (size_t k=0; k New element detected :\"< element detected with zero composition :\"<0){\n\t\t\t\t\t\tre_read_compo=true;\n\t\t\t\t\t\tsout<<\" \tall possible phases will be allowed again with new composition\" <1e-10){\n\n\t\t\t\t\t\tel_reduced_names.push_back(eldatabase[i]);\n\t\t\t\t\t\tW.push_back(Compo_all_el[i]);\n\t\t\t\t\t\tfile<0\n\t\t\t\t{\n\t\t\t\t\tCTECReadDatabaseLimited(TDBFILE, el_reduced_names, &ceq); // Define TDB-file and read only selected elements (non zero composition)\n\n\t\t\t\t}\n\t\t\t\t#endif\n\t\t\t\t//end *************************** applicable for CTEC only\n\n\n\n\n\t\t\t\tdata_base_already_read=true;\n\t\t\t\tsout<<\"reading phases\"<100){\n\t\t\t\t\t\tlength=0;\n\t\t\t\t\t\tsout<(el_reduced_names.size(),0.));\n\n\t\t\t\tSetPressure(1e5, &ceq); // Set Pressure\n\n\t\t\t\tSetMoles(1.0, &ceq); // Set Number of moles\n\t\t\t\tMU.resize(W.size(),0.);\n\t\t\t}\n\t\t\telse{\n\t\t\t\tfile<<\"==================================================================\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, first > not found in line:\"< liquidus is: \"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, first > not found in line:\"< solidus is: \"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, first / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, second / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, third / not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, / not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<strmyline.size()))))\n\t\t\t{\n\t\t\t\tstring strphasename=strmyline.substr(0,i);\n\t\t\t\tAll_Capital_Letters(strphasename);\n\t\t\t\tbool phase_found=false;\n\t\t\t\tfor (int j=0;j\");\n\t\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\t\tsout<<\" error in command line, > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<\");\n\t\t\tfile<<\"[\"<strmyline.size()))))\n\t\t\t{\n\t\t\t\tstring strphasename=strmyline.substr(0,i);\n\t\t\t\tAll_Capital_Letters(strphasename);\n\t\t\t\tbool phase_found=false;\n\t\t\t\tfor (int j=0;j\");\n\t\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\t\tsout<<\" error in command line, > not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, very first / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, second / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, third / not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, fourth / not found in line:\"<0)){\n\t\t\t//parameter target_delta_f_liq\n\t\t\t//paramter delta_T_min\n\t\t\t//paramter delta_T_max\n\t\t\tsout<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, very first / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, third / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, fourth / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, fifth / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, sixth / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, seventh / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, heigth / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<0\n\t\t\tback_diff_solidif(strGradientFileOut,strLIQUID,strSOLSOL,file,el_reduced_names,phnames,ceq, W, target_delta_f_liq,delta_T_min,delta_T_max, TK_Liquidus,i_ref,compo_unit,half_sdas,dim,Tpoint,Nb_increment,Store_Equilibria,Store_Equilibria_compo_unit,Suspended_phase_list,Fl_end_hot_tearing,strcomponb,element_file, FastSolidification);\n\t\t\t#endif\n\t\t\tgettimeofday(&end1, NULL);\n\n\t\t\tseconds = end1.tv_sec - start1.tv_sec;\n\t\t\tuseconds = end1.tv_usec - start1.tv_usec;\n\n\t\t\telapsed_time = ((double)(((seconds) * 1000 + useconds/1000.0) + 0.5))/1000.;\n\t\t\tfile<<\"[\"<0)){\n\t\t\t//parameter target_delta_f_liq\n\t\t\t//paramter delta_T_min\n\t\t\t//paramter delta_T_max\n\t\t\tvector < double > TC1;\n\t\t\tvector < double > TC2;\n\t\t\tvector < double > segments_time_h;\n\t\t\tsout<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, very first / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, third / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, fourth / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, fifth / not found in line:\"<strmyline.size())) {\n\t\t\t\t\tsout<<\" error in command line, sixth / not found in line:\"<strmyline.size())) {\n\t\t\t\t\tsout<<\" error in command line, seventh / not found in line:\"<strmyline.size())) {\n\t\t\t\t\ti = strmyline.find(\">\");\n\n\t\t\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\t\t\tsout<<\" error in command line, > not found in line:\"<0\n\t\t\thomo(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);\n\t\t\t#endif\n\t\t\tgettimeofday(&end1, NULL);\n\n\t\t\tseconds = end1.tv_sec - start1.tv_sec;\n\t\t\tuseconds = end1.tv_usec - start1.tv_usec;\n\n\t\t\telapsed_time = ((double)(((seconds) * 1000 + useconds/1000.0) + 0.5))/1000.;\n\n\t\t\tsout<<\" elapsed time for the back-diffusion solidification routine (s)= \"<0)){\n\t\t\t//parameter target_delta_f_liq\n\t\t\t//paramter delta_T_min\n\t\t\t//paramter delta_T_max\n\t\t\tvector < double > TC1;\n\t\t\tvector < double > TC2;\n\t\t\tvector < double > segments_time_h;\n\t\t\tsout<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<0\n\t\t\tcompute_properties(strFile,strSOLSOL,el_reduced_names, W, compo_unit,i_ref, &ceq, phnames,file,strcomponb,element_file);\n\t\t\t#endif\n\n\t\t}\n\t\telse if((strcommand==\"FIX_A_PHASE\")){\n\n\t\t\tsout<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, / not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, / not found in line:\"<strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, / not found in line:\"<\");\n\t\t\tif ((i<0) or (i>strmyline.size())) {\n\t\t\t\tsout<<\" error in command line, > not found in line:\"<>>> to be modified to use phase tuplets\n integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index:\n! 10*phase_number+comp.set\n ! or component set\n integer(c_int), intent(in),value :: n2 !\n integer(c_int), intent(out) :: cnum !exit: \n! sequential number of this condition\n character(c_char), intent(in) :: statvar !in: character\n! with state variable symbol\n real(c_double), intent(in),value :: mvalue !in: value of condition\n \n type(c_ptr), intent(in) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\n\t type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqsetc(statvar, n1, n2, mvalue, cnum, ceq)\n\tnullify(ceq)\n \n end subroutine c_tqsetc\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce')\n! calculate equilibrium with possible target\n! Target can be empty or a state variable with indicies n1 and n2\n! value is the calculated value of target\n integer(c_int), intent(in),value :: n1\n integer(c_int), intent(in),value :: n2\n type(c_ptr), intent(inout) :: c_ceq\n character(c_char), intent(inout) :: mtarget \n real(c_double), intent(inout) :: mvalue\n!\\end{verbatim}\n\ttype(gtp_equilibrium_data), pointer :: ceq\n character(len=:), allocatable :: fstring\n call c_f_pointer(c_ceq,ceq)\n fstring = c_to_f_string(mtarget)\n call tqce(fstring,n1,n2,mvalue,ceq)\n c_ceq = c_loc(ceq)\n\tdeallocate(fstring)\n\tnullify(ceq)\n end subroutine c_tqce\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv')\n! get equilibrium results using state variables\n! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 \n! n3 at the call is the dimension of values, changed to number of values\n! value is the calculated value, it can be an array with n3 values.\n implicit none\n integer(c_int), intent(in),value :: n1,n2\n integer(c_int), intent(inout) :: n3\n character(c_char), intent(in) :: statvar\n real(c_double), intent(inout) :: values(*)\n type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium\n!========================================================\n! >>>> implement use of phase tuples \n! stavar must be a symbol listed below\n! IMPORTANT: some terms explained after the table\n! Symbol index1,index2 Meaning (unit)\n!.... potentials\n! T 0,0 Temperature (K)\n! P 0,0 Pressure (Pa)\n! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J)\n! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT)\n! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT\n!...... extensive variables\n! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase\n! UM 0,0 or phase-tuple,0 same per mole components\n! UW 0,0 or phase-tuple,0 same per kg\n! UV 0,0 or phase-tuple,0 same per m3\n! UF phase-tuple,0 same per formula unit of phase\n! S*3 0,0 or phase-tuple,0 Entropy (J/K) \n! V 0,0 or phase-tuple,0 Volume (m3)\n! H 0,0 or phase-tuple,0 Enthalpy (J)\n! A 0,0 or phase-tuple,0 Helmholtz energy (J)\n! G 0,0 or phase-tuple,0 Gibbs energy (J)\n! ..... some extra state variables\n! NP phase-tuple,0 Moles of phase\n! BP phase-tuple,0 Mass of moles (kg)\n! Q phase-tuple,0 Internal stability/RT (dimensionless)\n! DG phase-tuple,0 Driving force/RT (dimensionless)\n!....... amounts of components\n! N 0,0 or component,0 or phase-tuple,component Moles of component\n! X component,0 or phase-tuple,component Mole fraction of component\n! B 0,0 or component,0 or phase-tuple,component Mass of component\n! W component,0 or phase-tuple,component Mass fraction of component\n! Y phase-tuple,constituent*1 Constituent fraction\n!........ some parameter identifiers\n! TC phase-tuple,0 Magnetic ordering temperature\n! BMAG phase-tuple,0 Aver. Bohr magneton number\n! MQ& phase-tuple,constituent Mobility\n! THET phase-tuple,0 Debye temperature\n! LNX phase-tuple,0 Lattice parameter\n! EC11 phase-tuple,0 Elastic constant C11\n! EC12 phase-tuple,0 Elastic constant C12\n! EC44 phase-tuple,0 Elastic constant C44\n!........ NOTES:\n! *1 The phase-tuple is is structure with 2 integers: phase and comp.set\n! *2 The constituent index is 10*species_number + sublattice_number\n! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also\n!--------------------------------------------------------------------\n! special addition for TQ interface: d2G/dyidyj\n! D2G + extended phase index\n!------------------------------------\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n integer :: n\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n \n! call list_conditions(6,ceq)\n! call list_phase_results(1,1,0,6,ceq)\n! write(*,*)'Phase and error code: ',1,gx%bmperr\n! call list_phase_results(2,1,0,6,ceq)\n! write(*,*)'Phase and error code: ',2,gx%bmperr\n! write(*,*)\n\n call c_to_f_str(statvar,fstring)\n call tqgetv(fstring, n1, n2, n3, values, ceq)\n! debug ...\n! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3)\n!55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4))\n! write(*,*)\n! end debug\n c_ceq = c_loc(ceq)\n\t\n end subroutine c_tqgetv\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)&\n bind(c,name='c_tqgphc1')\n! tq_get_phase_constitution\n! This subroutine returns the sublattices and constitution of a phase\n! n1 is phase tuple index\n! nsub is the number of sublattices (1 if no sublattices)\n! cinsub is an array with the number of const\\EDtuents in each sublattice\n! spix is an array with the species index of the constituents in all sublattices\n! sites is an array of the site ratios for all sublattices. \n! yfrac is the constituent fractions in same order as in spix\n! extra is an array with some extra values: \n! extra(1) is the number of moles of components per formula unit\n! extra(2) is the net charge of the phase\n implicit none\n !integer n1,nsub,cinsub(*),spix(*)\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(out) :: nsub\n integer(c_int), intent(out) :: cinsub(*)\n integer(c_int), intent(in) :: spix(*)\n !double precision sites(*),yfrac(*),extra(*)\n real(c_double), intent(in) :: sites(*)\n real(c_double), intent(in) :: yfrac(*)\n real(c_double), intent(in) :: extra(*)\n !type(gtp_equilibrium_data), pointer :: ceq\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq)\n call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgphc1\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1')\n! tq_set_phase_constitution\n! To set the constitution of a phase\n! n1 is phase tuple index\n! yfra is an array with the constituent fractions in all sublattices\n! in the same order as obtained by tqgphc1\n! extra is an array with returned values with the same meaning as in tqgphc1\n! NOTE The constituents fractions are normallized to sum to unity for each\n! sublattice and extra is calculated by tqsphc1\n! T and P must be set as conditions.\n implicit none\n integer(c_int), intent(in), value :: n1\n real(c_double), intent(in) ::yfra(*)\n real(c_double), intent(out) :: extra(*)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n yfra,extra,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqsphc1\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) &\n bind(c,name='c_tqcph1')\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNIG: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt \n! compositions, 2 if also 2nd derivatives\n! n3 is returned as number of constituents (dimension of returned arrays)\n! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P\n! dgdy is an array with G.Yi\n! d2gdydt is an array with G.T.Yi\n! d2gdydp is an array with G.P.Yi\n! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj \n! reurned in the order: 1,1; 1,2; 1,3; ... \n! 2,2; 2,3; ...\n! 3,3; ...\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(in), value :: n2\n integer(c_int), intent(out) :: n3\n real(c_double), intent(out) :: gtp(6)\n real(c_double), intent(out) :: dgdy(*)\n real(c_double), intent(out) :: d2gdydt(*)\n real(c_double), intent(out) :: d2gdydp(*)\n real(c_double), intent(out) :: d2gdy2(*)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqcph1\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n !\\begin{verbatim} \n subroutine c_reset_conditions(cline,c_ceq) bind(c, name='c_reset_conditions')\n implicit none\n character(c_char), intent(in) :: cline(24) \n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n fstring = c_to_f_string(cline)\n call c_f_pointer(c_ceq, ceq)\n \n call reset_conditions(fstring,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_reset_conditions\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_Change_Status_Phase(phasename,nystat,myval,c_ceq)&\n bind(c, name='c_Change_Status_Phase') \n!change the status Fixed or Entered of a phase \n!PHFIXED=2\n!PHENTERED=0\n implicit none\n character(c_char), intent(in) :: phasename(24)\n integer(c_int), intent(in), value :: nystat\n real(c_double), intent(in),value :: myval\n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\t\n type(gtp_equilibrium_data), pointer :: ceq \n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n call c_to_f_str(phasename,fstring)\n call Change_Status_Phase(fstring,nystat,myval,ceq)\n c_ceq = c_loc(ceq)\n \n1000 continue\t\n return\n end subroutine c_Change_Status_Phase\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_List_Conditions(c_ceq)&\n bind(c, name='c_List_Conditions') \n!change the status Fixed or Entered of a phase \n!PHFIXED=2\n!PHENTERED=0\n implicit none\n\t\n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\t\n type(gtp_equilibrium_data), pointer :: ceq \n call c_f_pointer(c_ceq, ceq)\n call list_conditions(6,ceq)\n c_ceq = c_loc(ceq)\n1000 continue\t\n return\n end subroutine c_List_Conditions\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_checktdb(tdbfile)&\n bind(c, name='c_checktdb') \n character(kind=c_char), intent(in) :: tdbfile\n!\\end{verbatim}\n integer:: nel,i\n character selel(maxel)*2\n character(len=:), allocatable :: fstring\n character(len=:), allocatable :: ext\n ext='.tdb'\n fstring = c_to_f_string(tdbfile)\n call checkdb(fstring,ext,nel,selel)\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(selel(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n end do\n deallocate(fstring)\n return\n end subroutine c_checktdb\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n \n!\\begin{verbatim} \n subroutine c_newEquilibrium(ceqname,ieq) bind(c, name='c_newEquilibrium') \n character(kind=c_char), intent(in) :: ceqname\n integer(c_int), intent(out):: ieq\n!\\end{verbatim}\n character(len=:), allocatable :: fstring\n fstring = c_to_f_string(ceqname)\n call enter_equilibrium(fstring,ieq)\n deallocate(fstring)\n end subroutine c_newEquilibrium\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_selecteq(ieq,c_ceq) bind(c, name='c_selecteq') \n integer(c_int), intent(in),value :: ieq\n type(c_ptr), intent(out) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n!call c_f_pointer(c_ceq, ceq)\n!call selecteq(ieq,ceq)\n ceq=>eqlista(ieq)\n c_ceq = c_loc(ceq)\n nullify(ceq)\n\t\n return\n end subroutine c_selecteq\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_copy_equilibrium(c_neweq,ceqname,c_ceq) &\n bind(c, name='c_copy_equilibrium') \n type(c_ptr), intent(inout) :: c_neweq \n character(kind=c_char), intent(in) :: ceqname\n type(c_ptr), intent(in) :: c_ceq \n!\\end{verbatim}\n character(len=:), allocatable :: fstring\n type(gtp_equilibrium_data), pointer :: ceq\n type(gtp_equilibrium_data), pointer :: neweq\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(ceqname)\n call copy_equilibrium(neweq,fstring,ceq)\n c_neweq=c_loc(neweq)\n deallocate(fstring)\n nullify(ceq)\n return\n end subroutine c_copy_equilibrium\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_set_status_globaldata() bind(c, name='c_set_status_globaldata') \n!\\end{verbatim}\n!globaldata%status=ibclr(globaldata%status,GSADV)\n!globaldata%status=ibclr(globaldata%status,GSNOPAR)\n!globaldata%status=ibclr(globaldata%status,GSXGRID)\n globaldata%status=ibclr(globaldata%status,GSNOACS)\n \n return\n end subroutine c_set_status_globaldata\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \t\n integer function c_errors_number() bind(c, name='c_errors_number')\n!\\end{verbatim}\t\n c_errors_number=0\n if(gx%bmperr.ne.0) then\n c_errors_number=gx%bmperr\n endif\n return\n end function c_errors_number\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \t\n subroutine c_new_gtp() bind(c, name='c_new_gtp') \n!\\end{verbatim}\t\n call new_gtp\n end subroutine c_new_gtp\n\t\nend module liboctqisoc\n" }, { "path": "examples/TQ4lib/Cpp/Scheil/linkscheil", "content": "REM You must first install OC to generate the libraries\nREM liboceq.a, liboceqplus.mod\nREM You must compile the parallel version, linkpara or Makefile-parallel\n\nREM These are copied there (assumed to be three levels above)\ncopy ..\\..\\..\\libocasi.a .\ncopy ..\\..\\..\\liboceqplus.mod .\n\nREM Then the libraries for TQ are copied here from one level above\ncopy ..\\liboctq.F90 .\ncopy ..\\liboctqisoc.F90 .\n\nREM Compile this library together with the isoc library and the program\ngfortran -c liboctq.F90\ngfortran -c liboctqisoc.F90\n\ng++ -o scheil -fopenmp -lstdc++ Example_OCASI.cpp liboctqisoc.o liboctq.o libocasi.a -lgfortran -lm\n\n" }, { "path": "examples/TQ4lib/Cpp/Scheil/ocasiintf.h", "content": "//define PARALLEL 0 no loop with parallelization\n//define PARALLEL 1 declared loops with parallelization\n#define PARALLEL 1\n#define MAXEL 41\n#define MAXPH 501\n#define PHFIXED 2\n#define PHENTERED 0\n#define PHSUS -3\n#define GRID 0\n#define NOGRID -1\n#define TCtoTK 273.15\n#define TAB \"\\t\"\n\n\n\n\n#include \"octqc.h\"\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include\n#include \n\nextern\"C\"\n{\n\tvoid c_Change_Status_Phase(char *, int ,double ,void *);\n\tvoid c_tqgetv(char *, int , int , int *, double *, void *); // get equilibrium results using state variables\n void c_tqsetc(char *, int, int , double, int *, void *); // set condition\n\tvoid c_tqce(char *, int , int , double *, void *); // calculate quilibrium with possible target\n\tvoid c_tqini(int, void *); // initiates the OC package\n \n\tvoid c_tqrfil(char *, void *); // read all elements from a TDB file\n //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements\n void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements\n //void c_tqgnp(int *, void **); // get total number of phases and composition sets\n void c_tqgpi(int *, char *, void *); // get index of phase phasename\n\tvoid c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx\n //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets\n void examine_gtp_equilibrium_data(void *); //\n //void c_getG(int, void *);\n //void c_calcg(int, int, int, int, void *);\n void c_tqgphc1(int, int * , int *, int *, double *, double *, double *,\n void *);\n void c_tqsphc1(int, double *, double *, void *);\n void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *);\n\t\n\tvoid c_List_Conditions(void *);\n\tvoid c_checktdb(char *);\n\tvoid c_newEquilibrium(char *,int *);\n\tvoid c_selecteq(int ,void *);\n void c_copy_equilibrium(void *,char *,void *);\n\tvoid c_set_status_globaldata();\n\tint c_errors_number();\n\tvoid c_new_gtp();\n\tvoid c_reset_conditions(char *,void *);\n}\n\nextern\"C\" int c_ntup; //\nextern\"C\" int c_nel; // number of elements\nextern\"C\" int c_maxc; //\nextern\"C\" char *c_cnam[MAXEL]; // character array with all element names\nextern\"C\" double c_gval[24];\nextern\"C\" int c_noofcs(int);\nextern\"C\" double c_mass[24];\n\nusing namespace std;\nconst double R=8.31451;\n\ntemplate < typename CHAR_TYPE,\n typename TRAITS_TYPE = std::char_traits >\n\nstruct basic_teebuf : public std::basic_streambuf< CHAR_TYPE, TRAITS_TYPE >\n{\n typedef std::basic_streambuf< CHAR_TYPE, TRAITS_TYPE > streambuf_type ;\n typedef typename TRAITS_TYPE::int_type int_type ;\n\n basic_teebuf( streambuf_type* buff_a, streambuf_type* buff_b )\n : first(buff_a), second(buff_b) {}\n\n protected:\n virtual int_type overflow( int_type c )\n {\n const int_type eof = TRAITS_TYPE::eof() ;\n if( TRAITS_TYPE::eq_int_type( c, eof ) )\n return TRAITS_TYPE::not_eof(c) ;\n else\n {\n const CHAR_TYPE ch = TRAITS_TYPE::to_char_type(c) ;\n if( TRAITS_TYPE::eq_int_type( first->sputc(ch), eof ) ||\n TRAITS_TYPE::eq_int_type( second->sputc(ch), eof ) )\n return eof ;\n else return c ;\n }\n }\n\n virtual int sync()\n { return !first->pubsync() && !second->pubsync() ? 0 : -1 ; }\n\n private:\n streambuf_type* first ;\n streambuf_type* second ;\n};\n\ntemplate < typename CHAR_TYPE,\n typename TRAITS_TYPE = std::char_traits >\nstruct basic_teestream : public std::basic_ostream< CHAR_TYPE, TRAITS_TYPE >\n{\n typedef std::basic_ostream< CHAR_TYPE, TRAITS_TYPE > stream_type ;\n typedef basic_teebuf< CHAR_TYPE, TRAITS_TYPE > streambuff_type ;\n\n basic_teestream( stream_type& first, stream_type& second )\n : stream_type( &stmbuf), stmbuf( first.rdbuf(), second.rdbuf() ) {}\n\n ~basic_teestream() { stmbuf.pubsync() ; }\n\n private: streambuff_type stmbuf ;\n};\ntypedef basic_teebuf teebuf ;\ntypedef basic_teestream teestream ;\nstd::ofstream logfile( \"oc_log.txt\" ) ;\nteestream sout( logfile, std::cout ) ;\n\nvoid Get_Ceq(const int &iceq,void *ceq){\n\tc_selecteq(iceq,ceq);\n\t//sout << \"-> Adress of ceq-Storage: [\" << ceq << \"]\" < Adress of ceq-Storage: [\" << ceq << \"]\" < Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n sout << c_cnam[i];\n if(i < c_nel-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << \" [\" << &ceq << \"]\" < &elnames, void *ceq)\n{\n\tchar *buffer=(char*)malloc(tdbfilename.length()+1);\n char *filename = strcpy(buffer, tdbfilename.c_str());\n char *selel[elnames.size()];\n for(size_t i = 0; i < elnames.size(); i++)\n {\n\t\tchar *buffer=(char*)malloc(elnames[i].length()+1);\n char *tempchar\n = strcpy(buffer, elnames[i].c_str());\n selel[i] = tempchar;\n }\n\t\n //==============================================\n c_tqrpfil(filename, elnames.size(), selel, ceq);\n //==============================================\n/*\n sout << \"-> Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n sout << c_cnam[i];\n if(i < c_nel-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n*/\n\tfree (buffer);\n};\n\nvoid ReadPhases(vector &phnames, void *ceq)\n{\n phnames.clear();\n\tphnames.resize(c_ntup);\n\t\n\n for(int i = 1; i < c_ntup+1; i++)\n {\n char phn[24];\n\n //==========================\n c_tqgpn(i, phn, ceq);\n //==========================\n\t\t\n \n\t\tint index;\n\t\tc_tqgpi(&index,phn,ceq);\n\t\tstring myname(phn);\n\t\ttransform(myname.begin(), myname.end(), myname.begin(), ::toupper);// to have it in CAPITAL LETTERS\n\t\tphnames[index-1]=myname;\n }\n/*\n sout << \"-> Phase Data: [\";\n for(size_t i = 0; i < phnames.size(); i++)\n {\n sout << i<< \" \"< &el_reduced_names,const int &i_ref, const string &compo_unit){\n\t{\n\t\tstring mystring(\"T=none\");\n\t\tchar *buffer=(char*)malloc(mystring.length()+1);\n\t\tchar *conditions = strcpy(buffer, mystring.c_str());\n\t\tc_reset_conditions(conditions,ceq);\n\t\tfree (buffer);\n\t}\n\tstring mystring=\"\";\n\tfor (int i=0;i Set Temperature to: [\" << T << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n \n \n};\n\nvoid SetPressure(const double &P, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"P\";\n // if (P < 1.0) P = 1.0;\n\n //=========================================\n c_tqsetc(par, n1, n2, P, &cnum, ceq);\n //=========================================\n\n// sout << \"-> Set Pressure to: [\" << P << \"]\" << \" [\" << &ceq << \"]\" <<\n// endl;\n};\n\nvoid SetMoles(const double &N, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"N\";\n\n //=========================================\n c_tqsetc(par, n1, n2, N, &cnum, ceq);\n //=========================================\n\n // sout << \"-> Set Moles to: [\" << N << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n};\n\nvoid SetComposition(vector& X, void *ceq, const int &i_ref,string &compo_unit)\n{\n int cnum;\n\n int n2 = 0;\n\n \n\t\n char par[60];\n strcpy(par,compo_unit.c_str());\n \n for (int i = 0; i < c_nel; i++)\n {\n if (X[i] < 1.0e-8) X[i] = 1.0e-8; // Check and fix, if composition is below treshold\n\n if(not (i == i_ref))\n { \n\t\t\tint j=i+1;\n\t\t\tdouble value= X[i];// Set and print composition, if element 'i' is not the reference/(last) element\n //==================================================\n c_tqsetc(par, j, n2,value, &cnum, ceq);\n //==================================================\n\n // sout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n // X[i] << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n }\n else\n { // Print composition, if element 'i' is the reference/(last) element\n double X_ref = 1;\n for(size_t j = 0; j < i; j++)\n {\n X_ref -= X[j];\n }\n\n// sout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n// X_ref << \"]\" << \" [\" << &ceq << \"]\" <<\n// endl;\n }\n }\n};\n\nvoid SetConstituents(int phidx, vector y, void *ceq)\n{\n int stable1 = phidx;\n double extra[MAXPH];\n double yfr[y.size()];\n for(size_t i = 0; i < y.size(); i++)\n {\n yfr[i] = y[i];\n }\n\n //===============================\n c_tqsphc1(stable1,yfr,extra,ceq);\n //===============================\n\n sout << \"-> Set Constituents to: [\";\n for(int i = 0; i < y.size(); i++)\n {\n sout << i << \": \" << yfr[i];\n if(i < y.size()-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n};\n\n\nvoid ReadPhaseFractions(const vector &phnames, vector& phfract,\n void *ceq)\n{\n double npf[MAXPH];\n char statevar[60] = \"NP\";\n\t\n int n1 = -1;//-1\n int n2 = 0;\n int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]);\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\t \n for(int i = 0; i < phnames.size(); i++){\n\t/*\n\tchar phn[24];\n\tc_tqgpn(i+1, phn, ceq);\n\tsize_t index=0;\n\t\tfor (size_t j=0;j Read Gibbs Data G: [\";\n for(int i = 0; i < 6; i++)\n {\n sout << gtp[i];\n if(i < 5)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n\n sout << \"-> Read Gibbs Data dGdY: [\";\n for(int i = 0; i < n3; i++)\n {\n sout << dgdy[i];\n if(i < n3-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n\n sout << \"-> Read Gibbs Data d2GdYdT: [\";\n for(int i = 0; i < n3; i++)\n {\n sout << d2gdydt[i];\n if(i < n3-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n\n sout << \"-> Read Gibbs Data d2GdYdP: [\";\n for(int i = 0; i < n3; i++)\n {\n sout << d2gdydp[i];\n if(i < n3-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n\n int kk=n2*(n2+1)/2;\n\n sout << \"-> Read Gibbs Data d2GdY2: [\";\n for(int i = 0; i < kk; i++)\n {\n sout << d2gdy2[i];\n if(i < kk-1)\n {\n sout << \", \";\n }\n }\n sout << \"]\" << endl;\n};\n\nvoid SelectSinglePhase(int PhIdx, void *ceq)\n{\n //\n};\nvoid List_Conditions(void *ceq){\n\tc_List_Conditions(ceq);\n}\nvoid CalculateEquilibrium(void *ceq, const int &n1, int &i_error, const vector < string > &Suspended_phase_list)\n{\n\t\n\tfor (int i=0;i &Suspended_phase_list , const string &strLIQUID,const string &strSOLIDSOLUTION, const vector &phnames){\n\t\n\tCalculateEquilibrium(&ceq,n1,i_error,Suspended_phase_list); \n\tif (i_error>0){\n\t\tsout<<\"first convergence issue\"<0){\n\t\t\tfor (int i=0;i0){\n\t\t\t\t\n\t\t\t\tsout<<\"!!!!!!!! convergence issue !!!!!!!!!!!!!!!!!!!!!\"< &MU)\n{\n double npf[1];\n char statevar[60] = \"MU\";\n \n\t for (int i = 1; i < c_nel+1; i++)\n {\n\t\tint n1 = i;\n\t\tint n2 = 0;\n\t\tint n3 = 1;\n\t\t//========================================\n\t\tc_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n\t\t//========================================\n\n\t\t\n\t\tMU[i-1]=npf[0];\n\t\t\n\t}\n};\ndouble ReadTemperature(void *ceq)\n{\n double npf[1];\n char statevar[60] = \"T\";\n int n1 = 0;\n int n2 = 0;\n int n3 = 1;\n\tdouble TK;\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\n \n TK=npf[0];\n\treturn(TK);\n};\ndouble ReadTotalEnthalpy(void *ceq)\n{\n double npf[1];\n char statevar[60] = \"H\";\n int n1 = 0;\n int n2 = 0;\n int n3 = 1;\n\tdouble H;\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\n\n H=npf[0];\n\treturn(H);\n};\nvoid ReadConstituentFractions(const vector &phnames, const vector &phfract,\n vector< vector > &elfract, void *ceq, const string &compo_unit)\n{\n \n \n\t\n double pxf[10*MAXPH];\n for (int i = 1; i < c_ntup+1; i++)\n {\n\t\tchar phn[24];\n\t\tc_tqgpn(i, phn, ceq);\n\t\tsize_t index=0;\n\t\tbool index_found=false;\n\t\tfor (size_t j=0;j 1e-10)\n else{\n char statevar[60] = \"X\";\n\t\t\tstrcpy(statevar,compo_unit.c_str());\n\n int n2 = -1; //composition of stable phase n2 = -1 means all fractions\n int n4 = sizeof(pxf)/sizeof(pxf[0]);\n\n //=======================================\n c_tqgetv(statevar, i, n2, &n4, pxf, ceq);\n //=======================================\n\t\t\t\n for (int k = 0; k < n4; k++)\n {\n\t\t\t\n elfract[index][k]=pxf[k];\n\t\t\t\t\n }\n\t\t\t\n\t\t\t\n \n }\n }\n};\n\nvoid ListExtConstituentFractions(int phidx, vector phnames, void *ceq)\n{\n int stable1 = phidx;\n int nlat;\n int nlatc[MAXPH];\n int conlista[MAXPH];\n double yfr[MAXPH];\n double sites[MAXPH];\n double extra[MAXPH];\n\n //======================================================================\n c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq);\n //======================================================================\n\n sout << \"-> Extended Constituent Fractions for \" << phnames[stable1-1]\n << \" [\" << extra[0] << \" moles of atoms/formula unit]\";\n int consti = 0;\n for(int i = 0; i < nlat; i++)\n {\n sout << \" [\";\n for(int j = 0; j < nlatc[i]; j++)\n {\n sout << \"Const. \" << consti << \": \" << yfr[consti];\n if(j < nlatc[i]-1)\n {\n sout << \", \";\n }\n consti += 1;\n }\n sout << \"]_(\" << sites[i] << \")\";\n }\n sout << endl;\n};\n\nstd::string IntToString ( int number )\n{\n\tstd::string mystr;\n\tstd::stringstream out;\n\tout << number;\n\tmystr = out.str();\n return mystr;\n}\n// Write the results of a given equilibrium\n// el_reduced_names: vector of names elements with non zero composition\n// phnames: vector of names phases that can appear for these elements\n// phfract: atomic fraction of these phases after equilibrium\n// elfract[i][j]: atomic composition of element i in phase j\n// ceqh: pointer for the given equilibrium calculation\n// mode: 1 write only atomic fractions of phases after equilibrium\n// mode: 1 write atomic fractions + compositions of phases after equilibrium\n\nvoid Write_Results_Equilibrium(ofstream& file, const vector &el_reduced_names, const vector &phnames, vector &phfract, \n\t\t\t\t\t\t vector< vector > &elfract, void *ceqh,const int &mode,const string &compo_unit, vector &MU,const string &temp_unit,const string &myequi){\n\t\n\t//-------------------------------List Results-------------------------------\n\t\n\tReadPhaseFractions(phnames, phfract, &ceqh); // Read the amount of stable phases\n\t\n\tif (mode >1) ReadConstituentFractions(phnames, phfract, elfract, &ceqh, compo_unit); // Read the composition of each stable phase\n\t\n\tdouble TC=ReadTemperature(&ceqh);\n\tif (temp_unit==\"C\") TC-=TCtoTK;\n\tsout<0){\n\t\t\tsout<<\" \"<2) {\n\t\tfile<1) {\n\t\tfile<1e-10){\t\t\n\t\t\t\n\t\t\t\tsout<<\" --------------------------------------- \"<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){\t\t\t\t \n\t\n\tint iceq=0;\n\tvector phfract;\n\tphfract.resize(phnames.size(),0.);\n\t\n\tvector< vector > elfract; // Array including all equilibrium compositions\n\telfract.resize(phnames.size(),vector(el_reduced_names.size(),0.));\n\t\n\t\n\t\n\t\n\t\n\tvector TKCE;\n\tvector< vector > CeqFract;\n\t\n\tTKCE.resize(0);\n\tCeqFract.resize(0);\n\tdouble TK_end=TK_start+(nstep-1)*step_TK;\n\tdouble TK=TK_start;\n\tint nstep_total=nstep;\n\tif (not first_iteration) nstep_total+=1;\n\tfor (int i=0; i(phnames.size(),0.));\n \n \n\tsize_t max_number_of_phase=0;\n// the three lines below trigger parallelism for the nex for {....} loop if PARALLEL is not 0\n \n//\tsout<<\"number of threads detected:\"<0\n#pragma omp parallel for \n#endif\t \n\tfor (int i=0; i0)) {\n\t\t\n\t\t\tc_selecteq(Store_Equilibria[i], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\n\t\t}else{\n\t\t\t//ceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\tc_selecteq(1, &ceqi);\n\t\t}\n\t\t\n\t\t//for (int k=0;k0) CeqFract[i][j]=phfract[j];\n\t\t\t}\n } \n\t}\n/*\t\n\tfor (int i=0; i\"<\"<0) sout<<\" \"<1e-8)&&(CeqFract[i+1][j]>1e-8)))\n\t\t\t{\n // a transition has been detected\t\t\t\n //\t\t\tsout<<\"********transition at: \"<0) {\n\t\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=\" + \";\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t\t\n\t\t\t\t\tTransitions.push_back(TKCE[i+1]);\n\t\t\t\t\tPhase_transitions_mixture.push_back(\"\");\n\t\t\t\t\tbool first_phase=true;\n\t\t\t\t\tfor (size_t k=0; k0) {\n\t\t\t\t\t\t\tif (not first_phase) Phase_transitions_mixture.back()+=\" + \";;\n\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\tfirst_phase=false;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\t\n\t\t\t\tj=phnames.size()+1;// exit the loop \n\t\t\t}\n\t\t}\n\t}\n}\n\n// ***************************************************************************************************************\n// find all the transitions temperatures for a given alloy composition\n// step_TK: first interval of temperature used\n// n_step : number of steps set to NSTEP\n// between TK_start and TK_end=TK_start+(n_step-1)*step_TK;\n// required_accuracy_on_TK: self explanatory\n// W : weight composition of elements\n// phnames: vector of names phases that can appear for these elements\n// el_reduced_names: vector of names elements with non zero composition\n// ceq: pointer for the given equilibrium calculation used to pass the standart equilibrium in non parallel computation\n// parallelization option is in Find_Transitions\n// see Find_Transitions for comments on parallelization\n\nvoid 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){\t\t\t\t \n\tstring mycompo_unit=compo_unit;\n\tdouble TK_end_ini, TK_start_ini;\n\tTK_start_ini=TK_start;\n\tTK_end_ini=TK_end;\n//\tsout<<\"sntep=\"< phfract;\n\tvector Transitions1;\n\tvector Transitions0;\n\t\n\tphfract.resize(phnames.size(),0.);\n\tstring root;\n\tTransitions1.push_back(TK_start);\n\t\n\t\n\t//c_no_ph_creation();\n\troot= \"CEQ_\";\n\tstring Ceq_Name=root;\n\t\n\tif (PARALLEL>0) {\n\t\n\tfor (int i=Store_Equilibria.size(); i Phase_transitions_mixture;\n\tbool status_ok=true;\n\tfor (size_t k=0; (k0) first_iteration=false;\n\t\tTransitions0.resize(0);\n\t\tfor (size_t i=0;i &el_reduced_names, const vector &phnames, void *ceq,vector &W,const double &target_delta_f_liq,\n\t\t\t\t\tconst 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)\n{\n\t\n\tvector< vector > elfract;\n\tvector phfract_old;\n\tvector phfract;\n\tvector phfract_cum;\n\telfract.resize(phnames.size(),vector(el_reduced_names.size(),0.));\n\tphfract_old.resize(phnames.size(),0.);\n\tphfract.resize(phnames.size(),0.);\n\tphfract_cum.resize(phnames.size(),0.);\n\tvector TransitionsT;\n\tvector TransitionsFl;\n\tvector Phase_transitions_mixture;\t\n\tstring my_compo_unit(\"X\");\n\tchar tab = '\\t';\n\tvector XLiq;\n\tXLiq.resize(el_reduced_names.size(),0.);\n\tvector XLiq_ini;\n\tXLiq_ini.resize(el_reduced_names.size(),0.);\n\tvector XssCastAt;\n\tXssCastAt.resize(el_reduced_names.size(),0.);\n\tdouble fsol_cum=0;\n\tdouble fLiq=1.0;\n\tdouble d_T=delta_T_min;\n\tint iLiq=0;\n\tint iSol=0;\n\tint i_error=0;\n\tbool phase_found=false;\n\tfor (int i=0;i5e-4)and(j_error<10)){\n\t\tfor (int i=0;i0){\n\t\t\t\t\n\t\t\t\tfor (int i=0;i0){\n\t\t\t\t\tfor (int i=0;i0){\n\t\t\tsout<<\"TK= \"<0) XssCastAt[i]+=fsolid*elfract[iSol][i];\n\t\t\t\t\tif (not i==i_ref) {\n\t\t\t\t\t\tdouble value=(XLiq[i]-phfract[iLiq]*elfract[iLiq][i])/(1.0-phfract[iLiq]);\n\t\t\t\t\t\tif (value<1e-8) value=1e-8;\n\t\t\t\t\t\tgradientOut<1e-6){\n\t\t\t\t\t\t\tgradientOut<0)){\n\t\t\t\t\t\tphfract_cum[j]+=phfract[j]*fLiq;\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\t\n\t\t\t\tfLiq*=phfract[iLiq];\n\t\t\t}\n\t\t\tbool transition_detected=false;\n\t\t\tfor (size_t j=0; j1e-8)&&(phfract[j]>1e-8))){\n\t // a transition has been detected\t\t\t\n\t //\t\t\tsout<<\"********transition at: \"<0) {\n\t\t\t\t\t\t\tif (not first_phase) Phase_transitions_mixture.back()+=\" + \";;\n\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\tfirst_phase=false;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\t\t\t\t\n\t\t\t\t}\n\t\t\t}\n\t\t\tif (phfract[iLiq]>target_delta_f_liq) {\n\t\t\t\td_T*=1.05;\n\t\t\t\tif (d_T>delta_T_max) d_T=delta_T_max;\n\t\t\t}\n\t\t\tif (phfract[iLiq]0){\n\t\tsout<<\" concentrations left in \"<0)){\n\t\t\tsout<<\"fat(\"<0)){\n\t\t\tfile<1e-10) file< &phnames,const vector &Suspended_phase_list){\n\tbool phase_found=false;\n\tint i_LIQ=0;\n\tvector< double > phfract;\n\tphfract.resize(phnames.size(),0.);\n\tTK=0;\n\t\n\tfor (int i=0;itemperature_accuracy)and (iter<=iter_max)){\n\t\t\n\t\tvalueT+=step_T;\n\t\tSetTemperature(valueT, &ceq);\n\t\tSafer_CalculateEquilibrium (ceq,NOGRID,i_error,Suspended_phase_list,strLIQUID,strSOLIDSOLUTION,phnames);\n\t\t/*CalculateEquilibrium(&ceq,NOGRID,i_error,Suspended_phase_list); \n\t\tif (i_error>0){\n\t\t\tfor (int i=0;i0){\n\t\t\tfor (int i=0;itargeted_fraction) and (step_T>0)) step_T=-fabs(step_T)/2.;\n\t\tif ((Fliter_max) i_error=1000;\n\t\n\tif (i_error==0){\n\t\tTK=valueT;\n\t}\n\telse{\n\t\tsout<<\"not converged\"<scheil.exe input.txt\nDEFINE_OUTPUT_FILE_NAME name of the log file\n\n********************************************************************************\n*****************************\n\n Open CalPhad Software Interface July 2016\n Computation performed on: 4 November 2016 , 22h:14mn:50s\n\n********************************************************************************\n*****************************\n\nTDB_FILE_NAME name of the thermodynamic data file\n\n TDB_FILE_NAME cost507r.tdb\n\n the following elements are in the database:\n AL / B / C / CE / CR / CU / FE / LI / MG / MN / N / ND / NI / SI / SN / TI / V\n/ Y / ZN / ZR /\nDEFINE_REF_ELEMENT\n DEFINE_REF_ELEMENT AL\nDEFINE_LIQUID_NAME\n DEFINE_LIQUID_NAME LIQUID\nDEFINE_SOLSOL_NAME\n DEFINE_SOLSOL_NAME FCC_A1\nDEFINE_UNIT_COMPO_INPUT\n DEFINE_UNIT_COMPO_INPUT W%\nDEFINE_UNIT_TEMP_INPUT C or K\n DEFINE_UNIT_TEMP_INPUT C\nDEFINE_NCPU<8>\n DEFINE_NCPU 8\nDEFINE_COMPOSITION\n DEFINE_COMPOSITION tqini created: DEFAULT_EQUIL\nIBRIUM\nMG=5/SI=1\nMG=5/SI=1\nreading phases\n list of possible phases in the system :\n LIQUID AL12MG17 AL5FE4 ALCU_THETA ALLI ALMG_BETA ALMG_DZETA ALMG_UPSILON ALTI A\nLTI3 BCC_A2 BCC_B2 BCT_A5\n CBCC_A12 CR3SI_A15 CRSI2 CUB_A13 DIAMOND_A4 FCC_A1 HCP_A3 LAVES_C15 MG24Y5 MG2S\nI MGY_GAMMA SIV3\nLIQUIDUS<>\n LIQUIDUS\n* ----> liquidus is: 629.716 C\n\nSOLIDUS<>\n SOLIDUS\n* ----> solidus is: 587.599 C\n\nCOMPUTE_TRANSITION_TEMPERATURES<1100.0/400.0/0.0010000/20 >\n COMPUTE_TRANSITION_TEMPERATURES 1100.0 / 400.0 / 0.0010000 /\n20\nfirst convergence issue\n======================================================================\n TQ Parallel: Yes / number of threads: 8\n Here are the transition temperatures that have been found\n in the temperature range [400,1100] C\n for the following composition:\n 0 629.72 LIQUID +\n 1 629.715 LIQUID + FCC_A1\n 2 592.104 LIQUID + FCC_A1 + MG2SI\n 3 587.591 FCC_A1 + MG2SI\n\nStore_Equilibria.size()=21\n elapsed time for the transition temperature routine (s)= 0.3205\n\n\nCOMPUTE_EQUILIBRIUM<500/3>\n COMPUTE_EQUILIBRIUM 500 / 3\n\n Equilibrium at: 500 C fat% FCC_A1=97.1874 MG2SI=2.81263\n MU(AL)= -28943.8\n MU(MG)= -47677.9\n MU(SI)= -44984.1\n ---------------------------------------\n FCC_A1\n ---------------------------------------\n AL = 96.5871 (W%)\n MG = 3.3932 (W%)\n SI = 0.0196668 (W%)\n ---------------------------------------\n MG2SI\n ---------------------------------------\n MG = 63.3809 (W%)\n SI = 36.6191 (W%)\n\nLIQUIDUS<>\n LIQUIDUS\n* ----> liquidus is: 629.716 C\n\nSCHEIL_SOLIDIFICATION\n SCHEIL_SOLIDIFICATION castcompoS0001.txt / 0.99500\n/ 1.0 / 0.1\nfirst convergence issue\n!!!!!!!! convergence issue !!!!!!!!!!!!!!!!!!!!!\n Error setting condition: T= 0.20000000E+04 2\nError code 4204 reset before calling grid minimizer\n3Y Gridmin: 263 points 0.00E+00 s and 0 clockcycles, T= 722.87\nPhases: 6 1 0.91 19 1 0.09 23 1 0.00\n------------------------------------------\n starting composition in at :\nAL = 0.935217 at\nMG = 0.0552247 at\nSI = 0.00955838 at\n------------------------------------------\n concentrations left in FCC_A1 after Scheil solidification:\nAL = 0.966794 at\nMG = 0.0320182 at\nSI = 0.00118751 at\n------------------------------------------\n Phases formed after Scheil solidification:\nfat(ALMG_BETA)=0.0203004\nfat(FCC_A1)=0.954425\nfat(MG2SI)=0.025275\n------------------------------------------\n======================================================================\n Here are the transition temperatures that have been found\n during a Scheil solidification simulation\n 0 627.716 C FL= 0.915013 LIQUID + FCC_A1\n 1 590.716 C FL= 0.300997 LIQUID + FCC_A1 + MG2SI\n 2 449.716 C FL= 0 ALMG_BETA + FCC_A1 + MG2SI\n end of solidification: 449.716\n\n elapsed time for the scheil solidification routine (s)= 0.640501\n\nC:\\Users\\...\\TQ4lib\\Cpp\\Scheil>\n\\end{verbatim}}\n\n\\end{document}\n\n" }, { "path": "examples/TQ4lib/Cpp/Scheil/tqintf.h", "content": "//define PARALLEL 0 no loop with parallelization\n//define PARALLEL 1 declared loops with parallelization\n#define PARALLEL 1\n#define OCVERSION \"Open Calphad TQ v3.0 beta\"\n#define MAXEL 41\n#define MAXPH 501\n#define PHFIXED 2\n#define PHENTERED 0\n#define PHSUS -3\n#define GRID 0\n#define NOGRID -1\n#define TCtoTK 273.15\n#define TAB \"\\t\"\n#define R 8.31451\n\n\n\n#include \"octqc.h\"\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include\n#include \n\nextern\"C\"\n{\n\tvoid c_Change_Status_Phase(char *, int ,double ,void *);\n\tvoid c_tqgetv(char *, int , int , int *, double *, void *); // get equilibrium results using state variables\n void c_tqsetc(char *, int, int , double, int *, void *); // set condition\n\tvoid c_tqce(char *, int , int , double *, void *); // calculate quilibrium with possible target\n\tvoid c_tqini(int, void *); // initiates the OC package\n \n\tvoid c_tqrfil(char *, void *); // read all elements from a TDB file\n //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements\n void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements\n //void c_tqgnp(int *, void **); // get total number of phases and composition sets\n void c_tqgpi(int *, char *, void *); // get index of phase phasename\n\tvoid c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx\n //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets\n void examine_gtp_equilibrium_data(void *); //\n //void c_getG(int, void *);\n //void c_calcg(int, int, int, int, void *);\n void c_tqgphc1(int, int * , int *, int *, double *, double *, double *,\n void *);\n void c_tqsphc1(int, double *, double *, void *);\n void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *);\n\t\n\tvoid c_List_Conditions(void *);\n\tvoid c_checktdb(char *);\n\tvoid c_newEquilibrium(char *,int *);\n\tvoid c_selecteq(int ,void *);\n void c_copy_equilibrium(void *,char *,void *);\n\tvoid c_set_status_globaldata();\n\tint c_errors_number();\n\tvoid c_new_gtp();\n\tvoid c_reset_conditions(char *,void *);\n}\n\nextern\"C\" int c_ntup; //\nextern\"C\" int c_nel; // number of elements\nextern\"C\" int c_maxc; //\nextern\"C\" char *c_cnam[MAXEL]; // character array with all element names\nextern\"C\" double c_gval[24];\nextern\"C\" int c_noofcs(int);\nextern\"C\" double c_mass[24];\n\nusing namespace std;\n\n\nvoid Get_Ceq(const int &iceq,void *ceq){\n\tc_selecteq(iceq,ceq);\n\t//cout << \"-> Adress of ceq-Storage: [\" << ceq << \"]\" < Adress of ceq-Storage: [\" << ceq << \"]\" < Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n cout << c_cnam[i];\n if(i < c_nel-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" < &elnames, void *ceq)\n{\n\tchar *buffer=(char*)malloc(tdbfilename.length()+1);\n char *filename = strcpy(buffer, tdbfilename.c_str());\n char *selel[elnames.size()];\n for(size_t i = 0; i < elnames.size(); i++)\n {\n\t\tchar *buffer=(char*)malloc(elnames[i].length()+1);\n char *tempchar\n = strcpy(buffer, elnames[i].c_str());\n selel[i] = tempchar;\n }\n\t\n //==============================================\n c_tqrpfil(filename, elnames.size(), selel, ceq);\n //==============================================\n/*\n cout << \"-> Element Data: [\";\n for(int i = 0; i < c_nel; i++)\n {\n cout << c_cnam[i];\n if(i < c_nel-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << \" [\" << &ceq << \"]\" <<\n endl;\n*/\n\tfree (buffer);\n};\n\nvoid ReadPhases(vector &phnames, void *ceq)\n{\n phnames.clear();\n\tphnames.resize(c_ntup);\n\t\n\n for(int i = 1; i < c_ntup+1; i++)\n {\n char phn[24];\n\n //==========================\n c_tqgpn(i, phn, ceq);\n //==========================\n\t\t\n \n\t\tint index;\n\t\tc_tqgpi(&index,phn,ceq);\n\t\tstring myname(phn);\n\t\ttransform(myname.begin(), myname.end(), myname.begin(), ::toupper);// to have it in CAPITAL LETTERS\n\t\tphnames[index-1]=myname;\n }\n/*\n cout << \"-> Phase Data: [\";\n for(size_t i = 0; i < phnames.size(); i++)\n {\n cout << i<< \" \"< &el_reduced_names,const int &i_ref, const string &compo_unit){\n\t{\n\t\tstring mystring(\"T=none\");\n\t\tchar *buffer=(char*)malloc(mystring.length()+1);\n\t\tchar *conditions = strcpy(buffer, mystring.c_str());\n\t\tc_reset_conditions(conditions,ceq);\n\t\tfree (buffer);\n\t}\n\tstring mystring=\"\";\n\tfor (int i=1;i Set Temperature to: [\" << T << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n \n \n};\n\nvoid SetPressure(const double &P, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"P\";\n // if (P < 1.0) P = 1.0;\n\n //=========================================\n c_tqsetc(par, n1, n2, P, &cnum, ceq);\n //=========================================\n\n// cout << \"-> Set Pressure to: [\" << P << \"]\" << \" [\" << &ceq << \"]\" <<\n// endl;\n};\n\nvoid SetMoles(const double &N, void *ceq)\n{\n int cnum;\n int n1 = 0;\n int n2 = 0;\n char par[60] = \"N\";\n\n //=========================================\n c_tqsetc(par, n1, n2, N, &cnum, ceq);\n //=========================================\n\n // cout << \"-> Set Moles to: [\" << N << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n};\n\nvoid SetComposition(vector& X, void *ceq, const int &i_ref,string &compo_unit)\n{\n int cnum;\n\n int n2 = 0;\n\n \n\t\n char par[60];\n strcpy(par,compo_unit.c_str());\n \n for (int i = 0; i < c_nel; i++)\n {\n if (X[i] < 1.0e-8) X[i] = 1.0e-8; // Check and fix, if composition is below treshold\n\n if(not (i == i_ref))\n { \n\t\t\tint j=i+1;\n\t\t\tdouble value= X[i];// Set and print composition, if element 'i' is not the reference/(last) element\n //==================================================\n c_tqsetc(par, j, n2,value, &cnum, ceq);\n //==================================================\n\n // cout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n // X[i] << \"]\" << \" [\" << &ceq << \"]\" <<\n // endl;\n }\n else\n { // Print composition, if element 'i' is the reference/(last) element\n double X_ref = 1;\n for(size_t j = 0; j < i; j++)\n {\n X_ref -= X[j];\n }\n\n// cout << \"-> Set Composition of \" << c_cnam[i] << \" to: [\" <<\n// X_ref << \"]\" << \" [\" << &ceq << \"]\" <<\n// endl;\n }\n }\n};\n\nvoid SetConstituents(int phidx, vector y, void *ceq)\n{\n int stable1 = phidx;\n double extra[MAXPH];\n double yfr[y.size()];\n for(size_t i = 0; i < y.size(); i++)\n {\n yfr[i] = y[i];\n }\n\n //===============================\n c_tqsphc1(stable1,yfr,extra,ceq);\n //===============================\n\n cout << \"-> Set Constituents to: [\";\n for(int i = 0; i < y.size(); i++)\n {\n cout << i << \": \" << yfr[i];\n if(i < y.size()-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n};\n\n\nvoid SelectSinglePhase(int PhIdx, void *ceq)\n{\n //\n};\nvoid List_Conditions(void *ceq){\n\tc_List_Conditions(ceq);\n}\nvoid CalculateEquilibrium(void *ceq, const int &n1, int &i_error, const vector < string > &Suspended_phase_list)\n{\n\t\n\tfor (int i=0;i Read Gibbs Data G: [\";\n for(int i = 0; i < 6; i++)\n {\n cout << gtp[i];\n if(i < 5)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data dGdY: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << dgdy[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdT: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << d2gdydt[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n cout << \"-> Read Gibbs Data d2GdYdP: [\";\n for(int i = 0; i < n3; i++)\n {\n cout << d2gdydp[i];\n if(i < n3-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n\n int kk=n2*(n2+1)/2;\n\n cout << \"-> Read Gibbs Data d2GdY2: [\";\n for(int i = 0; i < kk; i++)\n {\n cout << d2gdy2[i];\n if(i < kk-1)\n {\n cout << \", \";\n }\n }\n cout << \"]\" << endl;\n};\n\nvoid ReadPhaseFractions(const vector &phnames, vector& phfract,\n void *ceq)\n{\n double npf[MAXPH];\n char statevar[60] = \"NP\";\n\t\n int n1 = -1;//-1\n int n2 = 0;\n int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]);\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\t\n for(int i = 0; i < phnames.size(); i++){\n\t/*\n\tchar phn[24];\n\tc_tqgpn(i+1, phn, ceq);\n\tsize_t index=0;\n\t\tfor (size_t j=0;j &MU)\n{\n double npf[1];\n char statevar[60] = \"MU\";\n \n\t for (int i = 1; i < c_nel+1; i++)\n {\n\t\tint n1 = i;\n\t\tint n2 = 0;\n\t\tint n3 = 1;\n\t\t//========================================\n\t\tc_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n\t\t//========================================\n\n\t\t\n\t\tMU[i-1]=npf[0];\n\t\t\n\t}\n};\ndouble ReadTemperature(void *ceq)\n{\n double npf[1];\n char statevar[60] = \"T\";\n int n1 = 0;\n int n2 = 0;\n int n3 = 1;\n\tdouble TK;\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\n \n TK=npf[0];\n\treturn(TK);\n};\ndouble ReadTotalEnthalpy(void *ceq)\n{\n double npf[1];\n char statevar[60] = \"H\";\n int n1 = 0;\n int n2 = 0;\n int n3 = 1;\n\tdouble H;\n\n //========================================\n c_tqgetv(statevar, n1, n2, &n3, npf, ceq);\n //========================================\n\n\n H=npf[0];\n\treturn(H);\n};\nvoid ReadConstituentFractions(const vector &phnames, const vector &phfract,\n vector< vector > &elfract, void *ceq, const string &compo_unit)\n{\n \n \n\t\n double pxf[10*MAXPH];\n for (int i = 1; i < c_ntup+1; i++)\n {\n\t\tchar phn[24];\n\t\tc_tqgpn(i, phn, ceq);\n\t\tsize_t index=0;\n\t\tfor (size_t j=0;j 1e-10)\n {\n char statevar[60] = \"X\";\n\t\t\tstrcpy(statevar,compo_unit.c_str());\n\n int n2 = -1; //composition of stable phase n2 = -1 means all fractions\n int n4 = sizeof(pxf)/sizeof(pxf[0]);\n\n //=======================================\n c_tqgetv(statevar, i, n2, &n4, pxf, ceq);\n //=======================================\n\t\t\t\n for (int k = 0; k < n4; k++)\n {\n\t\t\t\n elfract[index][k]=pxf[k];\n\t\t\t\t\n }\n\t\t\t\n\t\t\t\n // cout << \"-> Constituent Fractions for \" << phnames[i-1] <<\" [\";\n\t\t\t//cout << \"-> Constituent Fractions for \" << phnames[index]<<\" [\";\n for (int k = 0; k < n4; k++)\n {\n //cout << c_cnam[k] << \": \" << elfract[index][k];\n if(k < n4-1)\n {\n // cout << \", \";\n }\n }\n //cout << \"]\" << \" [\" << &ceq << \"]\" < phnames, void *ceq)\n{\n int stable1 = phidx;\n int nlat;\n int nlatc[MAXPH];\n int conlista[MAXPH];\n double yfr[MAXPH];\n double sites[MAXPH];\n double extra[MAXPH];\n\n //======================================================================\n c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq);\n //======================================================================\n\n cout << \"-> Extended Constituent Fractions for \" << phnames[stable1-1]\n << \" [\" << extra[0] << \" moles of atoms/formula unit]\";\n int consti = 0;\n for(int i = 0; i < nlat; i++)\n {\n cout << \" [\";\n for(int j = 0; j < nlatc[i]; j++)\n {\n cout << \"Const. \" << consti << \": \" << yfr[consti];\n if(j < nlatc[i]-1)\n {\n cout << \", \";\n }\n consti += 1;\n }\n cout << \"]_(\" << sites[i] << \")\";\n }\n cout << endl;\n};\n\nstd::string IntToString ( int number )\n{\n\tstd::string mystr;\n\tstd::stringstream out;\n\tout << number;\n\tmystr = out.str();\n return mystr;\n}\n// Write the results of a given equilibrium\n// el_reduced_names: vector of names elements with non zero composition\n// phnames: vector of names phases that can appear for these elements\n// phfract: atomic fraction of these phases after equilibrium\n// elfract[i][j]: atomic composition of element i in phase j\n// ceqh: pointer for the given equilibrium calculation\n// mode: 1 write only atomic fractions of phases after equilibrium\n// mode: 1 write atomic fractions + compositions of phases after equilibrium\n\nvoid Write_Results_Equilibrium(ofstream& file, const vector &el_reduced_names, const vector &phnames, vector &phfract, \n\t\t\t\t\t\t vector< vector > &elfract, void *ceqh,const int &mode,const string &compo_unit, vector &MU){\n\t\n\t//-------------------------------List Results-------------------------------\n\t\n\tReadPhaseFractions(phnames, phfract, &ceqh); // Read the amount of stable phases\n\t\n\tif (mode >1) ReadConstituentFractions(phnames, phfract, elfract, &ceqh, compo_unit); // Read the composition of each stable phase\n\t\n\tdouble TC=ReadTemperature(&ceqh)-TCtoTK;\n\t\n\tcout<0){\n\t\t\tcout<<\" \"<2) {\n\t\tReadMU(&ceqh, MU);\n\t\tfor (size_t j=0; j1) {\n\t\tfor (size_t i=0; i0){\t\t\n\t\t\t\n\t\t\t\tcout<<\" --------------------------------------- \"<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){\t\t\t\t \n\t\n\tint iceq=0;\n\tvector phfract;\n\tphfract.resize(phnames.size(),0.);\n\t\n\tvector< vector > elfract; // Array including all equilibrium compositions\n\telfract.resize(phnames.size(),vector(el_reduced_names.size(),0.));\n\t\n\t\n\t\n\t\n\t\n\tvector TKCE;\n\tvector< vector > CeqFract;\n\t\n\tTKCE.resize(0);\n\tCeqFract.resize(0);\n\tdouble TK_end=TK_start+(nstep-1)*step_TK;\n\tdouble TK=TK_start;\n\tint nstep_total=nstep;\n\tif (not first_iteration) nstep_total+=1;\n\tfor (int i=0; i(phnames.size(),0.));\n \n \n\tsize_t max_number_of_phase=0;\n// the three lines below trigger parallelism for the nex for {....} loop if PARALLEL is not 0\n \n//\tcout<<\"number of threads detected:\"<0\n#pragma omp parallel for default(none), schedule(dynamic), shared(TKCE,W,Store_Equilibria, el_reduced_names,phnames,phfract,CeqFract,Suspended_phase_list)\n#endif\t \n\tfor (int i=0; i0)) {\n\t\t\n\t\t\tc_selecteq(Store_Equilibria[i], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\n\t\t}else{\n\t//\t\tceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\tc_selecteq(1, &ceqi);\n\t\t}\n\t\t\n\t\tfor (int k=0;k0) CeqFract[i][j]=phfract[j];\n\t\t}\n \n\t}\n/*\t\n\tfor (int i=0; i\"<\"<0) cout<<\" \"<1e-8)&&(CeqFract[i+1][j]>1e-8)))\n\t\t\t{\n // a transition has been detected\t\t\t\n //\t\t\tcout<<\"********transition at: \"<0) {\n\t\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=\" + \";\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t\t\n\t\t\t\t\tTransitions.push_back(TKCE[i+1]);\n\t\t\t\t\tPhase_transitions_mixture.push_back(\"\");\n\t\t\t\t\tbool first_phase=true;\n\t\t\t\t\tfor (size_t k=0; k0) {\n\t\t\t\t\t\t\tif (not first_phase) Phase_transitions_mixture.back()+=\" + \";;\n\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\tfirst_phase=false;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\t\n\t\t\t\tj=phnames.size()+1;// exit the loop \n\t\t\t}\n\t\t}\n\t}\n}\n\n// ***************************************************************************************************************\n// find all the transitions temperatures for a given alloy composition\n// step_TK: first interval of temperature used\n// n_step : number of steps set to NSTEP\n// between TK_start and TK_end=TK_start+(n_step-1)*step_TK;\n// required_accuracy_on_TK: self explanatory\n// W : weight composition of elements\n// phnames: vector of names phases that can appear for these elements\n// el_reduced_names: vector of names elements with non zero composition\n// ceq: pointer for the given equilibrium calculation used to pass the standart equilibrium in non parallel computation\n// parallelization option is in Find_Transitions\n// see Find_Transitions for comments on parallelization\n\nvoid 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){\t\t\t\t \n\tstring mycompo_unit=compo_unit;\n\tdouble TK_end_ini, TK_start_ini;\n\tTK_start_ini=TK_start;\n\tTK_end_ini=TK_end;\n//\tcout<<\"sntep=\"< phfract;\n\tvector Transitions1;\n\tvector Transitions0;\n\t\n\tphfract.resize(phnames.size(),0.);\n\tstring root;\n\tTransitions1.push_back(TK_start);\n\t\n\t\n\t//c_no_ph_creation();\n\troot= \"CEQ_\";\n\tstring Ceq_Name=root;\n\t\n\tif (PARALLEL>0) {\n\t\n\tfor (int i=Store_Equilibria.size(); i Phase_transitions_mixture;\n\tfor (size_t k=0; k0) first_iteration=false;\n\t\tTransitions0.resize(0);\n\t\tfor (size_t i=0;i0) 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){\t\n\t\n\tstring mycompo_unit=compo_unit;\t\n\tvector< vector< double> > LISTCOMPO;\n\tvector< double> LISTTK;\n\tvector Wrand;\n\tWrand.resize(W_ini.size(),0.);\n\tint total_number_of_errors=0;\n\tstring root= \"CEQ_\";\n\tstring Ceq_Name=root;\n\t\n\t\n\tint number_of_loops=64;\n\tint jter_print=0;\n\t\n\n//\tif (PARALLEL==0) number_of_loops=1;\n\t\n\tLISTCOMPO.resize(number_of_loops,vector(W_ini.size(),0.));\n\tLISTTK.resize(number_of_loops,0.);\n\n\tcout<<\"number of threads detected:\"<0) {\n\t\tint iceq;\n\t\tfor (int i=Store_Equilibria.size(); i0\n#pragma omp parallel for \n#endif\n\t\tfor (int k=0; k0)) {\n\t\t\t\tc_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\t\n\t\t\t}else{\n\t\t//\t\tceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\t\tc_selecteq(1, &ceqi);\n\t\t\t}\n\t\t\tSetComposition(LISTCOMPO[k], &ceqi, i_ref,mycompo_unit);// Set the composition when ceqi is created\n\t\t\t\n\t\t\t\n\t\t}\n/*\n#if PARALLEL>0\n#pragma omp parallel for \n#endif\n\t\tfor (int k=0; k0)) {\n\t\t\t\tc_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\t\n\t\t\t}else{\n\t\t//\t\tceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\t\tc_selecteq(1, &ceqi);\n\t\t\t}\n\t\t\t\n\t\n\t\t\tint i_error=0;\t\n\t\t\tCalculateEquilibrium(&ceqi,NOGRID,i_error,Suspended_phase_list);\n\t\t\tif (not(i_error==0)){\n\t\t\t\tcout<<\" equilibrium calculation not converged in transition subroutine for the following conditions\"<0)) {\n\t\t\t\tc_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\t\n\t\t\t}else{\n\t\t//\t\tceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\t\tc_selecteq(1, &ceqi);\n\t\t\t}\n\t\t\t\n\t\t\tSetTemperature(LISTTK[k], &ceqi); // set temperature for specific equilibrium\n//\t\t\tfor (int i=0;i0\n#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)\n#endif\t \n\t\tfor (int k=0; k0)) {\n\t\t\t\tc_selecteq(Store_Equilibria[k], &ceqi);// retrieve the pointer with index stored in Store_Equilibria\n\t\t\t\t\n\t\t\t}else{\n\t\t//\t\tceqi=ceq;// if no parallelization use STANDART EQUILIBRIUM\n\t\t\t\tc_selecteq(1, &ceqi);\n\t\t\t}\n\t\t\t\n\t\n\t\t\tint i_error=0;\n\t\t\t\n\t\t\t\n\t\t\t\n\t\t\tCalculateEquilibrium(&ceqi,NOGRID,i_error,Suspended_phase_list); // perform an equilibrium calculation\n\t\t\t\n\t\t\t\n\t\t\tif (not(i_error==0)){\n\t\t\t\t\n\t\t\t\tdouble TK=LISTTK[k]-1;\n\t\t\t\tSetTemperature(TK, &ceqi); // set temperature for specific equilibrium\n\t\t\t\tCalculateEquilibrium(&ceqi,GRID,i_error,Suspended_phase_list); // perform an equilibrium calculation\n\t\t\t\tif (i_error==0) {\n\t\t\t\t\t//cout<<\" case fixed\"<199) {\n\t\t\tcout<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,\n\t\t\t\t\tconst 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)\n{\n\t\n\tvector< vector > elfract;\n\tvector phfract_old;\n\tvector phfract;\n\telfract.resize(phnames.size(),vector(el_reduced_names.size(),0.));\n\tphfract_old.resize(phnames.size(),0.);\n\tphfract.resize(phnames.size(),0.);\n\tvector TransitionsT;\n\tvector TransitionsFl;\n\tvector Phase_transitions_mixture;\t\n\tstring my_compo_unit(\"X\");\n\tchar tab = '\\t';\n\tvector XLiq;\n\tXLiq.resize(el_reduced_names.size(),0.);\n\tdouble fLiq=1.0;\n\tdouble d_T=delta_T_min;\n\tint iLiq=0;\n\tint iSol=0;\n\tint i_error=0;\n\tbool phase_found=false;\n\tfor (int i=0;i5e-4)and(j_error<10)){\n\t\tfor (int i=0;i0){\n\t\t\td_T=delta_T_min;\n\t\t\n\t\t\tj_error+=1;\n\t\t\t//cout<<\"TK=\"<1e-8)&&(phfract[j]>1e-8))){\n\t // a transition has been detected\t\t\t\n\t //\t\t\tcout<<\"********transition at: \"<0) {\n\t\t\t\t\t\t\tif (not first_phase) Phase_transitions_mixture.back()+=\" + \";;\n\t\t\t\t\t\t\tPhase_transitions_mixture.back()+=phnames[k];\n\t\t\t\t\t\t\tfirst_phase=false;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\t\t\t\t\n\t\t\t\t}\n\t\t\t}\n\t\t\tif (phfract[iLiq]>target_delta_f_liq) {\n\t\t\t\td_T*=1.15;\n\t\t\t\tif (d_T>delta_T_max) d_T=delta_T_max;\n\t\t\t}\n\t\t\tif (phfract[iLiq] &phnames,const vector &Suspended_phase_list){\n\tbool phase_found=false;\n\tint i_LIQ=0;\n\tvector< double > phfract;\n\tphfract.resize(phnames.size(),0.);\n\tTK=0;\n\t\n\tfor (int i=0;itemperature_accuracy)and (iter<=iter_max)){\n\t\t\n\t\tvalueT+=step_T;\n\t\tSetTemperature(valueT, &ceq);\n\t\tCalculateEquilibrium(&ceq,NOGRID,i_error,Suspended_phase_list); \n\t\tif (i_error==0){\t\n\t\t\tReadPhaseFractions(phnames, phfract, &ceq);\n\t\t\tFl=phfract[i_LIQ];\n\t\t\t\n\t\t}\n\t\telse{\n\t\t\titer=iter_max+1;\n\t\t}\n\t\t\n\t\tif ((Fl>targeted_fraction) and (step_T>0)) step_T=-fabs(step_T)/2.;\n\t\tif ((Fliter_max) i_error=1000;\n\t\n\tif (i_error==0){\n\t\tTK=valueT;\n\t}\n\telse{\n\t\tcout<<\"not converged\"<firsteq\n write(*,*)'tqini created: ',ceq%eqname\n1000 continue\n return\n end subroutine tqini\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqrfil(filename,ceq)\n! read all elements from a TDB file\n implicit none\n character*(*) filename ! IN: database filename\n character ellista(10)*2 ! dummy\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim} %+\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n! second argument 0 means ellista is ignored, all element read\n call readtdb(filename,0,ellista)\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store the element name in the cname array\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n cmass(iz)=a1\n enddo\n! store phase tuples\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrfil\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqrpfil(filename,nsel,selel,ceq)\n! read TDB file with selection of elements\n implicit none\n character*(*) filename ! IN: database filename\n integer nsel\n character selel(*)*2 ! IN: elements to be read from the database\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n!\n call readtdb(filename,nsel,selel)\n if(gx%bmperr.ne.0) goto 1000\n! is this really necessary??\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store element name in module array components\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n enddo\n! store phase tuples and indices\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrpfil\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgcom(n,compnames,ceq)\n! get system component names. At present the elements\n implicit none\n integer n ! EXIT: number of components\n character*24, dimension(*) :: compnames ! EXIT: names of components\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*24,refs*24\n double precision a1,a2,a3\n do iz=1,nel\n compnames(iz)=' '\n call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3)\n! store name in module array components also (already done when reading TDB)\n cnam(iz)=compnames(iz)\n enddo\n n=nel\n1000 continue\n return\n end subroutine tqgcom\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnp(n,ceq)\n! get total number of phase tuples (phases and composition sets)\n! A second composition set of a phase is normally placed after all other\n! phases with one composition set\n implicit none\n integer n !EXIT: n is number of phases\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n! NOTE the number composition sets may change at a calculation or if new\n! composition sets are added or deleted explicitly\n! This changes the number of phase tuples!\n ntup=nooftup()\n n=ntup\n1000 continue\n return\n end subroutine tqgnp\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpn(phtupx,phasename,ceq)\n! get name of phase tuple with index phtupx (ceq redundant)\n implicit none\n integer phtupx ! IN: index in phase tuple array\n character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call get_phasetup_name(phtupx,phasename)\n1000 continue\n return\n end subroutine tqgpn\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpi(phtupx,phasename,ceq)\n! get index of phase phasename (including comp.set (ceq redundant)\n implicit none\n integer phtupx !EXIT: phase tuple index\n character phasename*(*) !IN: phase name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call find_phasetuple_by_name(phasename,phtupx)\n1000 continue\n return\n end subroutine tqgpi\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcn2(n,c,constituentname,ceq)\n! get name of consitutent with index c in phasetuple n\n! NOTE An identical routine with different constituent index is tqgpcn\n implicit none\n integer n !IN: phase number (not phase tuple)\n integer c !IN: constituent index sequentially over all sublattices\n character constituentname*(24) !EXIT: costituent name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n double precision mass\n call get_constituent_name(n,c,constituentname,mass)\n! write(*,*)'tqgpcn not implemented yet'\n! gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcn2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpci(n,c,constituentname,ceq)\n! get index of constituent with name in phase n\n implicit none\n integer n !IN: phase index\n integer c !IN: sequantial constituent index over all sublattices\n character constituentname*(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpci not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpci\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcs(n,c,stoi,mass,ceq)\n! get stoichiometry of constituent c in phase n \n!? missing argument number of elements????\n implicit none\n integer n !IN: phase number\n integer c !IN: sequantial constituent index over all sublattices\n double precision stoi(*) !EXIT: stoichiometry of elements \n double precision mass !EXIT: total mass\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpcs not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcs\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq)\n! get stoichiometry of component n1\n! n2 is number of elements (dimension of elnames and stoi)\n implicit none\n integer n1 !IN: component number\n integer n2 !EXIT: number of elements in component\n character elnames(*)*(2) ! EXIT: element symbols\n double precision stoi(*) ! EXIT: element stoichiometry\n double precision mass ! EXIT: component mass (sum of element mass)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgccf not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgccf\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnpc(n,c,ceq)\n! get number of constituents of phase n\n implicit none\n integer n !IN: Phase number\n integer c !EXIT: number of constituents\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgnpc not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgnpc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpsm(n,phases,status,amdgm,ceq)\n! get all phase names and their status and amounts or DGM\n integer n\n character phases(*)*24\n integer status(*)\n double precision amdgm(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer i\n character dummy*64,statevar*64\n n=nooftup()\n! phasetuple: lokph,compset,ixphase,lokvares,nextcs\n do i=1,n\n call get_phasetup_name(i,phases(i))\n! the status is in phase_varres record, THIS IS NOT PRIVATE\n! phastate values: 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended\n status(i)=ceq%phase_varres(phasetuple(i)%lokvares)%phstate\n! if status 0 or less the phase is not stable, extract DGM\n if(status(i).le.0) then\n statevar='DGM('//trim(phases(i))//')'\n call get_state_var_value(statevar,amdgm(i),dummy,ceq)\n else\n! this phase is stable, extract amount\n statevar='NPM('//trim(phases(i))//')'\n call get_state_var_value(statevar,amdgm(i),dummy,ceq)\n endif\n enddo\n1000 continue\n return\nend subroutine tqgpsm\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcref(cix,phase,tpref,ceq)\n! set component reference state\n integer cix\n character phase*(*)\n double precision tpref(*)\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer phtupx\n call find_phasetuple_by_name(phase,phtupx)\n if(gx%bmperr.ne.0) goto 1000\n call set_reference_state(cix,phtupx,tpref,ceq)\n1000 continue\n return\n end subroutine tqcref\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqphsts(phtupx,newstat,val,ceq)\n! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX\n integer phtupx,newstat\n double precision val\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer n\n if(phtupx.le.0) then\n! if tup<0 change status of all phases\n do n=1,ntup\n call change_phtup_status(n,newstat,val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n elseif(phtupx.le.ntup) then\n call change_phtup_status(phtupx,newstat,val,ceq)\n else\n write(*,*)'Illegal phase tuple index',phtupx\n gx%bmperr=8888\n endif\n1000 continue\n return\n end subroutine tqphsts\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsetc(stavar,n1,n2,value,cnum,ceq)\n! set condition\n! stavar is state variable as text\n! n1 and n2 are auxilliary indices\n! value is the value of the condition\n! cnum is returned as an index of the condition.\n! to remove a condition the value sould be equial to RNONE ????\n! phase index is phase tuple index (include composition set)\n! see TQGETV for doucumentation of stavar etc.\n implicit none\n integer n1 ! IN: 0 or phase tuple index or component number\n integer n2 ! IN: 0 or component number\n integer cnum ! EXIT: sequential number of this condition\n character stavar*(*) ! IN: character with state variable symbol\n double precision value ! IN: value of condition\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer ip,ip2\n character cline*60,selvar*4,cval*24\n!\n! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value\n11 format(a,a,2i5,1pe14.6)\n cline=' '\n! extract a value after an =\n ip=index(stavar,'=')\n if(ip.gt.0) then\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n!@CC\n ip2=index(stavar,'(')\n if(ip2.gt.0) then\n ip = ip2\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n endif\n!@CC\n! write(*,*)'Value after = :',cval\n else\n selvar=stavar\n cval=' '\n endif\n call capson(selvar)\n select case(selvar)\n case default\n write(*,*)'Condition wrong, not implemented or illegal: ',stavar\n gx%bmperr=8888; goto 1000\n! Potentials T and P\n case('T ','P ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n write(cline,110)selvar(1:1),value\n110 format(' ',a,'=',E15.8)\n endif\n! Total amount or amount of a component in moles\n case('N ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n if(n1.gt.0) then\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n112 format(' ',a,'(',a,')=',E15.8)\n! write(*,*)'Setting condition: ',cline(1:len_trim(cline))\n else\n write(cline,110)selvar(1:1),value\n endif\n endif\n! Overall fraction of a component \n case('X ','W ')\n! ?? fraction of phase component not implemented, n1 must be component number\n! call get_component_name(n1,cnam,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(ip.gt.0) then\n cline=' '//stavar\n else\n write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n120 format(1x,a,'(',a,')=',1pE15.8)\n endif\n case('H ','V ')\n! enthalpy or volume of system\n if(cval(1:1).eq.'=') then\n cline=' '//stavar\n else\n write(cline,130)selvar(1:1),value\n130 format(1x,a,'=',1pE15.8)\n endif\n! case ....\n! ?? MORE CONDITIONS WILL BE ADDED ...\n end select\n! write(*,*)'tqsetc condition: ',trim(cline)\n ip=1\n call set_condition(cline,ip,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip\n endif\n1000 continue\n return\n end subroutine tqsetc\n\n!@CC\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine toggle_dense_grid()\n if(btest(globaldata%status,GSXGRID)) then\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n write(*,3110)'reset'\n3110 format('Dense grid ',a)\n else\n globaldata%status=ibset(globaldata%status,GSXGRID)\n write(*,3110)'dense grid set'\n endif\n return\n end subroutine toggle_dense_grid\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqce(target,n1,n2,value,ceq)\n! calculate quilibrium with possible target\n! Target can be empty or a state variable with indices n1 and n2\n! value is the calculated value of target\n implicit none\n integer n1,n2,mode\n character target*(*)\n double precision value\n logical confirm\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer nyfas,j1,j2\n! mode=1 means start values using global gridminimization\n if(n1.lt.0) then\n! this means calculate without grid minimuzer\n mode=0\n confirm=.FALSE.\n! calcqeq3 is silent, no listing of phase changes etc.\n call calceq3(mode,confirm,ceq)\n else\n mode=1\n call calceq2(mode,ceq)\n if(gx%bmperr.eq.4204) then\n! if the error code is \"too many iterations\" try without grid minimizer\n! it converges in many cases\n! write(*,2048)gx%bmperr\n2048 format('Error ',i5,', cleaning up and trying harder')\n gx%bmperr=0\n call calceq2(0,ceq)\n endif\n endif\n if(gx%bmperr.ne.0) goto 1000\n! there may be new composition sets, update ntup\n! write(*,*)'Number of phase tuples: ',ntup\n nyfas=nooftup()\n! write(*,*)'Number of phase tuples: ',ntup,nyfas\n if(nyfas.ne.ntup) then\n! write(*,*)'Number of phase tuples changed: ',nyfas,ntup\n ntup=nyfas\n! if(allocated(ysave)) deallocate(ysave)\n! allocate(ysave(nyfas,maxconst))\n endif\n! copy the constitution to a local save array\n! if(.not.allocated(ysave)) then\n! allocate(ysave(nyfas,maxconst))\n! endif\n if(allocated(ysave)) deallocate(ysave)\n allocate(ysave(nyfas,maxconst))\n! the intention of saving constitution is to make it possible to interpolate\n! the calculation of G if the constitution is changed very little\n do j1=1,nyfas\n do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr)\n ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2)\n enddo\n enddo\n1000 continue\n return\n end subroutine tqce\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgetv(stavar,n1,n2,n3,values,ceq)\n! get equilibrium results using state variables\n! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 \n! n1 can be a phase tuple index, n2 a component index\n! n3 at the call is the dimension of the array values, \n! changed to number of values on exit\n! value is an array with the calculated value(s), n3 set to number of values.\n implicit none\n integer n1,n2,n3\n character stavar*(*)\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!========================================================\n! stavar must be a symbol listed below\n! IMPORTANT: some terms explained after the table\n! Symbol index1,index2 Meaning (unit)\n!.... potentials\n! T 0,0 Temperature (K)\n! P 0,0 Pressure (Pa)\n! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J)\n! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT)\n! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT\n!...... extensive variables\n! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase\n! UM 0,0 or ext.phase.index,0 same per mole components\n! UW 0,0 or ext.phase.index,0 same per kg\n! UV 0,0 or ext.phase.index,0 same per m3\n! UF ext.phase.index,0 same per formula unit of phase\n! S*3 0,0 or ext.phase.index,0 Entropy (J/K) \n! V 0,0 or ext.phase.index,0 Volume (m3)\n! H 0,0 or ext.phase.index,0 Enthalpy (J)\n! A 0,0 or ext.phase.index,0 Helmholtz energy (J)\n! G 0,0 or ext.phase.index,0 Gibbs energy (J)\n! ..... some extra state variables\n! NP ext.phase.index,0 Moles of phase\n! BP ext.phase.index,0 Mass of moles (kg)\n! Q ext.phase.index,0 Internal stability/RT (dimensionless)\n! DG ext.phase.index,0 Driving force/RT (dimensionless)\n!....... amounts of components\n! N 0,0 or component,0 or ext.phase.index,component Moles of component\n! X component,0 or ext.phase.index,component Mole fraction of component\n! B 0,0 or component,0 or ext.phase.index,component Mass of component\n! W component,0 or ext.phase.index,component Mass fraction of component\n! Y ext.phase.index,constituent*1 Constituent fraction\n!........ some parameter identifiers\n! TC ext.phase.index,0 Magnetic ordering temperature\n! BMAG ext.phase.index,0 Aver. Bohr magneton number\n! MQ& ext.phase.index,constituent Mobility\n! THET ext.phase.index,0 Debye temperature\n! LNX ext.phase.index,0 Lattice parameter\n! EC11 ext.phase.index,0 Elastic constant C11\n! EC12 ext.phase.index,0 Elastic constant C12\n! EC44 ext.phase.index,0 Elastic constant C44\n!........ NOTES:\n! *1 The phase index is the phase tuple index (extra composition sets at end)\n! *2 The constituent index is 10*species_number + sublattice_number\n! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also\n!--------------------------------------------------------------------\n! special addition for TQ interface: d2G/dyidyj\n! D2G + phase tuple\n!--------------------------------------------------------------------\n!\\end{verbatim}\n integer ics,mjj,nph,ki,kj,lp,lokph,lokcs\n character statevar*60,encoded*2048,name*24,selvar*4,norm*4\n! mjj should be the dimension of the array values ...\n mjj=n3\n selvar=stavar\n call capson(selvar)\n! for state variables like MQ&FE remove the part from & before the select\n! write(*,11)'In tqgetv: ',selvar,n1,n2,n3\n11 format(a,a,3i5)\n norm=' '\n lp=index(selvar,'&')\n if(lp.gt.0) then\n selvar(lp:)=' '\n else\n! check if variable is normallized, only M (per mole) allowed\n ki=len_trim(selvar)\n if(ki.ge.2) then\n if(selvar(ki:ki).eq.'M') then\n norm='M'\n selvar(ki:)=' '\n ki=ki-1\n endif\n endif\n endif\n!=======================================================================\n kj=index(selvar,'(')\n if(kj.gt.0) then\n selvar=selvar(1:kj-1)\n endif\n! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<'\n select case(selvar)\n case default\n write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar\n gx%bmperr=8888; goto 1000\n!--------------------------------------------------------------------\n! T or P\n case('T ','P ')\n call get_state_var_value(selvar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! chemical potential for a component\n case('MU ','MUS ')\n if(n1.lt.-1 .or. n1.eq.0) then\n write(*,*)'tqgetv 17: component number must be positive'\n gx%bmperr=8888; goto 1000\n elseif(n1 .eq.-1) then\n! this means all components\n statevar=trim(selvar)//'(*)'\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.le.noel()) then\n statevar=trim(selvar)//'('//trim(cnam(n1))//') '\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n! we must use index value(1) as the subroutine expect a single variable\n call get_state_var_value(statevar,values(1),encoded,ceq)\n else\n write(*,*)'No such component'\n endif\n!--------------------------------------------------------------------\n!@CC\n! Amount of moles /mass of components in a phase\n case('NP ', 'BP ')\n if(n1.lt.0) then\n! all phases\n statevar=stavar(1:2)//'(*)'\n!@CC\n! this returns all composition sets for all phases\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the amounts for all compsets of a phase sequentially\n! but here we want them in phase tuple order\n! the second argument is the number of values for each phase, here is 1 but\n! it can be for example compositions, then it should be number of components\n call sortinphtup(n3,1,values)\n else\n! NP for just one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar='NP('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Mole or mass fractions\n!@CC\n case('N ','B ','X ','W ')\n!@CC\n! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3\n if(n2.eq.0) then\n if(n1.lt.0) then\n! moles, mole or mass fraction of all components for all phases\n statevar=stavar(1:1)//'(*) '\n! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.eq.0) then\n! mole fraction for the state variable written as X(FE)\n! n1 and n2 not used, just check for wildcard\n! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar))\n if(index(stavar,'*').gt.0) then\n call get_many_svar(stavar,values,mjj,n3,encoded,ceq)\n else\n call get_state_var_value(stavar,values(1),encoded,ceq)\n endif\n else\n! mole fraction of a single component, no phase specification\n n3=1\n ics=1\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(cnam(n1))//')'\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n elseif(n1.lt.0) then\n!........................................................\n! for all phases one or several components\n if(n2.lt.0) then\n! this means all components all phases, for example x(*,*)\n statevar=stavar(1:1)//'(*,*) '\n! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, noel()\n! in this case\n ics=noel()\n call sortinphtup(n3,ics,values)\n else\n! a single component in all phases. n2 must not be zero\n! call get_component_name(n2,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(n2.le.0 .or. n2.ge.noel()) then\n write(*,*)'No such component'\n goto 1000\n endif\n! state variable like w(*,cr), the Cr content in all (stable) phases\n statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')'\n! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, in this case 1\n! ics=noel()\n! THIS MUST BE CHECKED !!!\n call sortinphtup(n3,1,values)\n endif\n elseif(n2.lt.0) then\n! this means all components in one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//',*) '\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n else\n! one component (n2) of one phase (n1)\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//','\n call get_component_name(n2,name,ceq)\n if(gx%bmperr.ne.0) goto 1000\n statevar(len_trim(statevar)+1:)=trim(name)//') '\n! write(*,*)'tqgetv 8: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n!--------------------------------------------------------------------\n! volume\n case('V ')\n if(norm(1:1).ne.' ') then\n statevar='V'//norm\n ki=2\n else\n statevar='V '\n ki=1\n endif\n if(n1.gt.0) then\n! Volume for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total volume\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Enthalpy\n case('H ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='H'//norm\n ki=2\n else\n statevar='H '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total enthalpy\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Gibbs energy\n case('G ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='G'//norm\n ki=2\n else\n statevar='G '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total Gibbs energy \n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Driving force relative stable equilibrium\n case('DG ')\n! Always normalized per mole\n if(norm(3:3).ne.' ') then\n statevar='DG'//norm\n ki=3\n else\n statevar='DG '\n ki=2\n endif\n! write(*,*)'tqgetv DGM: ',n1,ki\n if(n1.gt.0) then\n! The driving force for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'M('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! For all phases\n n3=0\n if(nooftup().gt.mjj) then\n write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup()\n gx%bmperr=8888\n goto 1000\n endif\n statevar='DGM(#) '\n write(*,*)'tqgetv 3: ',statevar\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3)\n write(*,*)'gx%bmperr: ',gx%bmperr\n endif\n!--------------------------------------------------------------------\n! Mobilities\n case('MQ ')\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')'\n! write(*,*)'statevar: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! Second derivatives of the Gibbs energy of a phase\n case('D2G ')\n lokcs=phasetuple(n1)%lokvares\n! this gives wrong value!! ??\n n3=size(ceq%phase_varres(lokcs)%yfr)\n! write(*,*)'D2G 3: ',n3\n kj=(n3*(n3+1))/2\n if(kj.gt.mjj) then\n write(*,*)'TQGETV error, array too small for D2G',mjj,kj\n gx%bmperr=8888\n goto 1000\n endif\n! write(*,*)'D2G 3: ',kj\n do ki=1,kj\n values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1)\n enddo\n end select\n!===========================================================================\n1000 continue\n return\n end subroutine tqgetv\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n subroutine tqgetg(lokres,n1,n2,values,ceq)\n! the partial derivative of the Gibbs energy ....??\n implicit none\n integer n1,n2,lokres\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n! \n double precision napfu, rgast\n integer count\n integer jl,size\n TYPE(gtp_phase_varres), pointer :: parres\n!\n count = 1\n!\n napfu=ceq%phase_varres(lokres)%abnorm(1)\n rgast=globaldata%rgas*ceq%tpval(1)\n parres=>ceq%phase_varres(lokres)\n! \n! write(*,100)(rgast*parres%gval(jl,1),jl=1,4)\n! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1)\n100 format('G/N, dG/dT:',4(1PE16.8))\n200 format('G/N/RT, N:',2(1PE16.8))\n! G_m^\\alpha = G_M^\\alpha/N^\\alpha, \\frac{\\partial G_m^\\alpha}{\\partial T},\n! \\frac{\\partial G_m^\\alpha}{\\partial P},\n! \\frac{\\partial^2 G_m^\\alpha}{\\partial T^2}\n values(count:count+3) = rgast*parres%gval(1:4,1)/napfu\n count = count + 4\n if (n1>0) then\n! 1/N^\\alpha * \\frac{\\partial G_M^\\alpha}{\\partial y_i}\n values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu\n count = count + n1\n if (n2>0) then\n! 1/N^\\alpha * \\frac{\\partial^2 G_M^\\alpha}{\\partial y_i\\partial y_j}\n values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu\n endif\n endif\n end subroutine tqgetg\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n \n subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,&\n consnames,n1,ceq)\n! equilibrates the constituent fractions of a phase for mole fractions xknown\n! and calculates the Darken matrix and unreduced diffusivities\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n! cpot are the (calculated) chemical potentials\n! tyst is TRUE means no outut\n! nend is the number of values returned in mugrad\n! mugrad are the derivatives of the chemical potentials wrt mole fractions??\n! mobval are the mobilities\n implicit none\n integer phtupx ! IN: index in phase tuple array\n integer nend\n logical tyst\n double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*)\n character*24, dimension(*) :: consnames \n integer n1\n TYPE(gtp_phasetuple), pointer :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n\n integer iph, ics, ll\n double precision mass\n character*24 spname\n \n phtup=>phasetuple(phtupx) \n call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq)\n \n iph=phasetuple(phtupx)%ixphase\n ics=1 \n n1 = noconst(iph,ics,firsteq)\n do ll=1,n1\n call get_constituent_name(iph,ll,consnames(ll),mass)\n enddo\n\n end subroutine tqgdmat\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n! tq_get_phase_constitution\n! This subroutine returns the sublattices and constitution of a phase\n! n1 is phase tuple index\n! nsub is the number of sublattices (1 if no sublattices)\n! cinsub is an array with the number of consttuents in each sublattice\n! spix is an array with the species index of the constituents in all sublattices\n! sites is an array of the site ratios for all sublattices. \n! yfrac is the constituent fractions in same order as in spix\n! extra is an array with some extra values: \n! extra(1) is the number of moles of components per formula unit\n! extra(2) is the net charge of the phase\n implicit none\n integer n1,nsub,cinsub(*),spix(*)\n double precision sites(*),yfrac(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n nsub,cinsub,spix,yfrac,sites,extra,ceq)\n1000 continue\n return\n end subroutine tqgphc1\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsphc1(n1,yfra,extra,ceq)\n! tq_set_phase_constitution\n! To set the constitution of a phase\n! n1 is phase tuple index\n! yfra is an array with the constituent fractions in all sublattices\n! in the same order as obtained by tqgphc1\n! extra is an array with returned values with the same meaning as in tqgphc1\n! NOTE The constituents fractions are normallized to sum to unity for each\n! sublattice and extra is calculated by tqsphc1\n! T and P must be set as conditions.\n implicit none\n integer n1\n double precision yfra(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n yfra,extra,ceq)\n1000 continue\n return\n end subroutine tqsphc1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNING: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt \n! compositions, 2 if also 2nd derivatives\n! n3 is returned as number of constituents (dimension of returned arrays)\n! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P\n! dgdy is an array with G.Yi\n! d2gdydt is an array with G.T.Yi\n! d2gdydp is an array with G.P.Yi\n! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj \n! reurned in the order: 1,1; 1,2; 1,3; ... \n! 2,2; 2,3; ...\n! 3,3; ...\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3\n double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! The inital size here can be 1000\n! n3=size(ceq%phase_varres(lokres)%yfr)\n! the actual number of constituents is better to take from this call\n n3=noconst(phasetuple(n1)%ixphase,1,ceq)\n! write(*,*)'tqcph1 3C',n3\n! gval last index is the property, other properties can also be extracted\n! t.ex. mobilites \n! The application program can also access these data directly ...\n if(gx%bmperr.eq.0) then\n do ij=1,6\n gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1)\n enddo\n do ij=1,n3\n dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1)\n d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1)\n d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1)\n enddo\n! size of upper triangle of symetrix matrix\n nofc=n3*(n3+1)/2\n do ij=1,nofc\n d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1)\n enddo\n else\n gtp=zero\n do ij=1,nofc\n dgdy(ij)=zero\n d2gdydt(ij)=zero\n d2gdydp(ij)=zero\n enddo\n nofc=nofc*(nofc+1)/2\n do ij=1,nofc\n d2gdy2(ij)=zero\n enddo\n endif\n1000 continue\n return\n end subroutine tqcph1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqcph2(n1,n2,n3,n4,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNIG: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is type of calculation (0, 1 or 2)\n! n3 is returned as number of constituents\n! n4 is index to ceq%phase_varres(lokres)% with all results\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3,n4\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! this should work but gave segmentation fault, find this a more cumbersum way\n n3=size(ceq%phase_varres(lokres)%yfr)\n n4=lokres\n! Uer can access results like\n! ceq%phase_varres(n4)%gval(1..6,1..prop)\n! prop=1 is G, other can be t.ex. Curie T, mobilites etc\n! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij)\n! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT\n! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP\n! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j)\n! arranged as a single dimenion array indexed by ixsym(i,j)\n!\n! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...)\n!\n1000 continue\n return\n end subroutine tqcph2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqdceq(name)\n! delete equilibrium with name\n implicit none\n character name*24\n! integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n! do not allow delete equilibrium 1\n if(n1.eq.1) then\n write(*,*)'No allowed to delete default equilibrium'\n gx%bmperr=4333\n goto 1000\n endif\n! ceq=>eqlista(n1)\n call delete_equilibria(name,ceq)\n1000 continue\n return\n end subroutine tqdceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcceq(name,n1,newceq,ceq)\n! copy_current_equilibrium to newceq\n! creates a new equilibrium record with name with values same as ceq\n! n1 is returned as index\n implicit none\n character name*24\n integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n !call enter_equilibrium(name,n1)\n !if(gx%bmperr.ne.0) goto 1000\n !newceq=>eqlista(n1)\n call copy_equilibrium(newceq,name,ceq)\n1000 continue\n return\n end subroutine tqcceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcneq(name,n1,newceq)\n! creates a new equilibrium record, same but simpler call than tqcceq\n! n1 is returned as index in eqlista\n implicit none\n character*(*), intent(in) :: name\n integer, intent(out) :: n1\n type(gtp_equilibrium_data), pointer, intent(out) :: newceq\n!\\end{verbatim}\n call enter_equilibrium(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n newceq=>eqlista(n1)\n1000 continue\n return\n end subroutine tqcneq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqselceq(name,ceq)\n! select current equilibrium to be that with name.\n! Note that equilibria can be deleted and change number but not name\n implicit none\n character name\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n call selecteq(n1,ceq)\n1000 continue\n return\n end subroutine tqselceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlr(lut,ceq)\n! list the equilibrium results like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer phtupx,iph,ics,lokvares,mode\n logical once\n write(lut,10)\n10 format(/20('*')/'Start debug output from TQLR: ')\n call list_conditions(lut,ceq)\n call list_global_results(lut,ceq)\n call list_components_result(lut,1,ceq)\n once=.TRUE.\n mode=0\n do phtupx=1,nooftup()\n lokvares=phasetuple(phtupx)%lokvares\n if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then\n iph=phasetuple(phtupx)%ixphase\n ics=phasetuple(phtupx)%compset\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n endif\n enddo\n write(lut,20)\n20 format('End debug output from TQLR'/20('*')/)\n1000 continue\n return\n end subroutine tqlr\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlc(lut,ceq)\n! list conditions like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n write(lut,10)\n10 format(/'Debug output from TQLC: ')\n call list_conditions(lut,ceq)\n1000 continue\n return\n end subroutine tqlc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqltdb\n! list TDB file elements, phases and parameters on screen\n implicit none\n!\\end{verbatim}\n integer n,kou\n! n is position in text, kou is output unit\n n=1; kou=6\n call list_many_formats(' ,,,, ',n,1,kou)\n write(*,10)\n10 format(/' no more ',/)\n return\n end subroutine tqltdb\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqquiet(yes)\n! if argument TRUE spurious output should be suppressed\n implicit none\n logical yes\n!\\end{verbatim}\n if(yes) then\n globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n else\n globaldata%status=ibset(globaldata%status,GSVERBOSE)\n endif\n return\n end subroutine tqquiet\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_globalbit(bit,onoff)\n! set a global bit\n implicit none\n integer bit,onoff\n!\\end{verbatim}\n! list here taken from models/gtp3.F90, only some allowed!!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 4 NOMERGE: no merge of gridmin result, \n! 5 NODATA: not any data, \n! 6 NOPHASE: no phase in system, \n! 7 NOACS: no automatic creation of composition set for any phase\n! 8 NOREMCS: do not remove any redundant unstable composition sets\n! 9 NOSAVE: data changed after last save command\n! 10 VERBOSE: maximum of listing\n! 11 SETVERB: permanent setting of verbose\n! 12 SILENT: as little output as possible\n! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation\n! 14 XGRID: extra dense grid for all phases\n! 15 NOPAR: do not run in parallel\n! 16 NOSMGLOB do not test global equilibrium at node points\n! 17 NOTELCOMP the elements are not the components\n! 18 TGRID use grid minimizer to test if global after calculating equilibrium\n! 19 OGRID use old grid generator\n! 20 NORECALC do not recalculate equilibria even if global test after fails\n! 21 OLDMAP use old map algorithm\n! 22 NOAUTOSP do not generate automatic start points for mapping\n! 23 GSYGRID extra dense grid\n! 24 GSVIRTUAL (CCI) enables calculations with a virtual element\n if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then\n if(onoff.gt.0) then\n! set bit\n globaldata%status=ibset(globaldata%status,bit)\n else\n globaldata%status=ibclr(globaldata%status,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_globalbit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_phasebit(phtupx,bit,onoff)\n! set a bit of phase\n implicit none\n integer phtupx,bit,onoff\n!\\end{verbatim}\n! taken from models/gtp3.F90\n!-Bits in PHASE record STATUS1 there are also bits in each phase_varres record!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 0 HID phase is hidden (not implemented)\n! 1 IMHID phase is implictly hidden (not implemented)\n! 2 ID phase is ideal, substitutional and no interaction\n! 3 NOCV phase has no concentration variation (fix composition)\n! 4 HASP phase has at least one parameter entered\n! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations\n! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations\n! 7 SORD phase has TCP type ordering (like for sigma)\n! 8 MFS phase has a disordered fraction set\n! 9 GAS this is the gas phase (first in phase list) \n! 10 LIQ phase is liquid (can be several but listed directly after gas)\n! 11 IONLIQ phase has ionic liquid model (I2SL)\n! 12 AQ1 phase has aqueous model (not implemented)\n! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED?\n! 14 QCE phase has quasichemical SRO configurational entropy (not implemented)\n! 15 CVMCE phase has some CVM ordering entropy (not implemented)\n! 16 EXCB phase need explicit charge balance (has ions)\n! 17 XGRID use extra dense grid for this phase\n! 18 FACTCE phase has FACT quasichemical SRO model (not implemented)\n! 19 NOCS not allowed to create composition sets for this phase\n! 20 HELM parameters are for a Helmholz energy model (not implemented),\n! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives\n! 22 not implemented ELMA phase has elastic model A (not implemented)\n! 23 EECLIQ the condensed phase (liquid) that should have highest entropy\n! 24 PHSUBO special use testing models DO NOT USE\n! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!!\n! 26 MULTI may be used with care\n! 27 BMAV Xion magnetic model with average Bohr magneton number\n! 28 UNIQUAC The UNIQUAC fluid model\n! 29 DILCE phase has dilute configigurational entropy (not implemented)\n! only bittar 3 left!\n integer lokph\n if(phtupx.le.0 .or. phtupx.gt.nooftup()) then\n gx%bmperr=4325\n elseif(bit.eq.17 .or. bit.eq.19) then\n lokph=phasetuple(phtupx)%lokph\n if(onoff.gt.0) then\n call set_phase_status_bit(lokph,bit)\n else\n call clear_phase_status_bit(lokph,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_phasebit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqset_gaddition(phtupx,gadd,ceq)\n! set fix addition to Gibbs energy of a phase#compset\n implicit none\n integer phtupx\n double precision gadd\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! Provided by Christophe Sigli 2018?\n integer lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n ceq%phase_varres(lokcs)%addg(1)=gadd\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n return\n end subroutine tqset_gaddition\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tq_add_const_energy(energy,phtupx,ceq)\n! add a constant energy in J/mole\n double precision,intent(in) :: energy\n type(gtp_equilibrium_data), pointer :: ceq\n integer,intent(in) :: phtupx\n!\\end{verbatim}\n! Provided by Jan Herrnring 2020.12.15\n integer :: lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n! add a constant term to G, value in J/FU\n! Abnorm is the number of moles of the phase\n ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1)\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n end subroutine tq_add_const_energy\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n \nend MODULE LIBOCTQ\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy modules\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule ftinyopen\n !\n ! This module replaces a C module for a popup window to open files\n ! used in the interactive OC. If you want to use the original\n ! version for opening files please check the linkmake or Makefile\n !\ncontains\n\n subroutine getfilename(typ,sval)\n implicit none\n integer typ\n character sval*(*)\n sval=' '\n return\n end subroutine getfilename\n\nend module ftinyopen\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy module (only Linux)\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule M_getkey\n !\n ! This module replaces a C module fore single character input on Linux\n !\ncontains\n\n character function getkex()\n getkex=' '\n return\n end function getkex\n\nend module M_getkey\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n" }, { "path": "examples/TQ4lib/Cpp/liboctqisoc.F90", "content": "!\n! Part of iso-C bining for OC TQlib from Teslos\n! modified by Matthias Stratmann, Christophe Sigli and Bo Sundman\n!\nMODULE cstr\n!\n! convert characters from Fortran to C and vice versa\ncontains\n function c_to_f_string(s) result(str)\n use iso_c_binding\n implicit none\n character(kind=c_char,len=1), intent(in) :: s(*)\n character(len=:), allocatable :: str\n integer i, nchars\n i = 1\n do\n if (s(i) == c_null_char) exit\n i = i + 1\n end do\n nchars = i - 1 ! Exclude null character from Fortran string\n allocate(character(len=nchars) :: str)\n str = transfer(s(1:nchars), str)\n\t\n end function c_to_f_string\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n subroutine c_to_f_str(s,sty)\n use iso_c_binding\n implicit none\n character(kind=c_char,len=1), intent(in) :: s(*)\n\tcharacter(len=24), intent(out) :: sty\n character(len=:), allocatable :: str\n\t\n integer i, nchars\n i = 1\n do\n if (s(i) == c_null_char) exit\n i = i + 1\n end do\n nchars = i - 1 ! Exclude null character from Fortran string\n allocate(character(len=nchars) :: str)\n sty = transfer(s(1:nchars), str)\n\tdeallocate (str)\n end subroutine c_to_f_str\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n subroutine f_to_c_string(fstring, cstr)\n use iso_c_binding\n implicit none\n character(len=24) :: fstring\n character(kind=c_char, len=1), intent(out) :: cstr(*)\n integer i\n do i = 1, len(fstring)\n cstr(i) = fstring(i:i)\n cstr(i+1) = c_null_char\n end do\n end subroutine f_to_c_string\n \nEND MODULE cstr\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n!\n! module liboctqisoc\n!\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\nMODULE liboctqisoc\n! \n! OCTQlib with iso-C binding\n!\n use iso_c_binding\n use cstr\n use liboctq\n! use general_thermodynamic_package\n implicit none\n\n integer(c_int), bind(c) :: c_nel\n integer(c_int), bind(c) ::c_maxc=40, c_maxp=500\n type(c_ptr), bind(c), dimension(maxc) :: c_cnam\n character(len=25), dimension(maxc), target :: cnames\n real(c_double), bind(c), dimension(maxc) :: c_mass\n \n integer(c_int), bind(c) :: c_ntup\n \n TYPE, bind(c) :: c_gtp_equilibrium_data \n! this contains all data specific to an equilibrium like conditions,\n! status, constitution and calculated values of all phases etc\n! Several equilibria may be calculated simultaneously in parallell threads\n! so each equilibrium must be independent \n! NOTE: the error code must be local to each equilibria!!!!\n! During step and map these records with results are saved\n! values of T and P, conditions etc.\n! Values here are normally set by external conditions or calculated from model\n! local list of components, phase_varres with amounts and constitution\n! lists of element, species, phases and thermodynamic parameters are global\n! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T\n! status: not used yet?\n! multiuse: used for various things like direction in start equilibria\n! eqno: sequential number assigned when created\n! next: index of next equilibrium in a sequence during step/map calculation.\n! eqname: name of equilibrium\n! tpval: value of T and P\n! rtn: value of R*T\n integer(c_int) :: status,multiuse,eqno,next\n! character(c_char) :: eqname ! NOT USED\n real(c_double) :: tpval(2),rtn\n! svfunres: the values of state variable functions valid for this equilibrium\n type(c_ptr) :: svfunres\n! the experiments are used in assessments and stored like conditions \n! lastcondition: link to condition list\n! lastexperiment: link to experiment list\n TYPE(c_ptr) :: lastcondition,lastexperiment\n! components and conversion matrix from components to elements\n! complist: array with components\n! compstoi: stoichiometric matrix of compoents relative to elements\n! invcompstoi: inverted stoichiometric matrix\n TYPE(c_ptr) :: complist\n real(c_double) :: compstoi\n real(c_double) :: invcompstoi\n! one record for each phase+composition set that can be calculated\n! phase_varres: here all calculated data for the phase is stored\n TYPE(c_ptr) :: phase_varres\n! index to the tpfun_parres array is the same as in the global array tpres \n! eq_tpres: here local calculated values of TP functions are stored\n TYPE(c_ptr) :: eq_tpres\n! current values of chemical potentials stored in component record but\n! duplicated here for easy acces by application software\n real(c_double) :: cmuval\n! xconc: convergence criteria for constituent fractions and other things\n real(c_double) :: xconv\n! delta-G value for merging gridpoints in grid minimizer\n! smaller value creates problem for test step3.BMM, MC and austenite merged\n real(c_double) :: gmindif=-5.0D-2\n! maxiter: maximum number of iterations allowed\n integer(c_int) :: maxiter\n! this is to save a copy of the last calculated system matrix, needed\n! to calculate dot derivatives, initiate to zero\n integer(c_int) :: sysmatdim=0,nfixmu=0,nfixph=0\n integer(c_int) :: fixmu\n integer(c_int) :: fixph\n real(c_double) :: savesysmat\n END TYPE c_gtp_equilibrium_data\n\ncontains\n\n! functions\n integer function c_noofcs(iph) bind(c, name='c_noofcs')\n integer(c_int), value :: iph\n c_noofcs = noofcs(iph)\n return \n end function c_noofcs\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n subroutine examine_gtp_equilibrium_data(c_ceq) &\n bind(c, name='examine_gtp_equilibrium_data')\n type(c_ptr), intent(in), value :: c_ceq\n type(gtp_equilibrium_data), pointer :: ceq\n integer :: i,j\n call c_f_pointer(c_ceq, ceq)\n write(*,10) ceq%status, ceq%multiuse, ceq%eqno\n10 format(/'gtp_equilibrium_data: status, multiuse, eqno, next'/, 3i4)\n write(*,20) ceq%eqname\n20 format(/'Name of equilibrium'/,a)\n write(*,30) ceq%tpval, ceq%rtn\n30 format(/'Value of T and P'/, 2f8.3, /'R*T'/, f8.4)\n do i = 1, size(ceq%compstoi,1)\n write(*,*) (ceq%compstoi(i,j), j=1,size(ceq%compstoi,2))\n end do\n write(*,*) ceq%cmuval\n write(*,*) ceq%xconv\n write(*,*) ceq%gmindif\n write(*,*) ceq%maxiter\n write(*,*) ceq%sysmatdim, ceq%nfixmu, ceq%nfixph\n write(*,*) ceq%fixmu, ceq%fixph, ceq%savesysmat\n end subroutine examine_gtp_equilibrium_data\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini')\n integer(c_int), intent(in) :: n\n type(c_ptr), intent(out) :: c_ceq\n!\\end{verbatim} \n type(gtp_equilibrium_data), pointer :: ceq\n integer :: i1,i2\n \n call tqini(n, ceq)\n c_ceq = c_loc(ceq)\n\t\n end subroutine c_tqini\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\! \n\n!\\begin{verbatim}\n subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil')\n character(kind=c_char,len=1), intent(in) :: filename(*)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n\ttype(gtp_equilibrium_data), pointer :: ceq\n\tcharacter(len=:), allocatable :: fstring\n integer :: i,j,l\n character(kind=c_char, len=1),dimension(24), target :: f_pointers\n! convert type(c_ptr) to fptr\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(filename)\n call tqrfil(fstring, ceq)\n! after tqrfil ntup variable is defined\n c_ntup = ntup\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(cnam(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n!\t c_mass(i)=cmass(i)\n!\t write(*,*) cmass(i)\n end do\n c_ceq = c_loc(ceq)\n\tdeallocate(fstring)\n\tnullify(ceq)\n end subroutine c_tqrfil\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n \n!\\begin{verbatim}\n subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil')\n!change \n character(kind=c_char), intent(in) :: filename\n integer(c_int), intent(in), value :: nel\n type(c_ptr), intent(in), dimension(nel), target :: c_selel\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=:), allocatable :: fstring\n character, pointer :: selel(:)\n integer :: i\n character elem(nel)*2\n fstring = c_to_f_string(filename)\n call c_f_pointer(c_ceq, ceq)\n! convert the c type selel strings to f-selel strings\n! note: additional character is for C terminated '\\0'\n do i = 1, nel\n call c_f_pointer(c_selel(i), selel, [3])\n elem(i) = c_to_f_string(selel)\n end do\n call tqrpfil(fstring, nel, elem, ceq)\n! after tqrpfil ntup variable is defined\n c_ntup = ntup\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(cnam(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n\t c_mass(i)=cmass(i)\n end do\n c_ceq = c_loc(ceq)\n\tdeallocate (fstring)\n\tnullify(ceq)\n end subroutine c_tqrpfil\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom')\n! get system components\n integer(c_int), intent(inout) :: n\n !character(kind=c_char, len=24), dimension(24), intent(out) :: c_components\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n integer, target :: nc\n character(len=24) :: fcomponents(maxel)\n character(kind=c_char, len=1), dimension(maxel*24) :: components\n type(gtp_equilibrium_data), pointer :: ceq \n integer :: i,j,l\n call c_f_pointer(c_ceq, ceq)\n call tqgcom(nc, fcomponents, ceq)\n! convert the F components strings to C \n l = len(fcomponents(1))\n do i = 1, nc\n do j = 1, l\n components((i-1)*l+j)(1:1) = fcomponents(i)(j:j)\n end do\n! null termination\n components(i*l) = c_null_char \n end do\n c_ceq = c_loc(ceq)\n n = nc\n end subroutine c_tqgcom\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp')\n integer(c_int), intent(inout) :: n\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqgnp(n, ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgnp\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn')\n! get name of phase n,\n! NOTE: n is phase number, not extended phase index\n integer(c_int), intent(in), value :: n\n character(kind=c_char, len=1), intent(inout) :: phasename(24)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n! fstring = c_to_f_string(phasename)\n call tqgpn(n, fstring, ceq)\n! copy the f-string to c-string and end with '\\0'\n do i=1,len(trim(fstring))\n phasename(i)(1:1) = fstring(i:i)\n phasename(i+1)(1:1) = c_null_char\n end do\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpn \n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi')\n! get index of phase phasename\n integer(c_int), intent(out) :: n\n character(c_char), intent(in) :: phasename(24)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(phasename)\n call tqgpi(n, fstring, ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpi\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn')\n! get name of constitutent c in phase n\n integer(c_int), intent(in) :: n ! phase number\n integer(c_int), intent(in) :: c ! extended constituent index: \n! 10*species_number + sublattice\n character(c_char), intent(out) :: constituentname(24)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n write(*,*) 'tqgpcn not implemented yet'\n end subroutine c_tqgpcn\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci')\n! get index of constituent with name in phase n\n integer(c_int), intent(in) :: n \n integer(c_int), intent(out) :: c ! exit: extended constituent index:\n! 10*species_number+sublattice\n character(c_char), intent(in) :: constituentname(24)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n fstring = c_to_f_string(constituentname)\n call c_f_pointer(c_ceq, ceq)\n call tqgpci(n, c, fstring, ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgpci\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs')\n!get stoichiometry of constituent c in phase n\n!? missing argument number of elements????\n integer(c_int), intent(in) :: n\n integer(c_int), intent(in) :: c ! in: extended constituent index:\n! 10*species_number + sublattice\n real(c_double), intent(out) :: stoi(*) ! exit: stoichiometry of elements\n real(c_double), intent(out) :: mass ! exit: total mass\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqgpcs(n,c,stoi,mass,ceq)\n c_ceq=c_loc(ceq)\n end subroutine c_tqgpcs\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq)\n! get stoichiometry of component n1\n! n2 is number of elements ( dimension of elements and stoi )\n integer(c_int), intent(in) :: n1 ! in: component number\n integer(c_int), intent(out) :: n2 ! exit: number of elements in component\n character(c_char), intent(out) :: elnames(2) ! exit: element symbols\n real(c_double), intent(out) :: stoi(*) ! exit: element stoichiometry\n real(c_double), intent(out) :: mass ! exit: component mass\n! (sum of element mass)\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqgccf(n1,n2,elnames,stoi, mass, ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgccf\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc')\n! get number of constituents of phase n\n integer(c_int), intent(in) :: n ! in: phase number \n integer(c_int), intent(out) :: c ! exit: number of constituents\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq,ceq)\n call tqgnpc(n,c,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgnpc\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) &\n bind(c, name='c_tqsetc')\n! set condition\n! stavar is state variable as text\n! n1 and n2 are auxilliary indices\n! value is the value of the condition\n! cnum is returned as an index of the condition.\n! to remove a condition the value sould be equial to RNONE ????\n! when a phase indesx is needed it should be 10*nph + ics\n! SEE TQGETV for doucumentation of stavar etc.\n!>>>> to be modified to use phase tuplets\n integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index:\n! 10*phase_number+comp.set\n ! or component set\n integer(c_int), intent(in),value :: n2 !\n integer(c_int), intent(out) :: cnum !exit: \n! sequential number of this condition\n character(c_char), intent(in) :: statvar !in: character\n! with state variable symbol\n real(c_double), intent(in),value :: mvalue !in: value of condition\n \n type(c_ptr), intent(in) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\n\t type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqsetc(statvar, n1, n2, mvalue, cnum, ceq)\n\tnullify(ceq)\n \n end subroutine c_tqsetc\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce')\n! calculate equilibrium with possible target\n! Target can be empty or a state variable with indicies n1 and n2\n! value is the calculated value of target\n integer(c_int), intent(in),value :: n1\n integer(c_int), intent(in),value :: n2\n type(c_ptr), intent(inout) :: c_ceq\n character(c_char), intent(inout) :: mtarget \n real(c_double), intent(inout) :: mvalue\n!\\end{verbatim}\n\ttype(gtp_equilibrium_data), pointer :: ceq\n character(len=:), allocatable :: fstring\n call c_f_pointer(c_ceq,ceq)\n fstring = c_to_f_string(mtarget)\n call tqce(fstring,n1,n2,mvalue,ceq)\n c_ceq = c_loc(ceq)\n\tdeallocate(fstring)\n\tnullify(ceq)\n end subroutine c_tqce\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv')\n! get equilibrium results using state variables\n! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 \n! n3 at the call is the dimension of values, changed to number of values\n! value is the calculated value, it can be an array with n3 values.\n implicit none\n integer(c_int), intent(in),value :: n1,n2\n integer(c_int), intent(inout) :: n3\n character(c_char), intent(in) :: statvar\n real(c_double), intent(inout) :: values(*)\n type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium\n!========================================================\n! >>>> implement use of phase tuples \n! stavar must be a symbol listed below\n! IMPORTANT: some terms explained after the table\n! Symbol index1,index2 Meaning (unit)\n!.... potentials\n! T 0,0 Temperature (K)\n! P 0,0 Pressure (Pa)\n! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J)\n! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT)\n! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT\n!...... extensive variables\n! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase\n! UM 0,0 or phase-tuple,0 same per mole components\n! UW 0,0 or phase-tuple,0 same per kg\n! UV 0,0 or phase-tuple,0 same per m3\n! UF phase-tuple,0 same per formula unit of phase\n! S*3 0,0 or phase-tuple,0 Entropy (J/K) \n! V 0,0 or phase-tuple,0 Volume (m3)\n! H 0,0 or phase-tuple,0 Enthalpy (J)\n! A 0,0 or phase-tuple,0 Helmholtz energy (J)\n! G 0,0 or phase-tuple,0 Gibbs energy (J)\n! ..... some extra state variables\n! NP phase-tuple,0 Moles of phase\n! BP phase-tuple,0 Mass of moles (kg)\n! Q phase-tuple,0 Internal stability/RT (dimensionless)\n! DG phase-tuple,0 Driving force/RT (dimensionless)\n!....... amounts of components\n! N 0,0 or component,0 or phase-tuple,component Moles of component\n! X component,0 or phase-tuple,component Mole fraction of component\n! B 0,0 or component,0 or phase-tuple,component Mass of component\n! W component,0 or phase-tuple,component Mass fraction of component\n! Y phase-tuple,constituent*1 Constituent fraction\n!........ some parameter identifiers\n! TC phase-tuple,0 Magnetic ordering temperature\n! BMAG phase-tuple,0 Aver. Bohr magneton number\n! MQ& phase-tuple,constituent Mobility\n! THET phase-tuple,0 Debye temperature\n! LNX phase-tuple,0 Lattice parameter\n! EC11 phase-tuple,0 Elastic constant C11\n! EC12 phase-tuple,0 Elastic constant C12\n! EC44 phase-tuple,0 Elastic constant C44\n!........ NOTES:\n! *1 The phase-tuple is is structure with 2 integers: phase and comp.set\n! *2 The constituent index is 10*species_number + sublattice_number\n! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also\n!--------------------------------------------------------------------\n! special addition for TQ interface: d2G/dyidyj\n! D2G + extended phase index\n!------------------------------------\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n integer :: n\n integer :: i\n call c_f_pointer(c_ceq, ceq)\n \n! call list_conditions(6,ceq)\n! call list_phase_results(1,1,0,6,ceq)\n! write(*,*)'Phase and error code: ',1,gx%bmperr\n! call list_phase_results(2,1,0,6,ceq)\n! write(*,*)'Phase and error code: ',2,gx%bmperr\n! write(*,*)\n\n call c_to_f_str(statvar,fstring)\n call tqgetv(fstring, n1, n2, n3, values, ceq)\n! debug ...\n! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3)\n!55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4))\n! write(*,*)\n! end debug\n c_ceq = c_loc(ceq)\n\t\n end subroutine c_tqgetv\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)&\n bind(c,name='c_tqgphc1')\n! tq_get_phase_constitution\n! This subroutine returns the sublattices and constitution of a phase\n! n1 is phase tuple index\n! nsub is the number of sublattices (1 if no sublattices)\n! cinsub is an array with the number of const\\EDtuents in each sublattice\n! spix is an array with the species index of the constituents in all sublattices\n! sites is an array of the site ratios for all sublattices. \n! yfrac is the constituent fractions in same order as in spix\n! extra is an array with some extra values: \n! extra(1) is the number of moles of components per formula unit\n! extra(2) is the net charge of the phase\n implicit none\n !integer n1,nsub,cinsub(*),spix(*)\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(out) :: nsub\n integer(c_int), intent(out) :: cinsub(*)\n integer(c_int), intent(in) :: spix(*)\n !double precision sites(*),yfrac(*),extra(*)\n real(c_double), intent(in) :: sites(*)\n real(c_double), intent(in) :: yfrac(*)\n real(c_double), intent(in) :: extra(*)\n !type(gtp_equilibrium_data), pointer :: ceq\n type(c_ptr), intent(inout) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq)\n call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqgphc1\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1')\n! tq_set_phase_constitution\n! To set the constitution of a phase\n! n1 is phase tuple index\n! yfra is an array with the constituent fractions in all sublattices\n! in the same order as obtained by tqgphc1\n! extra is an array with returned values with the same meaning as in tqgphc1\n! NOTE The constituents fractions are normallized to sum to unity for each\n! sublattice and extra is calculated by tqsphc1\n! T and P must be set as conditions.\n implicit none\n integer(c_int), intent(in), value :: n1\n real(c_double), intent(in) ::yfra(*)\n real(c_double), intent(out) :: extra(*)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n yfra,extra,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqsphc1\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) &\n bind(c,name='c_tqcph1')\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNIG: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt \n! compositions, 2 if also 2nd derivatives\n! n3 is returned as number of constituents (dimension of returned arrays)\n! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P\n! dgdy is an array with G.Yi\n! d2gdydt is an array with G.T.Yi\n! d2gdydp is an array with G.P.Yi\n! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj \n! reurned in the order: 1,1; 1,2; 1,3; ... \n! 2,2; 2,3; ...\n! 3,3; ...\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer(c_int), intent(in), value :: n1\n integer(c_int), intent(in), value :: n2\n integer(c_int), intent(out) :: n3\n real(c_double), intent(out) :: gtp(6)\n real(c_double), intent(out) :: dgdy(*)\n real(c_double), intent(out) :: d2gdydt(*)\n real(c_double), intent(out) :: d2gdydp(*)\n real(c_double), intent(out) :: d2gdy2(*)\n type(c_ptr), intent(inout) :: c_ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n call c_f_pointer(c_ceq, ceq)\n call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_tqcph1\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n !\\begin{verbatim} \n subroutine c_reset_conditions(cline,c_ceq) bind(c, name='c_reset_conditions')\n implicit none\n character(c_char), intent(in) :: cline(24) \n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n character(len=24) :: fstring\n fstring = c_to_f_string(cline)\n call c_f_pointer(c_ceq, ceq)\n \n call reset_conditions(fstring,ceq)\n c_ceq = c_loc(ceq)\n end subroutine c_reset_conditions\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim}\n subroutine c_Change_Status_Phase(phasename,nystat,myval,c_ceq)&\n bind(c, name='c_Change_Status_Phase') \n!change the status Fixed or Entered of a phase \n!PHFIXED=2\n!PHENTERED=0\n implicit none\n character(c_char), intent(in) :: phasename(24)\n integer(c_int), intent(in), value :: nystat\n real(c_double), intent(in),value :: myval\n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\t\n type(gtp_equilibrium_data), pointer :: ceq \n character(len=24) :: fstring\n call c_f_pointer(c_ceq, ceq)\n call c_to_f_str(phasename,fstring)\n call Change_Status_Phase(fstring,nystat,myval,ceq)\n c_ceq = c_loc(ceq)\n \n1000 continue\t\n return\n end subroutine c_Change_Status_Phase\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_List_Conditions(c_ceq)&\n bind(c, name='c_List_Conditions') \n!change the status Fixed or Entered of a phase \n!PHFIXED=2\n!PHENTERED=0\n implicit none\n\t\n type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium\n!\\end{verbatim}\t\n type(gtp_equilibrium_data), pointer :: ceq \n call c_f_pointer(c_ceq, ceq)\n call list_conditions(6,ceq)\n c_ceq = c_loc(ceq)\n1000 continue\t\n return\n end subroutine c_List_Conditions\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_checktdb(tdbfile)&\n bind(c, name='c_checktdb') \n character(kind=c_char), intent(in) :: tdbfile\n!\\end{verbatim}\n integer:: nel,i\n character selel(maxel)*2\n character(len=:), allocatable :: fstring\n character(len=:), allocatable :: ext\n ext='.tdb'\n fstring = c_to_f_string(tdbfile)\n call checkdb(fstring,ext,nel,selel)\n c_nel = nel\n do i = 1, nel\n cnames(i) = trim(selel(i)) // c_null_char\n c_cnam(i) = c_loc(cnames(i))\n end do\n deallocate(fstring)\n return\n end subroutine c_checktdb\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n \n!\\begin{verbatim} \n subroutine c_newEquilibrium(ceqname,ieq) bind(c, name='c_newEquilibrium') \n character(kind=c_char), intent(in) :: ceqname\n integer(c_int), intent(out):: ieq\n!\\end{verbatim}\n character(len=:), allocatable :: fstring\n fstring = c_to_f_string(ceqname)\n call enter_equilibrium(fstring,ieq)\n deallocate(fstring)\n end subroutine c_newEquilibrium\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_selecteq(ieq,c_ceq) bind(c, name='c_selecteq') \n integer(c_int), intent(in),value :: ieq\n type(c_ptr), intent(out) :: c_ceq \n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n!call c_f_pointer(c_ceq, ceq)\n!call selecteq(ieq,ceq)\n ceq=>eqlista(ieq)\n c_ceq = c_loc(ceq)\n nullify(ceq)\n\t\n return\n end subroutine c_selecteq\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_copy_equilibrium(c_neweq,ceqname,c_ceq) &\n bind(c, name='c_copy_equilibrium') \n type(c_ptr), intent(inout) :: c_neweq \n character(kind=c_char), intent(in) :: ceqname\n type(c_ptr), intent(in) :: c_ceq \n!\\end{verbatim}\n character(len=:), allocatable :: fstring\n type(gtp_equilibrium_data), pointer :: ceq\n type(gtp_equilibrium_data), pointer :: neweq\n call c_f_pointer(c_ceq, ceq)\n fstring = c_to_f_string(ceqname)\n call copy_equilibrium(neweq,fstring,ceq)\n c_neweq=c_loc(neweq)\n deallocate(fstring)\n nullify(ceq)\n return\n end subroutine c_copy_equilibrium\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \n subroutine c_set_status_globaldata() bind(c, name='c_set_status_globaldata') \n!\\end{verbatim}\n! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc\n! NOMERGE: no merge of gridmin result, \n! NODATA: not any data, \n! NOPHASE: no phase in system, \n! NOACS: no automatic creation of composition set\n! NOREMCS: do not remove any redundant unstable composition sets\n! NOSAVE: data changed after last save command\n! VERBOSE: maximum of listing\n! SETVERB: explicit setting of verbose\n! SILENT: as little output as possible\n! NOAFTEREQ: no manipulations of results after equilibrum calculation\n! XGRID: extra dense grid for all phases\n! NOPAR: do not run in parallel\n! NOSMGLOB do not test global equilibrium at node points\n! NOTELCOMP the elements are not the components\n! TGRID always check calculated equilibrium with grid minimizer\n!globaldata%status=ibclr(globaldata%status,GSADV)\n!globaldata%status=ibclr(globaldata%status,GSNOPAR)\n!globaldata%status=ibclr(globaldata%status,GSXGRID)\n globaldata%status=ibclr(globaldata%status,GSNOACS)\n return\n end subroutine c_set_status_globaldata\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \t\n integer function c_errors_number() bind(c, name='c_errors_number')\n!\\end{verbatim}\t\n c_errors_number=0\n if(gx%bmperr.ne.0) then\n c_errors_number=gx%bmperr\n endif\n return\n end function c_errors_number\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \t\n subroutine c_new_gtp() bind(c, name='c_new_gtp') \n!\\end{verbatim}\t\n call new_gtp\n return\n end subroutine c_new_gtp\n\t\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n \n !\\begin{verbatim}\n subroutine c_tqfree_newyes() bind(c, name='c_tqfree_newyes') \n integer intv(10) \n double precision dblv(10)\n\n if(allocated(firstash%eqlista)) then\n write(*,*)' *** Warning, assessment data not removed'\n endif\n \n if(allocated(firstash%eqlista)) deallocate(firstash%eqlista)\n deallocate(firstash)\n call new_gtp\n call init_gtp(intv,dblv)\n call deallocate_gtp(intv,dblv)\n\n end subroutine c_tqfree_newyes\n \n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\begin{verbatim} \t\n subroutine c_enter_composition_set(iph,ics) &\n bind(c, name='c_enter_compostion_set') \n implicit none\n integer(c_int), intent(in),value :: iph\n integer(c_int), intent(out) :: ics\n!\\end{verbatim}\t\n character*4 prefix,suffix\n prefix=' '; suffix=' '\n call enter_composition_set(iph,prefix,suffix,ics)\n return\n end subroutine c_enter_composition_set\n\t\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\nend module liboctqisoc\n" }, { "path": "examples/TQ4lib/F90/crfe/TQ1-crfe.F90", "content": "!\n! The first test program of programming interface LIBOCTQ using Cr-Fe binary\n!\n! Before compiling this you must first compile to OC program without omp\n! Then copy the library file ..\\..\\..\\lib\\liboctq.a\n! and ..\\..\\..\\liboceqplus.mod\n! and ..\\liboctq.F90\n! then compile gfortran -c liboctq.F90\n! the compile this file and link with tqoctq.o and liboceq.a\n!\n! check the file link-tqtest1\n!\nprogram octq1\n!\n use liboctq\n!\n implicit none\n! maxel and maxph defined in gtp3 package\n! phasetuples is a TYPE(gtp_phasetuples) array with phase numbers \n integer n,n1,n2,n3,n4,ip,cnum(maxel+3),mm,m2\n character filename*60\n character condition*60,line*80,statevar*60,quest*60,ch1*1\n character target*60,phcsname*24\n double precision value,temp,tp(2),mel(maxel)\n double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel),mus(maxel)\n double precision tpref(2),dgm(maxph)\n type(gtp_equilibrium_data), pointer :: ceq\n! DUMMY target for on-line help reference\n character :: dummy*10=' '\n!\n! initiate\n call tqini(n,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n! read database file\n filename='crfe '\n write(*,*)'Reading all elements from the database file: ',trim(filename)\n call tqrfil(filename,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! tqrfil enters the number of elements in NEL\n! and the element names in CNAM \n! and the number of phases in NTUP\n!\n! list elements and phases\n write(*,10)nel,(cnam(n)(1:2),n=1,nel)\n10 format(/'System with ',i2,' elements: ',10(a,', '))\n write(*,12,advance='no')ntup\n12 format('and ',i3,' phases: ')\n! list the phase names using the tuple index\n do n=1,ntup\n call tqgpn(n,phcsname,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,20,advance='no')trim(phcsname)\n20 format(a,', ')\n enddo\n write(*,*)\n!\n! set default values of temperature and pressure\n tp(1)=8.0D2\n tp(2)=1.0D5\n do n=1,nel\n xf(n)=0.5D0/dble(nel)\n enddo\n!\n! ask for conditions using the command line user interface (CUI)\n100 continue\n write(*,105)\n105 format(/'Give conditions:')\n ip=len(line)\n temp=tp(1)\n! old version of question routine\n! call gparrd('Temperature (K): ',line,ip,tp(1),temp,nohelp)\n call gparrdx('Temperature (K): ',line,ip,tp(1),temp,dummy)\n if(buperr.ne.0) goto 1000\n if(tp(1).lt.1.0d0) then\n write(*,*)'Temperature must be larger than 1 K'\n tp(1)=1.0D0\n endif\n temp=tp(2)\n call gparrdx('Pressure (Pa): ',line,ip,tp(2),temp,dummy)\n if(buperr.ne.0) goto 1000\n if(tp(2).lt.1.0d0) then\n write(*,*)'Pressure must be larger than 1 Pa'\n tp(2)=1.0D0\n endif\n do n=1,nel-1\n quest='Mole fraction of '//trim(cnam(n))//':'\n temp=xf(n)\n call gparrdx(quest,line,ip,xf(n),temp,dummy)\n if(buperr.ne.0) goto 1000\n if(xf(n).lt.1.0d-6) then\n write(*,*)'Fraction set to 1.0D-6'\n xf(n)=1.0D-6\n elseif(xf(n).ge.1.0d0) then\n write(*,*)'Fraction set to 0.999999D0'\n xf(n)=0.999999D0\n endif\n enddo\n! -------------------------------------\n! set conditions in OC for the calculation\n n1=0\n n2=0\n condition='T'\n call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq)\n if(gx%bmperr.ne.0) goto 1000\n condition='P'\n call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq)\n if(gx%bmperr.ne.0) goto 1000\n condition='N'\n call tqsetc(condition,n1,n2,one,cnum(3),ceq)\n if(gx%bmperr.ne.0) goto 1000\n do n=1,nel-1\n condition='X'\n call tqsetc(condition,n,n2,xf(n),cnum(3+n),ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n!\n! set reference state for the elements (components) to BCC at current T\n do n=1,nel\n phcsname='BCC_A2'\n tpref(1)=-one\n tpref(2)=1.0D5\n call tqcref(n,phcsname,tpref,ceq)\n if(gx%bmperr.ne.0) goto 600\n enddo\n!\n! calculate the equilibria\n! n1=0 means call grid minimizer\n target=' '\n n1=0\n n2=0\n call tqce(target,n1,n2,value,ceq)\n if(gx%bmperr.ne.0) then\n write(*,310)gx%bmperr,bmperrmess(gx%bmperr)\n310 format('Calculation failed, error code: ',i5/a)\n gx%bmperr=0; goto 600\n else\n write(*,320)\n320 format(/'Successful calculation')\n endif\n!\n!------------------------------------------------\n! list some results using TQ routines\n! amount and DGM of all phases\n statevar='NP'\n n1=-1\n n2=0\n! n3 is set to the dimension of npf\n! it is changed inside tqgetv to the number of values set\n! for this case n3 is set to the number of phase tuples\n! note that this can change if new composition set has been created\n n3=size(npf)\n call tqgetv(statevar,n1,n2,n3,npf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! list DGM for all phases\n statevar='DGM '\n call tqgetv(statevar,n1,n2,n3,dgm,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error extrating DGM',gx%bmperr\n goto 1000\n endif\n! here n3 is the number of phase tuples!\n write(*,502)\n502 format('Tuple index Phase name Amount DGM')\n do n=1,n3\n call tqgpn(n,phcsname,ceq)\n if(gx%bmperr.ne.0) goto 600\n write(*,505)n,phcsname,npf(n),dgm(n)\n505 format(i3,10x,a,2x,2(1pe12.4))\n enddo\n!------------------------------------------------\n! composition of stable phases\n! NOTE that the number of phases may have changed if new composition sets\n! created. n3 from previous call is current number of phase tuples\n ntup=n3\n phloop: do n=1,ntup\n if(npf(n).gt.zero) then\n! the phase is stable if it has a positive amount ... it can be stable with 0\n call tqgpn(n,phcsname,ceq)\n if(gx%bmperr.ne.0) goto 600\n write(*,510)trim(phcsname),npf(n)\n510 format(/'Stable phase: ',a,', amount: ',1PE12.4,', mole fractions:')\n! mole fractions of components in stable phase, n2=-1 means all fractions\n statevar='X'\n n2=-1\n n4=size(pxf)\n! Use phase tuple index: n\n call tqgetv(statevar,n,n2,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write 3 fractions on each line\n write(*,520)(cnam(m2)(1:8),pxf(m2),m2=1,n4)\n520 format(3(a,': ',F9.6,', '))\n endif\n enddo phloop\n! chemical potentials\n write(*,525)\n525 format(/'Component, mole fraction, chemical potential (SER) BCC')\n statevar='X'\n n=-1\n n2=0\n n4=size(pxf)\n call tqgetv(statevar,n,n2,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! mus is the chemical potential relative to SER\n statevar='MUS'\n n4=size(mus)\n call tqgetv(statevar,n,n2,n4,mus,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! mu is the chemival potential relative to user defined reference state\n statevar='MU'\n n4=size(mu)\n call tqgetv(statevar,n,n2,n4,mu,ceq)\n if(gx%bmperr.ne.0) goto 1000\n do n=1,nel\n write(*,530)cnam(n)(1:2),pxf(n),mus(n),mu(n)\n530 format(a,10x,F10.6,10x,2(1PE16.6))\n enddo\n! Some examples of using tqgetv\n write(*,*)\n write(*,*)'Mole fractions of all components in all stable phases:'\n n4=size(pxf)\n statevar='X(*,*) '\n call tqgetv(statevar,-1,-1,n4,pxf,ceq)\n write(*,540)' X(*,*): ',(pxf(ip),ip=1,n4)\n540 format(a,10F7.4)\n write(*,*)'Mole fraction of a component in all stable phases (unstable 0):'\n write(*,*)'in phase tuple order!'\n n4=size(pxf)\n statevar='X(*,CR) '\n call tqgetv(statevar,-1,1,n4,pxf,ceq)\n write(*,540)' X(*,CR): ',(pxf(ip),ip=1,n4)\n! for debugging also list results as OC\n call tqlr(kou,ceq)\n!\n! ask if more calculations of same system\n600 continue\n write(*,*)\n ip=len(line)\n call gparcdx('Any more calculations?',line,ip,1,ch1,'N',dummy)\n if(ch1.ne.'N') then\n! set silent!\n write(*,*)'Turning on silent mode, less output from OC'\n call tqquiet(.TRUE.)\n goto 100\n endif\n! \n! end of program\n1000 continue\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4399) then\n write(*,1010)gx%bmperr,bmperrmess(gx%bmperr)\n1010 format(' *** Error ',i5/a)\n else\n write(*,1020)gx%bmperr\n1020 format(' *** Error ',i5/'Unknown reason')\n endif\n endif\n write(*,*)\n write(*,*)'A bientot!'\nend program octq1\n\n" }, { "path": "examples/TQ4lib/F90/crfe/crfe.TDB", "content": "\n$ Database file written 2012- 9- 7\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n \n \n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :CR,FE : !\n\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE% : VA% : !\n\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE% : VA% : !\n\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE : CR : CR,FE : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n ! \n \n" }, { "path": "examples/TQ4lib/F90/crfe/link-tqtest1", "content": "REM command file to cretate test program 1 for OCASI/TQ\n\nREM Either execute the commands below interactivly or rename\nREM this file with extention .cmd and execute it\n\nREM YOU MUST HAVE COMPILED AND LINKED THE MAIN OC PROGRAM\nREM The copy commands assume you are on the directory \nREM TQ4lib/F90/test1\nREM and have the main program three directories up\nREM as when you downloaded the zip file with the program\n\ncopy ..\\..\\..\\..\\libs\\liboceq.a .\n\ncopy ..\\..\\..\\..\\liboceqplus.mod .\n\ncopy ..\\liboctq.F90 .\n\ngfortran -c liboctq.F90\n\ngfortran -o tqex1 TQ1-crfe.F90 liboctq.o liboceq.a\n\n" }, { "path": "examples/TQ4lib/F90/crfe/readme-tq1.tex", "content": "\\documentclass[12pt]{article}\n\\textwidth 165mm\n\\textheight 210mm\n\\oddsidemargin 1mm\n\\evensidemargin 1mm\n\\topmargin 1mm\n\\usepackage[latin1]{inputenc}\n\n\\begin{document}\n\n\\begin{center}\n{\\Large \\bf Example 1 using OC-TQ:\n\nCalculations in the binary Cr-Fe system\n\nwith a miscibility gap in the bcc phase\n\n}\n\n\\bigskip\n\nBo Sundman \\today\n\n\\end{center}\n\nThis is an example for the Fortran OCTQ interface.\n\nThe example is based on the TQ standard for interfacing thermodynamic\nsoftware with application software. A more extensive interface called\nOpenCalphad Application Software Interface (OCASI) is under\ndevelopment.\n\nIf you are not familiar with compiling and linking software and do not\nunderstand the intructions here please ask some guru close to you for\nhelp. The instructions here are very brief but I do not have time to\nanswer questions about how to compile and link software. If you find\nerrors you are welcome to report them.\n\nTo link this example you must first install the OC main program. This\ninstallation generates two files you need: {\\bf liboceq.a} and {\\bf\n liboceqplus.mod}. Both of these files are needed for these\napplications.\n\nYou also need the {\\bf liboctq.F90} source code which is on the\ndirectory above.\n\n\\bigskip\n\n{\\bf Files on this directory:}\n\\begin{itemize}\n\\item crfe.TDB is a small database in the TDB format.\n\\item link-tqtest1 is a text file without extention which you can use\n as command file a on Windows system if you add the extention .cmd\n and execute it a batch file in a terminal window (or if you double\n click on it). If you use LINUX you have to edit it to create a\n Makefile or give the corresponing commands interactively.\n\n In the link-tqtest1 file there are some additional comments and\n instructions. If you do not understand these instruction please ask\n a local guru for help.\n\\item readme-tq1.pdf is this file.\n\\item readme-tql.tex is a LaTeX file to generate this pdf file.\n\\item TQ1-crfe.F90 is the test1 program written in Fortran95/08.\n\\end{itemize}\n\n\\newpage\n\n{\\bf Compiling and linking the test program}\n\n\\bigskip\n\nWhen you have executed the link-tqtest1 file in a terminal window (or\nthe corresponding Makefile) you should have a program called\ntqtest1.exe. The linking below assumes that the OC main program and\nthe corresponing libraries will be two directories above this one.\n\nThe output during compiling and linking will be something like:\n\n{\\small\n\\begin{verbatim}\n\nC:\\Users...\\TQ4lib\\F90\\crfe>link-tqtest1\nC:\\Users...\\TQ4lib\\F90\\crfe>REM command file to cretate test program 1 for OCASI/TQ\nC:\\Users...\\TQ4lib\\F90\\crfe>REM Either execute the commands below interactivly or rename\nC:\\Users...\\TQ4lib\\F90\\crfe>REM this file with extention .cmd and execute it\nC:\\Users...\\TQ4lib\\F90\\crfe>REM YOU MUST HAVE COMPILED AND LINKED THE MAIN OC PROGRAM\nC:\\Users...\\TQ4lib\\F90\\crfe>REM The copy commands assume you are on the directory\nC:\\Users\\...\\TQ4lib\\F90\\crfe>REM TQ4lib/F90/test1\nC:\\Users\\...\\TQ4lib\\F90\\crfe>REM and have the main program three directories up\nC:\\Users\\...\\TQ4lib\\F90\\crfe>REM as when you downloaded the zip file with the program\nC:\\Users\\...\\TQ4lib\\F90\\crfe>copy ..\\..\\..\\liboceq.a .\n 1 file(s) copied.\nC:\\Users\\...\\TQ4lib\\F90\\crfe>copy ..\\..\\..\\liboceqplus.mod .\n 1 file(s) copied.\nC:\\Users\\...\\TQ4lib\\F90\\crfe>REM copy ..\\ftinyopen-dummy.F90 .\nC:\\Users\\...\\TQ4lib\\F90\\crfe>copy ..\\liboctq.F90 .\n 1 file(s) copied.\nC:\\Users\\...\\TQ4lib\\F90\\crfe>REM gfortran -c ftinyopen-dummy.F90\nC:\\Users\\...\\TQ4lib\\F90\\crfe>gfortran -c liboctq.F90\nC:\\Users\\...\\TQ4lib\\F90\\crfe>gfortran -o tqex1 TQ1-crfe.F90 liboctq.o liboceq.a\nC:\\Users\\...\\TQ4lib\\F90\\crfe>\n\n\\end{verbatim}\n}\n\n\\newpage\n\n\\bigskip\n\n{\\bf Running the test program}\n\n\\bigskip\n\nWhen you execute this program in a terminal window you have to answer\nsome questions. If you just press RETURN at the questions the default\nvalue (given within slashes //) will be take. This example calls a\nroutine TQLR in the TQ interface which generates a listing of the\nclaculated equilibrium and is mainly intended for debugging.\n\nDepending on your input you should obtain an output similar to the\ntext below. Comment are inserted in {\\em italics}.\n\n{\\small\n\\begin{verbatim}\nC:\\Users\\..\\TQ4lib\\F90\\crfe>tqex1\n tqini created: DEFAULT_EQUILIBRIUM\n Reading all elements from the database file: crfe\n\nSystem with 2 elements: CR, FE,\nand 4 phases: LIQUID, BCC_A2, FCC_A1, SIGMA,\n\n\\end{verbatim}\n}\n\n{\\em The output above is generated by the tq\\_init subroutine and the\n test program. Below you can accept the default values of T, P and\n the mole fractions of Cr by just pressing return. The output after\n giving the mole fraction is generated by the OC minimizer just for\n information.}\n\n{\\small\n\\begin{verbatim}\nGive conditions:\nTemperature (K): /800/:\nPressure (Pa): /100000/:\nMole fraction of CR: /0.25/:\n 3Y total gridpoints: 128\n 3Y Constitution of metastable phases set\nGridmin: 128 points 0.00E+00 s and 0 clockcycles, T= 800.00\nEquilibrium result:: 9 its, 0.0000E+00 s, 0 cc, G= -2.9963780E+04 J/mol\n\nSuccessful calculation\nTuple index Phase name Amount\n 1 LIQUID 0.0000\n 2 BCC_A2 0.8302\n 3 FCC_A1 0.0000\n 4 SIGMA 0.1698\n\nStable phase: BCC_A2, amount: 8.3018E-01, mole fractions:\nCR : 0.197577, FE : 0.802423,\n\nStable phase: SIGMA, amount: 1.6982E-01, mole fractions:\nCR : 0.506278, FE : 0.493722,\n\nComponent, mole fraction, chemical potential (SER) BCC\nCR 0.250000 -2.716211E+04 -1.024353E+03\nFE 0.750000 -3.089767E+04 -9.918059E+02\n\n\\end{verbatim}\n}\n\n{\\em The test program first writes a list of all phases and their\n amount, then again for each stable phase the amount and\n molefractions in each phase. Finally the the components are listed\n with their amount and their chemical potential referred to SER (the\n stable state at 298.15~K and 1 bar) and referred to BCC at the\n current T and 1 bar.\n\n The following output is provided by the subroutine TQLR which writes\n the same things (and a little more) using the standard way in OC.\n This can be used as a easy way to check your own output.}\n\n{\\small\n\\begin{verbatim}\n********************\nStart debug output from TQLR:\n 1:T=800, 2:P=100000, 3:N=1, 4:X(CR)=0.25\n Degrees of freedom are 0\nT= 800.00 K ( 526.85 C), P= 1.0000E+05 Pa, V= 6.6465E-06 m3\nN= 1.0000E+00 moles, B= 5.4884E+01 g, RT= 6.6516E+03 J/mol\nG= -2.9964E+04 J, G/N= -2.9964E+04 J/mol, H= 1.9289E+04 J, S= 6.1566E+01 J/K\nComponent name Moles Mole-fr Chem.pot/RT Activities Ref.state\nCR 2.5000E-01 0.25000 -1.5400E-01 8.5727E-01 BCC_A2\nFE 7.5000E-01 0.75000 -1.4911E-01 8.6148E-01 BCC_A2\n\nName Status Moles Volume Form.Units Cmp/FU dGm/RT Comp:\nBCC_A2.................. E 8.302E-01 6.02E-06 8.30E-01 1.00 0.00E+00 X:\n FE 8.02423E-01 CR 1.97577E-01\n\nSIGMA................... E 1.698E-01 6.23E-07 5.66E-03 30.00 0.00E+00 X:\n CR 5.06278E-01 FE 4.93722E-01\n\nEnd debug output from TQLR\n********************\n\n\n\\end{verbatim}\n}\n\n{\\em The program is then finished but you can calculate again using\nanother T, P and composition. In the case below the calculation is made\nat 600~K when the system has a miscibility gap in the BCC phase.\n\nWe also turn on the SILENT mode which means less output from OC.}\n\n{\\small\n\\begin{verbatim}\nAny more calculations? /N/: y\n Turning on silent mode, less output from OC\n\nGive conditions:\nTemperature (K): /800/: 600\nPressure (Pa): /100000/:\nMole fraction of CR: /0.25/:\n\nSuccessful calculation\nTuple index Phase name Amount\n 1 LIQUID 0.0000\n 2 BCC_A2 0.2157\n 3 FCC_A1 0.0000\n 4 SIGMA 0.0000\n 5 BCC_A2_AUTO#2 0.7843\n\n\\end{verbatim}\n}\n\n{\\em IMPORTANT: Note that there are now 5 phases because a second BCC\n composition set has been created. The new phase tuple is placed\n after the inital set of phases. The new BCC phase has the suffix\n AUTO as it is created automatically by the grid minimizer. It also\n has the composition set number 2 after the hash character, \\#2.\n\n The first 5 phases all have a composition set number 1. Using OC\n interactivly you normally give the composition set number after a\n hash character but for the first composition set it is not needed.\n\n The two composition sets for BCC have exactly the same thermodynamic\n parameters but the BCC phase can at this temperature be stable with\n two different compositions.\n\n You must be aware of that new composition sets can be created\n automatically when you use the grid minimizer. Thus the number of\n phase tuples may change. Although a phase tuple that has been stable\n at one calculation will never be removed automatically, only explicitly.\n\n You can create composition sets manually and add your own pre- and\n suffix and also a default constitution.\n\n Note also the you had no output from the calculation as the silent\n mode was turned on.}\n\n{\\small\n\\begin{verbatim}\n\nStable phase: BCC_A2, amount: 2.1567E-01, mole fractions:\nCR : 0.970535, FE : 0.029465,\n\nStable phase: BCC_A2_AUTO#2, amount: 7.8433E-01, mole fractions:\nCR : 0.970535, FE : 0.029465,\n\nComponent, mole fraction, chemical potential (SER) BCC\nCR 0.250000 -1.718694E+04 -1.364302E+02\nFE 0.750000 -1.975398E+04 -2.252379E+02\n\n********************\nStart debug output from TQLR:\n 1:T=600, 2:P=100000, 3:N=1, 4:X(CR)=0.25\n Degrees of freedom are 0\nT= 600.00 K ( 326.85 C), P= 1.0000E+05 Pa, V= 7.2044E-06 m3\nN= 1.0000E+00 moles, B= 5.4884E+01 g, RT= 4.9887E+03 J/mol\nG= -1.9112E+04 J, G/N= -1.9112E+04 J/mol, H= 9.3417E+03 J, S= 4.7423E+01 J/K\nComponent name Moles Mole-fr Chem.pot/RT Activities Ref.state\nCR 2.5000E-01 0.25000 -2.7348E-02 9.7302E-01 BCC_A2\nFE 7.5000E-01 0.75000 -4.5150E-02 9.5585E-01 BCC_A2\n\nName Status Moles Volume Form.Units Cmp/FU dGm/RT Comp:\nBCC_A2.................. E 2.157E-01 1.57E-06 2.16E-01 1.00 0.00E+00 X:\n CR 9.70535E-01 FE 2.94648E-02\n\nBCC_A2_AUTO#2........... E 7.843E-01 5.63E-06 7.84E-01 1.00 0.00E+00 X:\n FE 9.48133E-01 CR 5.18667E-02\n\nEnd debug output from TQLR\n********************\n\n\nAny more calculations? /N/:\n\n Auf wiedersehen\n\nC:\\Users\\...\\TQ4lib\\F90\\crfe>\n\\end{verbatim}\n}\n\n\\end{document}\n\n{\\small\n\\begin{verbatim}\n\n\\end{verbatim}\n}\n\n\\end{verbatim}\n}\n\n{\\small\n\\begin{verbatim}\n\n" }, { "path": "examples/TQ4lib/F90/feni/FENI.TDB", "content": "$ Database file written 2014- 1-15\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n \n \n FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6000 N !\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N !\n FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N !\n FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N !\n FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N !\n FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N !\n FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N !\n FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N !\n FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N !\n$ this is 1/RT\n FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N !\n\n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :FE,NI : !\n\n PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 !\n PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T\n -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y\n -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 !\n PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 !\n PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !\n PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n$ PHASE BCC_A2 %& 2 1 3 !\n$ CONSTITUENT BCC_A2 :FE%,NI : VA% : !\n\n PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 !\n PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 !\n PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 !\n PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 !\n PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS !\n PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS !\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :FE%,NI% : VA% : !\n\n PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 !\n PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 !\n PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 !\n PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 !\n$ LN(mobilities)\n PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !\n PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !\n PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n BOS 'Invented mobilities and molar volumes'\n ! \n \n" }, { "path": "examples/TQ4lib/F90/feni/TQ2-feni.F90", "content": "! second test program of OC-TQ\nprogram octq2\n!\n use liboctq\n!\n implicit none\n! maxel and maxph defined in pmod package\n! integer, parameter :: maxel=10,maxph=20\n integer n,n1,n2,n3,n4,nsel,ip,cnum(maxel+3),mm,m2,phstable,jp,nend,nv,i,zz\n character filename*60,phnames(maxph)*24\n character condition*60,line*80,statevar*60,quest*60,ch1*1\n character target*60,selel(2)*2,phcsname*36\n double precision value,temp,tp(2),mel(maxel),mf(maxel),volume\n double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel)\n type(gtp_phasetuple), pointer :: phtup\n type(gtp_equilibrium_data), pointer :: ceq\n double precision mugrad(300),mobilities(20),xknown(20),yarr(20),irt\n! for tqgp\n character xphase(100)*24\n integer xstat(100)\n double precision xdgm(100)\n! present the calculation\n write(*,5)\n5 format(/'Calculation of equilibria and mobility data in Fe-Ni system'/&\n /'Fictitious ln(mobility data) in the TDB file:'/&\n 'PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !'/&\n 'PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !'/&\n 'PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !'/&\n 'PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !'/&\n 'PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !'/&\n 'PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !'/&\n 'PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !'/&\n 'PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !'/)\n! set some defaults\n n=0\n filename='FENI '\n! initiate\n call tqini(n,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! read database file\n nsel=2\n selel(1)='FE'\n selel(2)='NI'\n call tqrpfil(filename,nsel,selel,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! This call store the number of elements and names in the module variables\n! nel and cnam. The current number of phase tuples is stored in ntup\n! and the phase and compositon set indices in phcs\n! NOTE the number of phase tuples can change if new compsets are created\n! for example by the grid minimiser.\n call tqgnp(ntup,ceq)\n if(gx%bmperr.ne.0) goto 1000\n do n=1,ntup\n call tqgpn(n,phnames(n),ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! -------------------------------------\n write(*,10)nel,(cnam(n)(1:2),n=1,nel)\n10 format(/'System with ',i2,' elements: ',10(a,', '))\n write(*,20)ntup,(phnames(n)(1:len_trim(phnames(n))),n=1,ntup)\n20 format('and ',i3,' phases: ',10(a,', '))\n! --------------------------------------\n! list parameters, the output unit, screen is zz=6\n call tqltdb\n! n=1\n! zz=6\n! call list_many_formats(' ,,,, ',n,1,zz)\n! write(*,22)\n!22 format(/' no more ',/)\n! --------------------------------------\n! test tqgpsm\n! call tqgpsm(zz,xphase,xstat,xdgm,ceq)\n! if(gx%bmperr.ne.0) stop 'error in tqgp'\n! do n=1,zz\n! write(*,30)n,xphase(n),xstat(n),xdgm(n)\n!\n! enddo\n! set default values\n tp(1)=1.0D3\n tp(2)=1.0D5\n do n=1,nel\n xf(n)=1.0/dble(nel)\n enddo\n! ask for conditions\n100 continue\n write(*,105)\n105 format(/'Give conditions:')\n ip=len(line)\n temp=tp(1)\n call gparrdx('Temperature: ',line,ip,tp(1),temp,'dummy')\n if(buperr.ne.0) goto 1000\n if(tp(1).lt.1.0d0) then\n write(*,*)'Temperature must be larger than 1 K'\n tp(1)=1.0D0\n endif\n temp=tp(2)\n call gparrdx('Pressure: ',line,ip,tp(2),temp,'dummy')\n if(buperr.ne.0) goto 1000\n if(tp(2).lt.1.0d0) then\n write(*,*)'Pressure must be larger than 1 Pa'\n tp(2)=1.0D0\n endif\n do n=1,nel-1\n quest='Mole fraction of '//cnam(n)(1:len_trim(cnam(n)))//':'\n temp=xf(n)\n call gparrdx(quest,line,ip,xf(n),temp,'dummy')\n if(buperr.ne.0) goto 1000\n if(xf(n).lt.1.0d-6) then\n write(*,*)'Fraction must be larger than 1.0D-6'\n xf(n)=1.0D-6\n endif\n enddo\n! -------------------------------------\n! set conditions\n n1=0\n n2=0\n condition='T'\n call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq)\n if(gx%bmperr.ne.0) goto 1000\n condition='P'\n call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq)\n if(gx%bmperr.ne.0) goto 1000\n condition='N'\n call tqsetc(condition,n1,n2,one,cnum(3),ceq)\n if(gx%bmperr.ne.0) goto 1000\n do n=1,nel-1\n condition='X'\n call tqsetc(condition,n,n2,xf(n),cnum(3+n),ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n!--------------------------------------\n! calculate the equilibria\n target=' '\n n1=0\n n2=0\n call tqce(target,n1,n2,value,ceq)\n if(gx%bmperr.ne.0) then\n write(*,310)gx%bmperr,bmperrmess(gx%bmperr)\n310 format('Calculation failed, error code: ',i5/a)\n goto 600\n gx%bmperr=0; goto 600\n else\n write(*,320)\n320 format(/'Successful calculation')\n endif\n!--------------------------------------\n! list some results\n! amount of all phases\n statevar='NP'\n n1=-1\n n2=0\n n3=size(npf)\n call tqgetv(statevar,n1,n2,n3,npf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,505)n3,(npf(n),n=1,n3)\n505 format(/'Amount of ',i2,' phases: ',(10F7.4))\n ntup=n3\n phloop: do n=1,ntup\n if(npf(n).gt.zero) then\n! the phase is stable if it has a positive amount ... it can be stable with 0\n phstable=n\n call tqgpn(n,phcsname,ceq)\n write(*,510)trim(phcsname),npf(n)\n510 format(/'Stable phase: ',a,', amount: ',1PE12.4,', mole fractions:')\n! composition of stable phase, n2=-1 means all fractions\n statevar='X'\n n2=-1\n n4=size(xknown)\n call tqgetv(statevar,n,n2,n4,xknown,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,520)(cnam(m2)(1:2),xknown(m2),m2=1,n4)\n520 format(3(a,': ',F9.6,', '))\n endif\n enddo phloop\n! volume\n statevar='V'\n n=0\n n2=0\n n4=size(pxf)\n! first index is phase+compset, second is component, third is dimension\n call tqgetv(statevar,n,n2,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,522)pxf(1)\n522 format(/'System volume: ',1pe12.4)\n! fractions, chemical potentials and mobilities\n! irt is 1/(RT)\n irt=one/(8.31451*tp(1))\n write(*,525)\n525 format(/'Component, mole fraction, chemical potentials, lnac = mu/RT')\n do n=1,nel\n statevar='MU'\n n2=0\n n4=size(pxf)\n! n is the componet, n2 is redundant, n4 is size of cpot\n call tqgetv(statevar,n,n2,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n mu(n)=pxf(1)\n! mole fraction\n statevar='X'\n call tqgetv(statevar,n,n2,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n mf(n)=pxf(1)\n write(*,530)cnam(n)(1:8),mf(n),mu(n),mu(n)*irt\n530 format(a,2x,F10.6,4x,1PE14.6,7x,E14.6)\n enddo\n write(*,540)\n540 format(/'LN(mobility of component in phase) and exp(ln(..)):')\n do n=1,ntup\n! mobility MQ&constituent(phase)\n call tqgpn(n,phcsname,ceq)\n do n1=1,nel\n statevar='MQ&'//trim(cnam(n1))\n call tqgetv(statevar,n,n1,n4,pxf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,550)trim(statevar),trim(phcsname),pxf(1),exp(pxf(1))\n550 format(a,'(',a,') = ',2(1PE20.6))\n enddo\n enddo\n!---------------------------------\n! copied from user i/f\n phtup=>phasetuple(phstable)\n write(*,590)phstable\n590 format(/'Calculating Darken stability matrix, dG_A/dN_B for phase ',i2,': ')\n mugrad=zero\n mobilities=zero\n! derivatives of mu and mobilities, the .TRUE. means no output\n! xknown is phase composition, mu is chemical potentials,\n! nend is number of values returned in mugrad (dG_A/dN_B)\n call equilph1d(phtup,ceq%tpval,xknown,mu,.TRUE.,nend,mugrad,mobilities,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,2096)nend\n2096 format(/'Chemical potential derivative matrix, dG_I/dN_J for ',&\n i3,' endmembers')\n write(*,2094)(nv,nv=1,nend)\n2094 format(3x,6(6x,i6)/(3x,6i12))\n do nv=0,nend-1\n! An extra LF is generated when just 6 components!!\n write(*,2095)nv+1,(mugrad(nend*nv+jp),jp=1,nend)\n2095 format(i3,6(1pe12.4)/(3x,6e12.4))\n enddo\n! mobilities, same as above\n write(*,2098)noel()\n2098 format(/'LN(mobility) values for',i3,' components')\n write(*,2095)1,(mobilities(jp),jp=1,noel())\n!--------------------------------------\n! testing tqgpsm\n write(*,2000)\n2000 format(/'Testing tqgpsm')\n call tqgpsm(zz,xphase,xstat,xdgm,ceq)\n if(gx%bmperr.ne.0) stop 'error in tqgp'\n do n=1,zz\n write(*,30)n,xphase(n),xstat(n),xdgm(n)\n30 format(i3,2x,a,2x,i3,E12.4)\n enddo\n!--------------------------------------\n! loop\n600 continue\n write(*,*)\n ip=len(line)\n call gparcdx('Any more calculations?',line,ip,1,ch1,'N','dummy')\n if(ch1.ne.'N') goto 100\n!--------------------------------------\n1000 continue\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4220) then\n write(*,1010)gx%bmperr,bmperrmess(gx%bmperr)\n1010 format(' *** Error ',i5/a)\n else\n write(*,1020)gx%bmperr\n1020 format(' *** Error ',i5/'Unknown reason')\n endif\n endif\n write(*,*)\n write(*,*)'Auf wiedersehen'\nend program octq2\n" }, { "path": "examples/TQ4lib/F90/feni/linkmake", "content": "REM Copy libraries (compiled without OpenMP) from OC directory\ncopy ..\\..\\..\\..\\libs\\liboceq.a .\nREM copy ..\\..\\..\\..\\libs\\liboceqplus.mod .\ncopy ..\\..\\..\\..\\liboceqplus.mod .\n\nREM Copy tqlibrary from directory above\ncopy ..\\liboctq.F90 .\n\nREM Compile and link\ngfortran -c liboctq.F90\n\nREM if some omp_* rutines are undefined add -fopenmp or recompile liboceq\nREM using linkmake (without -fopenmp)\n\ngfortran -o tqex2 TQ2-feni.F90 liboctq.o liboceq.a\n\n" }, { "path": "examples/TQ4lib/F90/feni/readme.tex", "content": "\\documentclass[12pt]{article}\n\\textwidth 165mm\n\\textheight 210mm\n\\oddsidemargin 1mm\n\\evensidemargin 1mm\n\\topmargin 1mm\n\\usepackage[latin1]{inputenc}\n\n\\begin{document}\n\n\\begin{center}\n{\\Large \\bf Example 2 using OCASI-TQ:\n\nCalculations in the binary Fe-Ni system\n\nincluding mobility data\n\n}\n\n\\bigskip\n\nBo Sundman \\today\n\n\\end{center}\n\nThis is an example for the OCASI Fortran TQ interface.\n\nThe example is based on the TQ standard for interfacing thermodynamic\nsoftware with application software. A more extensive interface called\nOpenCalphad Application Software Interface (OCASI) is under\ndevelopment.\n\nIf you are not familiar with compiling and linking software and do not\nunderstand the intructions here please ask some guru close to you for\nhelp. The instructions here are very brief but I do not have time to\nanswer questions about how to compile and link software. If you find\nerrors you are welcome to report them.\n\nTo link this example you must first install the OC main program. This\ninstallation generates two files you need: {\\bf liboceq.a} and {\\bf\n liboceqplus.mod}. Both of these files are needed for these\napplications.\n\nYou also need the {\\bf liboctq.F90} source code which is on the\ndirectory above this example.\n\n\\bigskip\n\n{\\bf Files on this directory:}\n\\begin{itemize}\n\\item readme.pdf is this file.\n\n\\item readme.tex is a LaTeX file to generate this pdf file.\n\n\\item FENI.TDB is a small database in the TDB format.\n\n\\item TQ2-feni.F90 is the test program written in Fortran95/08.\n\n\\item linkmake is a text file without extention which you can use as\n command file a on Windows system if you add the extention .cmd and\n execute it a batch file in a terminal window (or if you double click\n on it). If you use LINUX you can edit it to create a Makefile.\n\n In the linkmake file there are some additional comments and\n instructions. If you do not understand these instruction please ask\n a local guru for help.\n\\end{itemize}\n\n\\newpage\n\n{\\bf Compiling and linking the test program}\n\n\\bigskip\n\nWhen you executing the linkmake file in a terminal window (or the\ncorresponding Makefile) you should have a program called tqtest1.exe.\nThe linking below assumes that the OC main program and the corresponing\nlibraries will be two directories above this one.\n\nThe output during compiling and linking will be something like:\n\n{\\small\n\\begin{verbatim}\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>linkmake\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>REM Copy libraries (compiled without OpenMP)\n from OC directory\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>copy ..\\..\\..\\liboceq.a .\n 1 fil(er) kopierad(e).\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>copy ..\\..\\..\\liboceqplus.mod\n.\n 1 fil(er) kopierad(e).\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>REM Copy tqlibrary from directory above\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>copy ..\\liboctq.F90 .\n 1 fil(er) kopierad(e).\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>REM Compile and link\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>gfortran -c liboctq.F90\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>gfortran -o tqex2 TQ2-feni.F90\n liboctq.o liboceq.a\n\n\\end{verbatim}}\n\nWhen you run the program it will look like\n\n{\\small\n\\begin{verbatim}\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>tqex2.exe\n\nCalculation of equilibria and mobility data in Fe-Ni system\nFictitious mobility data for the liquid in the TDB file:\nPARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS !\nPARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS !\nPARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS !\nPARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS !\nPARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS !\nPARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS !\nPARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS !\nPARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS !\n\n tqini created: DEFAULT_EQUILIBRIUM\n\nSystem with 2 elements: FE, NI,\nand 2 phases: LIQUID, FCC_A1,\n\nGive conditions:\nTemperature: /1000/:\nPressure: /100000/:\nMole fraction of FE: /0.5/: .3\n 3Y Composition set(s) created: 1\n3Y Gridmin: 16 points 0.00E+00 s and 0 clockcycles, T= 1000.00\nPhase change: its/add/remove: 16 0 2\nEquilibrium calculation 21 its, 1.5600E-02 s and 15 clockcycles\n\nSuccessful calculation\n\nAmount of 2 phases: 0.0000 1.0000\n\nStable phase: FCC_A1, amount: 1.0000E+00, mole fractions:\nFE: 0.300000, NI: 0.700000,\n\nSystem volume: 5.7000E-06\n\nComponent, mole fraction, chemical potentials, lnac = mu/RT\nFE 0.300000 -5.569910E+04 -6.699023E+00\nNI 0.700000 -4.984943E+04 -5.995474E+00\n\nLN(mobility of component in phase) and exp(ln(..)):\nMQ&FE(LIQUID) = -2.002412E+01 2.012036E-09\nMQ&NI(LIQUID) = -1.974213E+01 2.667485E-09\nMQ&FE(FCC_A1) = -3.517653E+01 5.284780E-16\nMQ&NI(FCC_A1) = -3.538031E+01 4.310476E-16\n\nCalculating Darken stability matrix, dG_A/dN_B for phase 2:\nCalculation required 6 its\n\nChemical potential derivative matrix, dG_I/dN_J for 2 endmembers\n 1 2\n 1 3.9069E+04 -1.6744E+04\n 2 -1.6744E+04 7.1759E+03\n\nLN(mobility) values for 2 components\n 1 -3.5177E+01 -3.5380E+01\n\nAny more calculations? /N/: y\n\nGive conditions:\nTemperature: /1000/: 2000\nPressure: /100000/:\nMole fraction of FE: /0.7/: .3\n 3Y Composition set(s) created: 1\n3Y Gridmin: 16 points 0.00E+00 s and 0 clockcycles, T= 2000.00\nPhase change: its/add/remove: 5 0 3\nEquilibrium calculation 10 its, 1.5600E-02 s and 15 clockcycles\n\nSuccessful calculation\n\nAmount of 2 phases: 1.0000 0.0000\n\nStable phase: LIQUID, amount: 1.0000E+00, mole fractions:\nFE: 0.300000, NI: 0.700000,\n\nSystem volume: 7.7000E-06\n\nComponent, mole fraction, chemical potentials, lnac = mu/RT\nFE 0.300000 -1.504170E+05 -9.045449E+00\nNI 0.700000 -1.343949E+05 -8.081949E+00\n\nLN(mobility of component in phase) and exp(ln(..)):\nMQ&FE(LIQUID) = -1.938555E+01 3.810336E-09\nMQ&NI(LIQUID) = -1.899758E+01 5.616396E-09\nMQ&FE(FCC_A1) = -3.327521E+01 3.538017E-15\nMQ&NI(FCC_A1) = -3.353104E+01 2.739401E-15\n\nCalculating Darken stability matrix, dG_A/dN_B for phase 1:\nCalculation required 6 its\n\nChemical potential derivative matrix, dG_I/dN_J for 2 endmembers\n 1 2\n 1 4.7487E+04 -2.0351E+04\n 2 -2.0351E+04 8.7221E+03\n\nLN(mobility) values for 2 components\n 1 -1.9386E+01 -1.8998E+01\n\nAny more calculations? /N/:\n\n Auf wiedersehen\n\nC:\\Users\\...\\TQ4lib\\F90\\feni>\n\\end{verbatim}}\n\n\\end{document}\n\n" }, { "path": "examples/TQ4lib/F90/liboctq.F90", "content": "!\n! Minimal TQ interface.\n!\n! To compile and link this with an application one must first compile\n! and form a library with of the most OC subroutines (lib\\liboceq.a)\n! and copy this and the corresponding \"liboceqplus.mod\" file\n! from this compilation to the folder with this library\n!\n! NOTE that for the identification of phase and composition sets this\n! TQ interface use a Fortran TYPE called gtp_phasetuple containing two\n! integers, \"phase\" with the phase number and \"compset\" with the\n! comp.set The number of phase tuples is initially equal to the number\n! of phases and have the same index. This represent comp.set 1 of the\n! phases as each phase has just one composition set. A phase may have\n! several comp.sets created by calculations or by commands and these will\n! have phase tuple index higher than the number of phases and their index\n! is in the order of which they were created.\n! This may cause some problems if composition sets are deleted because that\n! will change the phase tuple index for those with higher index. So do not\n! delete comp.sets or at least be very careful when deleting comp.sets\n!\n! 210328 BOS Tested\n! 191101 BOS Updates some routines and added two dummy modules for C routines\n! 181030 BOS Updates some routines\n! 150520 BOS added a few subroutines for single phase data and calculations\n! 141210 BOS changed to use phase tuples\n! 140128 BOS added D2G and phase specific V and G\n! 140128 BOS added possibility to calculate without invoking grid minimizer\n! 140125 BOS Changed name to liboctq\n! 140123 BOS Added ouput of MQ G, V and normalized\n!------------------------------------------------------------\n! subroutines and functions\n! tqini ok initiate\n! tqrfil ok read a database file\n! tqrpfil ok read specified elements from database file\n! -------------------------\n! tqgcom ok get number of system components and their names\n! tqgnp ok get number of phase tuples (phases and comp. sets)\n! tqgpn ok get name of phase tuple\n! tqgpi ok get phase tuple index of phase using its name\n! tqgpcn - get name of constituent of a phase using index\n! tqgpci - get index of constituent of a phase using name\n! tqgpcs - get stoichiometry of species as system components \n! tqgccf - get stoichiometry of system component as elements\n! tqgnpc - get number of constituents in phase\n! tqgp + get all phase names and status\n! -------------------------\n! tqcref - set reference state for component\n! tqphsts ok set status of phase tuple\n! tqsetc ok set condition\n! tqce ok calculate equilibrium\n! tqgetv ok get equilibrium results as state variable values\n! -------------------------\n! tqgphc1 ok get phase constitution\n! tqsphc1 ok set phase constitution\n! tqcph1 ok calculate phase properties and return arrays\n! tqcph2 ok calculate phase properties and return index\n! tqdceq ok delete equilibrium record\n! tqcceq ok copy current equilibrium to a new one\n! tqselceq ok select new current equilibrium\n! tqlr ok list results \n! tqlc ok list conditions\n! tqltdb ok list TDB file \n!\n!------------------------------------------------------------\n!\n! The name of this library\nmodule liboctq\n!\n! access to main OC library for equilibrium calculations and models\n use liboceqplus\n!\n implicit none\n!\n integer, parameter :: maxc=maxel,maxp=maxph\n!\n! This is for storage and use of components\n integer nel\n character, dimension(maxc) :: cnam*24\n! Number of phase tuples\n integer ntup\n! use the array PHASETUPLE available from OC\n! save phase constitution to speed up calculation by interpolation\n double precision, allocatable, dimension(:,:) :: ysave\n!\ncontains\n!\n!\\begin{verbatim}\n subroutine tqini(n,ceq)\n! initiate workspace\n implicit none\n integer n ! Not nused, could be used for some initial allocation\n type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium\n!\\end{verbatim}\n! these should be provide linits and defaults\n integer intv(10)\n double precision dblv(10)\n intv(1)=-1\n! This call initiates the OC package\n!@CC\n if (allocated(eqlista)) then\n call new_gtp\n endif\n call init_gtp(intv,dblv)\n!@CC\n ceq=>firsteq\n write(*,*)'tqini created: ',ceq%eqname\n1000 continue\n return\n end subroutine tqini\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqrfil(filename,ceq)\n! read all elements from a TDB file\n implicit none\n character*(*) filename ! IN: database filename\n character ellista(10)*2 ! dummy\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim} %+\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n! second argument 0 means ellista is ignored, all element read\n call readtdb(filename,0,ellista)\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store the element name in the cname array\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n enddo\n! store phase tuples\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrfil\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqrpfil(filename,nsel,selel,ceq)\n! read TDB file with selection of elements\n implicit none\n character*(*) filename ! IN: database filename\n integer nsel\n character selel(*)*2 ! IN: elements to be read from the database\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n!\n call readtdb(filename,nsel,selel)\n if(gx%bmperr.ne.0) goto 1000\n! is this really necessary??\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store element name in module array components\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n enddo\n! store phase tuples and indices\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrpfil\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgcom(n,compnames,ceq)\n! get system component names. At present the elements\n implicit none\n integer n ! EXIT: number of components\n character*24, dimension(*) :: compnames ! EXIT: names of components\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*24,refs*24\n double precision a1,a2,a3\n do iz=1,nel\n compnames(iz)=' '\n call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3)\n! store name in module array components also (already done when reading TDB)\n cnam(iz)=compnames(iz)\n enddo\n n=nel\n1000 continue\n return\n end subroutine tqgcom\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnp(n,ceq)\n! get total number of phase tuples (phases and composition sets)\n! A second composition set of a phase is normally placed after all other\n! phases with one composition set\n implicit none\n integer n !EXIT: n is number of phases\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n! NOTE the number composition sets may change at a calculation or if new\n! composition sets are added or deleted explicitly\n! This changes the number of phase tuples!\n ntup=nooftup()\n n=ntup\n1000 continue\n return\n end subroutine tqgnp\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpn(phtupx,phasename,ceq)\n! get name of phase tuple with index phtupx (ceq redundant)\n implicit none\n integer phtupx ! IN: index in phase tuple array\n character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call get_phasetup_name(phtupx,phasename)\n1000 continue\n return\n end subroutine tqgpn\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpi(phtupx,phasename,ceq)\n! get index of phase phasename (including comp.set (ceq redundant)\n implicit none\n integer phtupx !EXIT: phase tuple index\n character phasename*(*) !IN: phase name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call find_phasetuple_by_name(phasename,phtupx)\n1000 continue\n return\n end subroutine tqgpi\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcn2(n,c,constituentname,ceq)\n! get name of consitutent with index c in phasetuple n\n! NOTE An identical routine with different constituent index is tqgpcn\n implicit none\n integer n !IN: phase number (not phase tuple)\n integer c !IN: constituent index sequentially over all sublattices\n character constituentname*(24) !EXIT: costituent name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n double precision mass\n call get_constituent_name(n,c,constituentname,mass)\n! write(*,*)'tqgpcn not implemented yet'\n! gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcn2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpci(n,c,constituentname,ceq)\n! get index of constituent with name in phase n\n implicit none\n integer n !IN: phase index\n integer c !IN: sequantial constituent index over all sublattices\n character constituentname*(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpci not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpci\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcs(n,c,stoi,mass,ceq)\n! get stoichiometry of constituent c in phase n \n!? missing argument number of elements????\n implicit none\n integer n !IN: phase number\n integer c !IN: sequantial constituent index over all sublattices\n double precision stoi(*) !EXIT: stoichiometry of elements \n double precision mass !EXIT: total mass\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpcs not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcs\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq)\n! get stoichiometry of component n1\n! n2 is number of elements (dimension of elnames and stoi)\n implicit none\n integer n1 !IN: component number\n integer n2 !EXIT: number of elements in component\n character elnames(*)*(2) ! EXIT: element symbols\n double precision stoi(*) ! EXIT: element stoichiometry\n double precision mass ! EXIT: component mass (sum of element mass)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgccf not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgccf\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnpc(n,c,ceq)\n! get number of constituents of phase n\n implicit none\n integer n !IN: Phase number\n integer c !EXIT: number of constituents\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgnpc not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgnpc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpsm(n,phases,status,amdgm,ceq)\n! get all phase names and their status and amounts or DGM\n integer n\n character phases(*)*24\n integer status(*)\n double precision amdgm(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer i\n character dummy*64,statevar*64\n n=nooftup()\n! phasetuple: lokph,compset,ixphase,lokvares,nextcs\n do i=1,n\n call get_phasetup_name(i,phases(i))\n! the status is in phase_varres record, THIS IS NOT PRIVATE\n! phastate values: 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended\n status(i)=ceq%phase_varres(phasetuple(i)%lokvares)%phstate\n! if status 0 or less the phase is not stable, extract DGM\n if(status(i).le.0) then\n statevar='DGM('//trim(phases(i))//')'\n call get_state_var_value(statevar,amdgm(i),dummy,ceq)\n else\n! this phase is stable, extract amount\n statevar='NPM('//trim(phases(i))//')'\n call get_state_var_value(statevar,amdgm(i),dummy,ceq)\n endif\n enddo\n1000 continue\n return\nend subroutine tqgpsm\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcref(cix,phase,tpref,ceq)\n! set component reference state\n integer cix\n character phase*(*)\n double precision tpref(*)\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer phtupx\n call find_phasetuple_by_name(phase,phtupx)\n if(gx%bmperr.ne.0) goto 1000\n call set_reference_state(cix,phtupx,tpref,ceq)\n1000 continue\n return\n end subroutine tqcref\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqphsts(phtupx,newstat,val,ceq)\n! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX\n integer phtupx,newstat\n double precision val\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer n\n if(phtupx.le.0) then\n! if tup<0 change status of all phases\n do n=1,ntup\n call change_phtup_status(n,newstat,val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n elseif(phtupx.le.ntup) then\n call change_phtup_status(phtupx,newstat,val,ceq)\n else\n write(*,*)'Illegal phase tuple index',phtupx\n gx%bmperr=8888\n endif\n1000 continue\n return\n end subroutine tqphsts\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsetc(stavar,n1,n2,value,cnum,ceq)\n! set condition\n! stavar is state variable as text\n! n1 and n2 are auxilliary indices\n! value is the value of the condition\n! cnum is returned as an index of the condition.\n! to remove a condition the value sould be equial to RNONE ????\n! phase index is phase tuple index (include composition set)\n! see TQGETV for doucumentation of stavar etc.\n implicit none\n integer n1 ! IN: 0 or phase tuple index or component number\n integer n2 ! IN: 0 or component number\n integer cnum ! EXIT: sequential number of this condition\n character stavar*(*) ! IN: character with state variable symbol\n double precision value ! IN: value of condition\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer ip,ip2\n character cline*60,selvar*4,cval*24\n!\n! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value\n11 format(a,a,2i5,1pe14.6)\n cline=' '\n! extract a value after an =\n ip=index(stavar,'=')\n if(ip.gt.0) then\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n!@CC\n ip2=index(stavar,'(')\n if(ip2.gt.0) then\n ip = ip2\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n endif\n!@CC\n! write(*,*)'Value after = :',cval\n else\n selvar=stavar\n cval=' '\n endif\n call capson(selvar)\n select case(selvar)\n case default\n write(*,*)'Condition wrong, not implemented or illegal: ',stavar\n gx%bmperr=8888; goto 1000\n! Potentials T and P\n case('T ','P ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n write(cline,110)selvar(1:1),value\n110 format(' ',a,'=',E15.8)\n endif\n! Total amount or amount of a component in moles\n case('N ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n if(n1.gt.0) then\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n112 format(' ',a,'(',a,')=',E15.8)\n! write(*,*)'Setting condition: ',cline(1:len_trim(cline))\n else\n write(cline,110)selvar(1:1),value\n endif\n endif\n! Overall fraction of a component \n case('X ','W ')\n! ?? fraction of phase component not implemented, n1 must be component number\n! call get_component_name(n1,cnam,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(ip.gt.0) then\n cline=' '//stavar\n else\n write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n120 format(1x,a,'(',a,')=',1pE15.8)\n endif\n case('H ','V ')\n! enthalpy or volume of system\n if(cval(1:1).eq.'=') then\n cline=' '//stavar\n else\n write(cline,130)selvar(1:1),value\n130 format(1x,a,'=',1pE15.8)\n endif\n! case ....\n! ?? MORE CONDITIONS WILL BE ADDED ...\n end select\n! write(*,*)'tqsetc condition: ',trim(cline)\n ip=1\n call set_condition(cline,ip,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip\n endif\n1000 continue\n return\n end subroutine tqsetc\n\n!@CC\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine toggle_dense_grid()\n if(btest(globaldata%status,GSXGRID)) then\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n write(*,3110)'reset'\n3110 format('Dense grid ',a)\n else\n globaldata%status=ibset(globaldata%status,GSXGRID)\n write(*,3110)'dense grid set'\n endif\n return\n end subroutine toggle_dense_grid\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqce(target,n1,n2,value,ceq)\n! calculate quilibrium with possible target\n! Target can be empty or a state variable with indices n1 and n2\n! value is the calculated value of target\n implicit none\n integer n1,n2,mode\n character target*(*)\n double precision value\n logical confirm\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer nyfas,j1,j2\n! mode=1 means start values using global gridminimization\n if(n1.lt.0) then\n! this means calculate without grid minimuzer\n mode=0\n confirm=.FALSE.\n! calcqeq3 is silent, no listing of phase changes etc.\n call calceq3(mode,confirm,ceq)\n else\n mode=1\n call calceq2(mode,ceq)\n if(gx%bmperr.eq.4204) then\n! if the error code is \"too many iterations\" try without grid minimizer\n! it converges in many cases\n! write(*,2048)gx%bmperr\n2048 format('Error ',i5,', cleaning up and trying harder')\n gx%bmperr=0\n call calceq2(0,ceq)\n endif\n endif\n if(gx%bmperr.ne.0) goto 1000\n! there may be new composition sets, update ntup\n! write(*,*)'Number of phase tuples: ',ntup\n nyfas=nooftup()\n! write(*,*)'Number of phase tuples: ',ntup,nyfas\n if(nyfas.ne.ntup) then\n! write(*,*)'Number of phase tuples changed: ',nyfas,ntup\n ntup=nyfas\n! if(allocated(ysave)) deallocate(ysave)\n! allocate(ysave(nyfas,maxconst))\n endif\n! copy the constitution to a local save array\n! if(.not.allocated(ysave)) then\n! allocate(ysave(nyfas,maxconst))\n! endif\n if(allocated(ysave)) deallocate(ysave)\n allocate(ysave(nyfas,maxconst))\n! the intention of saving constitution is to make it possible to interpolate\n! the calculation of G if the constitution is changed very little\n do j1=1,nyfas\n do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr)\n ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2)\n enddo\n enddo\n1000 continue\n return\n end subroutine tqce\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgetv(stavar,n1,n2,n3,values,ceq)\n! get equilibrium results using state variables\n! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 \n! n1 can be a phase tuple index, n2 a component index\n! n3 at the call is the dimension of the array values, \n! changed to number of values on exit\n! value is an array with the calculated value(s), n3 set to number of values.\n implicit none\n integer n1,n2,n3\n character stavar*(*)\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!========================================================\n! stavar must be a symbol listed below\n! IMPORTANT: some terms explained after the table\n! Symbol index1,index2 Meaning (unit)\n!.... potentials\n! T 0,0 Temperature (K)\n! P 0,0 Pressure (Pa)\n! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J)\n! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT)\n! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT\n!...... extensive variables\n! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase\n! UM 0,0 or ext.phase.index,0 same per mole components\n! UW 0,0 or ext.phase.index,0 same per kg\n! UV 0,0 or ext.phase.index,0 same per m3\n! UF ext.phase.index,0 same per formula unit of phase\n! S*3 0,0 or ext.phase.index,0 Entropy (J/K) \n! V 0,0 or ext.phase.index,0 Volume (m3)\n! H 0,0 or ext.phase.index,0 Enthalpy (J)\n! A 0,0 or ext.phase.index,0 Helmholtz energy (J)\n! G 0,0 or ext.phase.index,0 Gibbs energy (J)\n! ..... some extra state variables\n! NP ext.phase.index,0 Moles of phase\n! BP ext.phase.index,0 Mass of moles (kg)\n! Q ext.phase.index,0 Internal stability/RT (dimensionless)\n! DG ext.phase.index,0 Driving force/RT (dimensionless)\n!....... amounts of components\n! N 0,0 or component,0 or ext.phase.index,component Moles of component\n! X component,0 or ext.phase.index,component Mole fraction of component\n! B 0,0 or component,0 or ext.phase.index,component Mass of component\n! W component,0 or ext.phase.index,component Mass fraction of component\n! Y ext.phase.index,constituent*1 Constituent fraction\n!........ some parameter identifiers\n! TC ext.phase.index,0 Magnetic ordering temperature\n! BMAG ext.phase.index,0 Aver. Bohr magneton number\n! MQ& ext.phase.index,constituent Mobility\n! THET ext.phase.index,0 Debye temperature\n! LNX ext.phase.index,0 Lattice parameter\n! EC11 ext.phase.index,0 Elastic constant C11\n! EC12 ext.phase.index,0 Elastic constant C12\n! EC44 ext.phase.index,0 Elastic constant C44\n!........ NOTES:\n! *1 The phase index is the phase tuple index (extra composition sets at end)\n! *2 The constituent index is 10*species_number + sublattice_number\n! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also\n!--------------------------------------------------------------------\n! special addition for TQ interface: d2G/dyidyj\n! D2G + phase tuple\n!--------------------------------------------------------------------\n!\\end{verbatim}\n integer ics,mjj,nph,ki,kj,lp,lokph,lokcs\n character statevar*60,encoded*2048,name*24,selvar*4,norm*4\n! mjj should be the dimension of the array values ...\n mjj=n3\n selvar=stavar\n call capson(selvar)\n! for state variables like MQ&FE remove the part from & before the select\n! write(*,11)'In tqgetv: ',selvar,n1,n2,n3\n11 format(a,a,3i5)\n norm=' '\n lp=index(selvar,'&')\n if(lp.gt.0) then\n selvar(lp:)=' '\n else\n! check if variable is normallized, only M (per mole) allowed\n ki=len_trim(selvar)\n if(ki.ge.2) then\n if(selvar(ki:ki).eq.'M') then\n norm='M'\n selvar(ki:)=' '\n ki=ki-1\n endif\n endif\n endif\n!=======================================================================\n kj=index(selvar,'(')\n if(kj.gt.0) then\n selvar=selvar(1:kj-1)\n endif\n! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<'\n select case(selvar)\n case default\n write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar\n gx%bmperr=8888; goto 1000\n!--------------------------------------------------------------------\n! T or P\n case('T ','P ')\n call get_state_var_value(selvar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! chemical potential for a component\n case('MU ','MUS ')\n if(n1.lt.-1 .or. n1.eq.0) then\n write(*,*)'tqgetv 17: component number must be positive'\n gx%bmperr=8888; goto 1000\n elseif(n1 .eq.-1) then\n! this means all components\n statevar=trim(selvar)//'(*)'\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.le.noel()) then\n statevar=trim(selvar)//'('//trim(cnam(n1))//') '\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n! we must use index value(1) as the subroutine expect a single variable\n call get_state_var_value(statevar,values(1),encoded,ceq)\n else\n write(*,*)'No such component'\n endif\n!--------------------------------------------------------------------\n!@CC\n! Amount of moles /mass of components in a phase\n case('NP ', 'BP ')\n if(n1.lt.0) then\n! all phases\n statevar=stavar(1:2)//'(*)'\n!@CC\n! this returns all composition sets for all phases\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the amounts for all compsets of a phase sequentially\n! but here we want them in phase tuple order\n! the second argument is the number of values for each phase, here is 1 but\n! it can be for example compositions, then it should be number of components\n call sortinphtup(n3,1,values)\n else\n! NP for just one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar='NP('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Mole or mass fractions\n!@CC\n case('N ','B ','X ','W ')\n!@CC\n! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3\n if(n2.eq.0) then\n if(n1.lt.0) then\n! moles, mole or mass fraction of all components for all phases\n statevar=stavar(1:1)//'(*) '\n! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.eq.0) then\n! mole fraction for the state variable written as X(FE)\n! n1 and n2 not used, just check for wildcard\n! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar))\n if(index(stavar,'*').gt.0) then\n call get_many_svar(stavar,values,mjj,n3,encoded,ceq)\n else\n call get_state_var_value(stavar,values(1),encoded,ceq)\n endif\n else\n! mole fraction of a single component, no phase specification\n n3=1\n ics=1\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(cnam(n1))//')'\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n elseif(n1.lt.0) then\n!........................................................\n! for all phases one or several components\n if(n2.lt.0) then\n! this means all components all phases, for example x(*,*)\n statevar=stavar(1:1)//'(*,*) '\n! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, noel()\n! in this case\n ics=noel()\n call sortinphtup(n3,ics,values)\n else\n! a single component in all phases. n2 must not be zero\n! call get_component_name(n2,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(n2.le.0 .or. n2.ge.noel()) then\n write(*,*)'No such component'\n goto 1000\n endif\n! state variable like w(*,cr), the Cr content in all (stable) phases\n statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')'\n! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, in this case 1\n! ics=noel()\n! THIS MUST BE CHECKED !!!\n call sortinphtup(n3,1,values)\n endif\n elseif(n2.lt.0) then\n! this means all components in one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//',*) '\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n else\n! one component (n2) of one phase (n1)\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//','\n call get_component_name(n2,name,ceq)\n if(gx%bmperr.ne.0) goto 1000\n statevar(len_trim(statevar)+1:)=trim(name)//') '\n! write(*,*)'tqgetv 8: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n!--------------------------------------------------------------------\n! volume\n case('V ')\n if(norm(1:1).ne.' ') then\n statevar='V'//norm\n ki=2\n else\n statevar='V '\n ki=1\n endif\n if(n1.gt.0) then\n! Volume for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total volume\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Enthalpy\n case('H ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='H'//norm\n ki=2\n else\n statevar='H '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total enthalpy\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Gibbs energy\n case('G ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='G'//norm\n ki=2\n else\n statevar='G '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total Gibbs energy \n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Driving force relative stable equilibrium\n case('DG ')\n! Always normalized per mole\n if(norm(3:3).ne.' ') then\n statevar='DG'//norm\n ki=3\n else\n statevar='DG '\n ki=2\n endif\n! write(*,*)'tqgetv DGM: ',n1,ki\n if(n1.gt.0) then\n! The driving force for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'M('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! For all phases\n n3=0\n if(nooftup().gt.mjj) then\n write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup()\n gx%bmperr=8888\n goto 1000\n endif\n statevar='DGM(#) '\n write(*,*)'tqgetv 3: ',statevar\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3)\n write(*,*)'gx%bmperr: ',gx%bmperr\n endif\n!--------------------------------------------------------------------\n! Mobilities\n case('MQ ')\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')'\n! write(*,*)'statevar: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! Second derivatives of the Gibbs energy of a phase\n case('D2G ')\n lokcs=phasetuple(n1)%lokvares\n! this gives wrong value!! ??\n n3=size(ceq%phase_varres(lokcs)%yfr)\n! write(*,*)'D2G 3: ',n3\n kj=(n3*(n3+1))/2\n if(kj.gt.mjj) then\n write(*,*)'TQGETV error, array too small for D2G',mjj,kj\n gx%bmperr=8888\n goto 1000\n endif\n! write(*,*)'D2G 3: ',kj\n do ki=1,kj\n values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1)\n enddo\n end select\n!===========================================================================\n1000 continue\n return\n end subroutine tqgetv\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n subroutine tqgetg(lokres,n1,n2,values,ceq)\n! the partial derivative of the Gibbs energy ....??\n implicit none\n integer n1,n2,lokres\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n! \n double precision napfu, rgast\n integer count\n integer jl,size\n TYPE(gtp_phase_varres), pointer :: parres\n!\n count = 1\n!\n napfu=ceq%phase_varres(lokres)%abnorm(1)\n rgast=globaldata%rgas*ceq%tpval(1)\n parres=>ceq%phase_varres(lokres)\n! \n! write(*,100)(rgast*parres%gval(jl,1),jl=1,4)\n! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1)\n100 format('G/N, dG/dT:',4(1PE16.8))\n200 format('G/N/RT, N:',2(1PE16.8))\n! G_m^\\alpha = G_M^\\alpha/N^\\alpha, \\frac{\\partial G_m^\\alpha}{\\partial T},\n! \\frac{\\partial G_m^\\alpha}{\\partial P},\n! \\frac{\\partial^2 G_m^\\alpha}{\\partial T^2}\n values(count:count+3) = rgast*parres%gval(1:4,1)/napfu\n count = count + 4\n if (n1>0) then\n! 1/N^\\alpha * \\frac{\\partial G_M^\\alpha}{\\partial y_i}\n values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu\n count = count + n1\n if (n2>0) then\n! 1/N^\\alpha * \\frac{\\partial^2 G_M^\\alpha}{\\partial y_i\\partial y_j}\n values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu\n endif\n endif\n end subroutine tqgetg\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n \n subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,&\n consnames,n1,ceq)\n! equilibrates the constituent fractions of a phase for mole fractions xknown\n! and calculates the Darken matrix and unreduced diffusivities\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n! cpot are the (calculated) chemical potentials\n! tyst is TRUE means no outut\n! nend is the number of values returned in mugrad\n! mugrad are the derivatives of the chemical potentials wrt mole fractions??\n! mobval are the mobilities\n implicit none\n integer phtupx ! IN: index in phase tuple array\n integer nend\n logical tyst\n double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*)\n character*24, dimension(*) :: consnames \n integer n1\n TYPE(gtp_phasetuple), pointer :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n\n integer iph, ics, ll\n double precision mass\n character*24 spname\n \n phtup=>phasetuple(phtupx) \n call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq)\n \n iph=phasetuple(phtupx)%ixphase\n ics=1 \n n1 = noconst(iph,ics,firsteq)\n do ll=1,n1\n call get_constituent_name(iph,ll,consnames(ll),mass)\n enddo\n\n end subroutine tqgdmat\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n! tq_get_phase_constitution\n! This subroutine returns the sublattices and constitution of a phase\n! n1 is phase tuple index\n! nsub is the number of sublattices (1 if no sublattices)\n! cinsub is an array with the number of consttuents in each sublattice\n! spix is an array with the species index of the constituents in all sublattices\n! sites is an array of the site ratios for all sublattices. \n! yfrac is the constituent fractions in same order as in spix\n! extra is an array with some extra values: \n! extra(1) is the number of moles of components per formula unit\n! extra(2) is the net charge of the phase\n implicit none\n integer n1,nsub,cinsub(*),spix(*)\n double precision sites(*),yfrac(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n nsub,cinsub,spix,yfrac,sites,extra,ceq)\n1000 continue\n return\n end subroutine tqgphc1\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsphc1(n1,yfra,extra,ceq)\n! tq_set_phase_constitution\n! To set the constitution of a phase\n! n1 is phase tuple index\n! yfra is an array with the constituent fractions in all sublattices\n! in the same order as obtained by tqgphc1\n! extra is an array with returned values with the same meaning as in tqgphc1\n! NOTE The constituents fractions are normallized to sum to unity for each\n! sublattice and extra is calculated by tqsphc1\n! T and P must be set as conditions.\n implicit none\n integer n1\n double precision yfra(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n yfra,extra,ceq)\n1000 continue\n return\n end subroutine tqsphc1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNING: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt \n! compositions, 2 if also 2nd derivatives\n! n3 is returned as number of constituents (dimension of returned arrays)\n! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P\n! dgdy is an array with G.Yi\n! d2gdydt is an array with G.T.Yi\n! d2gdydp is an array with G.P.Yi\n! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj \n! reurned in the order: 1,1; 1,2; 1,3; ... \n! 2,2; 2,3; ...\n! 3,3; ...\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3\n double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! The inital size here can be 1000\n! n3=size(ceq%phase_varres(lokres)%yfr)\n! the actual number of constituents is better to take from this call\n n3=noconst(phasetuple(n1)%ixphase,1,ceq)\n! write(*,*)'tqcph1 3C',n3\n! gval last index is the property, other properties can also be extracted\n! t.ex. mobilites \n! The application program can also access these data directly ...\n if(gx%bmperr.eq.0) then\n do ij=1,6\n gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1)\n enddo\n do ij=1,n3\n dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1)\n d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1)\n d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1)\n enddo\n! size of upper triangle of symetrix matrix\n nofc=n3*(n3+1)/2\n do ij=1,nofc\n d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1)\n enddo\n else\n gtp=zero\n do ij=1,nofc\n dgdy(ij)=zero\n d2gdydt(ij)=zero\n d2gdydp(ij)=zero\n enddo\n nofc=nofc*(nofc+1)/2\n do ij=1,nofc\n d2gdy2(ij)=zero\n enddo\n endif\n1000 continue\n return\n end subroutine tqcph1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqcph2(n1,n2,n3,n4,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNIG: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is type of calculation (0, 1 or 2)\n! n3 is returned as number of constituents\n! n4 is index to ceq%phase_varres(lokres)% with all results\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3,n4\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! this should work but gave segmentation fault, find this a more cumbersum way\n n3=size(ceq%phase_varres(lokres)%yfr)\n n4=lokres\n! Uer can access results like\n! ceq%phase_varres(n4)%gval(1..6,1..prop)\n! prop=1 is G, other can be t.ex. Curie T, mobilites etc\n! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij)\n! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT\n! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP\n! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j)\n! arranged as a single dimenion array indexed by ixsym(i,j)\n!\n! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...)\n!\n1000 continue\n return\n end subroutine tqcph2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqdceq(name)\n! delete equilibrium with name\n implicit none\n character name*24\n! integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n! do not allow delete equilibrium 1\n if(n1.eq.1) then\n write(*,*)'No allowed to delete default equilibrium'\n gx%bmperr=4333\n goto 1000\n endif\n! ceq=>eqlista(n1)\n call delete_equilibria(name,ceq)\n1000 continue\n return\n end subroutine tqdceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcceq(name,n1,newceq,ceq)\n! copy_current_equilibrium to newceq\n! creates a new equilibrium record with name with values same as ceq\n! n1 is returned as index\n implicit none\n character name*24\n integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n !call enter_equilibrium(name,n1)\n !if(gx%bmperr.ne.0) goto 1000\n !newceq=>eqlista(n1)\n call copy_equilibrium(newceq,name,ceq)\n1000 continue\n return\n end subroutine tqcceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcneq(name,n1,newceq)\n! creates a new equilibrium record, same but simpler call than tqcceq\n! n1 is returned as index in eqlista\n implicit none\n character*(*), intent(in) :: name\n integer, intent(out) :: n1\n type(gtp_equilibrium_data), pointer, intent(out) :: newceq\n!\\end{verbatim}\n call enter_equilibrium(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n newceq=>eqlista(n1)\n1000 continue\n return\n end subroutine tqcneq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqselceq(name,ceq)\n! select current equilibrium to be that with name.\n! Note that equilibria can be deleted and change number but not name\n implicit none\n character name\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n call selecteq(n1,ceq)\n1000 continue\n return\n end subroutine tqselceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlr(lut,ceq)\n! list the equilibrium results like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer phtupx,iph,ics,lokvares,mode\n logical once\n write(lut,10)\n10 format(/20('*')/'Start debug output from TQLR: ')\n call list_conditions(lut,ceq)\n call list_global_results(lut,ceq)\n call list_components_result(lut,1,ceq)\n once=.TRUE.\n mode=0\n do phtupx=1,nooftup()\n lokvares=phasetuple(phtupx)%lokvares\n if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then\n iph=phasetuple(phtupx)%ixphase\n ics=phasetuple(phtupx)%compset\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n endif\n enddo\n write(lut,20)\n20 format('End debug output from TQLR'/20('*')/)\n1000 continue\n return\n end subroutine tqlr\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlc(lut,ceq)\n! list conditions like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n write(lut,10)\n10 format(/'Debug output from TQLC: ')\n call list_conditions(lut,ceq)\n1000 continue\n return\n end subroutine tqlc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqltdb\n! list TDB file elements, phases and parameters on screen\n implicit none\n!\\end{verbatim}\n integer n,kou\n! n is position in text, kou is output unit\n n=1; kou=6\n call list_many_formats(' ,,,, ',n,1,kou)\n write(*,10)\n10 format(/' no more ',/)\n return\n end subroutine tqltdb\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqquiet(yes)\n! if argument TRUE spurious output should be suppressed\n implicit none\n logical yes\n!\\end{verbatim}\n if(yes) then\n globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n else\n globaldata%status=ibset(globaldata%status,GSVERBOSE)\n endif\n return\n end subroutine tqquiet\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_globalbit(bit,onoff)\n! set a global bit\n implicit none\n integer bit,onoff\n!\\end{verbatim}\n! list here taken from models/gtp3.F90, only some allowed!!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 4 NOMERGE: no merge of gridmin result, \n! 5 NODATA: not any data, \n! 6 NOPHASE: no phase in system, \n! 7 NOACS: no automatic creation of composition set for any phase\n! 8 NOREMCS: do not remove any redundant unstable composition sets\n! 9 NOSAVE: data changed after last save command\n! 10 VERBOSE: maximum of listing\n! 11 SETVERB: permanent setting of verbose\n! 12 SILENT: as little output as possible\n! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation\n! 14 XGRID: extra dense grid for all phases\n! 15 NOPAR: do not run in parallel\n! 16 NOSMGLOB do not test global equilibrium at node points\n! 17 NOTELCOMP the elements are not the components\n! 18 TGRID use grid minimizer to test if global after calculating equilibrium\n! 19 OGRID use old grid generator\n! 20 NORECALC do not recalculate equilibria even if global test after fails\n! 21 OLDMAP use old map algorithm\n! 22 NOAUTOSP do not generate automatic start points for mapping\n! 23 GSYGRID extra dense grid\n! 24 GSVIRTUAL (CCI) enables calculations with a virtual element\n if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then\n if(onoff.gt.0) then\n! set bit\n globaldata%status=ibset(globaldata%status,bit)\n else\n globaldata%status=ibclr(globaldata%status,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_globalbit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_phasebit(phtupx,bit,onoff)\n! set a bit of phase\n implicit none\n integer phtupx,bit,onoff\n!\\end{verbatim}\n! taken from models/gtp3.F90\n!-Bits in PHASE record STATUS1 there are also bits in each phase_varres record!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 0 HID phase is hidden (not implemented)\n! 1 IMHID phase is implictly hidden (not implemented)\n! 2 ID phase is ideal, substitutional and no interaction\n! 3 NOCV phase has no concentration variation (fix composition)\n! 4 HASP phase has at least one parameter entered\n! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations\n! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations\n! 7 SORD phase has TCP type ordering (like for sigma)\n! 8 MFS phase has a disordered fraction set\n! 9 GAS this is the gas phase (first in phase list) \n! 10 LIQ phase is liquid (can be several but listed directly after gas)\n! 11 IONLIQ phase has ionic liquid model (I2SL)\n! 12 AQ1 phase has aqueous model (not implemented)\n! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED?\n! 14 QCE phase has quasichemical SRO configurational entropy (not implemented)\n! 15 CVMCE phase has some CVM ordering entropy (not implemented)\n! 16 EXCB phase need explicit charge balance (has ions)\n! 17 XGRID use extra dense grid for this phase\n! 18 FACTCE phase has FACT quasichemical SRO model (not implemented)\n! 19 NOCS not allowed to create composition sets for this phase\n! 20 HELM parameters are for a Helmholz energy model (not implemented),\n! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives\n! 22 not implemented ELMA phase has elastic model A (not implemented)\n! 23 EECLIQ the condensed phase (liquid) that should have highest entropy\n! 24 PHSUBO special use testing models DO NOT USE\n! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!!\n! 26 MULTI may be used with care\n! 27 BMAV Xion magnetic model with average Bohr magneton number\n! 28 UNIQUAC The UNIQUAC fluid model\n! 29 DILCE phase has dilute configigurational entropy (not implemented)\n! only bittar 3 left!\n integer lokph\n if(phtupx.le.0 .or. phtupx.gt.nooftup()) then\n gx%bmperr=4325\n elseif(bit.eq.17 .or. bit.eq.19) then\n lokph=phasetuple(phtupx)%lokph\n if(onoff.gt.0) then\n call set_phase_status_bit(lokph,bit)\n else\n call clear_phase_status_bit(lokph,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_phasebit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqset_gaddition(phtupx,gadd,ceq)\n! set fix addition to Gibbs energy of a phase#compset\n implicit none\n integer phtupx\n double precision gadd\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! Provided by Christophe Sigli 2018?\n integer lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n ceq%phase_varres(lokcs)%addg(1)=gadd\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n return\n end subroutine tqset_gaddition\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tq_add_const_energy(energy,phtupx,ceq)\n! add a constant energy in J/mole\n double precision,intent(in) :: energy\n type(gtp_equilibrium_data), pointer :: ceq\n integer,intent(in) :: phtupx\n!\\end{verbatim}\n! Provided by Jan Herrnring 2020.12.15\n integer :: lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n! add a constant term to G, value in J/FU\n! Abnorm is the number of moles of the phase\n ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1)\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n end subroutine tq_add_const_energy\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n \nend MODULE LIBOCTQ\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy modules\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule ftinyopen\n !\n ! This module replaces a C module for a popup window to open files\n ! used in the interactive OC. If you want to use the original\n ! version for opening files please check the linkmake or Makefile\n !\ncontains\n\n subroutine getfilename(typ,sval)\n implicit none\n integer typ\n character sval*(*)\n sval=' '\n return\n end subroutine getfilename\n\nend module ftinyopen\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy module (only Linux)\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule M_getkey\n !\n ! This module replaces a C module fore single character input on Linux\n !\ncontains\n\n character function getkex()\n getkex=' '\n return\n end function getkex\n\nend module M_getkey\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/AlNiPt-2005.TDB", "content": "$ AL-PT FROM /alnipt/alpt-new/MSL/alpt.PAR, \n$ this is the only differences from alnipt-1221.TDB \n$ L(L12, AL:AL:NI,PT:NI,PT)=RECPTPT+V74 \n$ Ni-Pt from ntt6 \n$ Al-Ni from Nath: alni-270403.TDB \n$ \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! \n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! \n ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01! \n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! \n ELEMENT PT FCC_A1 1.9508E+02 5.7237E+03 4.1631E+01! \n \n FUNCTION GHSERAL 2.98150E+02 -7976.15+137.093038*T-24.3671976*T*LN(T) \n -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y \n -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2 \n -5.764227E-06*T**3+74092*T**(-1); 9.33600E+02 Y \n -11278.378+188.684153*T-31.748192*T*LN(T)-1.231E+28*T**(-9); \n 6.00000E+03 N ! \n FUNCTION GBCCAL 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N ! \n FUNCTION GLIQAL 2.98140E+02 +11005.029-11.841867*T+7.934E-20*T**7 \n +GHSERAL#; 9.33590E+02 Y \n +10482.282-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N ! \n \n FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T) \n -.0048407*T**2; 1.72800E+03 Y \n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6.00000E+03 N ! \n FUNCTION GBCCNI 2.98150E+02 +8715.084-3.556*T+GHSERNI#; 6.00000E+03 N ! \n \n FUNCTION GHSERPT 2.98150E+02 -7595.631+124.388276*T-24.5526*T*LN(T) \n -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 1.30000E+03 Y \n -9253.174+161.529616*T-30.2527*T*LN(T)+.002321665*T**2 \n -6.56947E-07*T**3-272106*T**(-1); 2.04210E+03 Y \n -222518.973+1021.21087*T-136.422689*T*LN(T)+.020501692*T**2 \n -7.60985E-07*T**3+71709819*T**(-1); 4.00000E+03 N ! \n FUNCTION GBCCPT 2.98150E+02 +15000-2.4*T+GHSERPT#; 6.00000E+03 N! \n \n \n$ disordered FCC part moved here, BCC is just B2 ordering, no disordered part\n TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART FCC_A1,,,! \n\n\n$alni-270403 \n FUNCTION LLIQ2 298.15 +81204.81-31.95713*T;,, N 95DUP3 ! \n FUNCTION LLIQ3 298.15 +4365.35-2.51632*T;,, N 95DUP3 ! \n FUNCTION LLIQ4 298.15 -22101.64+13.16341*T;,, N 95DUP3 ! \n FUNCTION LLIQ0 298.15 -5*LLIQ2-9*LLIQ4;,, N 95DUP3 ! \n FUNCTION LLIQ1 298.15 -7*UNTIER*LLIQ3;,, N 95DUP3 ! \n FUNCTION DEUX 298.15 2;,, N 95DUP3 ! \n FUNCTION UNSURDEU 298.15 +DEUX**(-1);,, N 95DUP3 ! \n FUNCTION GB2NINI 298.15 +GBCCNI;,, N 95DUP3 ! \n FUNCTION GB2ALVA 298.15 +5000-.5*T+UNSURDEU*GBCCAL;,, N 95DUP3 ! \n FUNCTION GB2ALNI 298.15 -76198.65+13.202875*T \n +UNSURDEU*GBCCAL+UNSURDEU*GBCCNI;,, N 95DUP3 ! \n FUNCTION GB2NIVA 298.15 -GB2ALNI+GB2NINI+GB2ALVA;,, N 95DUP3 ! \n FUNCTION SIX 298.15 6;,, N 95DUP3 ! \n FUNCTION UNSURSIX 298.15 +SIX**(-1);,, N 95DUP3 ! \n FUNCTION GALALVA 298.15 +5000-.5*T+5*UNSURSIX*GBCCAL;,, N 95DUP3 ! \n FUNCTION GALNINI 298.15 +5000+GB2ALNI;,, N 95DUP3 ! \n FUNCTION GALNIVA 298.15 -59620.987+11.387*T \n +3*UNSURSIX*GBCCAL+2*UNSURSIX*GBCCNI;,, N 95DUP3 ! \n FUNCTION GALALNI 298.15 -GALNIVA+GALALVA+GALNINI;,, N 95DUP3 ! \n FUNCTION L32ALNI 298.15 -32247.363+21.965*T;,, N 95DUP3 ! \n FUNCTION L32NIVA 298.15 -3666.95+1.1722*T;,, N 95DUP3 ! \n FUNCTION U1ALNI 298.15 -13415.515+2.0819247*T;,, N 95DUP3 ! \n \n FUNCTION UALNI 298.15 -43590+6.22*T;,, N 03SUN ! \n FUNCTION ALPHA 298.15 -29600;,, N 03SUN ! \n FUNCTION BETA 298.15 -66718+11.64*T;,, N 03SUN ! \n FUNCTION AL3NI 298.15 ALPHA;,, N 03SUN ! \n FUNCTION AL2NI2 298.15 BETA;,, N 03SUN ! \n FUNCTION ALNI3 298.15 UALNI;,, N 03SUN ! \n \n FUNCTION URALNI 298.15 -34575+13.22*T;,, N 03SUN ! \n \n FUNCTION LFCC0 298.15 +AL3NI+1.5*AL2NI2+ALNI3+1.5*URALNI;,, N 03SUN ! \n FUNCTION LFCC1 298.15 +2*AL3NI-2*ALNI3;,, N 03SUN ! \n FUNCTION LFCC2 298.15 +AL3NI-1.5*AL2NI2+ALNI3-1.5*URALNI;,, N 03SUN ! \n FUNCTION LFCC3 298.15 0.0; 6000.00 N 03SUN ! \n FUNCTION U3ALNI 298.15 0.0; 6000.00 N 03SUN ! \n \n FUNCTION L0ALNI 298.15 5310-1.46*T;,, N ! \n FUNCTION UN_ASS 298.15 0; 300 N ! \n \n$****AL-PT \n$ FUNCTION UAB 298.15 -13595+8.3*T; 6000 N ! \n$ FUNCTION UPT3AL 298.15 +3*UAB#-3913; 6000 N ! \n$ FUNCTION UPTAL 298.15 +4*UAB#; 6000 N ! \n$ FUNCTION UPTAL3 298.15 +3*UAB#; 6000 N ! \n$ FUNCTION UL0 298.15 +1412.8+5.7*T; 6000 N ! \n$ FUNCTION USRO 298.15 +UAB#; 6000 N ! \n$ FUNCTION ULD0 298.15 -110531-22.9*T; 6000 N ! \n$ FUNCTION ULD1 298.15 -25094; 6000 N ! \n$ FUNCTION ULD2 298.15 +21475; 6000 N ! \n$ FUNCTION DG0 298.15 +UPTAL3#+1.5*UPTAL#+UPT3AL#; 6000 \n$ N ! \n$ FUNCTION DG1 298.15 +2*UPTAL3#-2*UPT3AL#; 6000 N ! \n$ FUNCTION DG2 298.15 +UPTAL3#-1.5*UPTAL#+UPT3AL#; 6000 \n$ N ! \n \n FUNCTION APL0FCC 298.15 4e4+4*T; 6000 N ! \n FUNCTION APL1FCC 298.15 0; 6000 N ! \n FUNCTION APL2FCC 298.15 0; 6000 N ! \n FUNCTION APL3FCC 298.15 0; 6000 N ! \n \n FUNCTION RAL3PT1 298.15 -44.8e3+5*T; 6000 N ! \n FUNCTION RAL2PT2 298.15 -81.4e3+5*T; 6000 N ! \n FUNCTION RAL1PT3 298.15 -66.9e3+5*T; 6000 N ! \n \n FUNCTION GAL3PT1 298.15 RAL3PT1-0.1875*APL0FCC-0.09375*APL1FCC \n -0.046875*APL2FCC-0.0234375*APL3FCC; 6000 N ! \n FUNCTION GAL2PT2 298.15 RAL2PT2-0.25*APL0FCC; 6000 N ! \n FUNCTION GAL1PT3 298.15 RAL1PT3-0.1875*APL0FCC+0.09375*APL1FCC \n -0.046875*APL2FCC+0.0234375*APL3FCC; 6000 N ! \n \n FUNCTION ALPTG0 2.98150E+02 +GAL3PT1#+1.5*GAL2PT2#+GAL1PT3#; \n 6.00000E+03 N ! \n FUNCTION ALPTG1 2.98150E+02 +2*GAL3PT1#-2*GAL1PT3#; 6.00000E+03 N ! \n FUNCTION ALPTG2 2.98150E+02 +GAL3PT1#-1.5*GAL2PT2#+GAL1PT3#; \n 6.00000E+03 N ! \n \n FUNCTION UL0 298.15 0; 6000 N ! \n$ UAP only used in ternary \n FUNCTION UAP 298.15 -22e3+2*T; 6000 N ! \n FUNCTION REC 298.15 -35e3+3*T; 6000 N ! \n \n$*****NI-PT \n FUNCTION L0FCC 298.15 27500+10.977*T; 6000 N ! \n FUNCTION L1FCC 298.15 -6500; 6000 N ! \n FUNCTION L2FCC 298.15 0; 6000 N ! \n FUNCTION L3FCC 298.15 0; 6000 N ! \n \n FUNCTION RNI3PT1 298.15 -1.09000000E+04; 6000 N ! \n FUNCTION RNI2PT2 298.15 -1.35000000E+04-0.5*T; 6000 N ! \n FUNCTION RNI1PT3 298.15 -8.30000000E+03-0.5*T; 6000 N ! \n \n FUNCTION GNI3PT1 298.15 RNI3PT1-0.1875*L0FCC-0.09375*L1FCC \n -0.046875*L2FCC-0.0234375*L3FCC; 6000 N ! \n FUNCTION GNI2PT2 298.15 RNI2PT2-0.25*L0FCC; 6000 N ! \n FUNCTION GNI1PT3 298.15 RNI1PT3-0.1875*L0FCC+0.09375*L1FCC \n -0.046875*L2FCC+0.0234375*L3FCC; 6000 N ! \n \n FUNCTION NIPTG0 2.98150E+02 +GNI3PT1#+1.5*GNI2PT2#+GNI1PT3#; \n 6.00000E+03 N ! \n FUNCTION NIPTG1 2.98150E+02 +2*GNI3PT1#-2*GNI1PT3#; 6.00000E+03 N ! \n FUNCTION NIPTG2 2.98150E+02 +GNI3PT1#-1.5*GNI2PT2#+GNI1PT3#; \n 6.00000E+03 N ! \n \n FUNCTION RECNINI 298.15 -3.67000000E+03; 6000 N ! \n FUNCTION RECNIPT 298.15 -3.25000000E+03; 6000 N ! \n FUNCTION RECPTPT 298.15 -2.73000000E+03; 6000 N ! \n \n$*****NI-AL-PT \n FUNCTION TROIS 2.98150E+02 3; 6.00000E+03 N ! \n FUNCTION UNTIER 2.98150E+02 +TROIS#**(-1); 6.00000E+03 N ! \n FUNCTION GNIPT 298.15 GNI3PT1#*UNTIER#; 6000 N ! \n FUNCTION GAL2NIPT 298.15 2*UAP#+2*U1ALNI#+GNIPT#-1.1E4; 6000 N 05LU! \n FUNCTION GNI2ALPT 298.15 2*U1ALNI#+2*GNIPT#+UAP#-1000; 6000 N 05LU! \n FUNCTION GPT2ALNI 298.15 2*GNIPT#+2*UAP#+U1ALNI#-10000; 6000 N 05LU! \n FUNCTION LALNIALPT 298.15 0.5*U1ALNI+0.5*UAP-0.5*GNIPT+10000;\n 6000 N 05LU!\n FUNCTION LALNINIPT 298.15 0.5*U1ALNI-0.5*UAP+0.5*GNIPT+3000;\n 6000 N 05LU ! \n FUNCTION LALPTNIPT 298.15 -0.5*U1ALNI+0.5*UAP+0.5*GNIPT; 6000 N 05LU!\n$*************** \n \n TYPE_DEFINITION % SEQ *! \n$ DEFINE_SYSTEM_DEFAULT ELEMENT 4 ! \n DEFAULT_COMMAND DEF_SYS_ELEMENT VA ! \n \n \n$******************************** Liquid \n \n PHASE LIQUID:L % 1 1.0 ! \n CONSTITUENT LIQUID:L :AL,NI,PT : ! \n \n PARAMETER G(LIQUID,AL;0) 2.98150E+02 +11005.029-11.841867*T \n +7.934E-20*T**7+GHSERAL#; 9.33600E+02 Y \n +10482.282-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N \n 91DIN ! \n PARAMETER G(LIQUID,NI;0) 2.98130E+02 +16414.686-9.397*T \n -3.82318E-21*T**7+GHSERNI#; 1.72800E+03 Y \n +18290.88-10.537*T-1.12754E+31*T**(-9)+GHSERNI#; 6.00E+03 N 91DIN ! \n PARAMETER G(LIQUID,PT;0) 2.98150E+02 +12520.614+115.114727*T \n -24.5526*T*LN(T)-.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 6.0E+02 \n Y \n +19019.913+33.017485*T-12.351404*T*LN(T)-.011543133*T**2+9.30579E-07*T**3 \n -600885*T**(-1); 2.04210E+03 Y \n +1404.968+205.861909*T-36.5*T*LN(T); 4.00000E+03 N REF283 ! \n \n PARAMETER L(LIQUID,AL,NI;0) 298.15 +LLIQ0;,, N 95DUP3 ! \n PARAMETER L(LIQUID,AL,NI;1) 298.15 +LLIQ1;,, N 95DUP3 ! \n PARAMETER L(LIQUID,AL,NI;2) 298.15 +LLIQ2;,, N 95DUP3 ! \n PARAMETER L(LIQUID,AL,NI;3) 298.15 +LLIQ3;,, N 95DUP3 ! \n PARAMETER L(LIQUID,AL,NI;4) 298.15 +LLIQ4;,, N 95DUP3 ! \n \n PARAMETER L(liquid,ni,pt;0) 2.98150E+02 -4.07756E+04; \n 6.00000E+03 N 05LU ! \n PARAMETER L(liquid,ni,pt;1) 2.98150E+02 -5.5E+03; 6.00000E+03 N 05LU ! \n PARAMETER L(liquid,ni,pt;2) 2.98150E+02 3.50E+03; 6.00000E+03 N 05LU ! \n \n PARAMETER L(liquid,al,ni,pt;0) 2.98150E+02 2.0E5; \n 6.00000E+03 N 05LU !\n PARAMETER G(LIQUID,AL,PT;0) 298.15 -3.10000000E+05+10*T; \n 6.0000E+03 N REF0 ! \n PARAMETER G(LIQUID,AL,PT;1) 298.15 -4.00000000E+04-15*T; \n 6.00E+03 N REF0 ! \n \n$********************* FCC_A1 \n \n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! \n PHASE FCC_A1 %( 2 1 1 ! \n CONSTITUENT FCC_A1 :AL,NI%,PT : VA% : ! \n \n PARAMETER G(FCC_A1,AL:VA;0) 2.98150E+02 +GHSERAL#; 6.00000E+03 N \n 91DIN ! \n PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 6.00000E+03 N \n 91DIN ! \n PARAMETER G(FCC_A1,PT:VA;0) 2.98150E+02 +GHSERPT#; 4.00000E+03 N \n REF283 ! \n$ PARAMETER TC(FCC_A1,PT:VA;0) 2.98150E+02 -307.85; 6.00000E+03 \n$ N REF: 0 ! \n PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N 89DIN ! \n PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N 89DIN ! \n$ PARAMETER L(fcc_a1,al,pt:va;0) 2.98150E+02 -262446.89; 2.90000E+03 N ! \n$ PARAMETER L(fcc_a1,al,pt:va;1) 2.9815E+02 102728.95-8.57*T; 2.90000E+03 N \n$ REF01! \n PARAMETER TC(FCC_A1,AL,NI:VA;0) 2.98150E+02 -1112; 6.00000E+03 N \n 95DUP3 ! \n PARAMETER TC(FCC_A1,AL,NI:VA;1) 2.98150E+02 1745; 6.00000E+03 N \n 95DUP3 ! \n \n PARAMETER L(FCC_A1,AL,NI:VA;0) 298.15 +LFCC0+4*L0ALNI;,, N 03SUN ! \n PARAMETER L(FCC_A1,AL,NI:VA;1) 298.15 +LFCC1;,, N 03SUN ! \n PARAMETER L(FCC_A1,AL,NI:VA;2) 298.15 +LFCC2;,, N 03SUN ! \n PARAMETER L(FCC_A1,AL,NI:VA;3) 298.15 +LFCC3;,, N 03SUN ! \n \n$ these ternary parameters below not included and wrong and duplicate ?? !!!\n PARAMETER L(fcc_a1,ni,pt:va;0) 2.98150E+02 +L0FCC+NIPTG0+0.375*RECNINI \n +0.75*RECNIPT#+0.375*RECPTPT#; 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,ni,pt:va;1) 2.98150E+02 +L1FCC+NIPTG1+0.75*RECNINI# \n -0.75*RECPTPT#; 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,ni,pt:va;2) 2.98150E+02 +L2FCC+NIPTG2-1.5*RECNIPT#; \n 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,ni,pt:va;3) 2.98150E+02 +L3FCC-0.75*RECNINI# \n +0.75*RECPTPT#; 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,ni,pt:va;4) 2.98150E+02 -0.375*RECNINI#+0.75*RECNIPT# \n -0.375*RECPTPT#; 6.0E+03 N 05LU ! \n \n PARAMETER L(fcc_a1,al,ni,pt:va;0) 2.98150E+02 +3.0E4; \n 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,al,ni,pt:va;1) 2.98150E+02 0; 6.00000E+03 N 05LU ! \n PARAMETER L(fcc_a1,al,ni,pt:va;2) 2.98150E+02 0; 6.00000E+03 N 05LU ! \n$ these ternary parameters above not included and duplicate and wrong ?? !!!\n \n PARAMETER G(FCC_A1,AL,PT:VA;0) 298.15 +APL0FCC#+ALPTG0#+1.5*REC#; \n 6000 N REF0 ! \n PARAMETER G(FCC_A1,AL,PT:VA;1) 298.15 +APL1FCC#+ALPTG1#; 6000 N \n REF0 ! \n PARAMETER G(FCC_A1,AL,PT:VA;2) 298.15 +APL2FCC#+ALPTG2#-1.5*REC#; \n 6000 N REF0 ! \n PARAMETER G(FCC_A1,AL,PT:VA;3) 298.15 +APL3FCC#; \n 6000 N REF0 ! \n \n \n$************FCC_4SL \n$ TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART FCC_A1,,,! \n$ TYPE_DEFINITION M GES A_P_D FCC_4SL C_S 2 NI:NI:NI:PT:VA ! \n$ TYPE_DEFINITION P GES A_P_D FCC_4SL C_S 3 NI:NI:PT:PT:VA ! \n$ TYPE_DEFINITION Q GES A_P_D FCC_4SL C_S 4 NI:PT:PT:PT:VA ! \n TYPE_DEFINITION Z GES A_P_D FCC_4SL MAGNETIC -3.0 2.80000E-01 ! \n PHASE FCC_4SL %*Z 5 .25 .25 .25 .25 1 ! \n CONSTITUENT FCC_4SL :AL,NI,PT:AL,NI,PT:AL,NI,PT:AL,NI,PT:VA%: ! \n \n$ PARA G(FCC_4SL,AL:AL:AL:AL:VA;0) 298.15 0; 6000 N! \n$ PARA G(FCC_4SL,NI:NI:NI:NI:VA;0) 298.15 0; 6000 N! \n$ PARA G(FCC_4SL,PT:PT:PT:PT:VA;0) 298.15 0; 6000 N! \n \n PARAMETER G(FCC_4SL,NI:AL:AL:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:NI:AL:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:NI:AL:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:AL:NI:AL:VA;0) 298.15 +AL3NI; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:AL:NI:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:NI:NI:AL:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:NI:NI:AL:VA;0) 298.15 +ALNI3; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:AL:AL:NI:VA;0) 298.15 +AL3NI; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:AL:AL:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:NI:AL:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:NI:AL:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:AL:NI:NI:VA;0) 298.15 +AL2NI2; ,, 03SUN ! \n PARAMETER G(FCC_4SL,NI:AL:NI:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! \n PARAMETER G(FCC_4SL,AL:NI:NI:NI:VA;0) 298.15 +ALNI3; ,, 03SUN ! \n \n PARAMETER G(FCC_4SL,PT:AL:AL:AL:VA;0) 298.15 +GAL3PT1#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:PT:AL:AL:VA;0) 298.15 +GAL3PT1#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:PT:AL:AL:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:AL:PT:AL:VA;0) 298.15 +GAL3PT1#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:AL:PT:AL:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:PT:PT:AL:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:PT:PT:AL:VA;0) 298.15 +GAL1PT3#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:AL:AL:PT:VA;0) 298.15 +GAL3PT1#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:AL:AL:PT:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:PT:AL:PT:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:PT:AL:PT:VA;0) 298.15 +GAL1PT3#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:AL:PT:PT:VA;0) 298.15 +GAL2PT2#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,PT:AL:PT:PT:VA;0) 298.15 +GAL1PT3#; \n\t3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL:PT:PT:PT:VA;0) 298.15 +GAL1PT3#; \n\t3000 N REF0 ! \n \n PARAMETER G(FCC_4SL,PT:NI:NI:NI:VA;0) 2.98150E+02 +GNI3PT1#; \n6.0E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:NI:NI:VA;0) 2.98150E+02 +GNI3PT1#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:PT:NI:NI:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI:PT:NI:VA;0) 2.98150E+02 +GNI3PT1#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:PT:NI:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:PT:NI:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:PT:PT:NI:VA;0) 2.98150E+02 +GNI1PT3#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI:NI:PT:VA;0) 2.98150E+02 +GNI3PT1#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:NI:PT:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:NI:PT:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:PT:NI:PT:VA;0) 2.98150E+02 +GNI1PT3#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI:PT:PT:VA;0) 2.98150E+02 +GNI2PT2#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:PT:PT:VA;0) 2.98150E+02 +GNI1PT3#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:PT:PT:VA;0) 2.98150E+02 +GNI1PT3#; \n6E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,NI:NI:AL:PT:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI:PT:AL:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:NI:PT:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:NI:AL:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:PT:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:AL:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:NI:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:NI:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:PT:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:AL:NI:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:NI:PT:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:NI:AL:VA;0) 2.98150E+02 +GNI2ALPT#; \n6E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,AL:AL:NI:PT:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:AL:PT:NI:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:AL:PT:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:AL:NI:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:PT:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:NI:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:AL:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:AL:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:PT:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:NI:AL:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:AL:PT:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:AL:NI:VA;0) 2.98150E+02 +GAL2NIPT#; \n6E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,PT:PT:NI:AL:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:PT:AL:NI:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:PT:AL:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:PT:NI:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:AL:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:NI:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:PT:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:PT:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:AL:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:NI:PT:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:PT:PT:AL:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:PT:NI:VA;0) 2.98150E+02 +GPT2ALNI#; \n6E+03 N 05LU ! \n \n PARAMETER L(FCC_4SL,AL,NI:*:*:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! \n PARAMETER L(FCC_4SL,*:AL,NI:*:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! \n PARAMETER L(FCC_4SL,*:*:AL,NI:*:VA;0) 298.15 +L0ALNI; ,, 03SUN ! \n PARAMETER L(FCC_4SL,*:*:*:AL,NI:VA;0) 298.15 +L0ALNI; ,, 03SUN ! \n \n PARAMETER G(FCC_4SL,AL,PT:*:*:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:AL,PT:*:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:*:AL,PT:*:VA;0) 298.15 +UL0#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:*:*:AL,PT:VA;0) 298.15 +UL0#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL,PT:AL,PT:*:*:VA;0) 298.15 +REC#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL,PT:*:AL,PT:*:VA;0) 298.15 +REC#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,AL,PT:*:*:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:AL,PT:AL,PT:*:VA;0) 298.15 +REC#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:AL,PT:*:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! \n PARAMETER G(FCC_4SL,*:*:AL,PT:AL,PT:VA;0) 298.15 +REC#; 3000 N REF0 ! \n \n PARAMETER L(FCC_4SL,*:*:AL,NI:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! \n PARAMETER L(FCC_4SL,*:AL,NI:*:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! \n PARAMETER L(FCC_4SL,AL,NI:*:*:AL,NI:VA;0) 298.15 +URALNI;,, N 03SUN ! \n PARAMETER L(FCC_4SL,*:AL,NI:AL,NI:*:VA;0) 298.15 +URALNI;,, N 03SUN ! \n PARAMETER L(FCC_4SL,AL,NI:*:AL,NI:*:VA;0) 298.15 +URALNI;,, N 03SUN ! \n PARAMETER L(FCC_4SL,AL,NI:AL,NI:*:*:VA;0) 298.15 +URALNI;,, N 03SUN ! \n \n PARAMETER G(FCC_4SL,NI:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:NI:NI,PT:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:NI:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:NI:VA;0) 2.98150E+02 RECNINI; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,PT:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,AL:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:AL:NI,PT:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:AL:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:AL:VA;0) 2.98150E+02 RECPTPT; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,NI:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:PT:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:NI:VA;0) 2.98150E+02 RECNIPT; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:NI:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:NI:AL:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:NI:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:NI:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+7000; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:AL:PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:NI,PT:PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:PT:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:AL:NI,PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:NI,PT:PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:NI,PT:AL:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL:NI,PT:PT:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n PARAMETER G(FCC_4SL,PT:NI,PT:AL:NI,PT:VA;0) 2.98150E+02 RECNIPT+2000; \n 6.00000E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,AL,NI:AL,PT:*:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,PT:AL,NI:*:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,NI:*:AL,PT:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,PT:*:AL,NI:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,NI:*:*:AL,PT:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,PT:*:*:AL,NI:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,NI:AL,PT:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,PT:AL,NI:*:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:AL,NI:AL,PT:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:AL,PT:AL,NI:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,NI:*:AL,PT:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,PT:*:AL,NI:VA;0) 2.9815E+02 LALNIALPT; \n6E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,AL,NI:NI,PT:*:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL,NI:*:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,NI:*:NI,PT:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:*:AL,NI:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,NI:*:*:NI,PT:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:*:*:AL,NI:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:AL,NI:NI,PT:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:NI,PT:AL,NI:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,NI:*:NI,PT:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:NI,PT:*:AL,NI:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,NI:NI,PT:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:NI,PT:AL,NI:*:VA;0) 2.9815E+02 LALNINIPT; \n6E+03 N 05LU ! \n \n PARAMETER G(FCC_4SL,AL,PT:NI,PT:*:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:AL,PT:*:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,PT:*:NI,PT:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:*:AL,PT:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,AL,PT:*:*:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,NI,PT:*:*:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:AL,PT:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:*:NI,PT:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,PT:*:NI,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:NI,PT:*:AL,PT:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:AL,PT:NI,PT:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n PARAMETER G(FCC_4SL,*:NI,PT:AL,PT:*:VA;0) 2.9815E+02 LALPTNIPT; \n6E+03 N 05LU ! \n \n$***********AL3NI1 \n PHASE AL3NI1 % 2 .75 .25 ! \n CONSTITUENT AL3NI1 :AL : NI : ! \n \n PARAMETER G(AL3NI1,AL:NI;0) 2.98150E+02 -48483.73+12.29913*T \n +.75*GHSERAL#+.25*GHSERNI#; 6.00000E+03 N 95DUP3 ! \n \n$******************** AL3NI2 \n \n PHASE AL3NI2 % 3 3 2 1 ! \n CONSTITUENT AL3NI2 :AL : AL,NI%,PT : NI,VA% : ! \n \n PARAMETER G(AL3NI2,AL:AL:NI;0) 298.15 +6*GALALNI;,, N 95DUP3 ! \n PARAMETER G(AL3NI2,AL:NI:NI;0) 298.15 +6*GALNINI;,, N 95DUP3 ! \n PARAMETER G(AL3NI2,AL:AL:VA;0) 298.15 +6*GALALVA;,, N 95DUP3 ! \n PARAMETER G(AL3NI2,AL:NI:VA;0) 298.15 +6*GALNIVA;,, N 95DUP3 ! \n \n PARAMETER G(AL3NI2,AL:PT:NI;0) 2.98150E+02 +3*GBCCAL#+GBCCNI#+2*GBCCPT#;\n 6.00000E+03 N 05LU ! \n PARAMETER G(AL3NI2,AL:PT:VA;0) 2.98150E+02 +3*GBCCAL#+2*GBCCPT#;\n 6.00000E+03 N 05LU ! \n \n PARAMETER L(AL3NI2,AL:AL,NI:*;0) 298.15 +6*L32ALNI;,, N 95DUP3 ! \n PARAMETER L(AL3NI2,AL:*:NI,VA;0) 298.15 +6*L32NIVA;,, N 95DUP3 ! \n \n$******************** AL3NI5 \n \n PHASE AL3NI5 % 2 .375 .625 ! \n CONSTITUENT AL3NI5 :AL : NI : ! \n \n PARAMETER G(AL3NI5,AL:NI;0) 298.15 -66520+18.9*T \n +.375*GHSERAL+.625*GHSERNI;,, N 03SUN ! \n \n$ PARAMETER G(AL3NI5,AL:NI;0) 2.98150E+02 +.375*GHSERAL#+.625*GHSERNI# \n$ -55507.7594+7.2648103*T; 6.00000E+03 N 95DUP3 ! \n \n$***************************** BCC_A2 \n \n \n \n$****************** BCC_B2 \n TYPE_DEFINITION W GES A_P_D BCC_A2 MAGNETIC -1.0 4.0000E-01 ! \n PHASE BCC_B2 %W 3 .5 .5 3 ! \n CONSTITUENT BCC_B2 :AL,NI%,PT,VA : AL%,NI,PT,VA : VA : ! \n \n PARA G(BCC_B2,AL:AL:VA;0) 298.15 +GBCCAL; 6000 N 91DIN ! \n PARA G(BCC_B2,NI:NI:VA;0) 298.15 +GBCCNI; 6000 N 91DIN ! \n PARA G(BCC_B2,PT:PT:VA;0) 298.15 +GBCCPT; 6000 N 91DIN ! \n PARA G(BCC_B2,VA:VA:VA;0) 298.15 30*T; 6000 N 13SUN! \n PARAMETER TC(BCC_B2,NI:VA:VA;0) 298.15 575;,, N 89DIN ! \n PARAMETER BMAGN(BCC_B2,NI:VA:VA;0) 298.15 .85;,, N 89DIN ! \n \n FUNCTION B2ALNI 295.15 -152397.3+26.40575*T;,, N 95DUP3 ! \nPARA G(BCC_B2,NI:AL:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCNI+.5*B2ALNI; \n6000 N 95DUP3 ! \nPARA G(BCC_B2,AL:NI:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCNI+.5*B2ALNI; \n6000 N 95DUP3 ! \n \n FUNCTION B2ALVA 295.15 10000-T;,,N 95DUP3 ! \nPARA G(BCC_B2,VA:AL:VA;0) 2.9815E+02 +0.5*GBCCAL+.5*B2ALVA; 6000 N 95DUP3 ! \nPARA G(BCC_B2,AL:VA:VA;0) 2.9815E+02 +0.5*GBCCAL+.5*B2ALVA; 6000 N 95DUP3 ! \n \nPARA G(BCC_B2,PT:AL:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCPT-98000+6*T; \n 6000 N 05LU ! \nPARA G(BCC_B2,AL:PT:VA;0) 2.9815E+02 +.5*GBCCAL+.5*GBCCPT-98000+6*T; \n 6000 N 05LU ! \n \n FUNCTION B2NIVA 295.15 +162397.3-27.40575*T;,, N 95DUP3 ! \nPARA G(BCC_B2,VA:NI:VA;0) 2.9815E+02 +.5*GBCCNI+.5*B2NIVA; 6000 N 95DUP3 ! \nPARA G(BCC_B2,NI:VA:VA;0) 2.9815E+02 +.5*GBCCNI+.5*B2NIVA; 6000 N 95DUP3 ! \n \nPARA G(BCC_B2,PT:NI:VA;0) 2.9815E+02 +.5*GBCCNI+.5*GBCCPT-20000; \n 6000 N 05LU ! \nPARA G(BCC_B2,NI:PT:VA;0) 2.9815E+02 +.5*GBCCNI+.5*GBCCPT-20000; \n 6000 N 05LU ! \n \nPARA G(BCC_B2,PT:VA:VA;0) 2.9815E+02 +.5*GBCCPT+1.0E5; 6000 N 05LU ! \nPARA G(BCC_B2,VA:PT:VA;0) 2.9815E+02 +.5*GBCCPT+1.0E5; 6000 N 05LU ! \n \n FUNCTION LB2ALNI 298.15 -62104+19.28*T;,, N 03SUN ! \nPARA G(BCC_B2,*:AL,NI:VA;0) 2.9815E+02 +.5*LB2ALNI; 6000 N 95DUP3 ! \nPARA G(BCC_B2,AL,NI:*:VA;0) 2.9815E+02 +.5*LB2ALNI; 6000 N 95DUP3 ! \n \n FUNCTION LB2ALVA 298.15 200000;,,N ! \nPARA G(BCC_B2,*:AL,VA:VA;0) 2.9815E+02 +.5*LB2ALVA; 6000 N 95DUP3 ! \nPARA G(BCC_B2,AL,VA:*:VA;0) 2.9815E+02 +.5*LB2ALVA; 6000 N 95DUP3 ! \n \n FUNCTION LB2NIVA 298.15 -64024.38+26.49419*T;,, N ! \nPARA G(BCC_B2,*:NI,VA:VA;0) 2.9815E+02 +.5*LB2NIVA; 6000 N 95DUP3 ! \nPARA G(BCC_B2,NI,VA:*:VA;0) 2.9815E+02 +.5*LB2NIVA; 6000 N 95DUP3 ! \n\nPARA G(BCC_B2,*:AL,PT:VA;0) 2.9815E+02 -45000; 6000 N 05LU ! \nPARA G(BCC_B2,AL,PT:*:VA;0) 2.9815E+02 -45000; 6000 N 05LU ! \n\nPARA G(BCC_B2,*:NI,PT:VA;0) 2.9815E+02 -5000; 6000 N 05LU ! \nPARA G(BCC_B2,NI,PT:*:VA;0) 2.9815E+02 -5000; 6000 N 05LU ! \n\nPARA G(BCC_B2,*:VA,PT:VA;0) 2.9815E+02 +0; 6000 N 05LU ! \nPARA G(BCC_B2,VA,PT:*:VA;0) 2.9815E+02 +0; 6000 N 05LU ! \n\n$******************************** Compounds in AL-Pt \n \n$ PHASE AL21PT8 % 2 .724138 .275862 ! \n$ CONS AL21PT8 :AL:PT NI:! \n$ PARAMETER G(AL21PT8,AL:NI;0) 2.98150E+02 -35000+.724138*GHSERAL# \n$ +.275862*GHSERNI#; 6.00000E+03 N REF: 0 ! \n \n$ PARAMETER G(AL21PT8,AL:PT;0) 298.15 -82342+23.7*T+.7242*GHSERAL# \n$ +.2759*GHSERPT#; 6000 N REF0 ! \n \n PHASE AL1PT1 % 2 .5 .5 ! \n CONS AL1PT1 :AL:PT NI:! \n PARAMETER G(AL1PT1,AL:NI;0) 2.98150E+02 -50000+10*T+.5*GHSERAL#+.5*GHSERNI#;\n 6000 N 05LU !\n PARAMETER G(AL1PT1,AL:NI,PT;0) 2.98150E+02 0; 6.00000E+03 \n N 05LU ! \n PARAMETER G(AL1PT1,AL:PT;0) 298.15 -95000+6*T+.5*GHSERAL# \n +.5*GHSERPT#; 6000 N REF0 ! \n$******************* \n \n PHASE ALPT2 % 2 .33333 .66667 ! \n CONSTITUENT ALPT2 :AL : PT : ! \n \n PARAMETER G(ALPT2,AL:PT;0) 298.15 -8.10000000E+04+5*T \n +.33333*GHSERAL#+.66667*GHSERPT#; 6000 N REF0 ! \n \n PHASE AL3PT2 % 2 .6 .4 ! \n CONSTITUENT AL3PT2 :AL : PT : ! \n \n PARAMETER G(AL3PT2,AL:PT;0) 298.15 -9.20000000E+04+3.5*T+.6*GHSERAL# \n +.4*GHSERPT#; 6000 N REF0 ! \n \n \n PHASE AL21PT5 % 2 .8077 .1923 ! \n CONSTITUENT AL21PT5 :AL : PT : ! \n \n PARAMETER G(AL21PT5,AL:PT;0) 298.15 -6.00000000E+04+4*T+.8077*GHSERAL# \n +.1923*GHSERPT#; 6000 N REF0 ! \n \n PHASE AL3PT5 % 2 .375 .625 ! \n CONSTITUENT AL3PT5 :AL : PT : ! \n \n PARAMETER G(AL3PT5,AL:PT;0) 298.15 -8.70000000E+04+5*T+.375*GHSERAL# \n +.625*GHSERPT#; 6000 N REF0 ! \n \n PHASE AL21PT8 % 2 .7241 .2759 ! \n CONSTITUENT AL21PT8 :AL : PT : ! \n \n PARAMETER G(AL21PT8,AL:PT;0) 298.15 -8.30000000E+04+6*T+.7241*GHSERAL# \n +.2759*GHSERPT#; 6000 N REF0 ! \n \n PHASE AL2PT % 2 .66667 .33333 ! \n CONSTITUENT AL2PT :AL : PT : ! \n \n PARAMETER G(AL2PT,AL:PT;0) 298.15 -8.90000000E+04+5*T+.66667*GHSERAL# \n +.33333*GHSERPT#; 6000 N REF0 ! \n \n$************************************* \n$ASSESSED_SYSTEM AL-NI(;P3 STP:.8/1200/1) ! \n \n \n LIST_OF_REFERENCES \n NUMBER SOURCE \n REF01 'Kaisheng WU and Zhanpeng JIN, J. Phase Equil., Vol.21(3), 2000' \n REF02 'P.Nash and M.F.Singleton, Bulletin of Alloy Phase Diagrams, \n Vol.10(3),1989' \n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990' \n 91DIN 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol 15(1991) \n p 317-425, also in NPL Report DMA(A)195 Rev. August 1990' \n REF95 'I Ansara, P Willemin B Sundman (1988); Al-Ni' \n REF295 'N. Saunders, unpublished research, COST-507, (1991); Al-Cu' \n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report \n DMA(A)195 \n September 1989' \n 89DIN 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989' \n REF26 'A. Fernandez Guillermet, Z. Metallkde. Vol 79(1988) p.524-536, \n TRITA-MAC 362 (1988); C-CO-NI AND C-CO-FE-NI' \n REF293 'N. Saunders, private communication (1991); Al-Ti-V' \n 95DUP3 'N. Dupin, Thesis, LTPCM, France, 1995; Al-Ni, also in I. Ansara, \n N. Dupin, H.L. Lukas, B. Sundman J. Alloys Compds, 247 (1-2), 20-30 \n (1997)' \n 99DUP 'N. Dupin, I. Ansara, Z. metallkd., Vol 90 (1999) p 76-85; Al-Ni' \n 99DUP3 'N. Dupin, July 1999, unpublished revision ; Al-Ni' \n 03SUN 'B. Sundman, N. Dupin, JEEP 2003 Lyon'\n REF0 'S Prins and B Sundman, provisional Al-Pt (2003)' \n 05LU 'X.-G Lu, PhD thesis work, unpublished' \n 13SUN 'B. Sundman, Vacancy' \n ! \n \n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/README.sim", "content": "\nThis contain the instructions to compile and run the AlNiPt example.\nThe OC-parallel2.pdf is a presentation of the example.\n\n1. copy OC/libs/liboceq.a compiled with -fopenmp here\n2. copy OC/liboceqplus.mod compiled with -fopenmp here\n3. For Linux/Mac copy OC/getkey.o here\n4. compile the version liboctq.F90 provided here\n5. compile and link sim-alnipt as below (getkey.o needed only on Linux/Mac:\n gfortran -o sim-alnipt -fopenmp sim-alnipt.F90 liboctq.o getkey.o liboceq.a\n\n\n6. Run with input file setup.dat which specifies\n databasefile, elements, gridpoints etc.\n\n7. The diffusion simulation is for a single dimension and the model is\n very simple. All elements have the samë constant mobility which is\n used to move the elements between the gridpoints keeping the total\n amount of elements constant.\n\n7. Output is written on ocsim.plt and can be plotted directly using GNUPLOT\n The alnipt-5000.png shows several composition profiles.\n\n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/liboctq.F90", "content": "!\n! Minimal TQ interface.\n!\n! To compile and link this with an application one must first compile\n! and form a library with of the most OC subroutines (lib\\liboceq.a)\n! and copy this and the corresponding \"liboceqplus.mod\" file\n! from this compilation to the folder with this library\n!\n! NOTE that for the identification of phase and composition sets this\n! TQ interface use a Fortran TYPE called gtp_phasetuple containing two\n! integers, \"phase\" with the phase number and \"compset\" with the\n! comp.set The number of phase tuples is initially equal to the number\n! of phases and have the same index. This represent comp.set 1 of the\n! phases as each phase has just one composition set. A phase may have\n! several comp.sets created by calculations or by commands and these will\n! have phase tuple index higher than the number of phases and their index\n! is in the order of which they were created.\n! This may cause some problems if composition sets are deleted because that\n! will change the phase tuple index for those with higher index. So do not\n! delete comp.sets or at least be very careful when deleting comp.sets\n!\n! 210328 BOS Tested\n! 191101 BOS Updates some routines and added two dummy modules for C routines\n! 181030 BOS Updates some routines\n! 150520 BOS added a few subroutines for single phase data and calculations\n! 141210 BOS changed to use phase tuples\n! 140128 BOS added D2G and phase specific V and G\n! 140128 BOS added possibility to calculate without invoking grid minimizer\n! 140125 BOS Changed name to liboctq\n! 140123 BOS Added ouput of MQ G, V and normalized\n!------------------------------------------------------------\n! subroutines and functions\n! tqini ok initiate\n! tqrfil ok read a database file\n! tqrpfil ok read specified elements from database file\n! -------------------------\n! tqgcom ok get number of system components and their names\n! tqgnp ok get number of phase tuples (phases and comp. sets)\n! tqgpn ok get name of phase tuple\n! tqgpi ok get phase tuple index of phase using its name\n! tqgpcn - get name of constituent of a phase using index\n! tqgpci - get index of constituent of a phase using name\n! tqgpcs - get stoichiometry of species as system components \n! tqgccf - get stoichiometry of system component as elements\n! tqgnpc - get number of constituents in phase\n! -------------------------\n! tqcref - set reference state for component\n! tqphsts ok set status of phase tuple\n! tqsetc ok set condition\n! tqce ok calculate equilibrium\n! tqgetv ok get equilibrium results as state variable values\n! -------------------------\n! tqgphc1 ok get phase constitution\n! tqsphc1 ok set phase constitution\n! tqcph1 ok calculate phase properties and return arrays\n! tqcph2 ok calculate phase properties and return index\n! tqdceq ok delete equilibrium record\n! tqcceq ok copy current equilibrium to a new one\n! tqselceq ok select new current equilibrium\n! tqlr ok list results \n! tqlc ok list conditions\n!\n!------------------------------------------------------------\n!\n! The name of this library\nmodule liboctq\n!\n! access to main OC library for equilibrium calculations and models\n use liboceqplus\n!\n implicit none\n!\n integer, parameter :: maxc=maxel,maxp=maxph\n!\n! This is for storage and use of components\n integer nel\n character, dimension(maxc) :: cnam*24\n! Number of phase tuples\n integer ntup\n! use the array PHASETUPLE available from OC\n! save phase constitution to speed up calculation by interpolation\n double precision, allocatable, dimension(:,:) :: ysave\n!\ncontains\n!\n!\\begin{verbatim}\n subroutine tqini(n,ceq)\n! initiate workspace\n implicit none\n integer n ! Not nused, could be used for some initial allocation\n type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium\n!\\end{verbatim}\n! these should be provide linits and defaults\n integer intv(10)\n double precision dblv(10)\n intv(1)=-1\n! This call initiates the OC package\n!@CC\n if (allocated(eqlista)) then\n call new_gtp\n endif\n call init_gtp(intv,dblv)\n!@CC\n ceq=>firsteq\n write(*,*)'tqini created: ',ceq%eqname\n1000 continue\n return\n end subroutine tqini\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqrfil(filename,ceq)\n! read all elements from a TDB file\n implicit none\n character*(*) filename ! IN: database filename\n character ellista(10)*2 ! dummy\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim} %+\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n! second argument 0 means ellista is ignored, all element read\n call readtdb(filename,0,ellista)\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store the element name in the cname array\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n enddo\n! store phase tuples\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrfil\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqrpfil(filename,nsel,selel,ceq)\n! read TDB file with selection of elements\n implicit none\n character*(*) filename ! IN: database filename\n integer nsel\n character selel(*)*2 ! IN: elements to be read from the database\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*2,name*24,refs*24\n double precision a1,a2,a3\n!\n call readtdb(filename,nsel,selel)\n if(gx%bmperr.ne.0) goto 1000\n! is this really necessary??\n! ceq=>firsteq\n nel=noel()\n do iz=1,nel\n! store element name in module array components\n call get_element_data(iz,elname,name,refs,a1,a2,a3)\n cnam(iz)=elname\n enddo\n! store phase tuples and indices\n ntup=nooftup()\n1000 continue\n return\n end subroutine tqrpfil\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgcom(n,compnames,ceq)\n! get system component names. At present the elements\n implicit none\n integer n ! EXIT: number of components\n character*24, dimension(*) :: compnames ! EXIT: names of components\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer iz\n character elname*24,refs*24\n double precision a1,a2,a3\n do iz=1,nel\n compnames(iz)=' '\n call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3)\n! store name in module array components also (already done when reading TDB)\n cnam(iz)=compnames(iz)\n enddo\n n=nel\n1000 continue\n return\n end subroutine tqgcom\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnp(n,ceq)\n! get total number of phase tuples (phases and composition sets)\n! A second composition set of a phase is normally placed after all other\n! phases with one composition set\n implicit none\n integer n !EXIT: n is number of phases\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n! NOTE the number composition sets may change at a calculation or if new\n! composition sets are added or deleted explicitly\n! This changes the number of phase tuples!\n ntup=nooftup()\n n=ntup\n1000 continue\n return\n end subroutine tqgnp\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpn(phtupx,phasename,ceq)\n! get name of phase tuple with index phtupx (ceq redundant)\n implicit none\n integer phtupx ! IN: index in phase tuple array\n character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call get_phasetup_name(phtupx,phasename)\n1000 continue\n return\n end subroutine tqgpn\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpi(phtupx,phasename,ceq)\n! get index of phase phasename (including comp.set (ceq redundant)\n implicit none\n integer phtupx !EXIT: phase tuple index\n character phasename*(*) !IN: phase name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n call find_phasetuple_by_name(phasename,phtupx)\n1000 continue\n return\n end subroutine tqgpi\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcn2(n,c,constituentname,ceq)\n! get name of consitutent with index c in phasetuple n\n! NOTE An identical routine with different constituent index is tqgpcn\n implicit none\n integer n !IN: phase number (not phase tuple)\n integer c !IN: constituent index sequentially over all sublattices\n character constituentname*(24) !EXIT: costituent name\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n double precision mass\n call get_constituent_name(n,c,constituentname,mass)\n! write(*,*)'tqgpcn not implemented yet'\n! gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcn2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpci(n,c,constituentname,ceq)\n! get index of constituent with name in phase n\n implicit none\n integer n !IN: phase index\n integer c !IN: sequantial constituent index over all sublattices\n character constituentname*(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpci not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpci\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgpcs(n,c,stoi,mass,ceq)\n! get stoichiometry of constituent c in phase n \n!? missing argument number of elements????\n implicit none\n integer n !IN: phase number\n integer c !IN: sequantial constituent index over all sublattices\n double precision stoi(*) !EXIT: stoichiometry of elements \n double precision mass !EXIT: total mass\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgpcs not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgpcs\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq)\n! get stoichiometry of component n1\n! n2 is number of elements (dimension of elnames and stoi)\n implicit none\n integer n1 !IN: component number\n integer n2 !EXIT: number of elements in component\n character elnames(*)*(2) ! EXIT: element symbols\n double precision stoi(*) ! EXIT: element stoichiometry\n double precision mass ! EXIT: component mass (sum of element mass)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgccf not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgccf\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgnpc(n,c,ceq)\n! get number of constituents of phase n\n implicit none\n integer n !IN: Phase number\n integer c !EXIT: number of constituents\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n write(*,*)'tqgnpc not implemented yet'\n gx%bmperr=8888\n1000 continue\n return\n end subroutine tqgnpc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcref(cix,phase,tpref,ceq)\n! set component reference state\n integer cix\n character phase*(*)\n double precision tpref(*)\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer phtupx\n call find_phasetuple_by_name(phase,phtupx)\n if(gx%bmperr.ne.0) goto 1000\n call set_reference_state(cix,phtupx,tpref,ceq)\n1000 continue\n return\n end subroutine tqcref\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqphsts(phtupx,newstat,val,ceq)\n! set status of phase tuple: SUSPEND, DORMANT, ENTERED, FIX\n integer phtupx,newstat\n double precision val\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer n\n if(phtupx.le.0) then\n! if tup<0 change status of all phases\n do n=1,ntup\n call change_phtup_status(n,newstat,val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n elseif(phtupx.le.ntup) then\n call change_phtup_status(phtupx,newstat,val,ceq)\n else\n write(*,*)'Illegal phase tuple index',phtupx\n gx%bmperr=8888\n endif\n1000 continue\n return\n end subroutine tqphsts\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsetc(stavar,n1,n2,value,cnum,ceq)\n! set condition\n! stavar is state variable as text\n! n1 and n2 are auxilliary indices\n! value is the value of the condition\n! cnum is returned as an index of the condition.\n! to remove a condition the value sould be equial to RNONE ????\n! phase index is phase tuple index (include composition set)\n! see TQGETV for doucumentation of stavar etc.\n implicit none\n integer n1 ! IN: 0 or phase tuple index or component number\n integer n2 ! IN: 0 or component number\n integer cnum ! EXIT: sequential number of this condition UNUSED\n character stavar*(*) ! IN: character with state variable symbol\n double precision value ! IN: value of condition\n type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium\n!\\end{verbatim}\n integer ip,ip2,ip3\n character cline*60,selvar*24,cval*24\n!\n! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value\n11 format(a,a,2i5,1pe14.6)\n cline=' '\n! extract a value after an =\n ip=index(stavar,'=')\n if(ip.gt.0) then\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n!@CC\n ip2=index(stavar,'(')\n if(ip2.gt.0) then\n ip = ip2\n selvar=stavar(1:ip-1)\n cval=stavar(ip:)\n endif\n!@CC\n! write(*,*)'Value after = :',cval\n else\n ip3=index(stavar,'(')\n if(ip3.gt.0) then\n selvar=stavar(1:ip3-1)\n else\n selvar=stavar\n endif\n cval=' '\n endif\n call capson(selvar)\n! write(*,*)'TQSETC selvar: ',trim(selvar),value\n select case(selvar)\n case default\n write(*,*)'Condition wrong, not implemented or illegal: ',stavar\n gx%bmperr=8888; goto 1000\n! Potentials T and P\n case('T ','P ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n write(cline,110)selvar(1:1),value\n110 format(' ',a,'=',E15.8)\n endif\n! Total amount or amount of a component in moles\n case('N ')\n if(ip.gt.0) then\n cline=' '//stavar\n else\n if(n1.gt.0) then\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n112 format(' ',a,'(',a,')=',E15.8)\n! write(*,*)'Setting condition: ',cline(1:len_trim(cline))\n else\n write(cline,110)selvar(1:1),value\n endif\n endif\n! Overall fraction of a component \n case('X ','W ')\n! ?? fraction of phase component not implemented, n1 must be component number\n! call get_component_name(n1,cnam,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(ip.gt.0) then\n cline=' '//stavar\n elseif(ip3.gt.0) then\n write(cline,119)trim(stavar),value\n119 format(1x,a,'=',1pE15.8)\n else\n write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value\n120 format(1x,a,'(',a,')=',1pE15.8)\n endif\n case('H ','V ')\n! enthalpy or volume of system\n if(cval(1:1).eq.'=') then\n cline=' '//stavar\n else\n write(cline,130)selvar(1:1),value\n130 format(1x,a,'=',1pE15.8)\n endif\n! case ....\n! ?? MORE CONDITIONS WILL BE ADDED ...\n end select\n! write(*,*)'tqsetc condition: ',trim(cline)\n! This is quite clumsy ... and time costly\n! write(*,*)'TQSETC debug: ',trim(cline)\n ip=1\n call set_condition(cline,ip,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting condition: ',cline(1:len_trim(cline)),ip\n endif\n1000 continue\n return\n end subroutine tqsetc\n\n!@CC\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine toggle_dense_grid()\n if(btest(globaldata%status,GSXGRID)) then\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n write(*,3110)'reset'\n3110 format('Dense grid ',a)\n else\n globaldata%status=ibset(globaldata%status,GSXGRID)\n write(*,3110)'dense grid set'\n endif\n return\n end subroutine toggle_dense_grid\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqce(target,n1,n2,value,ceq)\n! calculate quilibrium with possible target\n! Target can be empty or a state variable with indices n1 and n2\n! value is the calculated value of target\n implicit none\n integer n1,n2,mode\n character target*(*)\n double precision value\n logical confirm\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!\\end{verbatim}\n integer nyfas,j1,j2\n! mode=1 means start values using global gridminimization\n if(n1.lt.0) then\n! this means calculate without grid minimuzer\n mode=0\n confirm=.FALSE.\n! calcqeq3 is silent, no listing of phase changes etc.\n call calceq3(mode,confirm,ceq)\n! skip allocation of ysave\n goto 1000\n else\n mode=1\n call calceq2(mode,ceq)\n if(gx%bmperr.eq.4204) then\n! if the error code is \"too many iterations\" try without grid minimizer\n! it converges in many cases\n! write(*,2048)gx%bmperr\n2048 format('Error ',i5,', cleaning up and trying harder')\n gx%bmperr=0\n call calceq2(0,ceq)\n endif\n endif\n if(gx%bmperr.ne.0) goto 1000\n! there may be new composition sets, update ntup\n! write(*,*)'Number of phase tuples: ',ntup\n nyfas=nooftup()\n! write(*,*)'Number of phase tuples: ',ntup,nyfas\n if(nyfas.ne.ntup) then\n! write(*,*)'Number of phase tuples changed: ',nyfas,ntup\n ntup=nyfas\n! if(allocated(ysave)) deallocate(ysave)\n! allocate(ysave(nyfas,maxconst))\n endif\n! copy the constitution to a local save array\n! if(.not.allocated(ysave)) then\n! allocate(ysave(nyfas,maxconst))\n! endif\n! THIS IS BAD FOR PARALLELIZATION \n if(allocated(ysave)) deallocate(ysave)\n allocate(ysave(nyfas,maxconst))\n! the intention of saving constitution is to make it possible to interpolate\n! the calculation of G if the constitution is changed very little\n do j1=1,nyfas\n do j2=1,size(ceq%phase_varres(phasetuple(j1)%lokvares)%yfr)\n ysave(j1,j2)=ceq%phase_varres(phasetuple(j1)%lokvares)%yfr(j2)\n enddo\n enddo\n1000 continue\n return\n end subroutine tqce\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgetv(stavar,n1,n2,n3,values,ceq)\n! get equilibrium results using state variables\n! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 \n! n1 can be a phase tuple index, n2 a component index\n! n3 at the call is the dimension of the array values, \n! changed to number of values on exit\n! value is an array with the calculated value(s), n3 set to number of values.\n implicit none\n integer n1,n2,n3\n character stavar*(*)\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n!========================================================\n! stavar must be a symbol listed below\n! IMPORTANT: some terms explained after the table\n! Symbol index1,index2 Meaning (unit)\n!.... potentials\n! T 0,0 Temperature (K)\n! P 0,0 Pressure (Pa)\n! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J)\n! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT)\n! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT\n!...... extensive variables\n! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase\n! UM 0,0 or ext.phase.index,0 same per mole components\n! UW 0,0 or ext.phase.index,0 same per kg\n! UV 0,0 or ext.phase.index,0 same per m3\n! UF ext.phase.index,0 same per formula unit of phase\n! S*3 0,0 or ext.phase.index,0 Entropy (J/K) \n! V 0,0 or ext.phase.index,0 Volume (m3)\n! H 0,0 or ext.phase.index,0 Enthalpy (J)\n! A 0,0 or ext.phase.index,0 Helmholtz energy (J)\n! G 0,0 or ext.phase.index,0 Gibbs energy (J)\n! ..... some extra state variables\n! NP ext.phase.index,0 Moles of phase\n! BP ext.phase.index,0 Mass of moles (kg)\n! Q ext.phase.index,0 Internal stability/RT (dimensionless)\n! DG ext.phase.index,0 Driving force/RT (dimensionless)\n!....... amounts of components\n! N 0,0 or component,0 or ext.phase.index,component Moles of component\n! X component,0 or ext.phase.index,component Mole fraction of component\n! B 0,0 or component,0 or ext.phase.index,component Mass of component\n! W component,0 or ext.phase.index,component Mass fraction of component\n! Y ext.phase.index,constituent*1 Constituent fraction\n!........ some parameter identifiers\n! TC ext.phase.index,0 Magnetic ordering temperature\n! BMAG ext.phase.index,0 Aver. Bohr magneton number\n! MQ& ext.phase.index,constituent Mobility\n! THET ext.phase.index,0 Debye temperature\n! LNX ext.phase.index,0 Lattice parameter\n! EC11 ext.phase.index,0 Elastic constant C11\n! EC12 ext.phase.index,0 Elastic constant C12\n! EC44 ext.phase.index,0 Elastic constant C44\n!........ NOTES:\n! *1 The phase index is the phase tuple index (extra composition sets at end)\n! *2 The constituent index is 10*species_number + sublattice_number\n! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also\n!--------------------------------------------------------------------\n! special addition for TQ interface: d2G/dyidyj\n! D2G + phase tuple\n!--------------------------------------------------------------------\n!\\end{verbatim}\n integer ics,mjj,nph,ki,kj,lp,lokph,lokcs\n character statevar*60,encoded*2048,name*24,selvar*4,norm*4\n! mjj should be the dimension of the array values ...\n mjj=n3\n selvar=stavar\n call capson(selvar)\n! for state variables like MQ&FE remove the part from & before the select\n! write(*,11)'In tqgetv: ',selvar,n1,n2,n3\n11 format(a,a,3i5)\n norm=' '\n lp=index(selvar,'&')\n if(lp.gt.0) then\n selvar(lp:)=' '\n else\n! check if variable is normallized, only M (per mole) allowed\n ki=len_trim(selvar)\n if(ki.ge.2) then\n if(selvar(ki:ki).eq.'M') then\n norm='M'\n selvar(ki:)=' '\n ki=ki-1\n endif\n endif\n endif\n!=======================================================================\n kj=index(selvar,'(')\n if(kj.gt.0) then\n selvar=selvar(1:kj-1)\n endif\n! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<'\n select case(selvar)\n case default\n write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar\n gx%bmperr=8888; goto 1000\n!--------------------------------------------------------------------\n! T or P\n case('T ','P ')\n call get_state_var_value(selvar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! chemical potential for a component\n case('MU ','MUS ')\n if(n1.lt.-1 .or. n1.eq.0) then\n write(*,*)'tqgetv 17: component number must be positive'\n gx%bmperr=8888; goto 1000\n elseif(n1 .eq.-1) then\n! this means all components\n statevar=trim(selvar)//'(*)'\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.le.noel()) then\n statevar=trim(selvar)//'('//trim(cnam(n1))//') '\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n! we must use index value(1) as the subroutine expect a single variable\n call get_state_var_value(statevar,values(1),encoded,ceq)\n else\n write(*,*)'No such component'\n endif\n!--------------------------------------------------------------------\n!@CC\n! Amount of moles /mass of components in a phase\n case('NP ', 'BP ')\n if(n1.lt.0) then\n! all phases\n statevar=stavar(1:2)//'(*)'\n!@CC\n! this returns all composition sets for all phases\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the amounts for all compsets of a phase sequentially\n! but here we want them in phase tuple order\n! the second argument is the number of values for each phase, here is 1 but\n! it can be for example compositions, then it should be number of components\n call sortinphtup(n3,1,values)\n else\n! NP for just one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar='NP('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Mole or mass fractions\n!@CC\n case('N ','B ','X ','W ')\n!@CC\n! write(*,*)'in tqgetv n,x,w: ',n1,n2,n3\n if(n2.eq.0) then\n if(n1.lt.0) then\n! moles, mole or mass fraction of all components for all phases\n statevar=stavar(1:1)//'(*) '\n! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n elseif(n1.eq.0) then\n! mole fraction for the state variable written as X(FE)\n! n1 and n2 not used, just check for wildcard\n! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar))\n if(index(stavar,'*').gt.0) then\n call get_many_svar(stavar,values,mjj,n3,encoded,ceq)\n else\n call get_state_var_value(stavar,values(1),encoded,ceq)\n endif\n else\n! mole fraction of a single component, no phase specification\n n3=1\n ics=1\n! call get_component_name(n1,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(cnam(n1))//')'\n! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar))\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n elseif(n1.lt.0) then\n!........................................................\n! for all phases one or several components\n if(n2.lt.0) then\n! this means all components all phases, for example x(*,*)\n statevar=stavar(1:1)//'(*,*) '\n! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, noel()\n! in this case\n ics=noel()\n call sortinphtup(n3,ics,values)\n else\n! a single component in all phases. n2 must not be zero\n! call get_component_name(n2,name,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n if(n2.le.0 .or. n2.ge.noel()) then\n write(*,*)'No such component'\n goto 1000\n endif\n! state variable like w(*,cr), the Cr content in all (stable) phases\n statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')'\n! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar))\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n! this output gives the composition for all compsets of a phase sequentially\n! but we want them in phase tuple order\n! The second argument is the number of values for each phase, in this case 1\n! ics=noel()\n! THIS MUST BE CHECKED !!!\n call sortinphtup(n3,1,values)\n endif\n elseif(n2.lt.0) then\n! this means all components in one phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//',*) '\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n else\n! one component (n2) of one phase (n1)\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:1)//'('//trim(name)//','\n call get_component_name(n2,name,ceq)\n if(gx%bmperr.ne.0) goto 1000\n statevar(len_trim(statevar)+1:)=trim(name)//') '\n! write(*,*)'tqgetv 8: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n endif\n!--------------------------------------------------------------------\n! volume\n case('V ')\n if(norm(1:1).ne.' ') then\n statevar='V'//norm\n ki=2\n else\n statevar='V '\n ki=1\n endif\n if(n1.gt.0) then\n! Volume for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total volume\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Enthalpy\n case('H ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='H'//norm\n ki=2\n else\n statevar='H '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total enthalpy\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Gibbs energy\n case('G ')\n! phase specifier not allowed\n if(norm(1:1).ne.' ') then\n statevar='G'//norm\n ki=2\n else\n statevar='G '\n ki=1\n endif\n! write(*,*)'tqgetv 1: ',n1,ki\n if(n1.gt.0) then\n! Gibbs energy for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! Total Gibbs energy \n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n endif\n!--------------------------------------------------------------------\n! Driving force relative stable equilibrium\n case('DG ')\n! Always normalized per mole\n if(norm(3:3).ne.' ') then\n statevar='DG'//norm\n ki=3\n else\n statevar='DG '\n ki=2\n endif\n write(*,*)'tqgetv DGM: ',n1,ki\n if(n1.gt.0) then\n! The driving force for a specific phase\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=statevar(1:ki)//'M('//trim(name)//') '\n! write(*,*)'tqgetv 3: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n n3=1\n else\n! For all phases\n n3=0\n if(nooftup().gt.mjj) then\n write(*,*)'TQGETV error, array too small for DGM',mjj,nooftup()\n gx%bmperr=8888\n goto 1000\n endif\n statevar='DGM(#) '\n write(*,*)'tqgetv 3: ',statevar\n call get_many_svar(statevar,values,mjj,n3,encoded,ceq)\n write(*,'(a,10(1pe12.4))')'TQGETV: ',(values(ki),ki=1,n3)\n write(*,*)'gx%bmperr: ',gx%bmperr\n endif\n!--------------------------------------------------------------------\n! Mobilities\n case('MQ ')\n call get_phasetup_name(n1,name)\n if(gx%bmperr.ne.0) goto 1000\n statevar=stavar(1:len_trim(stavar))//'('//trim(name)//')'\n! write(*,*)'statevar: ',statevar\n call get_state_var_value(statevar,values(1),encoded,ceq)\n!--------------------------------------------------------------------\n! Second derivatives of the Gibbs energy of a phase\n case('D2G ')\n lokcs=phasetuple(n1)%lokvares\n! this gives wrong value!! ??\n n3=size(ceq%phase_varres(lokcs)%yfr)\n! write(*,*)'D2G 3: ',n3\n kj=(n3*(n3+1))/2\n if(kj.gt.mjj) then\n write(*,*)'TQGETV error, array too small for D2G',mjj,kj\n gx%bmperr=8888\n goto 1000\n endif\n! write(*,*)'D2G 3: ',kj\n do ki=1,kj\n values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1)\n enddo\n end select\n!===========================================================================\n1000 continue\n return\n end subroutine tqgetv\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n subroutine tqgetg(lokres,n1,n2,values,ceq)\n! the partial derivative of the Gibbs energy ....??\n implicit none\n integer n1,n2,lokres\n double precision values(*)\n type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium\n! \n double precision napfu, rgast\n integer count\n integer jl,size\n TYPE(gtp_phase_varres), pointer :: parres\n!\n count = 1\n!\n napfu=ceq%phase_varres(lokres)%abnorm(1)\n rgast=globaldata%rgas*ceq%tpval(1)\n parres=>ceq%phase_varres(lokres)\n! \n! write(*,100)(rgast*parres%gval(jl,1),jl=1,4)\n! write(*,200)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1)\n100 format('G/N, dG/dT:',4(1PE16.8))\n200 format('G/N/RT, N:',2(1PE16.8))\n! G_m^\\alpha = G_M^\\alpha/N^\\alpha, \\frac{\\partial G_m^\\alpha}{\\partial T},\n! \\frac{\\partial G_m^\\alpha}{\\partial P},\n! \\frac{\\partial^2 G_m^\\alpha}{\\partial T^2}\n values(count:count+3) = rgast*parres%gval(1:4,1)/napfu\n count = count + 4\n if (n1>0) then\n! 1/N^\\alpha * \\frac{\\partial G_M^\\alpha}{\\partial y_i}\n values(count:count+n1-1) = rgast*parres%dgval(1,1:n1,1)/napfu\n count = count + n1\n if (n2>0) then\n! 1/N^\\alpha * \\frac{\\partial^2 G_M^\\alpha}{\\partial y_i\\partial y_j}\n values(count:count+n2-1) = rgast*parres%d2gval(1:n2,1)/napfu\n endif\n endif\n end subroutine tqgetg\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n \n subroutine tqgdmat(phtupx,tpval,xknown,cpot,tyst,nend,mugrad,mobval,&\n consnames,n1,ceq)\n! equilibrates the constituent fractions of a phase for mole fractions xknown\n! and calculates the Darken matrix and unreduced diffusivities\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n! cpot are the (calculated) chemical potentials\n! tyst is TRUE means no outut\n! nend is the number of values returned in mugrad\n! mugrad are the derivatives of the chemical potentials wrt mole fractions??\n! mobval are the mobilities\n implicit none\n integer phtupx ! IN: index in phase tuple array\n integer nend\n logical tyst\n double precision tpval(*),xknown(*),cpot(*),mugrad(*),mobval(*)\n character*24, dimension(*) :: consnames \n integer n1\n TYPE(gtp_phasetuple), pointer :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n\n integer iph, ics, ll\n double precision mass\n character*24 spname\n \n phtup=>phasetuple(phtupx) \n call equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq)\n \n iph=phasetuple(phtupx)%ixphase\n ics=1 \n n1 = noconst(iph,ics,firsteq)\n do ll=1,n1\n call get_constituent_name(iph,ll,consnames(ll),mass)\n enddo\n\n end subroutine tqgdmat\n!@CC\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq)\n! tq_get_phase_constitution\n! This subroutine returns the sublattices and constitution of a phase\n! n1 is phase tuple index\n! nsub is the number of sublattices (1 if no sublattices)\n! cinsub is an array with the number of consttuents in each sublattice\n! spix is an array with the species index of the constituents in all sublattices\n! sites is an array of the site ratios for all sublattices. \n! yfrac is the constituent fractions in same order as in spix\n! extra is an array with some extra values: \n! extra(1) is the number of moles of components per formula unit\n! extra(2) is the net charge of the phase\n implicit none\n integer n1,nsub,cinsub(*),spix(*)\n double precision sites(*),yfrac(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call get_phase_data(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n nsub,cinsub,spix,yfrac,sites,extra,ceq)\n1000 continue\n return\n end subroutine tqgphc1\n \n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqsphc1(n1,yfra,extra,ceq)\n! tq_set_phase_constitution\n! To set the constitution of a phase\n! n1 is phase tuple index\n! yfra is an array with the constituent fractions in all sublattices\n! in the same order as obtained by tqgphc1\n! extra is an array with returned values with the same meaning as in tqgphc1\n! NOTE The constituents fractions are normallized to sum to unity for each\n! sublattice and extra is calculated by tqsphc1\n! T and P must be set as conditions.\n implicit none\n integer n1\n double precision yfra(*),extra(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n call set_constitution(phasetuple(n1)%ixphase,phasetuple(n1)%compset,&\n yfra,extra,ceq)\n1000 continue\n return\n end subroutine tqsphc1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNING: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt \n! compositions, 2 if also 2nd derivatives\n! n3 is returned as number of constituents (dimension of returned arrays)\n! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P\n! dgdy is an array with G.Yi\n! d2gdydt is an array with G.T.Yi\n! d2gdydp is an array with G.P.Yi\n! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj \n! reurned in the order: 1,1; 1,2; 1,3; ... \n! 2,2; 2,3; ...\n! 3,3; ...\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3\n double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! The inital size here can be 1000\n! n3=size(ceq%phase_varres(lokres)%yfr)\n! the actual number of constituents is better to take from this call\n n3=noconst(phasetuple(n1)%ixphase,1,ceq)\n! write(*,*)'tqcph1 3C',n3\n! gval last index is the property, other properties can also be extracted\n! t.ex. mobilites \n! The application program can also access these data directly ...\n if(gx%bmperr.eq.0) then\n do ij=1,6\n gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1)\n enddo\n do ij=1,n3\n dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1)\n d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1)\n d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1)\n enddo\n! size of upper triangle of symetrix matrix\n nofc=n3*(n3+1)/2\n do ij=1,nofc\n d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1)\n enddo\n else\n gtp=zero\n do ij=1,nofc\n dgdy(ij)=zero\n d2gdydt(ij)=zero\n d2gdydp(ij)=zero\n enddo\n nofc=nofc*(nofc+1)/2\n do ij=1,nofc\n d2gdy2(ij)=zero\n enddo\n endif\n1000 continue\n return\n end subroutine tqcph1\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim} %-\n subroutine tqcph2(n1,n2,n3,n4,ceq)\n! tq_calculate_phase_properties\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! WARNIG: this is not a subroutine to calculate chemical potentials\n! those can only be made by an equilibrium calculation.\n! The values returned are partial derivatives of G for the phase at the\n! current T, P and phase constitution. The phase constitution has been\n! obtained by a previous equilibrium calculation or \n! set by the subroutine tqsphc\n! It corresponds to the \"calculate phase\" command.\n!\n! NOTE that values are per formula unit divided by RT, \n! divide also by extra(1) in subroutine tqsphc1 to get them per mole component\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! calculate G and some or all derivatives for a phase at current composition\n! n1 is the phase tuple index\n! n2 is type of calculation (0, 1 or 2)\n! n3 is returned as number of constituents\n! n4 is index to ceq%phase_varres(lokres)% with all results\n! for indexing one can use the integer function ixsym(i1,i2)\n implicit none\n integer n1,n2,n3,n4\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ij,lokres,nofc\n! write(*,*)'tqcph1 1: ',ceq%eqname\n! write(*,*)'tqcph1 2',phasetuple(n1)%ixphase,phasetuple(n1)%compset\n!----------------------------------------------------------------------\n! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y\n call calcg(phasetuple(n1)%ixphase,phasetuple(n1)%compset,n2,lokres,ceq)\n!----------------------------------------------------------------------\n! write(*,*)'tqcph1 3A',lokres,gx%bmperr\n! this should work but gave segmentation fault, find this a more cumbersum way\n n3=size(ceq%phase_varres(lokres)%yfr)\n n4=lokres\n! Uer can access results like\n! ceq%phase_varres(n4)%gval(1..6,1..prop)\n! prop=1 is G, other can be t.ex. Curie T, mobilites etc\n! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij)\n! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT\n! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP\n! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j)\n! arranged as a single dimenion array indexed by ixsym(i,j)\n!\n! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...)\n!\n1000 continue\n return\n end subroutine tqcph2\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqdceq(name)\n! delete equilibrium with name\n implicit none\n character name*24\n! integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n! do not allow delete equilibrium 1\n if(n1.eq.1) then\n write(*,*)'No allowed to delete default equilibrium'\n gx%bmperr=4333\n goto 1000\n endif\n! ceq=>eqlista(n1)\n call delete_equilibria(name,ceq)\n1000 continue\n return\n end subroutine tqdceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcceq(name,n1,newceq,ceq)\n! copy_current_equilibrium to newceq\n! creates a new equilibrium record with name with values same as ceq\n! n1 is returned as index\n implicit none\n character name*24\n integer n1\n type(gtp_equilibrium_data), pointer :: newceq,ceq\n!\\end{verbatim}\n! call enter_equilibrium(name,n1)\n! if(gx%bmperr.ne.0) goto 1000\n! newceq=>eqlista(n1)\n call copy_equilibrium(newceq,name,ceq)\n1000 continue\n return\n end subroutine tqcceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqcneq(name,n1,newceq)\n! creates a new equilibrium record, same but simpler call than tqcceq\n! n1 is returned as index in eqlista\n implicit none\n character*(*), intent(in) :: name\n integer, intent(out) :: n1\n type(gtp_equilibrium_data), pointer, intent(out) :: newceq\n!\\end{verbatim}\n call enter_equilibrium(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n newceq=>eqlista(n1)\n1000 continue\n return\n end subroutine tqcneq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqselceq(name,ceq)\n! select current equilibrium to be that with name.\n! Note that equilibria can be deleted and change number but not name\n implicit none\n character name\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer n1\n call findeq(name,n1)\n if(gx%bmperr.ne.0) goto 1000\n call selecteq(n1,ceq)\n1000 continue\n return\n end subroutine tqselceq\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlr(lut,ceq)\n! list the equilibrium results like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer phtupx,iph,ics,lokvares,mode\n logical once\n write(lut,10)\n10 format(/20('*')/'Start debug output from TQLR: ')\n call list_conditions(lut,ceq)\n call list_global_results(lut,ceq)\n call list_components_result(lut,1,ceq)\n once=.TRUE.\n mode=0\n do phtupx=1,nooftup()\n lokvares=phasetuple(phtupx)%lokvares\n if(ceq%phase_varres(lokvares)%phstate.ge.phentstab) then\n iph=phasetuple(phtupx)%ixphase\n ics=phasetuple(phtupx)%compset\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n endif\n enddo\n write(lut,20)\n20 format('End debug output from TQLR'/20('*')/)\n1000 continue\n return\n end subroutine tqlr\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqlc(lut,ceq)\n! list conditions like in OC\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n write(lut,10)\n10 format(/'Debug output from TQLC: ')\n call list_conditions(lut,ceq)\n1000 continue\n return\n end subroutine tqlc\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqquiet(yes)\n! if argument TRUE spurious output should be suppressed\n implicit none\n logical yes\n!\\end{verbatim}\n if(yes) then\n globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n else\n globaldata%status=ibset(globaldata%status,GSVERBOSE)\n endif\n return\n end subroutine tqquiet\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_globalbit(bit,onoff)\n! set a global bit\n implicit none\n integer bit,onoff\n!\\end{verbatim}\n! list here taken from models/gtp3.F90, only some allowed!!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 4 NOMERGE: no merge of gridmin result, \n! 5 NODATA: not any data, \n! 6 NOPHASE: no phase in system, \n! 7 NOACS: no automatic creation of composition set for any phase\n! 8 NOREMCS: do not remove any redundant unstable composition sets\n! 9 NOSAVE: data changed after last save command\n! 10 VERBOSE: maximum of listing\n! 11 SETVERB: permanent setting of verbose\n! 12 SILENT: as little output as possible\n! 13 NOAFTEREQ: no manipulations of results after equilibrium calculation\n! 14 XGRID: extra dense grid for all phases\n! 15 NOPAR: do not run in parallel\n! 16 NOSMGLOB do not test global equilibrium at node points\n! 17 NOTELCOMP the elements are not the components\n! 18 TGRID use grid minimizer to test if global after calculating equilibrium\n! 19 OGRID use old grid generator\n! 20 NORECALC do not recalculate equilibria even if global test after fails\n! 21 OLDMAP use old map algorithm\n! 22 NOAUTOSP do not generate automatic start points for mapping\n! 23 GSYGRID extra dense grid\n! 24 GSVIRTUAL (CCI) enables calculations with a virtual element\n if((bit.ge.7 .and. bit.le.16) .or. (bit.ge.18 .and. bit.le.23)) then\n if(onoff.gt.0) then\n! set bit\n globaldata%status=ibset(globaldata%status,bit)\n else\n globaldata%status=ibclr(globaldata%status,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_globalbit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqchange_phasebit(phtupx,bit,onoff)\n! set a bit of phase\n implicit none\n integer phtupx,bit,onoff\n!\\end{verbatim}\n! taken from models/gtp3.F90\n!-Bits in PHASE record STATUS1 there are also bits in each phase_varres record!\n! BEWHEARE, the meaning of bits may have changed !!! check with gtp3.F90\n! 0 HID phase is hidden (not implemented)\n! 1 IMHID phase is implictly hidden (not implemented)\n! 2 ID phase is ideal, substitutional and no interaction\n! 3 NOCV phase has no concentration variation (fix composition)\n! 4 HASP phase has at least one parameter entered\n! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations\n! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations\n! 7 SORD phase has TCP type ordering (like for sigma)\n! 8 MFS phase has a disordered fraction set\n! 9 GAS this is the gas phase (first in phase list) \n! 10 LIQ phase is liquid (can be several but listed directly after gas)\n! 11 IONLIQ phase has ionic liquid model (I2SL)\n! 12 AQ1 phase has aqueous model (not implemented)\n! 13 STATE elemental liquid twostate (2-state) model parameter UNUSED?\n! 14 QCE phase has quasichemical SRO configurational entropy (not implemented)\n! 15 CVMCE phase has some CVM ordering entropy (not implemented)\n! 16 EXCB phase need explicit charge balance (has ions)\n! 17 XGRID use extra dense grid for this phase\n! 18 FACTCE phase has FACT quasichemical SRO model (not implemented)\n! 19 NOCS not allowed to create composition sets for this phase\n! 20 HELM parameters are for a Helmholz energy model (not implemented),\n! 21 PHNODGDY2 phase has model with no analytical 2nd derivatives\n! 22 not implemented ELMA phase has elastic model A (not implemented)\n! 23 EECLIQ the condensed phase (liquid) that should have highest entropy\n! 24 PHSUBO special use testing models DO NOT USE\n! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!!\n! 26 MULTI may be used with care\n! 27 BMAV Xion magnetic model with average Bohr magneton number\n! 28 UNIQUAC The UNIQUAC fluid model\n! 29 DILCE phase has dilute configigurational entropy (not implemented)\n! only bittar 3 left!\n integer lokph\n if(phtupx.le.0 .or. phtupx.gt.nooftup()) then\n gx%bmperr=4325\n elseif(bit.eq.17 .or. bit.eq.19) then\n lokph=phasetuple(phtupx)%lokph\n if(onoff.gt.0) then\n call set_phase_status_bit(lokph,bit)\n else\n call clear_phase_status_bit(lokph,bit)\n endif\n else\n gx%bmperr=4326\n endif\n return\n end subroutine tqchange_phasebit\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tqset_gaddition(phtupx,gadd,ceq)\n! set fix addition to Gibbs energy of a phase#compset\n implicit none\n integer phtupx\n double precision gadd\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! Provided by Christophe Sigli 2018?\n integer lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n ceq%phase_varres(lokcs)%addg(1)=gadd\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n return\n end subroutine tqset_gaddition\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\n subroutine tq_add_const_energy(energy,phtupx,ceq)\n! add a constant energy in J/mole\n double precision,intent(in) :: energy\n type(gtp_equilibrium_data), pointer :: ceq\n integer,intent(in) :: phtupx\n!\\end{verbatim}\n! Provided by Jan Herrnring 2020.12.15\n integer :: lokcs\n lokcs=phasetuple(phtupx)%lokvares\n if(.not.allocated(ceq%phase_varres(lokcs)%addg)) then\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n! add a constant term to G, value in J/FU\n! Abnorm is the number of moles of the phase\n ceq%phase_varres(lokcs)%addg(1)=energy*ceq%phase_varres(lokcs)%abnorm(1)\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n end subroutine tq_add_const_energy\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! Added for this simulation\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n!\\begin{verbatim}\nsubroutine tqdarken(itup,xval,verbose,muval,nend,darken,mobval,ceq)\n! calculates the equilibrium for a phase specified by a phase tuple\n! and with composition xval in mole fractions.\n! It returns the chemical potentials, the Darken stability matix and \n! the mobilities (copied from the equilibrium_data record)\n! The whole Darken matrix is returned in Darken(1:nend)\n! Internally a new set of constituent fractions are stored.\n!\n! use liboctq\n implicit none\n integer itup,nend\n logical verbose\n double precision xval(*),muval(*),mobval(*),darken(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n double precision tpval(2)\n type(gtp_phasetuple), pointer :: phtup\n!\n! use the current values of T and P\n tpval=ceq%tpval\n phtup=>phasetuple(itup)\n! write(*,20)itup,gx%bmperr,tpval(1),xval(1)\n20 format('TQDARKEN: ',i3,i7,F10.2,F10.6)\n call equilph1d(phtup,tpval,xval,muval,verbose,nend,darken,mobval,ceq)\n! write(*,20)itup,gx%bmperr,tpval(1),xval(1)\n return\nend subroutine tqdarken\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n! QUESTION: When this routine is not included in liboctq.F90\n! the compiler requires that there is an explicit INTERFACE required\n! because there is a pointer argument (ceq?) \n! and I have no idea how to do that. When including it here it is\n! not required\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nsubroutine diffcoef(itup,xval,dc,ceq)\n! binary diffusion coefficient\n! use liboctq\n implicit none\n integer nend,itup\n type(gtp_equilibrium_data), pointer :: ceq\n integer, parameter :: mm=10\n double precision xval(*),muval(mm),darken(mm*(mm+1)/2),mobval(mm),dc(*)\n logical silent\n double precision tildem\n double precision, parameter :: vm=1e-5\n! use mole fractions x_i = c_i/V_m\n! mobility \\tildeM_ii = (c_1 c_2/V_M)(c_1 M_2 + c_2 M_i)\n! D_ii = V_M \\tildeM_ii * det(Darken)\n! \n! \\tilde M_ii = V_m**2 x_1 x_2 (x_1 M_2 + x_2 M_1) !!??\n! D_ii = V_m**3 \\tildeM_ii det(Darken)\n!\n silent=.TRUE.\n call tqdarken(itup,xval,silent,muval,nend,darken,mobval,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! For a binary system the diffusion coefficient is \n! \\tildeM = (xval(1)*mobval(2)+xval(2)*mobval(1))*xval(1)*xval(2)\n! DC = \\tildeM *(Darken(1)*Darken(4)-Darken(2)*Darken(3))\n! NOTE the Darken matrix is symmetrical and thus Darken(2)=Darken(4)\n tildem=xval(1)*xval(2)*(xval(1)*mobval(2)+xval(2)*mobval(1))\n dc(1)=vm*tildem*(darken(1)*darken(4)-darken(2)*darken(3))\n! write(*,20)xval(1),xval(2),muval(1),muval(2),darken(1),darken(2),darken(3),&\n! darken(4),mobval(1),mobval(2),dc(1)\n20 format('Composition: ',8x,2F10.6/'Chemical potentials: ',2(1pe14.6)/&\n 'Darken matrix: ',6x,2e14.6/21x,2e14.6/&\n 'Mobilities: ',9x,2e14.6/&\n 'Diffusion coef: ',5x,e14.6)\n1000 continue\n return\nend subroutine diffcoef\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nend MODULE LIBOCTQ\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy modules\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule ftinyopen\n !\n ! This module replaces a C module for a popup window to open files\n ! used in the interactive OC. If you want to use the original\n ! version for opening files please check the linkmake or Makefile\n !\ncontains\n\n subroutine getfilename(typ,sval)\n implicit none\n integer typ\n character sval*(*)\n sval=' '\n return\n end subroutine getfilename\n\nend module ftinyopen\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n! dummy module (only Linux)\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\nmodule M_getkey\n !\n ! This module replaces a C module fore single character input on Linux\n !\ncontains\n\n character function getkex()\n getkex=' '\n return\n end function getkex\n\nend module M_getkey\n\n!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\!/!!\\\n\n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/linksim", "content": "REM C:\\Users\\bosun\\Documents\\OC\\OC6\\examples\\TQ4lib\\F90\\parasim\\\n\nREM Compile the OC program\n\nREM copy ..\\..\\..\\..\\libs\\liboceq.a\nREM copy ..\\..\\..\\..\\liboceqplus.mod\nREM on Linux or Mac you need also\nREM copy ..\\..\\..\\..\\getkey.o \n\nREM DO NOT COPY liboctq.F90 as there are a few subroutines added\nREM REM copy ..\\liboctq.F90\n\ngfortran -c -fopenmp liboctq.F90\n\ngfortran -o sim1 -fopenmp sim-alnipt.F90 liboctq.o liboceq.a\n\nREM on Linux and Mac you need\ngfortran -o sim1 -fopenmp sim-alnipt.F90 getkey.o liboctq.o liboceq.a\n\n\nREM In the setup file you specify the output. This can be plotted by GNUPLOT\n\n\n\n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/setup.input", "content": "# This is input file for the Al-Ni-Pt simulation\n# A line starting with a # character is a comment line\n#\n# database file name\nalnipt-2005.TDB\n# each element to be selected from the database on a separate line\n# end with empty line\nal\nni\npt\n\n# the stable phase in the simulation\nfcc\n# number of gridpoints (max 50)\n40\t \n# Mole fractions in alphabetical order, * means fraction is \"rest\"\n# fractions of Al and Pt, Ni rest on the left hand side\n0.1 * 0.01\n# Mole fraction of Al and Ni on the right hand side, Pt rest\n0.1 0.05 *\n# Temperature (K)\n1073\n# Mobilities of Al, Ni and Pt (mol per second and J)\n# These are multiplied with the difference in chemical potential\n0.001 0.001 0.001\n# Maximum number of timesteps\n10000\n# Minimum change in fractions to continue (condition to terminate)\n.001\n# GNUPLOT file name for plotting (empty line no intermediate results)\nocsim.plt\n# Empty line if run in parallel\n\n# end of setup file\n# this is not included on github\n\n" }, { "path": "examples/TQ4lib/F90/parallel-alnipt/sim-alnipt.F90", "content": "!\n! Small program to simulate diffusion in 1D using OC\n! Ternary system Al-Ni-Pt coating of superallys\n!\nprogram sim2\n!\n use liboctq\n!$ use omp_lib\n!\n implicit none\n integer, parameter :: gpmax=100,cmax=10,sfile=31\n integer notused,cnum(10),nsel,gpix(gpmax),gp,gp1,gp2,nt,cc1,cc2\n integer howmany,plut,modmod,maxloop,half,phtup,jj,jp,gpcur,nrow,ioerr\n character database*60,selel(cmax)*2,gpname*24,line*60\n character setupfile*60,profiles*60,phasename*24\n double precision tpval(2),nval,xval(cmax),dx(cmax),dxmax\n double precision xxx,xxy,dmu,dff,sum,gpxval(cmax)\n double precision sumpos,sumneg,sdxp,sdxn,mobi(cmax),xin(cmax)\n double precision eqcpu1,eqcpu2,eqcpusum\n double precision xleft(cmax),xright(cmax),xsum\n integer eqcc1, eqcc2,eqccsum,lrest,rrest,iel,rest\n double precision, parameter :: mumin=1.0d-4\n logical parallel\n type(gtp_equilibrium_data), pointer :: ceq,gridceq\n!\n type grid\n! This has a pointer to one equilibrium per gridpoint\n! and has an array of mole fractions in that gridpoint for diffusion\n type(gtp_equilibrium_data), pointer :: eqp\n double precision xval(cmax)\n end type grid\n type(grid), dimension(gpmax), target :: gpp\n type(grid), pointer :: gridpoint\n!\n write(*,1)\n1 format('Simulation of uphill diffusion Al-Ni-Pt, OC example 2021'/&\n 'Surface coating of Pt-Al on an Al-Ni turbine blade (see PDF)'//&\n 'In the input file is specified on separate lines:'/&\n 'database file, symbol of each element'/&\n 'name of stable phase,'/&\n 'number of gridpoints'/&\n 'Al and Pt mole fractions in the blade (Ni rest),'/&\n 'Al and Ni mole fractions of the surface layer (Pt rest),'/&\n 'Mobilities (mol/(J s)) of Al, Ni and Pt,'/&\n 'Maximum number of timesteps'/&\n 'Minimal change of fractions'/&\n 'file name for intermediate output (empty line means no output),'/&\n 'empty line means run in parallel,'//&\n 'Any lines starting with a hash caracter \"#\" are ignored.'//)\n!\n write(*,2,advance='no')\n2 format('Setup file name:')\n read(*,3)setupfile\n3 format(a)\n! open input file\n open(sfile,file=setupfile,access='sequential',status='old',iostat=ioerr)\n if(ioerr.ne.0) stop 'Error opening input file'\n!\n!-------------------------------------\n! initiate\n call tqini(notused,ceq)\n if(gx%bmperr.ne.0) stop 'Cannot initiate TQ interface'\n! read database and elements\n call readline(sfile,database)\n nsel=1\n eloop: do while(.true.)\n call readline(sfile,selel(nsel))\n if(selel(nsel)(1:1).eq.' ') exit eloop\n call capson(selel(nsel))\n nsel=nsel+1\n enddo eloop\n nsel=nsel-1\n rest=nsel\n! read database with selected elements, rest is zet to zero!\n call tqrpfil(database,rest,selel,ceq)\n if(gx%bmperr.ne.0) stop 'Cannot read selected elememts from database'\n!-----------------\n! suspend all phases except the specified phase\n call tqphsts(-1,-2,zero,ceq)\n if(gx%bmperr.ne.0) stop 'TQ error suspending phases'\n! set specified phase as ENTERED\n call readline(sfile,phasename)\n call tqgpi(phtup,phasename,ceq)\n if(gx%bmperr.ne.0) stop 'TQ error finding stable phase'\n call tqphsts(phtup,1,one,ceq)\n if(gx%bmperr.ne.0) stop 'TQ error entering stable phase'\n!-----------------\n! set phasename as reference state for all elements ?\n!-----------------\n! number of gridpoints\n call readline(sfile,line)\n jp=1\n call getint(line,jp,gpcur)\n if(buperr.ne.0) stop 'Input error 1'\n if(gpcur.lt.10 .or. gpcur.gt.100) then\n write(*,*)'Gridpoints must be between 10 and 100'\n stop 'Error in input file'\n endif\n!-----------------\n! Left side (interior) initial composition in alphabetical order\n call readline(sfile,line)\n jp=1\n xsum=zero\n xleft=zero\n lrest=0\n do iel=1,nsel\n call getrel(line,jp,xleft(iel))\n! the metlib routines have a global error code buperr\n if(buperr.ne.0) then\n if(line(jp:jp).eq.'*') then\n lrest=iel\n buperr=0\n jp=jp+1\n else\n write(*,*)'Error reading left side fractions for element ',iel\n stop\n endif\n elseif(xleft(iel).le.zero .or. xleft(iel).ge.one) then\n write(*,'(a,i3)')'Mole fraction must be between 0 and 1 for element',iel\n stop 'Error in setup file'\n endif\n xsum=xsum+xleft(iel)\n enddo\n if(lrest.eq.0) stop 'No element defined as \"rest\" on left hand side'\n xleft(lrest)=one-xsum\n if(xleft(lrest).ge.one) then\n write(*,*)'Fractions should add up to unity'\n stop 'Error in setup file'\n endif\n!-----------------\n! Right side (surface) initial composition in alphabetical order\n call readline(sfile,line)\n jp=1\n xsum=zero\n xright=zero\n rrest=0\n do iel=1,nsel\n call getrel(line,jp,xright(iel))\n if(buperr.ne.0) then\n if(line(jp:jp).eq.'*') then\n rrest=iel\n buperr=0\n jp=jp+1\n else\n write(*,*)'Error reading right side fractions for element ',iel\n stop\n endif\n elseif(xright(iel).le.zero .or. xright(iel).ge.one) then\n write(*,'(a,i3)')'Mole fraction must be between 0 and 1 for element',iel\n stop 'Error in setup file'\n endif\n xsum=xsum+xright(iel)\n enddo\n if(rrest.eq.0) stop 'No element defines as \"rest\" on right hand side'\n xright(rrest)=one-xsum\n if(xright(rrest).le.zero) then\n write(*,*)'Fractions on right hand side should add up to unity'\n stop 'Error in setup file'\n endif\n!----------------------------\n! Temperature\n call readline(sfile,line)\n jp=1\n call getrel(line,jp,tpval(1))\n if(buperr.ne.0) stop 'Input errot 7'\n if(tpval(1).lt.2.0D2 .or. tpval(1).gt.3.0D3) then\n write(*,*)'T must be between 200 and 3000 K'\n stop 'Error in setup file'\n endif\n! Pressure\n tpval(2)=1.0D5\n!----------------------------\n! Mobilities in alphabetical order\n call readline(sfile,line)\n jp=1\n do iel=1,nsel\n call getrel(line,jp,mobi(iel))\n if(buperr.ne.0) stop 'Input error 8'\n if(mobi(iel).gt.0.1 .or. mobi(iel).lt.1.0D-6) then\n write(*,*)'Mobility data out of range for element ',iel\n stop 'Error in setup file'\n endif\n enddo\n!----------------------------\n! Max timesteps\n call readline(sfile,line)\n jp=1\n call getint(line,jp,maxloop)\n if(buperr.ne.0) stop 'Input error 8'\n if(maxloop.lt.10) stop 'Too few timesteps'\n! Minimal change in fractions\n call readline(sfile,line)\n jp=1\n call getrel(line,jp,dff)\n if(dff.le.zero .or. dff.gt.0.1) stop 'Fraction change out of range'\n!----------------------------\n! intermediate output\n call readline(sfile,profiles)\n if(profiles(1:1).ne.' ') then\n modmod=1\n plut=30\n open(plut,file=profiles,access='sequential',status='unknown',iostat=ioerr)\n if(ioerr.ne.0) stop 'Cannot open profile output file'\n! start GNUPLOT graphics\n write(30,10)\n10 format('# GNUPLOT file for plotting profiles'/&\n 'set terminal wxt size 840,700 font \"Arial,16\"'/&\n 'set title \"OpenCalphad simulator\"'/&\n 'set origin 0.0, 0.0 '/'set size 1.0, 1.0'/&\n 'set xlabel \"Gridpoint\"'/'set ylabel \"Fractions\"'/&\n 'set key top right font \"Arial,12\"')\n else\n plut=0\n modmod=maxloop\n endif\n!----------------------------\n! run sequentially/parallel\n call readline(sfile,line)\n if(line(1:1).ne.' ') then\n parallel=.FALSE.\n else\n parallel=.TRUE.\n endif\n!------------------------------------- end of input\n! Echo input on screen and output file (if any)\n write(*,17)trim(database),(selel(iel),iel=1,nsel)\n write(*,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel)\n write(*,19)(xright(iel),iel=1,nsel)\n write(*,20)(mobi(iel),iel=1,nsel)\n write(*,21)tpval(1),maxloop,dff\n if(plut.gt.0) write(*,22)trim(profiles)\n17 format(/'# Input values: '/'# ',a,1x,10(1x,a))\n18 format('# ',a,i5/'# ',10(F7.4))\n19 format('# ',10(F7.4))\n20 format('# ',10(1PD12.4))\n21 format('# ',F8.2,i8,D12.4)\n22 format('# ',a//)\n if(plut.gt.0) then\n write(plut,17)trim(database),(selel(iel),iel=1,nsel)\n write(plut,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel)\n write(plut,19)(xright(iel),iel=1,nsel)\n write(plut,20)(mobi(iel),iel=1,nsel)\n write(plut,21)tpval(1),maxloop,dff\n! Start data for graphics \n if(plut.gt.0) write(plut,23)\n23 format(/'$profile << EOD')\n endif\n eqcpusum=zero\n eqccsum=0\n!---------------------------------------\n! set conditions\n nval=1.0D0\n! cnum not used at all!!\n call tqsetc('T ',0,0,tpval(1),cnum(1),ceq)\n if(gx%bmperr.ne.0) goto 1000\n call tqsetc('P ',0,0,tpval(2),cnum(2),ceq)\n if(gx%bmperr.ne.0) goto 1000\n call tqsetc('N ',0,0,nval,cnum(3),ceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n do iel=1,nsel\n if(iel.ne.lrest) then\n call tqsetc('X ',iel,0,xleft(iel),cnum(4),ceq)\n endif\n enddo\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------------------\n! calculate an equilibrium just to test\n write(*,*)'Calculating equilibrium with gridminimizer'\n call tqlc(kou,ceq)\n call tqce(' ',0,0,zero,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------------------\n! list the equilibrium results as a check\n call tqlr(kou,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------------------\n! create grid with gpcur equilibria with initial composition\n! half the gridpoints has the left hand composition, the other the right hand\n gpname='GP_001'\n half=gpcur/2\n write(*,43)\n43 format(/'Creating grid'/'Gridpoint name Fractions in alphabetical order')\n xval=xleft\n rest=lrest\n do gp=1,gpcur\n! copy the \"ceq\" equilibrium to a new record in gpp(gp)%eqp\n! the list of conditions are not copied but linked to original equilibrium\n call tqcceq(gpname,gpix(gp),gpp(gp)%eqp,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! To ensure the conditions are unique in each gridpoint nullify the list\n! (it creates som lost memory ...)\n nullify(gpp(gp)%eqp%lastcondition)\n! Set new conditions in equilibrium for this gridpoint\n call tqsetc('T ',0,0,tpval(1),cnum(1),gpp(gp)%eqp)\n if(gx%bmperr.ne.0) goto 1000\n call tqsetc('P ',0,0,tpval(2),cnum(2),gpp(gp)%eqp)\n if(gx%bmperr.ne.0) goto 1000\n call tqsetc('N ',0,0,nval,cnum(3),gpp(gp)%eqp)\n if(gx%bmperr.ne.0) goto 1000\n! halfway change compositions\n if(gp.gt.half) then\n xval=xright\n rest=rrest\n endif\n do iel=1,nsel\n if(iel.ne.rest) then\n call tqsetc('X ',iel,0,xval(iel),cnum(4),gpp(gp)%eqp)\n endif\n enddo\n if(gx%bmperr.ne.0) goto 1000\n! this is a way to check the gridpoint conditions\n! write(*,*)'Conditions for equilibrium ',gp\n! call tqlc(kou,gpp(gp)%eqp)\n! if(gx%bmperr.ne.0) goto 1000\n! calculate without gridmin\n! because start values for the phases were copied above\n call tqce(' ',-1,0,zero,gpp(gp)%eqp)\n if(gx%bmperr.ne.0) goto 1000\n!\n write(*,44)gp,trim(gpname),(xval(iel),iel=1,nsel)\n44 format(i5,6x,a,10F7.4)\n do iel=1,nsel\n gpp(gp)%xval(iel)=xval(iel)\n enddo\n! increment the equilibrium name index\n call incname(gpname,6)\n enddo\n! write intitial profile for all 3 components for all gridpoints\n nt=0\n nrow=1\n write(*,*)'Initial composition profile:',nsel,gpcur\n! \n do iel=1,nsel\n write(*,51)(gpp(gp)%xval(iel),gp=1,gpcur)\n enddo\n if(plut.gt.0) then\n write(plut,'(\"# \",2i10)')nt,nrow\n do iel=1,nsel\n write(plut,51)(gpp(gp)%xval(iel),gp=1,gpcur)\n enddo\n endif\n51 format(100(0pF6.3))\n52 format(i10,': ',100(0pF6.3))\n! \n if(parallel) then\n write(*,*)'Calculations will be made in parallel'\n else\n write(*,*)'Calculations will be made sequentially'\n endif\n!--------------------------------------- simulation starts\n call cpu_time(xxx)\n call system_clock(count=cc1)\n! Take a time step, calculate diffusion and modify compositions\n! Use the difference in chemical potential between two adjacent gridpoints\n! to calculate the flow of elements\n simulate: do while(.TRUE.)\n nt=nt+1\n dxmax=zero\n diff: do gp1=1,gpcur-1\n gp2=gp1+1\n sumneg=zero\n sumpos=zero\n do jj=1,nsel\n gpxval(jj)=gpp(gp1)%xval(jj)\n dmu=gpp(gp2)%eqp%cmuval(jj)-gpp(gp1)%eqp%cmuval(jj)\n dx(jj)=mobi(jj)*dmu\n if(abs(dx(jj)).gt.1.0d-2) then\n write(*,*)'Very strong diffusion!',nt,jj,dx(jj)\n endif\n! dxmax is used to check convergence, if max dxmax small then terminate\n if(abs(dx(jj)).gt.dxmax) dxmax=abs(dx(jj))\n if(dx(jj).gt.zero) then\n sumpos=sumpos+dx(jj)\n else\n sumneg=sumneg-dx(jj)\n endif\n enddo\n! The sum of the fractions should always be unity, make the sum of all\n if(sumpos.le.1.0D-12 .or. sumneg.le.1.0D-12) then\n! There is no diffusion\n sdxp=zero; sdxn=zero\n elseif(sumpos.gt.sumneg) then\n! scale the maximal flow to be the same as the minimal\n sdxp=sumneg/sumpos\n sdxn=one\n else\n sdxp=one\n sdxn=sumpos/sumneg\n endif\n! move the atoms!!\n do jj=1,nsel\n if(dx(jj).ge.zero) then\n gpp(gp1)%xval(jj)=gpp(gp1)%xval(jj)+dx(jj)*sdxp\n gpp(gp2)%xval(jj)=gpp(gp2)%xval(jj)-dx(jj)*sdxp\n else\n gpp(gp1)%xval(jj)=gpp(gp1)%xval(jj)+dx(jj)*sdxn\n gpp(gp2)%xval(jj)=gpp(gp2)%xval(jj)-dx(jj)*sdxn\n endif\n enddo\n! Check fractions are in range and sum is unity\n sum=zero\n do jj=1,nsel\n if(gpp(gp1)%xval(jj).ge.one .or.gpp(gp1)%xval(jj).le.zero) then\n write(*,69)gp1,jj,gpp(gp1)%xval(jj)\n69 format('Fraction outside limits at gridpoint ',2i3,F10.4)\n! stop 'katastrof 1!'\n if(gpp(gp1)%xval(jj).ge.one) gpp(gp1)%xval(jj)=1.0-1.0D-8\n if(gpp(gp1)%xval(jj).le.zero) gpp(gp1)%xval(jj)=1.0D-8\n endif\n sum=sum+gpp(gp1)%xval(jj)\n enddo\n if(abs(sum-one).gt.1.0D-7) then\n write(*,*)'Sum of fractions not unity at gridpoint ',gp1,sum\n write(*,'(a,3F10.5)')'Fractions: ',(gpxval(jj),jj=1,3)\n write(*,'(a,3F10.5)')'Fractions: ',(gpp(gp1)%xval(jj),jj=1,3)\n stop 'katastrof 2!'\n endif\n enddo diff\n! modmod controls output\n! initially write each profile, then every 10, then every 100, then 1000\n if(nt.eq.10) then\n modmod=10\n elseif(nt.eq.100) then\n modmod=100\n elseif(nt.eq.1000) then\n modmod=1000\n elseif(nt.eq.10000) then\n modmod=10000\n endif\n if(modmod.gt.maxloop) modmod=maxloop\n if(mod(nt,modmod).eq.0) then\n if(plut.gt.0) then\n modmod=2*modmod\n nrow=nrow+1\n write(plut,'(\"# \",2i10)')nt,nrow\n do iel=1,nsel\n write(plut,51)(gpp(gp)%xval(iel),gp=1,gpcur)\n enddo\n endif\n write(*,*)'Done ',nt,' timesteps'\n! debug output\n! write(*,50)nt,dxmax,(gpp(gp)%xval(1),gp=1,gpcur)\n! do iel=2,nsel\n! write(*,51)(gpp(gp)%xval(iel),gp=1,gpcur)\n! enddo\n endif\n!---------------------------------------\n! the equilibrium with the new composition in all gridpoints (parallel?)\n rest=lrest\n newx: do gp1=1,gpcur\n gridpoint=>gpp(gp1)\n if(gp1.gt.half) then\n rest=rrest\n endif\n do iel=1,nsel\n if(iel.ne.rest) then\n call tqsetc('X ',iel,0,gridpoint%xval(iel),cnum(4),gridpoint%eqp)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting condition: ',gridpoint%eqp%eqname\n gx%bmperr=0\n endif\n endif\n enddo\n! possible debug output of conditions ....\n! write(*,*)'Conditions for equilibrium ',gp1\n! call tqlc(kou,gridpoint%eqp)\n! if(gx%bmperr.ne.0) goto 1000\n enddo newx\n! alternative running without parallel\n call cpu_time(eqcpu1)\n call system_clock(count=eqcc1)\n pos: if(parallel) then\n!$OMP parallel do private(gridceq)\n neweq: do gp1=1,gpcur\n gridceq=>gpp(gp1)%eqp\n! This give new chemical potentials\n! the number of threads must be obtained inside the loop otherwize 1 or 0\n!$ howmany=omp_get_num_threads()\n! calculate without gridmin\n call tqce(' ',-1,0,zero,gridceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calculating equil: ',gridceq%eqname\n gx%bmperr=0\n endif\n enddo neweq\n!$omp end parallel do\n else\n howmany=1\n seqloop: do gp1=1,gpcur\n gridceq=>gpp(gp1)%eqp\n! Calculate equilibrium for new chemical potentials for next diffusion calc\n call tqce(' ',-1,0,zero,gridceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calculating equil: ',gridceq%eqname,gx%bmperr\n gx%bmperr=0\n endif\n enddo seqloop\n endif pos\n call cpu_time(eqcpu2)\n call system_clock(count=eqcc2)\n eqcpusum=eqcpusum+eqcpu2-eqcpu1\n eqccsum=eqccsum+eqcc2-eqcc1\n! loop back until simulation timestep exceeded or no change in composition\n if(abs(dxmax).lt.1.0D-5 .or. nt.gt.maxloop) exit simulate\n enddo simulate\n!---------------------------------------\n! Output of results and repeat input (if already forgotten)\n call system_clock(count=cc2)\n call cpu_time(xxy)\n write(*,190)nt,dxmax,xxy-xxx,cc2-cc1\n write(*,193)eqcpusum,eqccsum,howmany\n write(*,17)trim(database),(selel(iel),iel=1,nsel)\n write(*,18)trim(phasename),gpcur,(xleft(iel),iel=1,nsel)\n write(*,19)(xright(iel),iel=1,nsel)\n write(*,20)(mobi(iel),iel=1,nsel)\n write(*,21)tpval(1),maxloop,dff\n if(plut.gt.0) then\n! Results saved on file, finish the graphics output and CPU times\n write(plut,195)nsel\n195 format('EOD'//&\n 'set style line 1 linetype 1 linecolor rgb \"#000000\" linewidth 1',&\n ' pointtype 10'/&\n 'set style line 2 lt 1 lc rgb \"#4169E1\" lw 1 pt 7'/&\n 'set style line 3 lt 1 lc rgb \"#00C000\" lw 1 pt 6'//&\n 'plot for [myRow=0:',i3,'] $profile matrix using 1:3 ',&\n ' every :::myRow::myRow with linespoints linestyle 1+myRow ',&\n ' title sprintf(\"Row number %d\",myRow)'//'pause mouse')\n write(plut,190)nt,dxmax,xxy-xxx,cc2-cc1\n190 format(/'# Timesteps:',i6,', Dmax=',1E12.4/&\n '# CPU time:',F12.4,'s, clockcycles: ',i8)\n write(plut,193)eqcpusum,eqccsum,howmany\n193 format(/'# For equilibrium calculation: CPU time ',F12.4,' s and cc: ',i8/&\n '# Number of thread(s): ',i3)\n close(plut)\n endif\n!\n! Remind the file name for graphics\n write(*,'(/\"Graphics output on \",a)')trim(profiles)\n write(*,991)\n991 format(/'All well that ends well'/)\n stop\n!-----------------------------------------\n! OC error\n1000 continue\n write(*,1001)gx%bmperr,trim(bmperrmess(gx%bmperr))\n1001 format('Error code ',i5/'Message: ',a)\n stop\n!\nend program sim2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nsubroutine incname(name,pos)\n! increment sequential index in equilibrium name\n implicit none\n character name*(*)\n integer pos,jpos,iv\n jpos=pos\n loop: do while(jpos.gt.1)\n iv=ichar(name(jpos:jpos))-ichar('0')\n if(iv.lt.9) then\n iv=iv+1\n name(jpos:jpos)=char(iv+ichar('0')); exit loop\n else\n name(jpos:jpos)='0'\n jpos=jpos-1\n endif\n enddo loop\n return\nend subroutine incname\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nsubroutine readline(setup,line)\n! read seup file ingnoring comment lines\n implicit none\n integer setup\n integer :: nl=0\n save nl\n character line*(*)\n do while(.TRUE.)\n read(setup,10,end=1000)line\n10 format(a)\n nl=nl+1\n! write(*,*)'Echo input line: \"',trim(line),'\"'\n if(line(1:1).ne.'#') return\n enddo\n1000 continue\n write(*,*)'Found EOF of setup file after line ',nl\n return\nend subroutine readline\n\n" }, { "path": "examples/TQ4lib/readme.tex", "content": "\\documentclass[12pt]{article}\n\\textwidth 165mm\n\\textheight 210mm\n\\oddsidemargin 1mm\n\\evensidemargin 1mm\n\\topmargin 1mm\n\\usepackage[latin1]{inputenc}\n\n\\begin{document}\n\n\\begin{center} \n\n{\\Large \\bf The Open Calphad Application Software Interface (OCASI)\n\nBased on the TQ standard for interfacing thermodynamic software}\n\n\\bigskip\n\nBo Sundman \\today\n\n\\end{center}\n\nThere is a Fortran version and a tentative iso-C version for C++. \nIn the future it may be possible to merge these.\n\nIf you are not familiar with compiling and linking software and do not\nunderstand the intructions here please ask someone close to you for\nhelp. The instructions here are very brief but I am too busy to\nanswer questions about handling such things and I know nothing about\nC++\n\nTo link any of the examples you must first compile and link the OC\nmain program. When this works you must compile a special library\nexcluding the file browser ``tinyfiledialogs'' and this is done (on\nWindiws) by the command file {\\bf makeocasilib}. You must first add\nthe extension ``.cmd'' to this file and then execute it as a\ncommand/batch file. This generates the library files:\n\n{\\bf libocasi.a} and {\\bf liboceqplus.mod}\n\nBoth of these files are needed to compile and link the applications.\n\nThe initial iso-C version of the library was provided by Teslos in\n2014 and it has been extended by Matthias Stratmann at RUB, Germany\nand Christophe Sigli at Constellium, France to handle more calls to\ndifferent subroutines. As things are still under development there\nmay be slightly different versions on various subdirectories.\n\nFiles on this directory:\n\n\\begin{itemize}\n\\item readme.pdf is this file. There are specific readme files on the\n subdirectories.\n\n\\item readme.tex is LaTeX source for this file.\n Subdirectories:\n \\begin{itemize}\n \\item F90 has the source code for the TQ library, liboctq.F90 that\n was updated 1019.10.31 (Halloween) and three subqdirectories with\n examples.\n \\begin{itemize}\n \\item The crfe/ was updated in October, 2019.\n \\item feni/ has not been upd\n ated for a long time.\n \\item parallel-alnipt/ simulating diffusion in Al-Ni-Pt in\n parallel added August 2021. There are instructions how to use\n it in the directory.\n \\end{itemize}\n\n \\item Cpp has one C++ example provided by Matthias Stratmann at RUB,\n Germany and one from Cristophe Sigli, Consillium, France. There\n is a separate version of the Fortran TQ library and an isoC\n interface. I tested the Scheil program in February 2020 and it works\n but it generates some error messages I do not understand and as I\n do not know C++ I cannit fix that. I would be greateful for any help.\n\n Note that STEP SCHEIL is now available as a command in OC.\n\n \\end{itemize}\n\\end{itemize}\n\n\\end{document}\n" }, { "path": "examples/macros/AlC-OC.TDB", "content": "$ Database file written 2020-09-10\n$ Tentative assessment of AlC using Einstein model\n \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7423E+00!\n \n FUNCTION TEMP 10 +T**(-1); 6000 N !\n FUNCTION RTEMP 10 +R#**(-1)*TEMP#; 6000 N !\n\n$ EINSTEIN FOR ALFCC \n$ FUNCTION TESERAL 10 +283; 6000 N !\n$ G-FUN FOR ALFCC, without Einstein\n FUNCTION GTSERAL 10 -.001478307*T**2-7.83339395E-07*T**3; 6000 N !\n$ FUNCTION G0SERAL 10 -8160+GTSERAL; 6000 N !\n FUNCTION GHSERAL 10 -8160+GTSERAL; 6000 N !\n\n$ EINSTEIN FOR ALBCC\t \n$ FUNCTION TEBCCAL 10 +233; 6000 N !\n$ G-FUN FOR ALBCC adding Kaufman lattice stability without Einstein\n FUNCTION G0BCCAL 10 +GHSERAL+10083; 6000 N !\n\n$ EINSTEIN FOR ALHCP\t \n$ FUNCTION TEHCPAL 10 +263; 6000 N !\n$ G-FUN FOR ALHCP without Einstein\n FUNCTION G0HCPAL 10 +GHSERAL+5481; 6000 N !\n\n$ EINSTEIN FOR ALLIQ\t \n$ FUNCTION TELIQAL 10 +254; 6000 N !\n FUNCTION G0LIQAL 10 -209-3.777*T-4.5E-4*T**2; 6000 N !\n \n$ These are incorporated in the GEIN functions for Graphite\n$ FUNCTION FESERCC1 10 +.484047107; 6000 N !\n$ FUNCTION TESERCC1 10 +1953.2502; 6000 N !\n$ FUNCTION FESERCC2 10 +.121581878; 6000 N !\n$ FUNCTION TESERCC2 10 +447.96926; 6000 N !\n$ FUNCTION FESERCC3 10 +.349684332; 6000 N !\n$ FUNCTION TESERCC3 10 +947.01605; 6000 N !\n$ FUNCTION FESERCC4 10 +.0388463641; 6000 N !\n$ FUNCTION TESERCC4 10 +192.65039; 6000 N !\n$ FUNCTION FESERCC5 10 +.00584032345; 6000 N !\n$ FUNCTION TESERCC5 10 +64.463356; 6000 N !\n \n$ The first coefficient for THETA=1952.2502 is negative 0.484047107-1.0\n$ as the argument of LNTH with the factor 1.0\n FUNCTION GEGRACC 10 -0.5159523*GEIN(1953.2502) +0.121519*GEIN(447.96926)\n +0.3496843*GEIN(947.01605)+0.0388463*GEIN(192.65039)\n +0.005840323*GEIN(64.463356); 6000 N !\n\n$ This is used in metastable phases with C\n FUNCTION GTSERCC 10 -2.9531332E-04*T**2-3.3998492E-16*T**5; 6000 N !\n\n FUNCTION GHSERCC 10 -17752.213 +GEGRACC +GTSERCC; 6000 N !\n\n$ These are incorporated in the GEIN functions for Diamond \n$ the factor for the highest Einstein THETA negative as used in LNTH parameter\n$ FUNCTION FEDIACC1 10 +.231791; 6000 N !\n$ FUNCTION TEDIACC1 10 +813.63716; 6000 N !\n$ FUNCTION FEDIACC2 10 +.0114797; 6000 N !\n$ FUNCTION TEDIACC2 10 +345.35022; 6000 N !\n$ FUNCTION FEDIACC3 10 +.763257386; 6000 N !\n$ FUNCTION TEDIACC3 10 +1601.4467; 6000 N !\n\n FUNCTION GEDIACC 10 0.2318*GEIN(813.63716)+0.01148*GEIN(345.35022)\n -.236743*GEIN(1601.4467); 6000 N !\n\n FUNCTION G0DIACC 10 -16275.202-9.1299452E-05*T**2\n -2.1653414E-16*T**5; 6000 N !\n \n$ EINSTEIN FOR LIQCC the TELIQCC replaced by GEIN function\n$ FUNCTION TELIQCC 10 +1400; 6000 N !\n FUNCTION G0LIQCC 10 +63887-8.2*T-4.185E-4*T**2; 6000 N !\n\n \n$ EINSTEIN FOR ALCFCC replaced by GEIN functions\n$ FUNCTION TEFCCALC 10 +549; 6000 N !\n$ FUNCTION GEFCALC1 10 +1-1*EXP(-TEFCCALC#*T**(-1)); 6000 N !\n$ FUNCTION GEFCALC2 10 +1*LN(GEFCALC1#); 6000 N !\n$ FUNCTION GEFCALC3 10 +3*R#*T*GEFCALC2#; 6000 N !\n$ FUNCTION GEFCCALC 10 +1.5*R#*TEFCCALC#+GEFCALC3#; 6000 N !\n \n$ EINSTEIN FOR ALCBCC reolaced by GEIN functions\n$ FUNCTION TEBCCALC 10 +863; 6000 N !\n$ FUNCTION GEALCBC1 10 +1-1*EXP(-TEBCCALC#*T**(-1)); 6000 N !\n$ FUNCTION GEALCBC2 10 +1*LN(GEALCBC1#); 6000 N !\n$ FUNCTION GEALCBC3 10 +3*R#*T*GEALCBC2#; 6000 N !\n$ FUNCTION GEBCCALC 10 +1.5*R#*TEBCCALC#+GEALCBC3#; 6000 N !\n \n$ EINSTEIN FOR ALCHCP\n FUNCTION TEHCPALC 10 +452; 6000 N !\n\n$ EINSTEIN FOR AL4C3 , these are replaces by GEIN functions\n$ FUNCTION TEAL4C1 10 +401; 6000 N !\n$ FUNCTION TEAL4C2 10 +1077; 6000 N !\n$ G-FUN FOR AL4C3 \n FUNCTION G0AL4C3 10 -277339-5.423368E-003*T**2; 6000 N !\t \n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE AL4C3 % 2 4 3 !\n CONSTITUENT AL4C3 :AL : C : !\n$ there are 7 atoms/FU and a factor 7 has been multiplied by the weights\n$ of the GEIN functions. \n$ The Einstein contribution from LNTH is also multiplied by 7\n$ No need for an LNTH parameter unless solubility of a 3rd element\n$ PARAMETER G(AL4C3,AL:C) 10 +G0AL4C3+3.92*GEIN(401)+3.08*GEIN(1077);\n$ 6000 N 20HE !\n PARAMETER G(AL4C3,AL:C) 10 +G0AL4C3-3.08*GEIN(401)+3.08*GEIN(1077);\n 6000 N 20HE !\n PARAMETER LNTH(AL4C3,AL:C) 10 LN(401); 6000 N 20HE !\n\n PHASE BCC_A2 % 2 1 3 !\n CONSTITUENT BCC_A2 :AL : C,VA : !\n PARAMETER G(BCC_A2,AL:C) 10 +GTSERAL+3*GTSERCC+1006844; 6000 N 20HE !\n$ the LNTH parameter should be multiplied atomes/FU in the software\n$ For pure Al this is 1.0, for the metastable endmember Al:C it is 4.0\n PARAMETER LNTH(BCC_A2,AL:C) 10 LN(863); 6000 N 20HE !\n PARAMETER G(BCC_A2,AL:VA) 10 +G0BCCAL; 6000 N 20HE !\n PARAMETER LNTH(BCC_A2,AL:VA) 10 LN(233); 6000 N 20HE !\n PARAMETER G(BCC_A2,AL:C,VA;0) 10 -819896+14*T; 6000 N 20HE !\n \n PHASE HCP_A3 % 2 1 .5 !\n CONSTITUENT HCP_A3 :AL : C,VA : !\n\n PARAMETER G(HCP_A3,AL:C) 10 +GTSERAL+.5*GTSERCC+2176775; 6000 N 20HE !\n$ this parameter should be multiplied by 1.5 (atoms/FU)\n PARAMETER LNTH(HCP_A3,AL:C) 10 LN(452); 6000 N 20HE !\n PARAMETER G(HCP_A3,AL:VA) 10 +G0HCPAL; 6000 N 20HE !\n PARAMETER LNTH(HCP_A3,AL:VA) 10 LN(263); 6000 N 20HE !\n PARAMETER G(HCP_A3,AL:C,VA;0) 10 0; 6000 N 20HE !\n\n PHASE FCC_A1 % 2 1 1 !\n CONSTITUENT FCC_A1 :AL : C,VA : !\n PARAMETER G(FCC_A1,AL:C) 10 +GTSERAL+GTSERCC+57338; 6000 N 20HE !\n$ this parameter should be multiplied by 2 (atoms/FU)\n PARAMETER LNTH(FCC_A1,AL:C) 10 LN(549); 6000 N 20HE !\n PARAMETER G(FCC_A1,AL:VA;0) 10 +GHSERAL; 6000 N 20HE !\n PARAMETER LNTH(FCC_A1,AL:VA) 10 LN(283); 6000 N 20HE !\n PARAMETER G(FCC_A1,AL:C,VA;0) 10 -70345; 6000 N 20HE !\n\nPHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :C : !\n PARAMETER G(GRAPHITE,C) 10 +GHSERCC; 6000 N 20HE !\n PARAMETER LNTH(GRAPHITE,C) 10 LN(1953.2502); 6000 N 20HE !\n \n PHASE DIAMOND % 1 1.0 !\n CONSTITUENT DIAMOND :C : !\n PARAMETER G(DIAMOND,C) 10 G0DIACC+GEDIACC; 6000 N 20HE !\n PARAMETER LNTH(DIAMOND,C) 10 LN(1601.4467); 6000 N 20HE !\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :AL,C : !\n$ described by the liquid 2-state model, G2 describes the real liquid\n PARAMETER G(LIQUID,AL) 10 +G0LIQAL; 6000 N 20HE !\n PARAMETER LNTH(LIQUID,AL) 10 LN(254); 6000 N 20HE !\n$ NOTE! G2 is the same as GD in Thermo-Calc\n PARAMETER G2(LIQUID,AL) 10 +13398-R*T-.16597*T*LN(T); 6000 N 20HE !\n PARAMETER G(LIQUID,C;0) 10 +G0LIQCC; 6000 N 20HE !\n PARAMETER LNTH(LIQUID,C) 10 LN(1400); 6000 N 20HE !\n PARAMETER G2(LIQUID,C;0) 10 +59147-49.61*T+2.9806*T*LN(T); 6000 N 20HE !\n PARAMETER G(LIQUID,AL,C) 10 +20994-22*T; 6000 N 20HE !\n \n LIST_OF_REFERENCES\n NUMBER SOURCE\n 20HE 'Zhangting He, Bartek Kaplan, Huahai Mao and Malin Selleby,\n Calphad Vol 72, (2021) 102250'\n ! \n" }, { "path": "examples/macros/AlC-diagrams.OCM", "content": "@$=======================================================================\r\n@$ Example calculating Al-C phase diagram and heat capacities\r\n@$ down to low T using the new unary database\r\n@$\r\n\r\nnew Y\r\n\r\nset echo Y\r\n\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$=======================================================================\r\n\r\nr t ./AlC-OC\r\n\r\n\r\n@$\r\n@$ There are warnings because LNTH and G2 parameters has no model\r\n@$ This will be amended with a new database format.\r\n@$ At present the models are set below as commands.\r\n\r\n\r\n@&\r\n\r\n@$ Add the two-state model to the liquid\r\nam ph liq add two\r\nY\r\n\r\n@$ Add the Einstein model to the FCC\r\nam ph fcc add low\r\nY\r\n\r\n@$ Add the Einstein model to the Al4C3\r\nam ph al4c3 add low\r\nY\r\n\r\n@$ Add the Einstein model for BCC\r\nAm ph bcc add low\r\nY\r\n\r\n@$ Add the Einstein model for Diamond\r\nAm ph diam add low\r\nY\r\n\r\n@$ Add the Einstein model for graphite\r\nAm ph graph add low\r\nY\r\n\r\n@$ Add the Einstein model for hcp\r\nAm ph hcp add low\r\nY\r\n\r\nl d\r\n\r\n\r\n@$\r\n@$ Note that the is a line \" + Einsten Cp model\" or \" + Liquid 2 state model\" \r\n@$ Explaining the models used for these parameters\r\n\r\n@&\r\n\r\n@$ Calculate the phase diagram\r\n\r\nset c t=1000 p=1e5 n=1 x(c)=.1\r\n\r\nc e\r\n\r\nset ax 1 x(c) 0 1 .025\r\nset ax 2 T 100 5000 25\r\n\r\nmap\r\n\r\n\r\nplot\r\n\r\n\r\npos left\r\n\r\nTitle Al-C phase diagram Fig 1\r\n\r\n\r\n@&\r\n\r\n@$ ===========================================================\r\n@$ Calculate heat capacity for pure Al down to 10 K for liquid and FCC\r\n\r\nset c x(c)=1e-6\r\n\r\nc e\r\n\r\nent sym cp=hm.t;\r\n\r\n\r\nset ax 1 t 10 5000 10\r\nset ax 2 none\r\n\r\n@$ OC has some problems to calculate with several phases, calculate one by one\r\nset st ph *=sus\r\nset st ph liq=e 1\r\n\r\nstep\r\nN\r\nY\r\n\r\nplot\r\n\r\ncp\r\ntext 1500 32 2 0 Heat capacity for liquid Al\r\ntext N 500 14 2 0 In the metastable range below 933~K\r\ntext N 500 12 2 0 there is a transformation to the amorphous state\r\nTitle Heat capacity for liquid Al Fig 2\r\n\r\n\r\n@$ Note that Cp goes to zero t T=0\r\n@$ The bump in the Cp curve is du to the liquid/amorpheus transiton\r\n@&\r\n\r\nset st ph liq=sus\r\nset st ph fcc=ent 1\r\n\r\nc e\r\n\r\nstep\r\nN\r\nY\r\n\r\n\r\nplot\r\nt\r\ncp\r\ntext 500 140 2 0 FCC heat capacity for Al\r\ntext N 500 130 2 0 Above T=933 K it is metastable\r\ntext N 1500 30 2 0 The Equi Entropy Criteria is used to\r\ntext N 1500 20 2 0 prevent FCC to become stable at high T\r\nTitle Heat capacity for FCC Al Fig 3\r\n\r\n\r\n@$ The extrapolation of the heat capacity of metatstable FCC\r\n@$ at high T is unphysical.\r\n@$ It can be eliminated by the Equi Entropy Criterion\r\n\r\n@&\r\n\r\n@$ ===========================================================\r\n@$ Calculate heat capacity for pure C for liquid, graphite and diamone\r\n\r\nnew Y\r\n\r\nr t ./AlC-OC\r\nC\r\n\r\n@$ Add the two-state model to the liquid, graphite and diamond\r\nam ph liq add two\r\nY\r\n\r\nam ph dia add lowt\r\nY\r\n\r\nam ph gra add lowt\r\nY\r\n\r\n\r\nset c t=1000 p=1e5 n=1\r\n\r\n@$ Step separate does not work well, calculate phases one by one\r\n\r\nset st ph *=sus\r\nset st ph liq=e 1\r\n\r\nc e\r\n\r\nenter symb cp=hm.t;\r\n\r\nset ax 1 t 10 5000 10\r\n\r\nstep norm \r\n\r\n\r\n\r\n\r\nset st ph liq=sus\r\nset st ph dia=e 1\r\n\r\nc e\r\n\r\nstep norm\r\nN\r\n\r\n\r\n\r\nset st ph dia=sus\r\nset st ph gra=e 1\r\n\r\nc e\r\n\r\nstep norm\r\nN\r\n\r\n\r\nplot\r\n\r\ncp\r\ntext 2400 42 2 0 Heat capacity for liquid C\r\ntext N 1300 26 2 6 Heat capacity for graphite\r\ntext N 2000 23 2 5 Heat capacity for diamond\r\ntext N 800 10 2 0 Liquid and diamond are metastable for pure C\r\nTitle Heat capacity for C as graphite, liquid and diamond Fig 4\r\n\r\n\r\n\r\n@&\r\n\r\nplot\r\n\r\nS\r\ntext 1000 85 2 0 Pure C\r\ntext N 2800 80 2 17 Entropy as Liquid\r\ntext N 2500 37 2 15 Entropy as diamond\r\ntext N 2500 52 2 17 Entropy C as graphite\r\ntext N 200 10 0.95 90\r\nLiquid is not crystalline and can have non-zero entropy at T=0K\r\nTitle Entropy for C as graphite liquid and diamond Fig 5\r\n\r\n\r\n\r\n@$==========================================================================\r\n@$ end of AlC-diagrams macro\r\n@$==========================================================================\r\n\r\nset inter\r\n\r\n" }, { "path": "examples/macros/AlFe-4SLBF.TDB", "content": "\n$ Database file written 2008- 8-15\n$ From database: User data 2008. 8. 1 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n \n FUNCTION GHSERAL 298.15 -7976.15+137.093038*T-24.3671976*T*LN(T)\n -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y\n -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2\n -5.764227E-06*T**3+74092*T**(-1); 9.33470E+02 Y\n -11278.378+188.684153*T-31.748192*T*LN(T)-1.230524E+28*T**(-9); \n 2.90000E+03 N !\n FUNCTION GALLIQ 298.15 +11005.029-11.841867*T+7.934E-20*T**7\n +GHSERAL#; 9.33470E+02 Y\n +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6000 N !\n FUNCTION GALBCC 298.15 +10083-4.813*T+GHSERAL#; 6000 N !\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N !\n FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6000 N !\n FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27097.396+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION LFALFE0 298.15 -104700+30.65*T; 6000 N !\n FUNCTION LFALFE1 298.15 +30000-7*T; 6000 N !\n FUNCTION LFALFE2 298.15 +32200-17*T; 6000 N !\n FUNCTION UFALFE 298.15 -4000+T; 6000 N !\n FUNCTION GAL3FE 298.15 +3*UFALFE#+9000; 6000 N !\n FUNCTION GAL2FE2 298.15 +4*UFALFE#; 6000 N !\n FUNCTION GALFE3 298.15 +3*UFALFE#-3500; 6000 N !\n FUNCTION SFALFE 298.15 +UFALFE#; 6000 N !\n FUNCTION UBALFE1 298.15 -4023-1.14*T; 6000 N !\n FUNCTION UBALFE2 298.15 -1973-2*T; 6000 N !\n FUNCTION GD03ALFE 298.15 +2*UBALFE1#+UBALFE2#+3900; 6000 N !\n FUNCTION GB2ALFE 298.15 +4*UBALFE1#; 6000 N !\n FUNCTION GB32ALFE 298.15 +2*UBALFE1#+2*UBALFE2#; 6000 N !\n FUNCTION GD03FEAL 298.15 +2*UBALFE1#+UBALFE2#-70+0.5*T; 6000 N !\n FUNCTION BMALFE 298.15 -1.36; 6000 N !\n FUNCTION BLALFE0 298.15 -0.3; 6000 N !\n FUNCTION BLALFE1 298.15 -0.8; 6000 N !\n FUNCTION BLALFE2 298.15 0.2; 6000 N !\n FUNCTION ZERO 298.15 0.0; 6000.00 N !\n FUNCTION UN_ASS 298.15 0.0 ; 3.00000E+02 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n TYPE_DEFINITION X GES AMEND_PHASE_DESCRIPTION BCC_4SL DIS_PART A2_BCC,,,!\n TYPE_DEFINITION Y GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART A1_FCC,,,!\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :AL,FE : !\n\n PARAMETER G(LIQUID,AL;0) 298.15 +GALLIQ#; 6000 N 91Din !\n PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#; 6000 N 91Din !\n PARAMETER G(LIQUID,AL,FE;0) 298.15 -88090+19.8*T; 6000 N 08Sun !\n PARAMETER G(LIQUID,AL,FE;1) 298.15 -3800+3*T; 6000 N 08Sun !\n PARAMETER G(LIQUID,AL,FE;2) 298.15 -2000; 6000 N 08Sun !\n\n\n TYPE_DEFINITION F GES A_P_D @ MAGNETIC -3.0 2.80000E-01 !\n PHASE A1_FCC %F 2 1 1 !\n CONSTITUENT A1_FCC :AL,FE : VA : !\n\n PARAMETER G(A1_FCC,AL:VA;0) 298.15 +GHSERAL#; 6000 N 91Din !\n PARAMETER G(A1_FCC,FE:VA;0) 298.15 +GFEFCC#; 6000 N 91Din !\n PARAMETER TC(A1_FCC,FE:VA;0) 298.15 -201; 6000 N 91Din !\n PARAMETER BMAGN(A1_FCC,FE:VA;0) 298.15 -2.1; 6000 N 91Din !\n PARAMETER G(A1_FCC,AL,FE:VA;0) 298.15 +LFALFE0#; 6000 N 08Sun !\n PARAMETER G(A1_FCC,AL,FE:VA;1) 298.15 +LFALFE1#; 6000 N 08Sun !\n PARAMETER G(A1_FCC,AL,FE:VA;2) 298.15 +LFALFE2#; 6000 N 08Sun !\n\n\n TYPE_DEFINITION B GES A_P_D @ MAGNETIC -1.0 4.00000E-01 !\n PHASE A2_BCC %B 2 1 3 !\n CONSTITUENT A2_BCC :AL,FE : VA : !\n\n PARAMETER G(A2_BCC,AL:VA;0) 298.15 +GALBCC#; 2.90000E+03 N 91Din !\n PARAMETER G(A2_BCC,FE:VA;0) 298.15 +GHSERFE#; 6000 N 91Din !\n PARAMETER TC(A2_BCC,FE:VA;0) 298.15 1043; 6000 N 91Din !\n PARAMETER BMAGN(A2_BCC,FE:VA;0) 298.15 2.22; 6000 N 91Din !\n PARAMETER G(A2_BCC,AL,FE:VA;0) 298.15 -122960+32*T; 6000 N 93Sei !\n PARAMETER G(A2_BCC,AL,FE:VA;1) 298.15 2945.2; 6000 N 93Sei !\n PARAMETER TC(A2_BCC,AL,FE:VA;0) 298.15 -438; 6000 N 01Ohn !\n PARAMETER TC(A2_BCC,AL,FE:VA;1) 298.15 -1720; 6000 N 01Ohn !\n\n\n\n PHASE AL13FE4 % 3 .6275 .235 .1375 !\n CONSTITUENT AL13FE4 :AL : FE : AL,VA : !\n\n PARAMETER G(AL13FE4,AL:FE:AL;0) 298.15 -30680+7.4*T+.765*GHSERAL#\n +.235*GHSERFE#; 6000 N 08Sun !\n PARAMETER G(AL13FE4,AL:FE:VA;0) 298.15 -28100+7.4*T+.6275*GHSERAL#\n +.235*GHSERFE#; 6000 N 08Sun !\n\n\n PHASE AL2FE % 2 2 1 !\n CONSTITUENT AL2FE :AL : FE : !\n\n PARAMETER G(AL2FE,AL:FE;0) 298.15 -104000+23*T+2*GHSERAL#+GHSERFE#;\n 6000 N 08Sun !\n\n\n PHASE AL5FE2 % 2 5 2 !\n CONSTITUENT AL5FE2 :AL : FE : !\n\n PARAMETER G(AL5FE2,AL:FE;0) 298.15 -235600+54*T+5*GHSERAL#\n +2*GHSERFE#; 6000 N 08Sun !\n\n\n PHASE AL8FE5_D82 % 2 8 5 !\n CONSTITUENT AL8FE5_D82 :AL,FE : AL,FE : !\n\n PARAMETER G(AL8FE5_D82,AL:AL;0) 298.15 +13*GALBCC#; 6000 N 08Sun !\n PARAMETER G(AL8FE5_D82,FE:AL;0) 298.15 +200000+36*T+5*GALBCC#\n +8*GHSERFE#; 6000 N 08Sun !\n PARAMETER G(AL8FE5_D82,AL:FE;0) 298.15 -394000+36*T+8*GALBCC#\n +5*GHSERFE#; 6000 N 08Sun !\n PARAMETER G(AL8FE5_D82,FE:FE;0) 298.15 +13*GHSERFE#+13000; 6000 N 08Sun !\n PARAMETER G(AL8FE5_D82,AL:AL,FE;0) 298.15 -100000; 6000 N 08Sun !\n PARAMETER G(AL8FE5_D82,AL,FE:FE;0) 298.15 -174000; 6000 N 08Sun !\n\n\n$ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A2_BCC \n PHASE BCC_4SL:B %BX 5 .25 .25 .25 .25 3 !\n CONSTITUENT BCC_4SL:B :AL,FE : AL,FE : AL,FE : AL,FE : VA : !\n\n PARAMETER G(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 +GD03ALFE#; 6000 N 08Sun !\n PARAMETER TC(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 -125; 6000 N 01Ohn !\n PARAMETER BMAGN(BCC_4SL,AL:AL:AL:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun !\n \n PARAMETER G(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 +GB2ALFE#; 6000 N 08Sun !\n PARAMETER TC(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 -250; 6000 N 01Ohn !\n PARAMETER BMAGN(BCC_4SL,AL:AL:FE:FE:VA;0) 298.15 2*BMALFE; 6000 N 08Sun !\n \n PARAMETER G(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 +GB32ALFE#; 6000 N 08Sun !\n PARAMETER TC(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 -125; 6000 N 01Ohn !\n PARAMETER BMAGN(BCC_4SL,AL:FE:AL:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun !\n \n PARAMETER G(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 +GD03FEAL#; 6000 N 08Sun !\n PARAMETER TC(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 -125; 6000 N 01Ohn !\n PARAMETER BMAGN(BCC_4SL,AL:FE:FE:FE:VA;0) 298.15 BMALFE; 6000 N 08Sun !\n \n PARAMETER G(BCC_4SL,AL,FE:*:*:*:VA;1) 298.15 -634+0.68*T; 6000 N 08Sun !\n PARAMETER G(BCC_4SL,AL,FE:*:*:*:VA;2) 298.15 -190; 6000 N 08Sun !\n PARAMETER TC(BCC_4SL,AL,FE:*:*:*:VA;0) 298.15 +125; 6000 N 01Ohn !\n PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;0) 298.15 BLALFE0; 6000 N 08Sun !\n PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;1) 298.15 BLALFE1; 6000 N 08Sun !\n PARAMETER BMAGN(BCC_4SL,AL,FE:*:*:*:VA;2) 298.15 BLALFE2; 6000 N 08Sun !\n\n\n\n$ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A1_FCC \n PHASE FCC_4SL:F %FY 5 .25 .25 .25 .25 1 !\n CONSTITUENT FCC_4SL:F :AL,FE : AL,FE : AL,FE : AL,FE : VA : !\n\n PARAMETER G(FCC_4SL,AL:AL:AL:AL:VA;0) 298.15 +ZERO#; 6000 N 08Con !\n PARAMETER G(FCC_4SL,FE:AL:AL:AL:VA;0) 298.15 +GAL3FE#; 6000 N 08Con !\n PARAMETER G(FCC_4SL,FE:FE:AL:AL:VA;0) 298.15 +GAL2FE2#; 6000 N 08Con !\n PARAMETER G(FCC_4SL,FE:FE:FE:AL:VA;0) 298.15 +GALFE3#; 6000 N 08Con !\n PARAMETER G(FCC_4SL,FE:FE:FE:FE:VA;0) 298.15 +ZERO#; 6000 N 08Con !\n PARAMETER G(FCC_4SL,AL,FE:AL,FE:*:*:VA;0) 298.15 +SFALFE#; 6000 N 08Con !\n\n\nASSESSED_SYSTEM AL-FE(TDB -A2_B2 -A2_VA -BCC_VA -B2_BCC \n ;G5 C_S:BCC_4/AL:AL:FE:FE:VA: C_S:BCC_4/AL:FE:FE:FE:VA:\n ;P3 TMM:300/3000 STP:0.99/1400/-1 STP:0.77/600/1 STP:0.45/500/1 )\n!\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n 91Din 'A T Dinsdale, Calphad 1991'\n 93Sei 'M Seiersten, unpublished 1993'\n 01Ohn 'I Ohnuma, unpublished 2001'\n 08Con 'D Connetable et al, Calphad 2008; AL-C-Fe'\n 08Sun 'B Sundman, to be published'\n 08Dup 'N Dupin, vacancies in bcc'\n ! \n \n" }, { "path": "examples/macros/BEF.TDB", "content": "\n$\n$ Mo-Ni-Re ND 2017 June 1st - to be used with OC\n$\n$ Mo-Re Mathieu 2013, sigma slightly modified\n$ Mo-Ni Frisk 1994\n$ Ni-Re Yakoob 2012\n$\n$ CHI and SIGMA\n$ with disordered contribution\n$ DIS_CHI and DIS_SIGMA\n$ H:DFT S: assessed\n$ CHI\n$ all compounds from DFT\n$ SIGMA\n$ BEF\n$\n\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01!\n \n FUNCTION GHSERMO 298.15\n -7746.302+131.9197*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3\n +65812*T**(-1)-1.30927E-10*T**4;\n 2896 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N !\n\n FUNCTION GFCCMO 298.15\n +7453.698+132.5497*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3\n +65812*T**(-1)-1.30927E-10*T**4;\n 2896 Y\n -15356.41+284.189746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N REF1 !\n \n FUNCTION GHCPMO 298.15\n +3803.698+131.9197*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3\n +65812*T**(-1)-1.30927E-10*T**4;\n 2896 Y\n -19006.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);,, N REF1 !\n \n FUNCTION GLIQMO 298.15\n +34085.045+117.224788*T-23.56414*T*LN(T)-.003443396*T**2+5.66283E-07*T**3\n +65812*T**(-1)-1.30927E-10*T**4+4.24519E-22*T**7;\n 2896 Y\n +3538.963+271.6697*T-42.63829*T*LN(T);,, N REF1 !\n \n FUNCTION GHSERNI 298.15\n -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2;\n 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9);,, N !\n \n FUNCTION GBCCNI 298.15\n +3535.925+114.298*T-22.096*T*LN(T)-4.8407E-3*T**2;\n 1728.00 Y\n -19125.571+275.579*T-43.1*T*LN(T)+1127.54E28*T**(-9);,, N !\n \n FUNCTION GHCPNI 298.15\n -4133.159+119.109*T-22.096*T*LN(T)-.0048407*T**2;\n 1.72800E+03 Y\n -26794.655+280.39*T-43.1*T*LN(T)+1.12754E+31*T**(-9);,, N !\n \n FUNCTION GLIQNI 298.15\n +11235.527+108.457*T-22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7;\n 1.72800E+03 Y\n -9549.775+268.598*T-43.1*T*LN(T);,, N REF1 !\n\n FUNCTION GHSERRE 298.15\n -7695.279+128.421589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3\n +32915*T**(-1);\n 1200 Y\n -15775.998+194.667426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1);\n 2400 Y\n -70882.739+462.110749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3\n +18075200*T**(-1);\n 3458 Y\n +346325.888-1211.37186*T+140.831655*T*LN(T)-.033764567*T**2\n +1.053726E-06*T**3-1.34548866E+08*T**(-1);\n 5000 Y\n -78564.296+346.997842*T-49.519*T*LN(T);,, N !\n \n FUNCTION GFCCRE 298.15\n +3304.721+126.921589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3\n +32915*T**(-1);\n 1200 Y\n -4775.998+193.167426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1);\n 2400 Y\n -59882.739+460.610749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3\n +18075200*T**(-1);\n 3458 Y\n +357325.888-1212.87186*T+140.831655*T*LN(T)-.033764567*T**2\n +1.053726E-06*T**3-1.34548866E+08*T**(-1);\n 5000 Y\n -67564.296+345.497842*T-49.519*T*LN(T);,, N REF1 !\n \n FUNCTION GBCCRE 298.15\n +9304.721+124.721589*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3\n +32915*T**(-1);\n 1200 Y\n +1224.002+190.967426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1);\n 2400 Y\n -53882.739+458.410749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3\n +18075200*T**(-1);\n 3458 Y\n +363325.888-1215.07186*T+140.831655*T*LN(T)-.033764567*T**2\n +1.053726E-06*T**3-1.34548866E+08*T**(-1);\n 5000 Y\n -61564.296+343.297842*T-49.519*T*LN(T);,, N REF1 !\n \n FUNCTION GLIQRE 298.15\n +16125.604+122.076209*T-24.348*T*LN(T)-.00253505*T**2+1.92818E-07*T**3\n +32915*T**(-1);\n 1200 Y\n +8044.885+188.322047*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1);\n 2000 Y\n +568842.665-2527.83846*T+314.178898*T*LN(T)-.08939817*T**2\n +3.92854E-06*T**3-1.63100987E+08*T**(-1);\n 3458 Y\n -39044.888+335.723691*T-49.519*T*LN(T);,, N REF1 !\n\n FUN M1R2 298.15 +680;,, N !\n FUN M1R3 298.15 +16094;,, N !\n FUN M2R3 298.15 -14434;,, N !\n FUN M1R4 298.15 +0;,, N !\n FUN M2R4 298.15 -81839;,, N !\n FUN M3R4 298.15 -86837;,, N !\n FUN M1R5 298.15 +4361;,, N !\n FUN M2R5 298.15 -28743;,, N !\n FUN M3R5 298.15 -73358;,, N !\n FUN M4R5 298.15 +21024;,, N !\n FUN R1M2 298.15 -22076;,, N !\n FUN R1M3 298.15 -19297;,, N !\n FUN R1M4 298.15 +5847;,, N !\n FUN R1M5 298.15 -30827;,, N !\n FUN R2M3 298.15 +6571;,, N !\n FUN R2M4 298.15 +42569;,, N !\n FUN R2M5 298.15 -25482;,, N !\n FUN R3M4 298.15 -1467;,, N !\n FUN R3M5 298.15 -62108;,, N !\n FUN R4M5 298.15 -119768;,, N !\n \n FUN M1N2 298.15 -112309;,, N !\n FUN M1N3 298.15 +29525;,, N !\n FUN M2N3 298.15 -109029;,, N !\n FUN M1N4 298.15 -965;,, N !\n FUN M2N4 298.15 -134018;,, N !\n FUN M3N4 298.15 -167595;,, N !\n FUN M1N5 298.15 -40910;,, N !\n FUN M2N5 298.15 -2219;,, N !\n FUN M3N5 298.15 +66189;,, N !\n FUN M4N5 298.15 -16596;,, N !\n FUN N1M2 298.15 -73811;,, N !\n FUN N1M3 298.15 -7043;,, N !\n FUN N1M4 298.15 -41875;,, N !\n FUN N1M5 298.15 +17271;,, N !\n FUN N2M3 298.15 +82688;,, N !\n FUN N2M4 298.15 +63970;,, N !\n FUN N2M5 298.15 +97740;,, N !\n FUN N3M4 298.15 +19008;,, N !\n FUN N3M5 298.15 +55865;,, N !\n FUN N4M5 298.15 -114625;,, N !\n\n FUN R1N2 298.15 -2123;,, N !\n FUN R1N3 298.15 -19973;,, N !\n FUN R2N3 298.15 +5210;,, N !\n FUN R1N4 298.15 -1351;,, N !\n FUN R2N4 298.15 -89153;,, N !\n FUN R3N4 298.15 -89828;,, N !\n FUN R1N5 298.15 -61558;,, N !\n FUN R2N5 298.15 -2026;,, N !\n FUN R3N5 298.15 +75934;,, N !\n FUN R4N5 298.15 -24700;,, N !\n FUN N1R2 298.15 -103625;,, N !\n FUN N1R3 298.15 +20648;,, N !\n FUN N1R4 298.15 -88284;,, N !\n FUN N1R5 298.15 +32709;,, N !\n FUN N2R3 298.15 -46120;,, N !\n FUN N2R4 298.15 +91951;,, N !\n FUN N2R5 298.15 +36182;,, N !\n FUN N3R4 298.15 +70531;,, N !\n FUN N3R5 298.15 +136624;,, N !\n FUN N4R5 298.15 -77381;,, N !\n\n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n PHASE LIQUID % 1 1.0 !\n CONST LIQUID :MO,RE,NI : !\n \n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONST FCC_A1 :MO,RE,NI : VA : !\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :MO,RE,NI : VA : !\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONST HCP_A3 :MO,RE,NI : VA : !\n\n PHASE MONI_DELTA % 3 24 20 12 !\n CONST MONI_DELTA :NI : MO,NI : MO : !\n\n TYPE_DEFINITION + GES AMEND_PHASE_DESCRIPTION CHI NEVER DIS_CHI,,,!\n PHASE DIS_CHI % 1 1.0 !\n CONSTITUENT DIS_CHI :MO,RE,NI : !\n PHASE CHI %+ 4 2 8 24 24 !\n CONST CHI :MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : !\n\n TYPE_DEFINITION * GES AMEND_PHASE_DESCRIPTION SIGMA NEVER DIS_SIG,,,!\n PHASE DIS_SIG % 1 1.0 !\n CONST DIS_SIG :MO,RE,NI : !\n PHASE SIGMA %* 5 2 4 8 8 8 !\n CONST SIGMA :MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : MO,RE,NI : !\n\n$=========================================================================\n$ Unary parameters\n$=========================================================================\n\n$-------------------------------------------------------------------- SGTE \n\n PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO;,, N REF1 !\n PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GBCCNI;,, N REF1 !\n PARAMETER TC(BCC_A2,NI:VA;0) 2.98150E+02 575;,, N REF1 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 2.98150E+02 .85;,, N REF1 !\n PARAMETER G(BCC_A2,RE:VA;0) 298.15 +GBCCRE;,, N REF1 !\n\n PARAMETER G(FCC_A1,MO:VA;0) 298.15 +GFCCMO;,, N REF1 !\n PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI;,, N REF1 !\n PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633;,, N REF1 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52;,, N REF1 !\n PARAMETER G(FCC_A1,RE:VA;0) 298.15 GFCCRE;,, N REF1 !\n\n PARAMETER G(HCP_A3,MO:VA;0) 298.15 +GHCPMO;,, N REF1 !\n PARAMETER G(HCP_A3,NI:VA;0) 298.15 +GHCPNI;,, N REF1 !\n PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE;,, N REF1 !\n\n PARAMETER G(LIQUID,MO;0) 298.15 GLIQMO;,, N REF1 !\n PARAMETER G(LIQUID,NI;0) 298.15 GLIQNI;,, N REF1 !\n PARAMETER G(LIQUID,RE;0) 298.15 GLIQRE;,, N REF1 !\n \n$-------------------------------------------------------------------- DFT\n\n$ PARA G(DIS_CHI,MO;0) 298.15 +26126+GHSERMO;,, N DFTCHI !\n$ PARA G(DIS_CHI,NI;0) 298.15 +13550+GHSERNI;,, N DFTCHI !\n$ PARA G(DIS_CHI,RE;0) 298.15 +4903+GHSERRE;,, N DFTCHI !\n\n$ PARA G(DIS_SIG,MO;0) 298.15 +16098+GHSERMO;,, N DFTSIG !\n$ PARA G(DIS_SIG,NI;0) 298.15 +13582+GHSERNI;,, N DFTSIG !\n$ PARA G(DIS_SIG,RE;0) 298.15 +9331+GHSERRE;,, N DFTSIG !\n \n$----------------------------------------------------------------------------\n$ S assessed in Mo-Re\n\n PARA G(DIS_CHI,MO;0) 298.15 +26126+GHSERMO-0.5596*T;,, N REF9 !\n PARA G(DIS_CHI,RE;0) 298.15 +4903+GHSERRE+0.00905*T;,, N REF9 !\n \n PARA G(DIS_SIG,MO;0) 298.15 +16098+GHSERMO+1.251*T;,, N REF9 !\n PARA G(DIS_SIG,RE;0) 298.15 +9331+GHSERRE-1.205*T;,, N REF9 !\n \n$----------------------------------------------------------------------------\n$ Ni sigma and chi - test for S\n\n PARA G(DIS_SIG,NI;0) 298.15 +13582+GHSERNI+3*T;,, N MONIRE !\n PARA G(DIS_CHI,NI;0) 298.15 +13550+GHSERNI+6*T;,, N MONIRE!\n\n$=========================================================================\n$ Binary parameters\n$=========================================================================\n\n$------------------------------------------------------------------- Mo-Ni\n\n PARA L(LIQUID,MO,NI;0) 298.15 -46540+19.53*T;,, N 90Fri4 !\n PARA L(LIQUID,MO,NI;1) 298.15 2915;,, N 90Fri4 !\n \n PARA L(FCC_A1,MO,NI:VA;0) 298.15 +4803.7-5.96*T;,, N 90Fri4 !\n PARA L(FCC_A1,MO,NI:VA;1) 298.15 10880;,, N 90Fri4 !\n\n PARA L(BCC_A2,MO,NI:VA;0) 298.15 46422;,, N 90Fri4 !\n \n PARA G(MONI_DELTA,NI:MO:MO;0) 298.15\n +24*GHSERNI+32*GHSERMO-212100+1089*T-142*T*LN(T);,, N 90Fri4 !\n PARA G(MONI_DELTA,NI:NI:MO;0) 298.15\n +24*GHSERNI+20*GBCCNI+12*GHSERMO-1030-93.5*T+13.5*T*LN(T);,, N 90Fri4 !\n\n$ ID to FCC\n PARA L(HCP_A3,MO,NI:VA;0) 298.15 +4803.7-5.96*T;,, N MONIRE !\n PARA L(HCP_A3,MO,NI:VA;1) 298.15 +10880;,, N MONIRE !\n\n PARA G(CHI,NI:MO:MO:MO;0) 298.15 +219710;,, N DFTCHI !\n PARA G(CHI,MO:NI:MO:MO;0) 298.15 +814131;,, N DFTCHI !\n PARA G(CHI,NI:NI:MO:MO;0) 298.15 +965490;,, N DFTCHI !\n PARA G(CHI,MO:MO:NI:MO;0) 298.15 -172228;,, N DFTCHI !\n PARA G(CHI,MO:MO:MO:NI;0) 298.15 -481244;,, N DFTCHI !\n PARA G(CHI,NI:MO:NI:MO;0) 298.15 -43099;,, N DFTCHI !\n PARA G(CHI,NI:MO:MO:NI;0) 298.15 -352925;,, N DFTCHI !\n PARA G(CHI,MO:NI:NI:MO;0) 298.15 -163370;,, N DFTCHI !\n PARA G(CHI,MO:NI:MO:NI;0) 298.15 -532188;,, N DFTCHI !\n PARA G(CHI,NI:NI:NI:MO;0) 298.15 +14892;,, N DFTCHI !\n PARA G(CHI,NI:NI:MO:NI;0) 298.15 -271198;,, N DFTCHI !\n PARA G(CHI,MO:MO:NI:NI;0) 298.15 -877718;,, N DFTCHI !\n PARA G(CHI,NI:MO:NI:NI;0) 298.15 -849987;,, N DFTCHI !\n PARA G(CHI,MO:NI:NI:NI;0) 298.15 -221731;,, N DFTCHI !\n\n PARA G(SIGMA,MO:NI:*:*:*;0) 298.15 -112309;,, N ND !\n PARA G(SIGMA,MO:*:NI:*:*;0) 298.15 +29525;,, N ND !\n PARA G(SIGMA,MO:*:*:NI:*;0) 298.15 -965;,, N ND !\n PARA G(SIGMA,MO:*:*:*:NI;0) 298.15 -40910;,, N ND !\n PARA G(SIGMA,*:MO:NI:*:*;0) 298.15 -109029;,, N ND !\n PARA G(SIGMA,*:MO:*:NI:*;0) 298.15 -134018;,, N ND !\n PARA G(SIGMA,*:MO:*:*:NI;0) 298.15 -2219;,, N ND !\n PARA G(SIGMA,*:*:MO:NI:*;0) 298.15 -167595;,, N ND !\n PARA G(SIGMA,*:*:MO:*:NI;0) 298.15 +66189;,, N ND !\n PARA G(SIGMA,*:*:*:MO:NI;0) 298.15 -16596;,, N ND !\n PARA G(SIGMA,NI:MO:*:*:*;0) 298.15 -73811;,, N ND !\n PARA G(SIGMA,NI:*:MO:*:*;0) 298.15 -7043;,, N ND !\n PARA G(SIGMA,NI:*:*:MO:*;0) 298.15 -41875;,, N ND !\n PARA G(SIGMA,NI:*:*:*:MO;0) 298.15 +17271;,, N ND !\n PARA G(SIGMA,*:NI:MO:*:*;0) 298.15 +82688;,, N ND !\n PARA G(SIGMA,*:NI:*:MO:*;0) 298.15 +63970;,, N ND !\n PARA G(SIGMA,*:NI:*:*:MO;0) 298.15 +97740;,, N ND !\n PARA G(SIGMA,*:*:NI:MO:*;0) 298.15 +19008;,, N ND !\n PARA G(SIGMA,*:*:NI:*:MO;0) 298.15 +55865;,, N ND !\n PARA G(SIGMA,*:*:*:NI:MO;0) 298.15 -114625;,, N ND !\n\n$------------------------------------------------------------------- Mo-Re\n\n PARAMETER L(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T;,, N REF9 !\n PARAMETER L(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T;,, N REF9 !\n\n PARAMETER L(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.951*T;,, N REF9 !\n\n PARAMETER L(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610;,, N REF9 !\n PARAMETER L(LIQUID,MO,RE;1) 298.15 +8.07*T-7790;,, N REF9 !\n\n$ ID to HCP\n PARA L(FCC_A1,MO,RE:VA;0) 298.15 +12740+1.951*T;,, N MONIRE !\n\n PARA G(CHI,RE:MO:MO:MO;0) 298.15 +72898;,, N DFTCHI !\n PARA G(CHI,MO:RE:MO:MO;0) 298.15 +238327;,, N DFTCHI !\n PARA G(CHI,RE:RE:MO:MO;0) 298.15 +327082;,, N DFTCHI !\n PARA G(CHI,MO:MO:RE:MO;0) 298.15 -194830;,, N DFTCHI !\n PARA G(CHI,MO:MO:MO:RE;0) 298.15 -681482;,, N DFTCHI !\n PARA G(CHI,RE:MO:RE:MO;0) 298.15 -127372;,, N DFTCHI !\n PARA G(CHI,RE:MO:MO:RE;0) 298.15 -583384;,, N DFTCHI !\n PARA G(CHI,MO:RE:RE:MO;0) 298.15 +141480;,, N DFTCHI !\n PARA G(CHI,MO:RE:MO:RE;0) 298.15 -300477;,, N DFTCHI !\n PARA G(CHI,RE:RE:RE:MO;0) 298.15 +239483;,, N DFTCHI !\n PARA G(CHI,RE:RE:MO:RE;0) 298.15 -165184;,, N DFTCHI !\n PARA G(CHI,MO:MO:RE:RE;0) 298.15 -569681;,, N DFTCHI !\n PARA G(CHI,RE:MO:RE:RE;0) 298.15 -468084;,, N DFTCHI !\n PARA G(CHI,MO:RE:RE:RE;0) 298.15 -125904;,, N DFTCHI !\n\n PARA G(SIGMA,MO:RE:*:*:*;0) 298.15 +680;,, N ND !\n PARA G(SIGMA,MO:*:RE:*:*;0) 298.15 +16094;,, N ND !\n PARA G(SIGMA,MO:*:*:RE:*;0) 298.15 +0;,, N ND !\n PARA G(SIGMA,MO:*:*:*:RE;0) 298.15 +4361;,, N ND !\n PARA G(SIGMA,*:MO:RE:*:*;0) 298.15 -14434;,, N ND !\n PARA G(SIGMA,*:MO:*:RE:*;0) 298.15 -81839;,, N ND !\n PARA G(SIGMA,*:MO:*:*:RE;0) 298.15 -28743;,, N ND !\n PARA G(SIGMA,*:*:MO:RE:*;0) 298.15 -86837;,, N ND !\n PARA G(SIGMA,*:*:MO:*:RE;0) 298.15 -73358;,, N ND !\n PARA G(SIGMA,*:*:*:MO:RE;0) 298.15 +21024;,, N ND !\n PARA G(SIGMA,RE:MO:*:*:*;0) 298.15 -22076;,, N ND !\n PARA G(SIGMA,RE:*:MO:*:*;0) 298.15 -19297;,, N ND !\n PARA G(SIGMA,RE:*:*:MO:*;0) 298.15 +5847;,, N ND !\n PARA G(SIGMA,RE:*:*:*:MO;0) 298.15 -30827;,, N ND !\n PARA G(SIGMA,*:RE:MO:*:*;0) 298.15 +6571;,, N ND !\n PARA G(SIGMA,*:RE:*:MO:*;0) 298.15 +42569;,, N ND !\n PARA G(SIGMA,*:RE:*:*:MO;0) 298.15 -25482;,, N ND !\n PARA G(SIGMA,*:*:RE:MO:*;0) 298.15 -1467;,, N ND !\n PARA G(SIGMA,*:*:RE:*:MO;0) 298.15 -62108;,, N ND !\n PARA G(SIGMA,*:*:*:RE:MO;0) 298.15 -119768;,, N ND !\n\n$------------------------------------------------------------------- Ni-Re\n\n PARA L(LIQUID,NI,RE;0) 298.15 21480.3504;,, N NIRE !\n\n PARA L(FCC_A1,NI,RE:VA;0) 298.15 5054.48711+8.28748232*T;,, N NIRE !\n\n PARA L(HCP_A3,NI,RE:VA;0) 298.15 9968.56426+7.59954301*T;,, N NIRE !\n\n$ ID to LIQ\n PARA L(BCC_A2,NI,RE:VA;0) 298.15 +21480.3504;,, N MONIRE !\n\n PARA G(CHI,RE:NI:NI:NI;0) 298.15 -89694;,, N DFTCHI !\n PARA G(CHI,NI:RE:NI:NI;0) 298.15 -393802;,, N DFTCHI !\n PARA G(CHI,RE:RE:NI:NI;0) 298.15 -511876;,, N DFTCHI !\n PARA G(CHI,NI:NI:RE:NI;0) 298.15 +232248;,, N DFTCHI !\n PARA G(CHI,NI:NI:NI:RE;0) 298.15 +59918;,, N DFTCHI !\n PARA G(CHI,RE:NI:RE:NI;0) 298.15 +163650;,, N DFTCHI !\n PARA G(CHI,RE:NI:NI:RE;0) 298.15 -40656;,, N DFTCHI !\n PARA G(CHI,NI:RE:RE:NI;0) 298.15 -135674;,, N DFTCHI !\n PARA G(CHI,NI:RE:NI:RE;0) 298.15 +217732;,, N DFTCHI !\n PARA G(CHI,RE:RE:RE:NI;0) 298.15 -276649;,, N DFTCHI !\n PARA G(CHI,RE:RE:NI:RE;0) 298.15 +262496;,, N DFTCHI !\n PARA G(CHI,NI:NI:RE:RE;0) 298.15 -36360;,, N DFTCHI !\n PARA G(CHI,RE:NI:RE:RE;0) 298.15 -99055;,, N DFTCHI !\n PARA G(CHI,NI:RE:RE:RE;0) 298.15 +78569;,, N DFTCHI !\n\n PARA G(SIGMA,NI:RE:*:*:*;0) 298.15 -103625;,, N ND !\n PARA G(SIGMA,NI:*:RE:*:*;0) 298.15 +20648;,, N ND !\n PARA G(SIGMA,NI:*:*:RE:*;0) 298.15 -88284;,, N ND !\n PARA G(SIGMA,NI:*:*:*:RE;0) 298.15 +32709;,, N ND !\n PARA G(SIGMA,*:NI:RE:*:*;0) 298.15 -46120;,, N ND !\n PARA G(SIGMA,*:NI:*:RE:*;0) 298.15 +91951;,, N ND !\n PARA G(SIGMA,*:NI:*:*:RE;0) 298.15 +36182;,, N ND !\n PARA G(SIGMA,*:*:NI:RE:*;0) 298.15 +70531;,, N ND !\n PARA G(SIGMA,*:*:NI:*:RE;0) 298.15 +136624;,, N ND !\n PARA G(SIGMA,*:*:*:NI:RE;0) 298.15 -77381;,, N ND !\n PARA G(SIGMA,RE:NI:*:*:*;0) 298.15 -2123;,, N ND !\n PARA G(SIGMA,RE:*:NI:*:*;0) 298.15 -19973;,, N ND !\n PARA G(SIGMA,RE:*:*:NI:*;0) 298.15 -1351;,, N ND !\n PARA G(SIGMA,RE:*:*:*:NI;0) 298.15 -61558;,, N ND !\n PARA G(SIGMA,*:RE:NI:*:*;0) 298.15 +5210;,, N ND !\n PARA G(SIGMA,*:RE:*:NI:*;0) 298.15 -89153;,, N ND !\n PARA G(SIGMA,*:RE:*:*:NI;0) 298.15 -2026;,, N ND !\n PARA G(SIGMA,*:*:RE:NI:*;0) 298.15 -89828;,, N ND !\n PARA G(SIGMA,*:*:RE:*:NI;0) 298.15 +75934;,, N ND !\n PARA G(SIGMA,*:*:*:RE:NI;0) 298.15 -24700;,, N ND !\n\n$=========================================================================\n$ Ternary parameters\n$=========================================================================\n\n PARA G(CHI,NI:MO:MO:RE;0) 298.15 -519693;,, N DFTCHI !\n PARA G(CHI,NI:RE:MO:RE;0) 298.15 -106844;,, N DFTCHI !\n PARA G(CHI,NI:MO:RE:MO;0) 298.15 +35426;,, N DFTCHI !\n PARA G(CHI,NI:RE:MO:MO;0) 298.15 +496740;,, N DFTCHI !\n PARA G(CHI,NI:MO:RE:RE;0) 298.15 -409153;,, N DFTCHI !\n PARA G(CHI,NI:RE:RE:MO;0) 298.15 +366739;,, N DFTCHI !\n PARA G(CHI,RE:NI:MO:RE;0) 298.15 +16373;,, N DFTCHI !\n PARA G(CHI,MO:NI:RE:MO;0) 298.15 +533241;,, N DFTCHI !\n PARA G(CHI,MO:NI:RE:RE;0) 298.15 -211610;,, N DFTCHI !\n PARA G(CHI,RE:NI:RE:MO;0) 298.15 +600355;,, N DFTCHI !\n PARA G(CHI,RE:NI:MO:MO;0) 298.15 +913000;,, N DFTCHI !\n PARA G(CHI,MO:NI:MO:RE;0) 298.15 -113332;,, N DFTCHI !\n PARA G(CHI,NI:NI:RE:MO;0) 298.15 +632479;,, N DFTCHI !\n PARA G(CHI,NI:NI:MO:RE;0) 298.15 +16967;,, N DFTCHI !\n PARA G(CHI,RE:MO:NI:RE;0) 298.15 -31431;,, N DFTCHI !\n PARA G(CHI,MO:RE:NI:RE;0) 298.15 +124857;,, N DFTCHI !\n PARA G(CHI,RE:RE:NI:MO;0) 298.15 +85119;,, N DFTCHI !\n PARA G(CHI,RE:MO:NI:MO;0) 298.15 -105163;,, N DFTCHI !\n PARA G(CHI,MO:RE:NI:MO;0) 298.15 -19854;,, N DFTCHI !\n PARA G(CHI,MO:MO:NI:RE;0) 298.15 -145816;,, N DFTCHI !\n PARA G(CHI,RE:MO:RE:NI;0) 298.15 -458236;,, N DFTCHI !\n PARA G(CHI,MO:MO:RE:NI;0) 298.15 -524528;,, N DFTCHI !\n PARA G(CHI,MO:RE:RE:NI;0) 298.15 -344447;,, N DFTCHI !\n PARA G(CHI,RE:MO:MO:NI;0) 298.15 -425639;,, N DFTCHI !\n PARA G(CHI,MO:RE:MO:NI;0) 298.15 -447354;,, N DFTCHI !\n PARA G(CHI,RE:RE:MO:NI;0) 298.15 -400043;,, N DFTCHI !\n PARA G(CHI,NI:RE:NI:MO;0) 298.15 +144227;,, N DFTCHI !\n PARA G(CHI,NI:MO:NI:RE;0) 298.15 -89466;,, N DFTCHI !\n PARA G(CHI,NI:RE:MO:NI;0) 298.15 -234016;,, N DFTCHI !\n PARA G(CHI,NI:MO:RE:NI;0) 298.15 -393733;,, N DFTCHI !\n PARA G(CHI,RE:NI:NI:MO;0) 298.15 -122124;,, N DFTCHI !\n PARA G(CHI,MO:NI:NI:RE;0) 298.15 -194827;,, N DFTCHI !\n PARA G(CHI,RE:NI:MO:NI;0) 298.15 -389947;,, N DFTCHI !\n PARA G(CHI,MO:NI:RE:NI;0) 298.15 +3924;,, N DFTCHI !\n PARA G(CHI,RE:MO:NI:NI;0) 298.15 -862872;,, N DFTCHI !\n PARA G(CHI,MO:RE:NI:NI;0) 298.15 -559164;,, N DFTCHI !\n \n$============================================================================\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), \n developed by SGTE (Scientific Group Thermodata Europe), 1991-2008,\n and provided by TCSAB (Jan. 2008). '\n REF5 'JC Crivello 2012 march, Armide project v1.13 chi phase'\n REF9 'R. Mathieu et al., Armide project Calphad, 43 (2013) 18-31' \n DFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase' \n DFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase' \n 90Fri4 'K Frisk, Calphad 14(1990)3 p 311-320; Mo-Ni'\n NIRE 'K. Yaqoob and JM Joubert'\n MONIRE 'ND Mo-Ni-Re tests'\n ND 'N. Dupin , BEF testing'\n !\n\n" }, { "path": "examples/macros/CHO-gas.TDB", "content": "\n$ Database file written 2015- 8-29\n$ From database: SSUB3 \n DATABASE_INFO about the CHO-gas database\n It is an extract for the elements C, H and O from the SGTE substance database\n the year 2001. It contains a large number of gas species and a few\n condenced phases.!\n$\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01!\n ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02!\n \n SPECIES C1H1 C1H1!\n SPECIES C1H1O1 C1H1O1!\n SPECIES C1H1O2 C1H1O2!\n SPECIES C1H2 C1H2!\n SPECIES C1H2O1 C1H2O1!\n SPECIES C1H2O2 C1H2O2!\n SPECIES C1H2O2_CIS C1H2O2!\n SPECIES C1H2O2_DIOXIRANE C1H2O2!\n SPECIES C1H2O2_TRANS C1H2O2!\n SPECIES C1H3 C1H3!\n SPECIES C1H3O1_CH2OH C1H3O1!\n SPECIES C1H3O1_CH3O C1H3O1!\n SPECIES C1H4 C1H4!\n SPECIES C1H4O1 C1H4O1!\n SPECIES C1O1 C1O1!\n SPECIES C1O2 C1O2!\n SPECIES C2 C2!\n SPECIES C2H1 C2H1!\n SPECIES C2H2 C2H2!\n SPECIES C2H2O1 C2H2O1!\n SPECIES C2H3 C2H3!\n SPECIES C2H4 C2H4!\n SPECIES C2H4O1_ACETALDEHYDE C2H4O1!\n SPECIES C2H4O1_OXIRANE C2H4O1!\n SPECIES C2H4O2 C2H4O2!\n SPECIES C2H4O2_ACETICACID C2H4O2!\n SPECIES C2H4O2_DIOXETANE C2H4O2!\n SPECIES C2H4O3_123TRIOXOLANE C2H4O3!\n SPECIES C2H4O3_124TRIOXOLANE C2H4O3!\n SPECIES C2H5 C2H5!\n SPECIES C2H6 C2H6!\n SPECIES C2H6O1 C2H6O1!\n SPECIES C2H6O2 C2H6O2!\n SPECIES C2O1 C2O1!\n SPECIES C3 C3!\n SPECIES C3H1 C3H1!\n SPECIES C3H4_1 C3H4!\n SPECIES C3H4_2 C3H4!\n SPECIES C3H6 C3H6!\n SPECIES C3H6O1 C3H6O1!\n SPECIES C3H6_2 C3H6!\n SPECIES C3H8 C3H8!\n SPECIES C3O2 C3O2!\n SPECIES C4 C4!\n SPECIES C4H1 C4H1!\n SPECIES C4H10_1 C4H10!\n SPECIES C4H10_2 C4H10!\n SPECIES C4H2 C4H2!\n SPECIES C4H4 C4H4!\n SPECIES C4H4_1_3 C4H4!\n SPECIES C4H6_1 C4H6!\n SPECIES C4H6_2 C4H6!\n SPECIES C4H6_3 C4H6!\n SPECIES C4H6_4 C4H6!\n SPECIES C4H6_5 C4H6!\n SPECIES C4H8 C4H8!\n SPECIES C4H8_1 C4H8!\n SPECIES C4H8_2 C4H8!\n SPECIES C4H8_3 C4H8!\n SPECIES C4H8_4 C4H8!\n SPECIES C4H8_5 C4H8!\n SPECIES C5 C5!\n SPECIES C60 C60!\n SPECIES C6H6 C6H6!\n SPECIES C6H6O1 C6H6O1!\n SPECIES H1O1 H1O1!\n SPECIES H1O2 H1O2!\n SPECIES H2 H2!\n SPECIES H2O1 H2O1!\n SPECIES H2O2 H2O2!\n SPECIES O2 O2!\n SPECIES O3 O3!\n \n FUNCTION F3895T 2.98150E+02 +710430.933-17.7062919*T-20.97529*T*LN(T)\n +1.998237E-04*T**2-3.34617167E-08*T**3+1680.6515*T**(-1); 3.40000E+03 \n Y\n +698015.711+2.57175186*T-23.05071*T*LN(T)-6.04604E-05*T**2\n +6.74291667E-10*T**3+8558245*T**(-1); 1.00000E+04 Y\n +736197.571-32.7975309*T-19.44529*T*LN(T)-1.5396035E-04*T**2\n -6.15402167E-11*T**3-56188350*T**(-1); 2.00000E+04 N !\n FUNCTION F4246T 2.98150E+02 +589091.036+6.37586112*T-28.31773*T*LN(T)\n +2.3216165E-04*T**2-7.36439667E-07*T**3-27186.245*T**(-1); 9.00000E+02 \n Y\n +591708.657-35.2925324*T-21.90158*T*LN(T)-.00592793*T**2\n +2.9876E-07*T**3-172733.6*T**(-1); 2.80000E+03 Y\n +579194.621+42.13831*T-32.13932*T*LN(T)-.002507963*T**2\n +9.59279833E-08*T**3+2285342*T**(-1); 6.40000E+03 Y\n +409696.643+452.714152*T-79.92745*T*LN(T)+.003347292*T**2\n -3.63044167E-08*T**3+1.115888E+08*T**(-1); 1.20000E+04 Y\n +800166.03-30.0457765*T-28.18561*T*LN(T)+2.7641345E-04*T**2\n -1.923675E-09*T**3-4.4613505E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F4282T 2.98150E+02 +34663.1187-68.3993353*T-21.87253*T*LN(T)\n -.018848125*T**2+1.978875E-06*T**3-112550.6*T**(-1); 1.10000E+03 Y\n +10875.4517+145.536698*T-52.16378*T*LN(T)-.001376625*T**2\n +4.73872167E-08*T**3+3443852*T**(-1); 3.60000E+03 Y\n +3695.68232+174.659191*T-55.81562*T*LN(T)-5.33191E-04*T**2\n +1.07304333E-08*T**3+6222210*T**(-1); 6.00000E+03 N !\n FUNCTION F4287T 2.98150E+02 -224579.294-49.1626181*T-27.13519*T*LN(T)\n -.03548659*T**2+5.02649167E-06*T**3+89572.2*T**(-1); 7.00000E+02 Y\n -239557.575+145.651699*T-56.49751*T*LN(T)-.00960395*T**2\n +6.83389333E-07*T**3+1534296*T**(-1); 1.90000E+03 Y\n -268690.124+327.648549*T-80.82941*T*LN(T)-3.4153865E-04*T**2\n +9.43135333E-09*T**3+8273490*T**(-1); 6.00000E+03 N !\n FUNCTION F4298T 2.98150E+02 +381898.015-5.8112289*T-27.63198*T*LN(T)\n -.007897355*T**2-3.87669333E-08*T**3-62547*T**(-1); 9.00000E+02 Y\n +378165.881+8.88081456*T-29.13698*T*LN(T)-.00988883*T**2\n +6.15529E-07*T**3+710779*T**(-1); 2.20000E+03 Y\n +340850.246+220.65528*T-57.01662*T*LN(T)-4.862414E-04*T**2\n +1.48344217E-08*T**3+10277000*T**(-1); 6.00000E+03 N !\n FUNCTION F4308T 2.98150E+02 -113219.01-136.968085*T-9.266226*T*LN(T)\n -.039279425*T**2+4.39612833E-06*T**3-223966.05*T**(-1); 9.00000E+02 Y\n -140078.823+144.485426*T-50.12368*T*LN(T)-.01134191*T**2\n +7.60462333E-07*T**3+3113545*T**(-1); 2.00000E+03 Y\n -178622.186+374.929455*T-80.70841*T*LN(T)-3.54568E-04*T**2\n +9.67480833E-09*T**3+12424215*T**(-1); 6.00000E+03 N !\n FUNCTION F4315T 2.98150E+02 -388781.001-103.90421*T-16.81765*T*LN(T)\n -.05671885*T**2+7.970165E-06*T**3+48801.55*T**(-1); 7.00000E+02 Y\n -409999.916+178.628265*T-59.57362*T*LN(T)-.0180534*T**2\n +1.33848133E-06*T**3+2039066.5*T**(-1); 1.70000E+03 Y\n -459640.338+500.116138*T-102.7958*T*LN(T)-8.65375E-04*T**2\n +2.308845E-08*T**3+13013465*T**(-1); 6.00000E+03 N !\n FUNCTION F4320T 2.98150E+02 +27318.4015-158.350101*T-6.392688*T*LN(T)\n -.07291625*T**2+1.17752067E-05*T**3-12222.075*T**(-1); 6.00000E+02 Y\n +5573.92678+166.117642*T-56.49072*T*LN(T)-.021391445*T**2\n +1.77927667E-06*T**3+1762681*T**(-1); 1.60000E+03 Y\n -1463919.16+9430.16255*T-1294.007*T*LN(T)+.4412455*T**2\n -3.07016E-05*T**3+3.279501E+08*T**(-1); 1.80000E+03 Y\n -36820.5158+492.992794*T-101.3071*T*LN(T)-.0012632635*T**2\n +4.60931667E-08*T**3+8156590*T**(-1); 3.80000E+03 N !\n FUNCTION F4326T 2.98150E+02 -372453.966-100.891302*T-17.32496*T*LN(T)\n -.05637795*T**2+7.91681333E-06*T**3+42419.085*T**(-1); 7.00000E+02 Y\n -393558.584+180.039941*T-59.83597*T*LN(T)-.01795244*T**2\n +1.330329E-06*T**3+2022398*T**(-1); 1.70000E+03 Y\n -442917.663+499.668746*T-102.8073*T*LN(T)-8.671225E-04*T**2\n +2.304695E-08*T**3+12935575*T**(-1); 6.00000E+03 N !\n FUNCTION F4331T 2.98150E+02 +137013.412-8.99457393*T-25.84363*T*LN(T)\n -.021245325*T**2+1.58670483E-06*T**3-33266.495*T**(-1); 1.60000E+03 Y\n +84303.6035+343.362209*T-73.42088*T*LN(T)-.0017754415*T**2\n +6.12003E-08*T**3+11112475*T**(-1); 4.40000E+03 Y\n +64161.9832+414.726089*T-82.17617*T*LN(T)-1.024296E-04*T**2\n +2.10901667E-09*T**3+19781775*T**(-1); 6.00000E+03 N !\n FUNCTION F4342T 2.98150E+02 -31298.3817-55.7322048*T-24.61425*T*LN(T)\n -.04353285*T**2+5.34829833E-06*T**3+55658.25*T**(-1); 7.00000E+02 Y\n -43832.867+109.01195*T-49.49554*T*LN(T)-.02127646*T**2\n +1.55219067E-06*T**3+1252337.5*T**(-1); 1.70000E+03 Y\n -103097.337+489.690506*T-100.6003*T*LN(T)-.0011952165*T**2\n +3.56136E-08*T**3+14443730*T**(-1); 5.30000E+03 Y\n -120483.247+545.193751*T-107.3055*T*LN(T)-7.377055E-05*T**2\n +1.335003E-09*T**3+22773150*T**(-1); 6.00000E+03 N !\n FUNCTION F4348T 2.98150E+02 +10647.9115-220.041163*T+2.897875*T*LN(T)\n -.0631791*T**2+7.98735833E-06*T**3-294680.9*T**(-1); 7.00000E+02 Y\n -8352.38175+27.9795444*T-34.49142*T*LN(T)-.03027099*T**2\n +2.51015167E-06*T**3+1523708*T**(-1); 1.40000E+03 Y\n -65111.0776+451.440995*T-92.64558*T*LN(T)-.003388665*T**2\n +1.41701483E-07*T**3+12047630*T**(-1); 3.50000E+03 Y\n -92729.9649+564.732519*T-106.8476*T*LN(T)-1.4186865E-04*T**2\n +3.13837167E-09*T**3+22203380*T**(-1); 6.00000E+03 N !\n FUNCTION F4354T 2.98150E+02 -77295.563-147.095197*T-2.234656*T*LN(T)\n -.048463265*T**2+4.33754333E-06*T**3-305431.45*T**(-1); 1.00000E+03 Y\n -110499.85+168.104152*T-47.22933*T*LN(T)-.021108925*T**2\n +1.1779525E-06*T**3+4316954*T**(-1); 2.00000E+03 Y\n -181918.388+576.950971*T-101.1311*T*LN(T)-.002684469*T**2\n -2.361885E-08*T**3+22404635*T**(-1); 6.00000E+03 N !\n FUNCTION F4361T 2.98150E+02 -205205.838-196.101493*T-1.169187*T*LN(T)\n -.06931275*T**2+8.62977667E-06*T**3-275306.2*T**(-1); 7.00000E+02 Y\n -225205.951+67.2670437*T-40.94166*T*LN(T)-.033860495*T**2\n +2.6413E-06*T**3+1622706*T**(-1); 1.50000E+03 Y\n -296381.314+570.842619*T-109.5301*T*LN(T)-.0039814965*T**2\n +1.5649925E-07*T**3+15683740*T**(-1); 3.70000E+03 Y\n -332630.415+711.963927*T-127.0897*T*LN(T)-1.98456E-04*T**2\n +4.28468667E-09*T**3+29832830*T**(-1); 6.00000E+03 N !\n FUNCTION F4504T 2.98150E+02 -118162.143-23.1824004*T-25.84624*T*LN(T)\n -.003281553*T**2-1.63612533E-07*T**3-55604.1*T**(-1); 8.00000E+02 Y\n -122211.036+7.61017665*T-29.9366*T*LN(T)-.0027053115*T**2\n +1.75559167E-07*T**3+541480.5*T**(-1); 2.20000E+03 Y\n -131274.213+62.1198833*T-37.17593*T*LN(T)-1.020237E-04*T**2\n -6.44914833E-10*T**3+2724014*T**(-1); 6.00000E+03 N !\n FUNCTION F4525T 2.98150E+02 -404733.623-4.69677711*T-29.32959*T*LN(T)\n -.01996358*T**2+2.45837833E-06*T**3+124430.9*T**(-1); 9.00000E+02 Y\n -421187.23+168.064895*T-54.43846*T*LN(T)-.002556694*T**2\n +1.34184133E-07*T**3+2179368*T**(-1); 2.70000E+03 Y\n -462626.164+339.502796*T-76.00339*T*LN(T)+.0026074805*T**2\n -1.06680183E-07*T**3+17540465*T**(-1); 7.60000E+03 Y\n +322101.769-1097.44815*T+85.62125*T*LN(T)-.01226122*T**2\n +1.50875083E-07*T**3-7.00947E+08*T**(-1); 1.00000E+04 N !\n FUNCTION F4656T 2.98150E+02 +803005.137+419.915369*T-97.48141*T*LN(T)\n +.08202995*T**2-1.97357E-05*T**3+690749.5*T**(-1); 5.00000E+02 Y\n +826732.964-2.78397075*T-30.08349*T*LN(T)-.002621389*T**2\n +8.30959667E-08*T**3-868501*T**(-1); 4.30000E+03 Y\n +850321.493-26.7776267*T-27.96957*T*LN(T)-.0019408995*T**2\n +3.222655E-08*T**3-22380050*T**(-1); 1.20000E+04 Y\n +409662.376+520.53814*T-86.66656*T*LN(T)+.0015642485*T**2\n -7.28093667E-09*T**3+6.04612E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F4935T 2.98150E+02 +555907.867+57.0634842*T-39.08261*T*LN(T)\n -.00569665*T**2-4.27085667E-07*T**3+135750.65*T**(-1); 1.00000E+03 Y\n +560368.69-14.5499453*T-28.12154*T*LN(T)-.015627865*T**2\n +1.1143725E-06*T**3-38275.195*T**(-1); 2.10000E+03 Y\n +500130.672+354.303072*T-77.12859*T*LN(T)+.001864081*T**2\n -4.41159667E-08*T**3+13617155*T**(-1); 6.40000E+03 Y\n +548031.854+234.921123*T-63.15948*T*LN(T)+6.031155E-05*T**2\n -8.38662167E-10*T**3-17395655*T**(-1); 1.00000E+04 N !\n FUNCTION F4946T 2.98150E+02 +210657.364+102.660059*T-43.33318*T*LN(T)\n -.015969725*T**2+1.09745783E-06*T**3+366936*T**(-1); 1.70000E+03 Y\n +162805.829+400.859267*T-83.17592*T*LN(T)-8.50672E-04*T**2\n -8.40052167E-09*T**3+11371695*T**(-1); 4.70000E+03 Y\n +284779.332+156.173741*T-55.55581*T*LN(T)-.003209261*T**2\n +1.402618E-08*T**3-81696300*T**(-1); 9.20000E+03 Y\n +643212.249-464.67941*T+13.72962*T*LN(T)-.009112535*T**2\n +1.07541683E-07*T**3-4.2679415E+08*T**(-1); 1.00000E+04 N !\n FUNCTION F4952T 2.98150E+02 +151415.125+72.4381635*T-43.81075*T*LN(T)\n -.03613022*T**2+4.79519333E-06*T**3+382398.4*T**(-1); 7.00000E+02 Y\n +142101.575+203.310692*T-63.80547*T*LN(T)-.01690562*T**2\n +1.30392183E-06*T**3+1202199*T**(-1); 1.60000E+03 Y\n -521002.261+4278.76381*T-605.9819*T*LN(T)+.17949305*T**2\n -1.20661517E-05*T**3+1.523018E+08*T**(-1); 1.90000E+03 Y\n +103618.901+480.915312*T-101.4818*T*LN(T)-.001202355*T**2\n +4.295965E-08*T**3+7646635*T**(-1); 3.80000E+03 N !\n FUNCTION F4958T 2.98150E+02 +253597.563-148.811942*T-7.989506*T*LN(T)\n -.0560301*T**2+7.22032833E-06*T**3-86107.5*T**(-1); 7.00000E+02 Y\n +237578.897+66.4331994*T-40.61565*T*LN(T)-.026213335*T**2\n +2.05575833E-06*T**3+1400582*T**(-1); 1.50000E+03 Y\n +180976.129+465.400317*T-94.92649*T*LN(T)-.0026392345*T**2\n +1.00493533E-07*T**3+12635730*T**(-1); 3.90000E+03 Y\n +155481.051+562.46419*T-106.9625*T*LN(T)-1.2237275E-04*T**2\n +2.58523833E-09*T**3+22815630*T**(-1); 6.00000E+03 N !\n FUNCTION F4964T 2.98150E+02 +47209.5269-186.336653*T+1.510335*T*LN(T)\n -.0796424*T**2+1.11523633E-05*T**3-126378.45*T**(-1); 6.00000E+02 Y\n +30955.0457+58.8547956*T-36.41994*T*LN(T)-.040167385*T**2\n +3.41469333E-06*T**3+1183016*T**(-1); 1.30000E+03 Y\n -31590.202+549.033592*T-104.2592*T*LN(T)-.007018595*T**2\n +3.29534167E-07*T**3+12115675*T**(-1); 3.00000E+03 Y\n -77650.6893+755.842185*T-130.5377*T*LN(T)-3.066123E-04*T**2\n +7.24598833E-09*T**3+27459580*T**(-1); 6.00000E+03 N !\n FUNCTION F4970T 2.98150E+02 -173989.405-156.99242*T-9.305309*T*LN(T)\n -.08173745*T**2+1.02731833E-05*T**3-121696.15*T**(-1); 7.00000E+02 Y\n -197927.136+155.523133*T-56.42274*T*LN(T)-.040210435*T**2\n +3.34282833E-06*T**3+2170644*T**(-1); 1.40000E+03 Y\n -274280.51+724.192005*T-134.4989*T*LN(T)-.004176673*T**2\n +1.71613167E-07*T**3+16359150*T**(-1); 3.60000E+03 Y\n -316924.333+892.309086*T-155.4574*T*LN(T)+4.1221575E-04*T**2\n -1.63666333E-08*T**3+32783160*T**(-1); 4.00000E+03 N !\n FUNCTION F4976T 2.98150E+02 -52606.8578-367.498257*T+29.36196*T*LN(T)\n -.136964*T**2+2.35275833E-05*T**3-323036.9*T**(-1); 5.00000E+02 Y\n -77630.9831+56.9543113*T-37.71421*T*LN(T)-.0571355*T**2\n +5.70833667E-06*T**3+1424051.5*T**(-1); 1.00000E+03 Y\n -108375.735+371.761128*T-83.21364*T*LN(T)-.027068305*T**2\n +1.96504167E-06*T**3+5337015*T**(-1); 1.60000E+03 Y\n -2858294.25+17650.9728*T-2389.988*T*LN(T)+.8305585*T**2\n -5.77916333E-05*T**3+6.17399E+08*T**(-1); 1.80000E+03 Y\n -171464.932+825.2504*T-144.5405*T*LN(T)-.0025049425*T**2\n +9.14716E-08*T**3+15298245*T**(-1); 3.80000E+03 N !\n FUNCTION F4986T 2.98150E+02 -443770.401-168.903162*T-8.022861*T*LN(T)\n -.10740745*T**2+1.413715E-05*T**3+49334.8*T**(-1); 7.00000E+02 Y\n -479189.377+285.05528*T-76.23373*T*LN(T)-.048655465*T**2\n +4.55710833E-06*T**3+3510111*T**(-1); 1.50000E+03 N !\n FUNCTION F4990T 2.98150E+02 +8600.55198-384.321458*T+31.14058*T*LN(T)\n -.16008725*T**2+2.74520167E-05*T**3-311796.05*T**(-1); 5.00000E+02 Y\n -20873.1918+111.496997*T-47.09066*T*LN(T)-.06790435*T**2\n +7.07247833E-06*T**3+1765445*T**(-1); 1.00000E+03 Y\n -61239.1701+527.756432*T-107.3236*T*LN(T)-.027785625*T**2\n +2.04065167E-06*T**3+6859500*T**(-1); 1.60000E+03 Y\n -2974981.48+18839.9139*T-2552.066*T*LN(T)+.8813205*T**2\n -6.13141333E-05*T**3+6.552305E+08*T**(-1); 1.80000E+03 Y\n -124376.871+989.457025*T-169.8804*T*LN(T)-.0024329025*T**2\n +8.888945E-08*T**3+16386475*T**(-1); 3.80000E+03 N !\n FUNCTION F4998T 2.98150E+02 -114416.512-173.280628*T-6.921309*T*LN(T)\n -.14411235*T**2+2.31421167E-05*T**3+114636*T**(-1); 6.00000E+02 Y\n -153978.555+424.109101*T-99.34723*T*LN(T)-.047880135*T**2\n +4.28756333E-06*T**3+3296112*T**(-1); 1.30000E+03 Y\n -196415.878+798.997011*T-152.2039*T*LN(T)-.018563915*T**2\n +1.23563633E-06*T**3+9703745*T**(-1); 1.60000E+03 Y\n -3028548.52+18573.7356*T-2524.618*T*LN(T)+.8618175*T**2\n -5.99569833E-05*T**3+6.40709E+08*T**(-1); 1.80000E+03 Y\n -241127.366+1118.82388*T-195.2168*T*LN(T)-.0023590335*T**2\n +8.61798667E-08*T**3+16030240*T**(-1); 3.80000E+03 N !\n FUNCTION F5006T 2.98150E+02 -213887.084-386.194788*T+29.65119*T*LN(T)\n -.18332665*T**2+3.2053E-05*T**3-278756.65*T**(-1); 5.00000E+02 Y\n -248977.395+204.108404*T-63.48805*T*LN(T)-.07357715*T**2\n +7.78997833E-06*T**3+2194321*T**(-1); 1.00000E+03 Y\n -294026.156+670.832149*T-131.0756*T*LN(T)-.02832299*T**2\n +2.08569167E-06*T**3+7847720*T**(-1); 1.60000E+03 Y\n -3346139.56+19853.1461*T-2691.994*T*LN(T)+.923992*T**2\n -6.42789E-05*T**3+6.86977E+08*T**(-1); 1.80000E+03 Y\n -357660.046+1139.67333*T-194.6438*T*LN(T)-.0024674455*T**2\n +9.01985167E-08*T**3+17218070*T**(-1); 3.80000E+03 N !\n FUNCTION F5014T 2.98150E+02 +103695.78-248.192017*T+6.535456*T*LN(T)\n -.0876786*T**2+1.08003583E-05*T**3-293497.1*T**(-1); 7.00000E+02 Y\n +80275.9858+60.5182301*T-40.0912*T*LN(T)-.046084495*T**2\n +3.772465E-06*T**3+1925892*T**(-1); 1.40000E+03 Y\n -4338.1575+691.320485*T-126.6998*T*LN(T)-.00614309*T**2\n +2.665555E-07*T**3+17610670*T**(-1); 3.30000E+03 Y\n -50997.0146+888.071661*T-151.4679*T*LN(T)-2.7785525E-04*T**2\n +6.34659667E-09*T**3+34266230*T**(-1); 6.00000E+03 N !\n FUNCTION F5026T 2.98150E+02 -90150.09-192.644467*T+2.384174*T*LN(T)\n -.0962022*T**2+1.15030917E-05*T**3-161159.75*T**(-1); 7.00000E+02 Y\n -114140.24+121.641652*T-45.03662*T*LN(T)-.05415545*T**2\n +4.43007333E-06*T**3+2130084*T**(-1); 1.40000E+03 Y\n -212082.164+853.908038*T-145.619*T*LN(T)-.007637925*T**2\n +3.37957333E-07*T**3+20220470*T**(-1); 3.20000E+03 Y\n -268113.331+1093.5554*T-175.8524*T*LN(T)-3.4791075E-04*T**2\n +8.02933833E-09*T**3+39919465*T**(-1); 6.00000E+03 N !\n FUNCTION F5034T 2.98150E+02 -243272.597-221.374773*T+.7796648*T*LN(T)\n -.12058845*T**2+1.72144833E-05*T**3-164276.9*T**(-1); 6.00000E+02 Y\n -269097.38+168.629562*T-59.56378*T*LN(T)-.05772375*T**2\n +4.884735E-06*T**3+1912790*T**(-1); 1.30000E+03 Y\n -358292.955+867.098816*T-156.2194*T*LN(T)-.010522415*T**2\n +4.92514167E-07*T**3+17521960*T**(-1); 3.00000E+03 Y\n -427579.406+1177.35994*T-195.6293*T*LN(T)-4.820784E-04*T**2\n +1.14137917E-08*T**3+40682500*T**(-1); 6.00000E+03 N !\n FUNCTION F5044T 2.98150E+02 -416598.432+134.357846*T-60.84898*T*LN(T)\n -.0824635*T**2+9.70528667E-06*T**3+345719.2*T**(-1); 1.00000E+03 N !\n FUNCTION F5081T 2.98150E+02 +277813.193+28.9798334*T-37.78569*T*LN(T)\n -.01453685*T**2+1.57701533E-06*T**3+112606.3*T**(-1); 1.00000E+03 Y\n +264063.563+160.518573*T-56.6296*T*LN(T)-.0026141425*T**2\n +9.85593667E-08*T**3+2048364*T**(-1); 3.50000E+03 Y\n +234215.001+257.69025*T-68.43674*T*LN(T)-4.895632E-04*T**2\n +2.485785E-08*T**3+16450450*T**(-1); 6.00000E+03 N !\n FUNCTION F5113T 2.98150E+02 +829826.554-14.7696351*T-32.21563*T*LN(T)\n -.014548565*T**2+1.77806833E-06*T**3-100277.6*T**(-1); 1.00000E+03 Y\n +809388.444+179.25291*T-59.93982*T*LN(T)+.0025413955*T**2\n -2.54139667E-07*T**3+2769455*T**(-1); 2.80000E+03 Y\n +959399.017-367.175865*T+7.286391*T*LN(T)-.010483215*T**2\n +2.00694833E-07*T**3-58720050*T**(-1); 5.10000E+03 Y\n +645204.419+237.848566*T-60.73106*T*LN(T)-.0047721765*T**2\n +1.3846755E-07*T**3+1.945987E+08*T**(-1); 8.00000E+03 Y\n -79243.2062+1580.27099*T-211.8741*T*LN(T)+.009202285*T**2\n -1.030498E-07*T**3+8.44019E+08*T**(-1); 1.00000E+04 N !\n FUNCTION F5130T 2.98150E+02 +611989.348+96.3308561*T-48.29552*T*LN(T)\n -.020416105*T**2+2.40121167E-06*T**3+286785.6*T**(-1); 9.00000E+02 Y\n +603734.835+194.753441*T-62.91113*T*LN(T)-.008746555*T**2\n +6.34741E-07*T**3+1176564*T**(-1); 1.60000E+03 Y\n +428832.638+1236.10822*T-200.7133*T*LN(T)+.03914231*T**2\n -2.50175333E-06*T**3+42232610*T**(-1); 2.10000E+03 Y\n +581080.642+349.628056*T-83.7538*T*LN(T)-6.025005E-04*T**2\n +2.010855E-08*T**3+5274980*T**(-1); 4.00000E+03 N !\n FUNCTION F5142T 2.98150E+02 +181410.617-122.851573*T-10.20607*T*LN(T)\n -.09533745*T**2+1.50758583E-05*T**3; 6.00000E+02 Y\n +166868.714+123.51993*T-49.16033*T*LN(T)-.048685235*T**2\n +4.554395E-06*T**3+1025661.5*T**(-1); 1.35000E+03 N !\n FUNCTION F5145T 2.98150E+02 +173490.978-86.0624782*T-17.22925*T*LN(T)\n -.0839689*T**2+1.23994933E-05*T**3; 6.00000E+02 Y\n +164149.935+76.784887*T-43.11068*T*LN(T)-.05198975*T**2\n +4.980055E-06*T**3+635844.5*T**(-1); 1.35000E+03 N !\n FUNCTION F5148T 2.98150E+02 +9960.10176-169.389262*T-5.296785*T*LN(T)\n -.11043535*T**2+1.3915705E-05*T**3-29916.7*T**(-1); 7.00000E+02 Y\n -20079.5568+230.805154*T-65.85768*T*LN(T)-.05571235*T**2\n +4.55149E-06*T**3+2783191*T**(-1); 1.40000E+03 Y\n -123982.893+1002.03018*T-171.6758*T*LN(T)-.00713415*T**2\n +3.037055E-07*T**3+22144770*T**(-1); 3.40000E+03 Y\n -176512.668+1224.25918*T-199.6496*T*LN(T)-5.34708E-04*T**2\n +1.37195383E-08*T**3+40697190*T**(-1); 4.00000E+03 N !\n FUNCTION F5154T 2.98150E+02 -230878.388-155.527401*T-10.67908*T*LN(T)\n -.1200629*T**2+1.5123685E-05*T**3+38056.18*T**(-1); 6.00000E+02 Y\n -239483.66-23.861997*T-31.11135*T*LN(T)-.09829625*T**2\n +1.0728685E-05*T**3+723035.5*T**(-1); 1.00000E+03 N !\n FUNCTION F5157T 2.98150E+02 +14789.4507-271.642378*T+11.34939*T*LN(T)\n -.13386645*T**2+2.00341833E-05*T**3-272154.55*T**(-1); 6.00000E+02 Y\n -5877.08746+63.1182105*T-41.1683*T*LN(T)-.07381185*T**2\n +7.01085E-06*T**3+1272695.5*T**(-1); 1.35000E+03 N !\n FUNCTION F5161T 2.98150E+02 -109364.396-321.907815*T+21.52618*T*LN(T)\n -.1721779*T**2+2.66239E-05*T**3-291993*T**(-1); 6.00000E+02 Y\n -136284.127+126.13378*T-49.09882*T*LN(T)-.08908635*T**2\n +8.15831167E-06*T**3+1652173.5*T**(-1); 1.00000E+03 Y\n -139266.757+270.053278*T-72.22463*T*LN(T)-.0649997*T**2\n +4.53440333E-06*T**3; 1.47310E+03 Y\n +257891.373-1948.43811*T+217.2249*T*LN(T)-.15124325*T**2\n +8.672805E-06*T**3-96828650*T**(-1); 2.20000E+03 Y\n +99792.4667-390.62824*T+2.18137*T*LN(T)-.0596624*T**2\n +2.314065E-06*T**3-1.0470605E+08*T**(-1); 2.80000E+03 Y\n +4552037.53-17003.1518*T+2055.691*T*LN(T)-.47848015*T**2\n +1.82760667E-05*T**3-1.903921E+09*T**(-1); 3.40000E+03 Y\n -224887.496+1106.77062*T-188.6147*T*LN(T)-.01046*T**2; 4.00000E+03 N \n !\n FUNCTION F5180T 2.98150E+02 -118237.391+100.762627*T-53.19108*T*LN(T)\n -.030805495*T**2+3.59023833E-06*T**3+332492.95*T**(-1); 1.00000E+03 Y\n -150856.91+416.603392*T-98.47748*T*LN(T)-.0022049665*T**2\n +1.09623667E-07*T**3+4818702*T**(-1); 3.30000E+03 Y\n -164679.617+482.276431*T-106.8785*T*LN(T)+2.986764E-05*T**2\n +4.29362E-10*T**3+9089650*T**(-1); 6.00000E+03 N !\n FUNCTION F5190T 2.98150E+02 +1015583.43+114.927796*T-53.39543*T*LN(T)\n -.01399763*T**2+8.26027167E-07*T**3+181008.25*T**(-1); 2.50000E+03 Y\n +937071.116+522.054721*T-106.1735*T*LN(T)+.0016641645*T**2\n -4.03015E-08*T**3+21906740*T**(-1); 7.00000E+03 Y\n +974994.003+406.652032*T-92.4518*T*LN(T)-2.6888155E-04*T**2\n +7.07303167E-09*T**3+7587140*T**(-1); 1.00000E+04 N !\n FUNCTION F5205T 2.98150E+02 +751541.722+252.532282*T-73.01*T*LN(T)\n -.0216856*T**2+2.96625833E-06*T**3+733430*T**(-1); 8.00000E+02 Y\n +739011.333+395.36198*T-94.137*T*LN(T)-.00478225*T**2+2.37405E-07*T**3\n +2194465*T**(-1); 3.20000E+03 Y\n +712634.362+524.463672*T-110.728*T*LN(T)-2.049E-04*T**2+5.39E-09*T**3\n +10118465*T**(-1); 4.00000E+03 N !\n FUNCTION F5195T 2.98150E+02 -137766.886-262.245087*T+8.962001*T*LN(T)\n -.1969312*T**2+2.74147E-05*T**3-206440*T**(-1); 6.00000E+02 Y\n -178579.034+346.123228*T-84.951*T*LN(T)-.10048435*T**2\n +8.73554E-06*T**3+3128305*T**(-1); 1.30000E+03 Y\n -258789.548+1055.24805*T-184.924*T*LN(T)-.04513245*T**2\n +2.99413E-06*T**3+15193975*T**(-1); 1.50000E+03 N !\n FUNCTION F5200T 2.98150E+02 -146155.003-277.516061*T+14.289*T*LN(T)\n -.2069239*T**2+2.98628333E-05*T**3-154585*T**(-1); 6.00000E+02 Y\n -195079.37+449.056779*T-97.801*T*LN(T)-.09222675*T**2\n +7.70571667E-06*T**3+3862255*T**(-1); 1.50000E+03 N !\n FUNCTION F5210T 2.98150E+02 +420839.085+277.118737*T-75.491*T*LN(T)\n -.02448245*T**2+1.97030333E-06*T**3+682970*T**(-1); 1.60000E+03 Y\n +367789.415+651.154953*T-126.464*T*LN(T)-.00206835*T**2\n +7.59616667E-08*T**3+11366585*T**(-1); 4.00000E+03 N !\n FUNCTION F5218T 2.98150E+02 +288051.702-62.1217039*T-23.51726*T*LN(T)\n -.10484665*T**2+1.70475E-05*T**3+166261.7*T**(-1); 6.00000E+02 Y\n +271269.255+222.99465*T-68.63141*T*LN(T)-.05050485*T**2\n +4.70099667E-06*T**3+1349256.5*T**(-1); 1.35000E+03 N !\n FUNCTION F5213T 2.98150E+02 +370172.153-109.109385*T-11.397*T*LN(T)\n -.1111325*T**2+1.61656983E-05*T**3+358940*T**(-1); 7.00000E+02 Y\n +325301.98+486.389913*T-101.491*T*LN(T)-.0296325*T**2\n +2.12065333E-06*T**3+4595505*T**(-1); 1.90000E+03 Y\n +243710.536+1013.16655*T-172.226*T*LN(T)-.00194705*T**2\n +6.80733333E-08*T**3+22628525*T**(-1); 4.00000E+03 N !\n FUNCTION F5222T 2.98150E+02 +148974.923-154.988667*T-9.679935*T*LN(T)\n -.13252255*T**2+1.875805E-05*T**3-64604.3*T**(-1); 7.00000E+02 Y\n +143586.528-18.9490501*T-32.19739*T*LN(T)-.0996706*T**2\n +1.0683635E-05*T**3; 1.35000E+03 N !\n FUNCTION F5225T 2.98150E+02 +121653.925-773.246123*T+98.0989*T*LN(T)\n -.3288666*T**2+8.00427167E-05*T**3-1078152*T**(-1); 5.00000E+02 Y\n +69670.1413+288.910378*T-76.01784*T*LN(T)-.06784355*T**2\n +6.41405167E-06*T**3+1865350.5*T**(-1); 1.35000E+03 N !\n FUNCTION F5229T 2.98150E+02 +171954.749-626.535566*T+70.21254*T*LN(T)\n -.27331145*T**2+6.370085E-05*T**3-1007086.5*T**(-1); 5.00000E+02 Y\n +134813.21+143.300138*T-56.40032*T*LN(T)-.0793759*T**2\n +7.720665E-06*T**3+1073901*T**(-1); 1.35000E+03 N !\n FUNCTION F5232T 2.98150E+02 +137810.196-224.576236*T+2.364458*T*LN(T)\n -.14050145*T**2+2.03154833E-05*T**3-328490*T**(-1); 6.00000E+02 Y\n +121325.209+49.3857422*T-40.8135*T*LN(T)-.0897223*T**2\n +9.02328333E-06*T**3+865653*T**(-1); 1.35000E+03 N !\n FUNCTION F5235T 2.98150E+02 +151050.533-349.7586*T+27.653*T*LN(T)\n -.17688495*T**2+2.748815E-05*T**3-55550*T**(-1); 6.00000E+02 Y\n +103768.902+358.874068*T-81.845*T*LN(T)-.0637295*T**2\n +5.44480167E-06*T**3+3783270*T**(-1); 1.40000E+03 Y\n -17659.4864+1268.26244*T-206.872*T*LN(T)-.0052678*T**2\n +2.01658333E-07*T**3+26324075*T**(-1); 4.00000E+03 N !\n FUNCTION F5240T 2.98150E+02 +7830.75067-135.953552*T-5.378*T*LN(T)\n -.1516055*T**2+1.77087667E-05*T**3+697635*T**(-1); 1.00000E+03 N !\n FUNCTION F5242T 2.98150E+02 +12533.4694-811.558153*T+99.93819*T*LN(T)\n -.3308519*T**2+7.42945833E-05*T**3-1242512*T**(-1); 5.00000E+02 Y\n -34223.5657+125.568769*T-53.29244*T*LN(T)-.1034473*T**2\n +1.02151667E-05*T**3+1500742*T**(-1); 1.35000E+03 N !\n FUNCTION F5246T 2.98150E+02 -9954.98882-420.389759*T+33.53622*T*LN(T)\n -.19866405*T**2+3.05487167E-05*T**3-458273.5*T**(-1); 6.00000E+02 Y\n -41465.8704+91.7966661*T-46.86917*T*LN(T)-.10633385*T**2\n +1.0445635E-05*T**3+1888323*T**(-1); 1.35000E+03 N !\n FUNCTION F5250T 2.98150E+02 -19845.8404-271.195989*T+10.01855*T*LN(T)\n -.17302075*T**2+2.49936167E-05*T**3-356884.75*T**(-1); 6.00000E+02 Y\n -46739.5847+154.950922*T-56.55596*T*LN(T)-.09892585*T**2\n +9.35312333E-06*T**3+1703068*T**(-1); 1.35000E+03 N !\n FUNCTION F5254T 2.98150E+02 +25802.6842-440.237142*T+43.351*T*LN(T)\n -.2105867*T**2+3.14729833E-05*T**3-227945*T**(-1); 6.00000E+02 Y\n -29324.4938+373.689954*T-82.076*T*LN(T)-.08318905*T**2\n +7.05010833E-06*T**3+4327090*T**(-1); 1.50000E+03 N !\n FUNCTION F5257T 2.98150E+02 -6.10167508-885.983713*T+114.5039*T*LN(T)\n -.3592508*T**2+8.41611667E-05*T**3-1525313*T**(-1); 5.00000E+02 Y\n -47563.4441+107.259988*T-49.09213*T*LN(T)-.1065104*T**2\n +1.0644305E-05*T**3+1115990*T**(-1); 1.35000E+03 N !\n FUNCTION F5280T 2.98150E+02 +1028316.51+169.994576*T-62.97185*T*LN(T)\n -.0317015*T**2+4.09694E-06*T**3+186275.3*T**(-1); 9.00000E+02 Y\n +999750.247+470.150388*T-106.5965*T*LN(T)-.0014783715*T**2\n +7.07236167E-08*T**3+3747842.5*T**(-1); 3.50000E+03 Y\n +990603.918+513.736611*T-112.1708*T*LN(T)-6.611165E-06*T**2\n +1.10554567E-10*T**3+6565820*T**(-1); 1.00000E+04 N !\n FUNCTION F5304T 2.98150E+02 +2466802.51+88.4522193*T+10.293*T*LN(T)\n -1.15472*T**2+1.77008333E-04*T**3+4621630*T**(-1); 8.00000E+02 Y\n +1709986.12+9262.28939*T-1356.31*T*LN(T)-.0366229*T**2\n +1.98371667E-06*T**3+84578000*T**(-1); 3.30000E+03 N !\n FUNCTION F5325T 2.98150E+02 +71643.2857-315.496947*T+25.001*T*LN(T)\n -.2161207*T**2+3.431025E-05*T**3+151720*T**(-1); 6.00000E+02 Y\n +13101.0393+567.138312*T-111.518*T*LN(T)-.07424425*T**2\n +6.56452833E-06*T**3+4867785*T**(-1); 1.30000E+03 Y\n -109518.172+1531.0277*T-245.03*T*LN(T)-.00845165*T**2\n +3.60173333E-07*T**3+26305545*T**(-1); 3.50000E+03 Y\n -158376.968+1751.98658*T-273.057*T*LN(T)-.0015082*T**2\n +4.57316667E-08*T**3+41807370*T**(-1); 4.00000E+03 N !\n FUNCTION F5331T 2.98150E+02 -115232.054-209.218178*T+2.935807*T*LN(T)\n -.222882*T**2+3.73738333E-05*T**3+285881.45*T**(-1); 6.00000E+02 Y\n -166306.578+593.403695*T-122.2293*T*LN(T)-.0853405*T**2\n +8.77358E-06*T**3+4226408.5*T**(-1); 9.00000E+02 N !\n FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); \n 6.00000E+03 N !\n FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T)\n +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y\n +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2\n +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y\n +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2\n +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y\n -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2\n -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y\n +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2\n -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T)\n -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y\n -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2\n +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y\n -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2\n -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N !\n FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T)\n +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y\n +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2\n +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y\n -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2\n +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N !\n FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T)\n -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y\n -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2\n +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y\n -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2\n +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y\n -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2\n -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y\n -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2\n -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T)\n -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y\n -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2\n +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N !\n FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T)\n +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 \n Y\n +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2\n +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N !\n FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T)\n -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y\n -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2\n +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y\n +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2\n +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y\n -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2\n -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y\n -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3\n +.25153895*T**(-1); 2.00000E+04 N !\n FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T)\n -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y\n +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2\n -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y\n +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2\n -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y\n +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2\n +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y\n +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2\n +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y\n -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2\n -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y\n +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2\n -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N !\n FUNCTION F4313T 2.98150E+02 -452357.992+535.146046*T-99.1608*T*LN(T); \n 1.50000E+03 N !\n FUNCTION F4359T 2.98150E+02 -262897.462+419.668519*T-81.588*T*LN(T); \n 4.00000E+02 N !\n FUNCTION F4984T 2.98150E+02 -520876.535+666.560666*T-123.386*T*LN(T); \n 5.00000E+02 N !\n FUNCTION F5032T 2.98150E+02 -310828.243+585.538554*T-111.4199*T*LN(T); \n 4.00000E+02 N !\n FUNCTION F5042T 2.98150E+02 -484027.237+267.60133*T-47.07*T*LN(T)\n -.1834684*T**2+1.43650667E-05*T**3-23012*T**(-1); 8.00000E+02 N !\n FUNCTION F5302T 2.98150E+02 +2232387.45+1624.15871*T-217.988*T*LN(T)\n -.88971*T**2+1.13199333E-04*T**3+7681900*T**(-1); 1.00000E+03 N !\n FUNCTION F5323T 2.98150E+02 +8456.49693+740.043096*T-136.106*T*LN(T); \n 3.53000E+02 N !\n FUNCTION F3871T 2.98150E+02 -17368.4408+170.730317*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 4.76530E+03 Y\n -17368.4408+170.730317*T-24.3*T*LN(T)-4.723E-04*T**2+2562600*T**(-1)\n -2.643E+08*T**(-2)+1.2E+10*T**(-3); 6.00000E+03 N !\n FUNCTION F3893T 2.98150E+02 -16359.4285+175.609805*T-24.31*T*LN(T)\n -4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T)\n +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y\n -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2\n +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y\n -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2\n -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y\n -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N !\n FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); \n 1.50000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE GAS:G % 1 1.0 !\n CONSTITUENT GAS:G :C,C1H1,C1H1O1,C1H1O2,C1H2,C1H2O1,C1H2O2_CIS,\n C1H2O2_DIOXIRANE,C1H2O2_TRANS,C1H3,C1H3O1_CH2OH,C1H3O1_CH3O,C1H4,C1H4O1,\n C1O1,C1O2,C2,C2H1,C2H2,C2H2O1,C2H3,C2H4,C2H4O1_ACETALDEHYDE,\n C2H4O1_OXIRANE,C2H4O2_ACETICACID,C2H4O2_DIOXETANE,C2H4O3_123TRIOXOLANE,\n C2H4O3_124TRIOXOLANE,C2H5,C2H6,C2H6O1,C2H6O2,C2O1,C3,C3H1,C3H4_1,C3H4_2,\n C3H6,C3H6O1,C3H6_2,C3H8,C3O2,C4,C4H1,C4H10_1,C4H10_2,C4H2,C4H4,C4H4_1_3,\n C4H6_1,C4H6_2,C4H6_3,C4H6_4,C4H6_5,C4H8,C4H8_1,C4H8_2,C4H8_3,C4H8_4,\n C4H8_5,C5,C60,C6H6,C6H6O1,H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : !\n\n PARAMETER G(GAS,C;0) 2.98150E+02 +F3895T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2437 !\n PARAMETER G(GAS,C1H1;0) 2.98150E+02 +F4246T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2556 !\n PARAMETER G(GAS,C1H1O1;0) 2.98150E+02 +F4282T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2566 !\n PARAMETER G(GAS,C1H1O2;0) 2.98150E+02 +F4287T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2568 !\n PARAMETER G(GAS,C1H2;0) 2.98150E+02 +F4298T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2571 !\n PARAMETER G(GAS,C1H2O1;0) 2.98150E+02 +F4308T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2574 !\n PARAMETER G(GAS,C1H2O2_CIS;0) 2.98150E+02 +F4315T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2579 !\n PARAMETER G(GAS,C1H2O2_DIOXIRANE;0) 2.98150E+02 +F4320T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2580 !\n PARAMETER G(GAS,C1H2O2_TRANS;0) 2.98150E+02 +F4326T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2581 !\n PARAMETER G(GAS,C1H3;0) 2.98150E+02 +F4331T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2582 !\n PARAMETER G(GAS,C1H3O1_CH2OH;0) 2.98150E+02 +F4342T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2585 !\n PARAMETER G(GAS,C1H3O1_CH3O;0) 2.98150E+02 +F4348T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2586 !\n PARAMETER G(GAS,C1H4;0) 2.98150E+02 +F4354T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2587 !\n PARAMETER G(GAS,C1H4O1;0) 2.98150E+02 +F4361T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2591 !\n PARAMETER G(GAS,C1O1;0) 2.98150E+02 +F4504T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2659 !\n PARAMETER G(GAS,C1O2;0) 2.98150E+02 +F4525T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2668 !\n PARAMETER G(GAS,C2;0) 2.98150E+02 +F4656T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2743 !\n PARAMETER G(GAS,C2H1;0) 2.98150E+02 +F4935T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2820 !\n PARAMETER G(GAS,C2H2;0) 2.98150E+02 +F4946T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2823 !\n PARAMETER G(GAS,C2H2O1;0) 2.98150E+02 +F4952T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2825 !\n PARAMETER G(GAS,C2H3;0) 2.98150E+02 +F4958T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2826 !\n PARAMETER G(GAS,C2H4;0) 2.98150E+02 +F4964T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2827 !\n PARAMETER G(GAS,C2H4O1_ACETALDEHYDE;0) 2.98150E+02 +F4970T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2829 !\n PARAMETER G(GAS,C2H4O1_OXIRANE;0) 2.98150E+02 +F4976T#+R#*T*LN(1E-05*P);\n 6.00000E+03 N REF2830 !\n PARAMETER G(GAS,C2H4O2_ACETICACID;0) 2.98150E+02 +F4986T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2834 !\n PARAMETER G(GAS,C2H4O2_DIOXETANE;0) 2.98150E+02 +F4990T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2835 !\n PARAMETER G(GAS,C2H4O3_123TRIOXOLANE;0) 2.98150E+02 +F4998T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2836 !\n PARAMETER G(GAS,C2H4O3_124TRIOXOLANE;0) 2.98150E+02 +F5006T#\n +R#*T*LN(1E-05*P); 6.00000E+03 N REF2837 !\n PARAMETER G(GAS,C2H5;0) 2.98150E+02 +F5014T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2838 !\n PARAMETER G(GAS,C2H6;0) 2.98150E+02 +F5026T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2840 !\n PARAMETER G(GAS,C2H6O1;0) 2.98150E+02 +F5034T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2844 !\n PARAMETER G(GAS,C2H6O2;0) 2.98150E+02 +F5044T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2852 !\n PARAMETER G(GAS,C2O1;0) 2.98150E+02 +F5081T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2874 !\n PARAMETER G(GAS,C3;0) 2.98150E+02 +F5113T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2892 !\n PARAMETER G(GAS,C3H1;0) 2.98150E+02 +F5130T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2903 !\n PARAMETER G(GAS,C3H4_1;0) 2.98150E+02 +F5142T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2905 !\n PARAMETER G(GAS,C3H4_2;0) 2.98150E+02 +F5145T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2908 !\n PARAMETER G(GAS,C3H6;0) 2.98150E+02 +F5148T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2911 !\n PARAMETER G(GAS,C3H6O1;0) 2.98150E+02 +F5154T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2913 !\n PARAMETER G(GAS,C3H6_2;0) 2.98150E+02 +F5157T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2916 !\n PARAMETER G(GAS,C3H8;0) 2.98150E+02 +F5161T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2919 !\n PARAMETER G(GAS,C3O2;0) 2.98150E+02 +F5180T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2928 !\n PARAMETER G(GAS,C4;0) 2.98150E+02 +F5190T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2932 !\n PARAMETER G(GAS,C4H1;0) 2.98150E+02 +F5205T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2938 !\n PARAMETER G(GAS,C4H10_1;0) 2.98150E+02 +F5195T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2933 !\n PARAMETER G(GAS,C4H10_2;0) 2.98150E+02 +F5200T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2935 !\n PARAMETER G(GAS,C4H2;0) 2.98150E+02 +F5210T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2940 !\n PARAMETER G(GAS,C4H4;0) 2.98150E+02 +F5218T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2944 !\n PARAMETER G(GAS,C4H4_1_3;0) 2.98150E+02 +F5213T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2942 !\n PARAMETER G(GAS,C4H6_1;0) 2.98150E+02 +F5222T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2947 !\n PARAMETER G(GAS,C4H6_2;0) 2.98150E+02 +F5225T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2950 !\n PARAMETER G(GAS,C4H6_3;0) 2.98150E+02 +F5229T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2953 !\n PARAMETER G(GAS,C4H6_4;0) 2.98150E+02 +F5232T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2956 !\n PARAMETER G(GAS,C4H6_5;0) 2.98150E+02 +F5235T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2959 !\n PARAMETER G(GAS,C4H8;0) 2.98150E+02 +F5240T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2961 !\n PARAMETER G(GAS,C4H8_1;0) 2.98150E+02 +F5242T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2963 !\n PARAMETER G(GAS,C4H8_2;0) 2.98150E+02 +F5246T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2966 !\n PARAMETER G(GAS,C4H8_3;0) 2.98150E+02 +F5250T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2969 !\n PARAMETER G(GAS,C4H8_4;0) 2.98150E+02 +F5254T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2972 !\n PARAMETER G(GAS,C4H8_5;0) 2.98150E+02 +F5257T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2974 !\n PARAMETER G(GAS,C5;0) 2.98150E+02 +F5280T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF2988 !\n PARAMETER G(GAS,C60;0) 2.98150E+02 +F5304T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF3010 !\n PARAMETER G(GAS,C6H6;0) 2.98150E+02 +F5325T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF3042 !\n PARAMETER G(GAS,C6H6O1;0) 2.98150E+02 +F5331T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF3044 !\n PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF5999 !\n PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF6072 !\n PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF6089 !\n PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF6138 !\n PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF6189 !\n PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF6196 !\n PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF7675 !\n PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF7802 !\n PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF7957 !\n\n\n PHASE C1H2O2_L % 1 1.0 !\n CONSTITUENT C1H2O2_L :C1H2O2 : !\n\n PARAMETER G(C1H2O2_L,C1H2O2;0) 2.98150E+02 +F4313T#; 6.00000E+03 N \n REF2576 !\n\n\n PHASE C1H4O1_L % 1 1.0 !\n CONSTITUENT C1H4O1_L :C1H4O1 : !\n\n PARAMETER G(C1H4O1_L,C1H4O1;0) 2.98150E+02 +F4359T#; 6.00000E+03 N \n REF2589 !\n\n\n PHASE C2H4O2_L % 1 1.0 !\n CONSTITUENT C2H4O2_L :C2H4O2 : !\n\n PARAMETER G(C2H4O2_L,C2H4O2;0) 2.98150E+02 +F4984T#; 6.00000E+03 N \n REF2831 !\n\n\n PHASE C2H6O1_L % 1 1.0 !\n CONSTITUENT C2H6O1_L :C2H6O1 : !\n\n PARAMETER G(C2H6O1_L,C2H6O1;0) 2.98150E+02 +F5032T#; 6.00000E+03 N \n REF2841 !\n\n\n PHASE C2H6O2_L % 1 1.0 !\n CONSTITUENT C2H6O2_L :C2H6O2 : !\n\n PARAMETER G(C2H6O2_L,C2H6O2;0) 2.98150E+02 +F5042T#; 6.00000E+03 N \n REF2849 !\n\n\n PHASE C60_S % 1 1.0 !\n CONSTITUENT C60_S :C60 : !\n\n PARAMETER G(C60_S,C60;0) 2.98150E+02 +F5302T#; 6.00000E+03 N \n REF2996 !\n\n\n PHASE C6H6_L % 1 1.0 !\n CONSTITUENT C6H6_L :C6H6 : !\n\n PARAMETER G(C6H6_L,C6H6;0) 2.98150E+02 +F5323T#; 6.00000E+03 N \n REF3039 !\n\n\n PHASE CARBON_L % 1 1.0 !\n CONSTITUENT CARBON_L :C : !\n\n PARAMETER G(CARBON_L,C;0) 2.98150E+02 +F3871T#+117369-24.6299289*T; \n 6.00000E+03 N REF2421 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :C : !\n\n PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +F3871T#; 6.00000E+03 N REF2421 !\n\n\n PHASE DIAMOND % 1 1.0 !\n CONSTITUENT DIAMOND :C : !\n\n PARAMETER G(DIAMOND,C;0) 2.98150E+02 +F3893T#; 6.00000E+03 N \n REF2433 !\n\n\n PHASE H2O1_L % 1 1.0 !\n CONSTITUENT H2O1_L :H2O1 : !\n\n PARAMETER G(H2O1_L,H2O1;0) 2.98150E+02 +F10952T#; 6.00000E+03 N \n REF6184 !\n\n\n PHASE H2O2_L % 1 1.0 !\n CONSTITUENT H2O2_L :H2O2 : !\n\n PARAMETER G(H2O2_L,H2O2;0) 2.98150E+02 +F10981T#; 6.00000E+03 N \n REF6193 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF2437 'C1 T.C.R.A.S. Class: 1'\n REF2556 'C1H1 T.C.R.A.S. Class: 2'\n REF2566 'C1H1O1 T.C.R.A.S. Class: 4 \n FORMYL '\n REF2568 'C1H1O2 T.C.R.A.S. Class: 6'\n REF2571 'C1H2 T.C.R.A.S. Class: 5 \n METHYLENE '\n REF2574 'C1H2O1 T.C.R.A.S. Class: 5 \n FORMALDEHYDE '\n REF2579 'C1H2O2_CIS T.C.R.A.S. Class: 5'\n REF2580 'C1H2O2_DIOXIRANE T.C.R.A.S. Class: 6'\n REF2581 'C1H2O2_TRANS T.C.R.A.S. Class: 5'\n REF2582 'C1H3 T.C.R.A.S. Class: 5 \n METHYL '\n REF2585 'C1H3O1_CH2OH T.C.R.A.S. Class: 6'\n REF2586 'C1H3O1_CH3O T.C.R.A.S. Class: 5'\n REF2587 'C1H4 T.C.R.A.S. Class: 5 \n METHANE '\n REF2591 'C1H4O1 T.C.R.A.S. Class: 5 \n METHANOL '\n REF2659 'C1O1 JANAF THERMOCHEMICAL TABLES SGTE ** \n CARBON MONOXIDE \n STANDARD STATE : CODATA KEY VALUE. /CP FROM JANAF PUB. 9/65'\n REF2668 'C1O2 T.C.R.A.S. Class: 2 \n CARBON DIOXIDE '\n REF2743 'C2 T.C.R.A.S. Class: 2 \n CARBON '\n REF2820 'C2H1 T.C.R.A.S. Class: 6 \n CCH RADICAL '\n REF2823 'C2H2 T.C.R.A.S. Class: 2 \n ACETYLENE '\n REF2825 'C2H2O1 T.C.R.A.S. Class: 6'\n REF2826 'C2H3 T.C.R.A.S. Class: 6'\n REF2827 'C2H4 T.C.R.A.S. Class: 6 \n ETHYLENE '\n REF2829 'C2H4O1_ACETALDEHYDE T.C.R.A.S. Class: 5'\n REF2830 'C2H4O1_OXIRANE T.C.R.A.S. Class: 6'\n REF2834 'C2H4O2_ACETICACID T.C.R.A.S. Class: 5'\n REF2835 'C2H4O2_DIOXETANE T.C.R.A.S. Class: 6'\n REF2836 'C2H4O3_123TRIOXOLANE T.C.R.A.S. Class: 7'\n REF2837 'C2H4O3_124TRIOXOLANE T.C.R.A.S. Class: 7'\n REF2838 'C2H5 T.C.R.A.S. Class: 6'\n REF2840 'C2H6 T.C.R.A.S. Class: 6'\n REF2844 'C2H6O1 T.C.R.A.S. Class: 6 \n ETHANOL '\n REF2852 'C2H6O2 THERMODATA \n E-GLYCOL .Data revised by THDA.'\n REF2874 'C2O1 T.C.R.A.S. Class: 5'\n REF2892 'C3 T.C.R.A.S. Class: 6 \n CARBON '\n REF2903 'C3H1 T.C.R.A.S. Class: 6'\n REF2905 'C3H4_1 STULL WESTRUM SINKE 1969 SGTE \n ALLENE = 1,2-PROPADIENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2908 'C3H4_2 STULL WESTRUM SINKE 1969 SGTE \n PROPYNE (METHYLACETYLENE) \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2911 'C3H6 T.C.R.A.S. Class: 5 \n CYCLOPROPANE '\n REF2913 'C3H6O1 THERMODATA 01/93 \n ACETONE \n 28/01/93'\n REF2916 'C3H6_2 STULL WESTRUM SINKE 1969 SGTE \n PROPENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2919 'C3H8 THERMODATA SGTE \n PROPANE \n PROPANE'\n REF2928 'C3O2 T.C.R.A.S. Class: 6'\n REF2932 'C4 T.C.R.A.S. Class: 7'\n REF2938 'C4H1 T.C.R.A.S Class: 6 \n 1,3-BUTADIYNYL. Data provided by T.C.R.A.S. in 2000'\n REF2933 'C4H10_1 T.C.R.A.S Class: 4 \n BUTANE. Data provided by T.C.R.A.S. in 2000'\n REF2935 'C4H10_2 T.C.R.A.S Class: 4 \n METHYLPROPANE N-BUTANE. Data provided by T.C.R.A.S. in 2000'\n REF2940 'C4H2 T.C.R.A.S Class: 6 \n 1,3-BUTADIYNE. Data provided by T.C.R.A.S. in 2000'\n REF2944 'C4H4 STULL WESTRUM SINKE 1969 SGTE \n 1-BUTEN-3-YNE VINYLACETYLENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2942 'C4H4_1,3 T.C.R.A.S Class: 6 \n 1,3-CYCLOBUTADIENE. Data provided by T.C.R.A.S. in 2000'\n REF2947 'C4H6_1 STULL WESTRUM SINKE 1969 SGTE \n 1,2-BUTADIENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2950 'C4H6_2 STULL WESTRUM SINKE 1969 SGTE \n 1,3-BUTADIENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2953 'C4H6_3 STULL WESTRUM SINKE 1969 SGTE \n 1-BUTYNE ETHYLACETYLENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2956 'C4H6_4 STULL WESTRUM SINKE 1969 SGTE \n 2-BUTYNE DIMETHYLACETYLENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2959 'C4H6_5 T.C.R.A.S Class: 6 \n CYCLOBUTENE. Data provided by T.C.R.A.S. in 2000'\n REF2961 'C4H8 I. BARIN 3rd. Edition \n CYCLOBUTANE Data taken from BARIN 3rd. Ed. (1995)'\n REF2963 'C4H8_1 STULL WESTRUM SINKE 1969 SGTE \n 1-BUTENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2966 'C4H8_2 STULL WESTRUM SINKE 1969 SGTE \n 2-BUTENE,CIS \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2969 'C4H8_3 STULL WESTRUM SINKE 1969 SGTE \n 2-BUTENE,TRANS \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2972 'C4H8_ T.C.R.A.S Class: 6 \n CYCLOBUTANE. Data provided by T.C.R.A.S. in 2000'\n REF2974 'C4H8_5 STULL WESTRUM SINKE 1969 SGTE \n 2-METHYLPROPENE \n EXTRAPOLATION BY THERMODATA FROM 1000 TO 1350K.'\n REF2988 'C5 T.C.R.A.S. Class: 7'\n REF3010 'C60 MHR-95 \n Data processed from [94Kor/Sid] M.V. Korobov, L.N. sidorov, \n J. Chem. Thermo, 26, 61-73 (1994). Recalculated from the rotational \n data in [91McK] and vibration frequencies in [94Kor/Sid]. Note that \n a frequency with degeneracy 5 is missing from list in [94Kor/Sid]; \n taken to be 419 cm-1, which gives very good, though not exact, \n agreement with values quoted in [94Kor/Sid]. Note discrepancy \n between calculated DrS(298) = -8943.5 J mol K-1 for the reaction \n 60C=C60and that given by [94Kor/Sid] in their Table 5, \n -8950 J mol K-1. Enthalpy of formation: DfH = 2588 kJ/mol from \n DsubH(298.15K) = 166 +/- 11 kJ mol-1 [94Kor/Sid]. Vapour pressure \n values reproduced very well. \n [91McK] J.T. McKinnon, J. Phys. Chem. 95 8941(1993)'.\n REF3042 'C6H6 T.C.R.A.S Class: 5 \n BENZENE. Data provided by T.C.R.A.S. in 2000'\n REF3044 'C6H6O1 THERMODATA 01/93 \n PHENOL \n 28/01/93'\n REF5999 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** \n HYDROGEN '\n REF6072 'H1O1 T.C.R.A.S. Class: 1'\n REF6089 'H1O2 T.C.R.A.S. Class: 4'\n REF6138 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** \n HYDROGEN \n STANDARD STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61'\n REF6189 'H2O1 T.C.R.A.S. Class: 1 \n WATER '\n REF6196 'H2O2 JANAF SECOND EDIT SGTE \n HYDROGEN PEROXIDE '\n REF7675 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE \n OXYGEN '\n REF7802 'O2 T.C.R.A.S. Class: 1 \n OXYGEN '\n REF7957 'O3 T.C.R.A.S. Class: 4 \n OZONE '\n REF2576 'C1H2O2 THERMODATA 01/93 \n FORMIC ACID MONOMERIC \n 28/01/93'\n REF2589 'C1H4O1 I. BARIN 3rd. Edition \n METHANOL. H298 and S298 modified.'\n REF2831 'C2H4O2 THERMODATA 01/93 \n ACETIC ACID \n 28/01/93 Tb=389K.'\n REF2841 'C2H6O1 THERMODATA 01/93 \n ETHANOL \n 28/01/93'\n REF2849 'C2H6O2 THERMODATA \n E-GLYCOL \n Data revised by THDA.'\n REF2996 'C60 MHR-95 \n Data processed from [94Kor/Sid] M.V. Korobov, \n L.N. sidorov, J. Chem. Thermo, 26, 61-73 (1994). \n Fitted to the data in [94Kor/Sid], who took the phase transition \n at 257K to be first-order with DtrsH = (7+/-1) kJ mol-1. Note \n that [94Kor/Sid] do not give an explicit value for S(298.15K). \n S(298.15K) = 422.6 J mol K-1 was calculated from S(300) =425.8 \n and Cp expression, but there is a discrepancy with S(298.15K) \n calculated from DrS(298) for 60C=C60 given by [94Kor/Sid] \n in their Table 5, which gives S(298.15K) = 425.4 J mol K-1. \n Enthalpy of formation : DfH = +2422 +/- 14 kJ/mol from [92Ste/Chi], \n the value preferred, if obliquely, by [94Kor/Sid]. \n [92Ste/Chi]W.V. Steele, R.D. Chirico, N.K. Smith, W.e. Billups, \n P.R. Elmore, A.E. Wheeler, J. Phys. Chem. 96 4731 (1993).'\n REF3039 'C6H6 R.W.T.H.-94 \n Knacke, Kubaschewski, Hesselmann, 1991. In previous versions \n power of Cp was missing.'\n REF2421 'C1 S.G.T.E. ** \n \n Data from SGTE Unary DB, pressure dependent data added by atd 7/9/95'\n REF2433 'C1 S.G.T.E. ** \n \n Data from SGTE Unary DB, data added by atd 7/9/95, H298-H0 taken \n from 1994 database (ex THERMODATA 01/93)'\n REF6184 'H2O1 T.C.R.A.S. Class: 4 \n WATER \n T.C.R.A.S. Class: 4 modified by atd 12/9/94'\n REF6193 'H2O2 THERMODATA 01/93 \n HYDROGEN PEROXIDE \n 28/01/93'\n ! \n \n" }, { "path": "examples/macros/MgNaCl.TDB", "content": "$ MgCl2-NaCl.TDB\n$ File converted by dat2TDB_ND2021 on 2021-12-15 11:33\n$ from file MgCl2-NaCl.dat \n$\n$ System Cl-Mg-Na\n$\n \n ELEMENT /- ELECTRON_GAS 0.0 0.0 0.0 !\n ELEMENT VA VACUUM 0.0 0.0 0.0 !\n ELEMENT CL SER 35.45300000 0.0 0.0 ! \n ELEMENT MG SER 24.30500000 0.0 0.0 ! \n ELEMENT NA SER 22.98976928 0.0 0.0 ! \n\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n$ Functions to express not integer T powers\n$ T**i = EXP(i*LN(T))\n FUN LNT 298.15 LN(T);,, N !\n FUN HALFLNT 298.15 0.5*LNT;,, N !\n FUN SQRT 298.15 EXP(HALFLNT);,, N !\n FUN ONE5LNT 298.15 1.5*LNT;,, N !\n FUN SSQRT 298.15 EXP(ONE5LNT);,, N !\n\n\n$==============================================================================\n$ FUNCTIONS FOR MQMQA\n$==============================================================================\n\n FUNCTION GLIQNACL 298.15 \n -417806.48+442.50770*T-77.763600*T*LN(T)+0.37656000E-02*T**2; \n 1500.0000 Y\n -409333.88+359.89172*T-66.466800*T*LN(T);\n 3500.0000 N REF ! \n FUNCTION GLIQMGCL 298.15 \n -658788.27+1093.7361*T-193.40890*T*LN(T)+0.18100695*T**2\n -.53331179E-04*T**3+1894252.0*T**(-1);\n 660.00000 Y\n -634331.55+499.20330*T-92.048000*T*LN(T);\n 3500.0000 N REF ! \n\n PHASE SALT:Q % 1 1.0 !\n CONST SALT:Q : \n NA/CL 6.000000 6.000000 2.40000\n MG/CL 6.000000 3.000000 2.40000\n$ 1 2 3 3 3.0000000 6.0000000 3.0000000 3.0000000\n MG,NA/CL 6.000000 3.000000 3.000000 \n$ QUADRUPLETS with default Z\n : ! \n$ 1 1 3 3 6.0000000 6.0000000 6.0000000 6.0000000\n PARAMETER G(SALT,NA/CL-Q) 298.15 0.33333333*GLIQNACL;,, N REF ! \n$ 2 2 3 3 6.0000000 6.0000000 3.0000000 3.0000000\n PARAMETER G(SALT,MG/CL-Q) 298.15 0.33333333*GLIQMGCL;,, N REF ! \n$ G 1 2 3 3 0 0 0 0\n$ 0 0 -10395.800 0.00000000 0.00000000 0.00000000\n PARAMETER G(SALT,MGNA/CL-Q) 298.15 \n -5197.9000;,, N REF !\n$ G 1 2 3 3 1 0 0 0\n$ 0 0 660.50000 0.00000000 0.00000000 0.00000000\n PARAMETER L(SALT,MGNA/CL-Q,NA/CL-Q;0) 298.15 \n 330.2500;,, N REF !\n$ G 1 2 3 3 0 1 0 0\n$ 0 0 -4641.5000 0.00000000 0.00000000 0.00000000\n PARAMETER L(SALT,MGNA/CL-Q,MG/CL-Q;0) 298.15 \n -2320.7500;,, N REF !\n\n\nPHASE NACL % 2 1.0 1.0 !\nCONST NACL :NA:CL: !\nPARAMETER G(NACL,NA:CL) 298.15 -425542.29 +240.42080*T -45.940000*T*LN(T)\n -.81590000E-02*T**2; 1500 Y\n -443900.04 +419.42650*T -70.417000*T*LN(T); 6000 N REF2 !\n\nPHASE MGCL2 % 2 1.0 2.0 !\nCONST MGCL2 :MG:CL: !\nPARAMETER G(MgCl2,MG:CL) 298.15 -676336.86+242.25622*T-54.584300*T*LN(T)\n -.10710650E-01*T**2 +0.39278333E-06*T**2 +556059.50*T**(-1) +1596.7080*SQRT;\n 1500 Y -678190.36+537.75324*T -91.226106*T*LN(T); 6000 N REF2 !\n\nPHASE NaMgCl3 % 3 1.0 1.0 3.0 !\nCONST NAMGCL3 :NA:MG:CL: !\nPARAMETER G(NAMGCL3,NA:MG:CL) 298.15 -1083303.0+455.19995*T-90.000000*T*LN(T)\n -0.0375*T**2; 1500 Y -1167678.0+1277.9372*T-202.50000*T*LN(T); 6000 N REF2 !\n\nPHASE Na2MgCl4 % 3 2.0 1.0 4.0 !\nCONST NA2MGCL4 :NA:MG:CL: !\nPARAMETER G(NA2MGCL4,NA:MG:CL) 298.15 -1508686.5+693.72143*T-135.00000*T*LN(T)\n -.56250000E-01*T**2; 1500 Y\n -1635249.0+1927.8274*T-303.75000*T*LN(T); 6000 N REF2 !\n\n\n$ These 2 phases MUST BE SET DORMANT but are useful for chemical potentials\nPHASE LIQREF_NACL % 2 1.0 1.0 !\nCONST LIQREF_NACL :NA:CL: !\nPARAMETER G(LIQREF_NACL,NA:CL) 298.15 GLIQNACL; 6000 N REF !\n\nPHASE LIQREF_MGCL2 % 2 1.0 2.0 !\nCONST LIQREF_MGCL2 :MG:CL: !\nPARAMETER G(LIQREF_MGCL2,MG:CL) 298.15 GLIQMGCL; 6000 N REF !\n\n$======================================================== Stoichiometric phases\n\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF 'Automatic conversion with dat2TDB from MgCl2-NaCl.dat' \n REF2 'Manual conversion by Bosse' \n !\n\n" }, { "path": "examples/macros/MgNaClX.TDB", "content": "$ MgCl2-NaCl.TDB\n$ File converted by dat2TDB_ND2021 on 2021-12-15 11:33\n$ from file MgCl2-NaCl.dat \n$\n$ System Cl-Mg-Na\n$\n \n ELEMENT /- ELECTRON_GAS 0.0 0.0 0.0 !\n ELEMENT VA VACUUM 0.0 0.0 0.0 !\n ELEMENT CL SER 35.45300000 0.0 0.0 ! \n ELEMENT MG SER 24.30500000 0.0 0.0 ! \n ELEMENT NA SER 22.98976928 0.0 0.0 ! \n\n \n SPECIES NA/CL NA/CL 6.000000 6.000000 2.40000 !\n SPECIES mg/cl MG/CL 6.000000 3.000000 2.40000 !\n$ 1 2 3 3 3.0000000 6.0000000 3.0000000 3.0000000\n SPECIES MGNA/CL MG,NA/CL 6.000000 3.000000 3.000000 !\n$ QUADRUPLETS with default Z\n\n\nTYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE SALT:Q % 1 1.0 !\n CONST SALT:Q : NA/CL-Q MG/CL-Q MGNA/CL-Q : !\n\n PARAMETER G(SALT,NA/CL-Q) 298.15 0.33333333*GLIQNACL;,, N REF ! \n$ 2 2 3 3 6.0000000 6.0000000 3.0000000 3.0000000\n PARAMETER G(SALT,MG/CL-Q) 298.15 0.33333333*GLIQMGCL;,, N REF ! \n$ G 1 2 3 3 0 0 0 0\n$ 0 0 -10395.800 0.00000000 0.00000000 0.00000000\n PARAMETER G(SALT,MGNA/CL-Q) 298.15 \n -5197.9000;,, N REF !\n$ G 1 2 3 3 1 0 0 0\n$ 0 0 660.50000 0.00000000 0.00000000 0.00000000\n PARAMETER L(SALT,MGNA/CL-Q,NA/CL-Q;0) 298.15 \n 330.2500;,, N REF !\n$ G 1 2 3 3 0 1 0 0\n$ 0 0 -4641.5000 0.00000000 0.00000000 0.00000000\n PARAMETER L(SALT,MGNA/CL-Q,MG/CL-Q;0) 298.15 \n -2320.7500;,, N REF !\n\n\n$ Functions to express not integer T powers\n$ T**i = EXP(i*LN(T))\n FUN LNT 298.15 LN(T);,, N !\n FUN HALFLNT 298.15 0.5*LNT;,, N !\n FUN SQRT 298.15 EXP(HALFLNT);,, N !\n FUN ONE5LNT 298.15 1.5*LNT;,, N !\n FUN SSQRT 298.15 EXP(ONE5LNT);,, N !\n\n\n$==============================================================================\n$ FUNCTIONS FOR MQMQA\n$==============================================================================\n\n FUNCTION GLIQNACL 298.15 \n -417806.48+442.50770*T-77.763600*T*LN(T)+0.37656000E-02*T**2; \n 1500.0000 Y\n -409333.88+359.89172*T-66.466800*T*LN(T);\n 3500.0000 N REF ! \n FUNCTION GLIQMGCL 298.15 \n -658788.27+1093.7361*T-193.40890*T*LN(T)+0.18100695*T**2\n -.53331179E-04*T**3+1894252.0*T**(-1);\n 660.00000 Y\n -634331.55+499.20330*T-92.048000*T*LN(T);\n 3500.0000 N REF ! \n\nPHASE NACL % 2 1.0 1.0 !\nCONST NACL :NA:CL: !\nPARAMETER G(NACL,NA:CL) 298.15 -425542.29 +240.42080*T -45.940000*T*LN(T)\n -.81590000E-02*T**2; 1500 Y\n -443900.04 +419.42650*T -70.417000*T*LN(T); 6000 N REF2 !\n\nPHASE MGCL2 % 2 1.0 2.0 !\nCONST MGCL2 :MG:CL: !\nPARAMETER G(MgCl2,MG:CL) 298.15 -676336.86+242.25622*T-54.584300*T*LN(T)\n -.10710650E-01*T**2 +0.39278333E-06*T**2 +556059.50*T**(-1) +1596.7080*SQRT;\n 1500 Y -678190.36+537.75324*T -91.226106*T*LN(T); 6000 N REF2 !\n\nPHASE NaMgCl3 % 3 1.0 1.0 3.0 !\nCONST NAMGCL3 :NA:MG:CL: !\nPARAMETER G(NAMGCL3,NA:MG:CL) 298.15 -1083303.0+455.19995*T-90.000000*T*LN(T)\n -0.0375*T**2; 1500 Y -1167678.0+1277.9372*T-202.50000*T*LN(T); 6000 N REF2 !\n\nPHASE Na2MgCl4 % 3 2.0 1.0 4.0 !\nCONST NA2MGCL4 :NA:MG:CL: !\nPARAMETER G(NA2MGCL4,NA:MG:CL) 298.15 -1508686.5+693.72143*T-135.00000*T*LN(T)\n -.56250000E-01*T**2; 1500 Y\n -1635249.0+1927.8274*T-303.75000*T*LN(T); 6000 N REF2 !\n\n\n$ These 2 phases MUST BE SET DORMANT but are useful for chemical potentials\nPHASE LIQREF_NACL % 2 1.0 1.0 !\nCONST LIQREF_NACL :NA:CL: !\nPARAMETER G(LIQREF_NACL,NA:CL) 298.15 GLIQNACL; 6000 N REF !\n\nPHASE LIQREF_MGCL2 % 2 1.0 2.0 !\nCONST LIQREF_MGCL2 :MG:CL: !\nPARAMETER G(LIQREF_MGCL2,MG:CL) 298.15 GLIQMGCL; 6000 N REF !\n\n$======================================================== Stoichiometric phases\n\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF 'Automatic conversion with dat2TDB from MgCl2-NaCl.dat' \n REF2 'Manual conversion by Bosse' \n !\n\n" }, { "path": "examples/macros/MoRe.TDB", "content": "$ Database file written by Open Calphad 2023-09-21\n\nELEMENT /- Electron_gas 0.0000E+00 0.0000E+00 0.0000E+00 !\nELEMENT VA Vacuum 0.0000E+00 0.0000E+00 0.0000E+00 !\nELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01 !\nELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01 !\n\n$ =================\n\n\n$ =================\n\nFUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N !\nFUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(+T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2896 Y -30556.41+283.559746*T-42.63829*T*LN(+T)-4.849315E+33*T**(-9); \n 5000 N !\nFUNCTION EVTOJ 298.15 +96485.5547; 6000 N !\nFUNCTION GCHIMO 298.15 +G58CHIMO*UNS58; 6000 N !\nFUNCTION GCHIRE 298.15 +G58CHIRE*UNS58; 6000 N !\nFUNCTION GSERMO 298.15 -10.949432*EVTOJ; 6000 N !\nFUNCTION GSERRE 298.15 -12.4224915*EVTOJ; 6000 N !\nFUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(+T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y -15775.998\n +194.667426*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(+T)\n +.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +346325.888\n -1211.37186*T+140.831655*T*LN(+T)-.033764567*T**2+1.053726E-06*T**3\n -134548866*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(+T); \n 6000 N !\nFUNCTION GSIGMO 298.15 +G30SIGMO*UNS30; 6000 N !\nFUNCTION GSIGRE 298.15 +G30SIGRE*UNS30; 6000 N !\nFUNCTION G58CHIRE 298.15 -717.557146*EVTOJ; 6000 N !\nFUNCTION UNS58 298.15 +CINQ8**(-1); 6000 N !\nFUNCTION G58CHIMO 298.15 -619.36214*EVTOJ; 6000 N !\nFUNCTION G30SIGRE 298.15 -369.773611*EVTOJ; 6000 N !\nFUNCTION UNS30 298.15 +TRENTE**(-1); 6000 N !\nFUNCTION G30SIGMO 298.15 -323.477558*EVTOJ; 6000 N !\nFUNCTION CINQ8 298.15 +58; 6000 N !\nFUNCTION TRENTE 298.15 +30; 6000 N !\n\n$ =================\n\n\nTYPE_DEFINITION % SEQ * !\nDEFINE_SYSTEM_DEFAULT ELEMENT 2 !\nDEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n$ =================\n\n\n$ + Volume model P*V0(x)*exp(VA(x,T))\n PHASE LIQUID:L % 1 1.000 !\n CONSTITUENT LIQUID:L :MO RE:!\n PARAMETER G(LIQUID,MO;0) 298.15 +34085.045+117.224788*T\n -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)\n -1.30927E-10*T**4+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T\n -42.63829*T*LN(+T); 5000 N REF1 !\n PARAMETER G(LIQUID,RE;0) 298.15 +16125.604+122.076209*T-24.348*T*LN(+T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +8044.885\n +188.322047*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T\n +314.178898*T*LN(+T)-.08939817*T**2+3.92854E-06*T**3\n -163100987*T**(-1); 3458 Y -39044.888+335.723691*T\n -49.519*T*LN(+T); 6000 N REF1 !\n PARAMETER G(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610; 6000 N RM2013 !\n PARAMETER G(LIQUID,MO,RE;1) 298.15 +8.07*T-7790; 6000 N RM2013 !\n\n$ + Volume model P*V0(x)*exp(VA(x,T))\n TYPE_DEFINITION 1 GES A_P_D BCC_A2 MAGNETIC -1 0.4000!\n PHASE BCC_A2 %1 2 1.000 3.000 !\n CONSTITUENT BCC_A2 :MO RE: VA:!\n PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO; 5000 N REF1 !\n PARAMETER G(BCC_A2,RE:VA;0) 298.15 +9304.721+124.721589*T\n -24.348*T*LN(+T)-.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); \n 1200 Y +1224.002+190.967426*T-33.586*T*LN(+T)+.00224565*T**2\n -2.81835E-07*T**3+1376270*T**(-1); 2400 Y -53882.739+458.410749*T\n -67.956*T*LN(+T)+.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1);\n 3458 Y +363325.888-1215.07186*T+140.831655*T*LN(+T)\n -.033764567*T**2+1.053726E-06*T**3-134548866*T**(-1); 5000 Y \n -61564.296+343.297842*T-49.519*T*LN(+T); 6000 N REF1 !\n PARAMETER G(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T; 6000 N RM2013 !\n PARAMETER G(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T; 6000 N RM2013 !\n\n$ *** Warning: disordered fraction sets need manual editing!\n$- TYPE_DEFINITION 2 GES A_P_D CHI DIS_PART DIS_CHI !\n TYPE_DEFINITION 2 GES A_P_D CHI NEVER DIS_CHI !\n$ + Volume model P*V0(x)*exp(VA(x,T))\n PHASE CHI %2 4 2.000 8.000 24.000 24.000 !\n CONSTITUENT CHI :MO RE: MO RE: MO RE: MO RE:!\n PARAMETER G(CHI,MO:MO:MO:RE;0) 298.15 -667.0576*EVTOJ-2*GCHIMO-8*GCHIMO\n -24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:MO:RE:MO;0) 298.15 -662.013824*EVTOJ-2*GCHIMO\n -8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:MO:RE:RE;0) 298.15 -706.53129*EVTOJ-2*GCHIMO\n -8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:MO:MO;0) 298.15 -630.436204*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:MO:RE;0) 298.15 -676.652914*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:RE:MO;0) 298.15 -672.07236*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:RE:RE;0) 298.15 -715.47601*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:MO:MO;0) 298.15 -621.992644*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:MO:RE;0) 298.15 -669.426922*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:RE:MO;0) 298.15 -664.700708*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:RE:RE;0) 298.15 -708.864342*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:MO:MO;0) 298.15 -632.902352*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:MO:RE;0) 298.15 -678.636738*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:RE:MO;0) 298.15 -674.442674*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n\n$ disordered part\n PHASE DIS_CHI % 1 1.0 !\n CONSTITUENT DIS_CHI :MO RE: !\n$ Disordered fraction parameters:--------------------\n PARAMETER G(DIS_CHI,MO;0) 298.15 +GCHIMO-GSERMO+GHSERMO-0.5596*T; 6000 N \n RM2013 !\n PARAMETER G(DIS_CHI,RE;0) 298.15 +GCHIRE-GSERRE+GHSERRE+.0905*T; 6000 N \n RM2013 !\n\n$ + Volume model P*V0(x)*exp(VA(x,T))\n TYPE_DEFINITION 3 GES A_P_D HCP_A3 MAGNETIC -3 0.2800!\n PHASE HCP_A3 %3 2 1.000 0.500 !\n CONSTITUENT HCP_A3 :MO RE: VA:!\n PARAMETER G(HCP_A3,MO:VA;0) 298.15 +3803.698+131.9197*T\n -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)\n -1.30927E-10*T**4; 2896 Y -19006.41+283.559746*T\n -42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N REF1 !\n PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE; 6000 N REF1 !\n PARAMETER G(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.95*T; 6000 N RM2013 !\n\n$ *** Warning: disordered fraction sets need manual editing!\n$ TYPE_DEFINITION 4 GES A_P_D SIGMA DIS_PART DIS_SIGMA !\n TYPE_DEFINITION 4 GES A_P_D SIGMA NEVER DIS_SIG !\n$ + Volume model P*V0(x)*exp(VA(x,T))\n PHASE SIGMA %4 5 2.000 4.000 8.000 8.000 8.000 !\n CONSTITUENT SIGMA :MO RE: MO RE: MO RE: MO RE: MO RE:!\n PARAMETER G(SIGMA,MO:MO:MO:MO:RE;0) 298.15 -336.420911*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:MO:RE:MO;0) 298.15 -338.810302*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:MO:RE:RE;0) 298.15 -350.940389*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:MO:MO;0) 298.15 -336.272469*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:MO:RE;0) 298.15 -348.274113*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:RE:MO;0) 298.15 -350.877403*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:RE:RE;0) 298.15 -361.705173*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:MO:MO;0) 298.15 -329.386161*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:MO:RE;0) 298.15 -341.899815*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:RE:MO;0) 298.15 -344.381107*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:RE:RE;0) 298.15 -355.892909*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:MO:MO;0) 298.15 -342.25167*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:MO:RE;0) 298.15 -353.543856*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:RE:MO;0) 298.15 -356.308695*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:RE:RE;0) 298.15 -366.47672*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:MO:MO;0) 298.15 -327.229897*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:MO:RE;0) 298.15 -340.042158*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:RE:MO;0) 298.15 -342.644194*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:RE:RE;0) 298.15 -354.494334*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:MO:MO;0) 298.15 -340.103152*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:MO:RE;0) 298.15 -351.792339*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:RE:MO;0) 298.15 -354.690887*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:RE:RE;0) 298.15 -365.120645*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:MO:MO;0) 298.15 -332.95143*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:MO:RE;0) 298.15 -345.245205*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:RE:MO;0) 298.15 -347.970121*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:RE:RE;0) 298.15 -359.220781*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:MO:MO;0) 298.15 -345.809448*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:MO:RE;0) 298.15 -356.822818*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:RE:MO;0) 298.15 -359.887484*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n\n$ disordered part\n PHASE DIS_SIG % 1 1.0 !\n CONSTITUENT DIS_SIG :MO RE: !\n$ Disordered fraction parameters:--------------------\n PARAMETER G(DIS_SIG,MO;0) 298.15 +GSIGMO-GSERMO+GHSERMO+1.251*T; 6000 N \n RM2013 !\n PARAMETER G(DIS_SIG,RE;0) 298.15 +GSIGRE-GSERRE+GHSERRE-1.205*T; 6000 N \n RM2013 !\n\n$ =================\n\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\nREF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), \n developed by SGTE (Scientific Group Thermodata Europe), 1991 \n -2008, and provided by TCSAB (Jan. 2008).'\nRM2013 '*** Not set by database or user'\nDFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase'\nDFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase'\n!\n" }, { "path": "examples/macros/MoRe1.PDB", "content": "$ Database file written by Open Calphad 2016-10-17\n\nELEMENT /- Electron_gas 0.0000E+00 0.0000E+00 0.0000E+00 !\nELEMENT VA Vaccum 0.0000E+00 0.0000E+00 0.0000E+00 !\nELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01 !\nELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01 !\n\n$ =================\n\nFUNCTION RTLNP 10 8.31451*R*LN(1.0D-5*P); 20000 N !\nFUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(+T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2896 Y -30556.41+283.559746*T-42.63829*T*LN(+T)-4.849315E+33*T**(-9); \n 5000 N !\nFUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(+T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y -15775.998\n +194.667426*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2400 Y -70882.739+462.110749*T-67.956*T*LN(+T)\n +.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1); 3458 Y +346325.888\n -1211.37186*T+140.831655*T*LN(+T)-.033764567*T**2+1.053726E-06*T**3\n -134548866*T**(-1); 5000 Y -78564.296+346.997842*T-49.519*T*LN(+T); \n 6000 N !\nFUNCTION EVTOJ 298.15 +96485.5547; 6000 N !\nFUNCTION GCHIRE 298.15 +G58CHIRE*UNS58; 6000 N !\nFUNCTION GCHIMO 298.15 +G58CHIMO*UNS58; 6000 N !\nFUNCTION GSIGRE 298.15 +G30SIGRE*UNS30; 6000 N !\nFUNCTION GSIGMO 298.15 +G30SIGMO*UNS30; 6000 N !\nFUNCTION GSERMO 298.15 -10.949432*EVTOJ; 6000 N !\nFUNCTION GSERRE 298.15 -12.4224915*EVTOJ; 6000 N !\nFUNCTION G58CHIMO 298.15 -619.36214*EVTOJ; 6000 N !\nFUNCTION UNS58 298.15 +CINQ8**(-1); 6000 N !\nFUNCTION G58CHIRE 298.15 -717.557146*EVTOJ; 6000 N !\nFUNCTION G30SIGMO 298.15 -323.477558*EVTOJ; 6000 N !\nFUNCTION UNS30 298.15 +TRENTE**(-1); 6000 N !\nFUNCTION G30SIGRE 298.15 -369.773611*EVTOJ; 6000 N !\nFUNCTION CINQ8 298.15 +58; 6000 N !\nFUNCTION TRENTE 298.15 +30; 6000 N !\n\n$ =================\n\n\n$ The proposed PDB format for model. CEF2 means CEF model with 2 sublattices\n$ The site ratios inside the parenthesis\n$ IMAGB means Inden's BCC model for magnetic ordering\n PHASE BCC_A2 CEF2( 1.000 3.000 ) IMAGB !\n CONSTITUENT BCC_A2 :MO RE: VA:!\n PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO; 5000 N REF1 !\n PARAMETER G(BCC_A2,RE:VA;0) 298.15 +9304.721+124.721589*T\n -24.348*T*LN(+T)-.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); \n 1200 Y +1224.002+190.967426*T-33.586*T*LN(+T)+.00224565*T**2\n -2.81835E-07*T**3+1376270*T**(-1); 2400 Y -53882.739+458.410749*T\n -67.956*T*LN(+T)+.01184945*T**2-7.88955E-07*T**3+18075200*T**(-1);\n 3458 Y +363325.888-1215.07186*T+140.831655*T*LN(+T)\n -.033764567*T**2+1.053726E-06*T**3-134548866*T**(-1); 5000 Y \n -61564.296+343.297842*T-49.519*T*LN(+T); 6000 N REF1 !\n PARAMETER G(BCC_A2,MO,RE:VA;0) 298.15 -15025+11.404*T; 6000 N RM2013 !\n PARAMETER G(BCC_A2,MO,RE:VA;1) 298.15 +8.07*T; 6000 N RM2013 !\n\n$ The N in CEF4N means disordered a contribution. All sublattices are added\n$ together for the disordered part and the ordered part as disordered\n$ is not subtracted.\n PHASE CHI CEF4N( 2.000 8.000 24.000 24.000 ) !\n CONSTITUENT CHI :MO RE: MO RE: MO RE: MO RE:!\n PARAMETER G(CHI,MO:MO:MO:RE;0) 298.15 -667.0576*EVTOJ-2*GCHIMO-8*GCHIMO\n -24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:MO:RE:MO;0) 298.15 -662.013824*EVTOJ-2*GCHIMO\n -8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:MO:RE:RE;0) 298.15 -706.53129*EVTOJ-2*GCHIMO\n -8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:MO:MO;0) 298.15 -630.436204*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:MO:RE;0) 298.15 -676.652914*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:RE:MO;0) 298.15 -672.07236*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,MO:RE:RE:RE;0) 298.15 -715.47601*EVTOJ-2*GCHIMO\n -8*GCHIRE-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:MO:MO;0) 298.15 -621.992644*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:MO:RE;0) 298.15 -669.426922*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:RE:MO;0) 298.15 -664.700708*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:MO:RE:RE;0) 298.15 -708.864342*EVTOJ\n -2*GCHIRE-8*GCHIMO-24*GCHIRE-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:MO:MO;0) 298.15 -632.902352*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIMO; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:MO:RE;0) 298.15 -678.636738*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIMO-24*GCHIRE; 6000 N DFTCHI !\n PARAMETER G(CHI,RE:RE:RE:MO;0) 298.15 -674.442674*EVTOJ\n -2*GCHIRE-8*GCHIRE-24*GCHIRE-24*GCHIMO; 6000 N DFTCHI !\n$ Disordered fraction parameters:--------------------\n PARAMETER GD(CHI,MO;0) 298.15 +GCHIMO-GSERMO+GHSERMO-0.5596*T; 6000 N \n RM2013 !\n PARAMETER GD(CHI,RE;0) 298.15 +GCHIRE-GSERRE+GHSERRE+.0905*T; 6000 N \n RM2013 !\n\n$ Nothing special here\n PHASE HCP_A3 CEF2( 1.000 0.500 ) IMAGF !\n CONSTITUENT HCP_A3 :MO RE: VA:!\n PARAMETER G(HCP_A3,MO:VA;0) 298.15 +3803.698+131.9197*T\n -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)\n -1.30927E-10*T**4; 2896 Y -19006.41+283.559746*T\n -42.63829*T*LN(+T)-4.849315E+33*T**(-9); 5000 N REF1 !\n PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE; 6000 N REF1 !\n PARAMETER G(HCP_A3,MO,RE:VA;0) 298.15 +12740+1.95*T; 6000 N RM2013 !\n\n$ The model SUBRKM means substitution model with Redlich-Kister binary excess\n$ and_Muggianu ternary extrapolation.\n PHASE LIQUID SUBRKM !\n CONSTITUENT LIQUID :MO RE:!\n PARAMETER G(LIQUID,MO;0) 298.15 +34085.045+117.224788*T\n -23.56414*T*LN(+T)-.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)\n -1.30927E-10*T**4+4.24519E-22*T**7; 2896 Y +3538.963+271.6697*T\n -42.63829*T*LN(+T); 5000 N REF1 !\n PARAMETER G(LIQUID,RE;0) 298.15 +16125.604+122.076209*T-24.348*T*LN(+T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y +8044.885\n +188.322047*T-33.586*T*LN(+T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2000 Y +568842.665-2527.83846*T\n +314.178898*T*LN(+T)-.08939817*T**2+3.92854E-06*T**3\n -163100987*T**(-1); 3458 Y -39044.888+335.723691*T\n -49.519*T*LN(+T); 6000 N REF1 !\n PARAMETER G(LIQUID,MO,RE;0) 298.15 -15025+11.404*T-2610; 6000 N RM2013 !\n PARAMETER G(LIQUID,MO,RE;1) 298.15 +8.07*T-7790; 6000 N RM2013 !\n\n$ This model is the same as for the CHI_PHASE but with 5 sublattices\n PHASE SIGMA CEF5N( 2.000 4.000 8.000 8.000 8.000) !\n CONSTITUENT SIGMA :MO RE: MO RE: MO RE: MO RE: MO RE:!\n PARAMETER G(SIGMA,MO:MO:MO:MO:RE;0) 298.15 -336.420911*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:MO:RE:MO;0) 298.15 -338.810302*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:MO:RE:RE;0) 298.15 -350.940389*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:MO:MO;0) 298.15 -336.272469*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:MO:RE;0) 298.15 -348.274113*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:RE:MO;0) 298.15 -350.877403*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:MO:RE:RE:RE;0) 298.15 -361.705173*EVTOJ-2*GSIGMO\n -4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:MO:MO;0) 298.15 -329.386161*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:MO:RE;0) 298.15 -341.899815*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:RE:MO;0) 298.15 -344.381107*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:MO:RE:RE;0) 298.15 -355.892909*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:MO:MO;0) 298.15 -342.25167*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:MO:RE;0) 298.15 -353.543856*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:RE:MO;0) 298.15 -356.308695*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,MO:RE:RE:RE:RE;0) 298.15 -366.47672*EVTOJ-2*GSIGMO\n -4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:MO:MO;0) 298.15 -327.229897*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:MO:RE;0) 298.15 -340.042158*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:RE:MO;0) 298.15 -342.644194*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:MO:RE:RE;0) 298.15 -354.494334*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:MO:MO;0) 298.15 -340.103152*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:MO:RE;0) 298.15 -351.792339*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:RE:MO;0) 298.15 -354.690887*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:MO:RE:RE:RE;0) 298.15 -365.120645*EVTOJ\n -2*GSIGRE-4*GSIGMO-8*GSIGRE-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:MO:MO;0) 298.15 -332.95143*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:MO:RE;0) 298.15 -345.245205*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:RE:MO;0) 298.15 -347.970121*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:MO:RE:RE;0) 298.15 -359.220781*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGMO-8*GSIGRE-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:MO:MO;0) 298.15 -345.809448*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGMO; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:MO:RE;0) 298.15 -356.822818*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGMO-8*GSIGRE; 6000 N DFTSIG !\n PARAMETER G(SIGMA,RE:RE:RE:RE:MO;0) 298.15 -359.887484*EVTOJ\n -2*GSIGRE-4*GSIGRE-8*GSIGRE-8*GSIGRE-8*GSIGMO; 6000 N DFTSIG !\n$ Disordered fraction parameters:--------------------\n PARAMETER GD(SIGMA,MO;0) 298.15 +GSIGMO-GSERMO+GHSERMO+1.251*T; 6000 N \n RM2013 !\n PARAMETER GD(SIGMA,RE;0) 298.15 +GSIGRE-GSERRE+GHSERRE-1.205*T; 6000 N \n RM2013 !\n\n$ =================\n\n\nBIBLIOGRAPHY\nDUMMY 'OC BUG not reading first line ...'\nREF1 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6), \n developed by SGTE (Scientific Group Thermodata Europe), 1991\n -2008, and provided by TCSAB (Jan. 2008).'\nDFTCHI 'JC Crivello 2012 march, Armide project v1.13 chi phase'\nRM2013 '*** Not set by database or user'\nDFTSIG 'JC Crivello 2012 march, Armide project v1.9 sigma phase'\n!\n" }, { "path": "examples/macros/OU.TDB", "content": "\n$ Database file written 2013- 3-10\n$ From database: USER \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT O GAS_1/2_MOLE_O2 1.5999E+01 4.3410E+03 1.0252E+02!\n ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 6.3640E+03 5.0200E+01!\n \n SPECIES O-2 O1/-2!\n SPECIES O2 O2!\n SPECIES O3 O3!\n SPECIES U+3 U1/+3!\n SPECIES U+4 U1/+4!\n SPECIES U+5 U1/+5!\n SPECIES UO O1U1!\n SPECIES UO2 O2U1!\n SPECIES UO3 O3U1!\n \n FUNCTION OGAS 298.15 +243206.494-20.8612587*T-21.01555*T*LN(T)\n +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2950 Y\n +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2\n +7.64520667E-09*T**3-3973170.5*T**(-1); 6000 N !\n FUNCTION O2GAS 298.15 -6960.69252-51.1831473*T-22.25862*T*LN(T)\n -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y\n -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2\n +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y\n +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2\n +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y\n -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2\n -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y\n -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3\n +.25153895*T**(-1); 2.00000E+04 N !\n FUNCTION O3GAS 298.15 +130696.944-37.9096651*T-27.58118*T*LN(T)\n -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 4.00000E+02 Y\n +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2\n -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y\n +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2\n -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y\n +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2\n +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y\n +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2\n +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y\n -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2\n -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y\n +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2\n -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6000 N !\n FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.136*T*LN(T)\n -.005098888*T**2+6.61846E-07*T**3-38365*T**(-1); 1.00000E+03 Y\n -6568.763+12.65988*T-16.8138*T*LN(T)-5.95798E-04*T**2+6.781E-09*T**3\n +262905*T**(-1); 3.30000E+03 Y\n -13986.728+31.259625*T-18.9536*T*LN(T)-4.25243E-04*T**2\n +1.0721E-08*T**3+4383200*T**(-1); 6000 N !\n FUNCTION GASU 298.15 +523164.925+13.603288*T-32.513*T*LN(T)\n +.01126565*T**2-2.43328E-06*T**3+151130*T**(-1); 9.00000E+02 Y\n +541065.13-173.693179*T-5.336*T*LN(T)-.00723615*T**2-4.306E-08*T**3\n -2072960*T**(-1); 2.10000E+03 Y\n +605452.662-512.542339*T+38.748*T*LN(T)-.0208079*T**2+7.5045E-07*T**3\n -19886375*T**(-1); 4.50000E+03 Y\n -41328.1657+1300.29089*T-176.856*T*LN(T)+.0113664*T**2\n -1.56178333E-07*T**3+3.4654725E+08*T**(-1); 9.20000E+03 Y\n +410972.67+537.324611*T-92.012*T*LN(T)+.0043702*T**2\n -4.90033333E-08*T**3-99572850*T**(-1); 1.20000E+04 N !\n FUNCTION GLIQUU 298.15 +3947.766+120.631251*T-26.9182*T*LN(T)\n +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y\n -10166.3+281.797193*T-48.66*T*LN(T); 3.00000E+03 N !\n FUNCTION GFCCUU 298.15 -3407.734+130.955151*T-26.9182*T*LN(T)\n +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y\n -17521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N !\n FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T)\n -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1.04900E+03 Y\n -4698.365+202.685635*T-38.2836*T*LN(T); 3.00000E+03 N !\n FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T)\n +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y\n -22521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N !\n FUNCTION GTETUU 298.15 -5156.136+106.976316*T-22.841*T*LN(T)\n -.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 9.41500E+02 Y\n -14327.309+244.16802*T-42.9278*T*LN(T); 3.00000E+03 N !\n FUNCTION UOGAS 298.15 +7058.467+16.66929*T-38.48092*T*LN(T)\n -.01650935*T**2+6.74198333E-06*T**3-1.22913333E-09*T**4+257767*T**(-1); \n 1.30000E+03 Y\n +10617.823+76.4054808*T-50.04939*T*LN(T)+.0090553*T**2\n -2.0628666E-06*T**3+1.42865E-10*T**4-1254735*T**(-1); 4.00000E+03 N !\n FUNCTION UO2GAS 298.15 -477055.313+30.72281*T-44.35744*T*LN(T)\n -.018817925*T**2+3.85927167E-06*T**3-4.58556667E-10*T**4\n +37425.465*T**(-1); 1.50000E+03 Y\n -483042.479+128.845816*T-59.57586*T*LN(T)-.0026962*T**2\n -1.57719683E-08*T**3+8.57269167E-12*T**4+315972.55*T**(-1); 4000 N !\n FUNCTION UO3GAS 298.15 -813296.059+27.9636972*T-46.69199*T*LN(T)\n -.047347135*T**2+1.58195017E-05*T**3-2.84654167E-09*T**4\n +139692.15*T**(-1); 9.00000E+02 Y\n -827058.826+248.932783*T-81.70962*T*LN(T)-.001004739*T**2\n +1.85084167E-07*T**3-1.8022825E-11*T**4+1290177.5*T**(-1); 4000 N !\n FUNCTION LOWLIQ 298.15 +G4OV#+79775-25.0114*T-2.62269566E-21*T**7;\n 2.60000E+03 N !\n FUNCTION O2ULIQ 298.15 -1590418+3618.8*T-480*T*LN(T)+.07*T**2\n -1E-06*T**3; 6000 N !\n FUNCTION G3OO 298.15 +G3OV#+GHSEROO#; 6000 N !\n FUNCTION G4OO 298.15 +G4OV#+GHSEROO#; 6000 N !\n FUNCTION G5OO 298.15 +G5OV#+GHSEROO#; 6000 N !\n FUNCTION G3OV 298.15 +G4OV#-G4VV#+G3VV#; 6000 N !\n FUNCTION G4OV 298.15 +GUO2#; 6000 N !\n FUNCTION G5OV 298.15 +GUO25#-.5*GHSEROO#+.69315*R#*T; 6000 N !\n FUNCTION G3VV 298.15 +GUO15#-1.5*GHSEROO#+1.12467*R#*T; 6000 N !\n FUNCTION G4VV 298.15 +G4OV#-2*GHSEROO#+545210.5; 6000 N !\n FUNCTION G5VV 298.15 +G5OV#-2*GHSEROO#+700000; 6000 N !\n FUNCTION GU3O8 298.15 -3674804.49+1600.50059*T\n -276.747749*T*LN(T)-.0136644165*T**2+2036667.44*T**(-1); 2000 N !\n FUNCTION GU4O9 298.15 -4621329.3+1786.83274*T-311.20912*T*LN(T)\n -.0311301013*T**2+1741269.49*T**(-1); 2.00000E+03 N !\n FUNCTION GUO15 298.15 +GUO2#-.5*GHSEROO#+747127-70.22618*T; 6000 N !\n FUNCTION GUO2 298.15 -1118940.2+554.00559*T-93.268*T*LN(T)\n +.0101704254*T**2-2.03335671E-06*T**3+1091073.7*T**(-1); 6000 N !\n FUNCTION GUO25 298.15 +GUO2#+.5*GHSEROO#-58351.62+39.67611*T; 6000 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE GAS:G % 1 1.0 !\n CONSTITUENT GAS:G :O,O2,O3,U,UO,UO2,UO3 : !\n\n PARAMETER G(GAS,O;0) 298.15 +OGAS#+RTLNP#; 6000 N REF174 !\n PARAMETER G(GAS,O2;0) 298.15 +O2GAS#+RTLNP#; 6000 N REF175 !\n PARAMETER G(GAS,O3;0) 298.15 +O3GAS#+RTLNP#; 6000 N REF176 !\n PARAMETER G(GAS,U;0) 298.15 +GASU#+RTLNP#; 6000 N REF160 !\n PARAMETER G(GAS,UO;0) 298.15 +UOGAS#+RTLNP#; 6000 N REF208 !\n PARAMETER G(GAS,UO2;0) 298.15 +UO2GAS#+RTLNP#; 6000 N REF209 !\n PARAMETER G(GAS,UO3;0) 298.15 +UO3GAS#+RTLNP#; 6000 N REF210 !\n\n\n PHASE IONIC_LIQUID:Y % 2 6 4 !\n CONSTITUENT IONIC_LIQUID:Y :U+4 : O-2,VA,O : !\n\n PARAMETER G(IONIC_LIQUID,U+4:O-2;0) 298.15 +2*LOWLIQ#; 2.60000E+03 Y\n +2*O2ULIQ#; 6000 N REF425 !\n PARAMETER G(IONIC_LIQUID,U+4:VA;0) 298.15 +GLIQUU#; 6000 N REF10 !\n PARAMETER G(IONIC_LIQUID,O;0) 298.15 +GHSEROO#-2648.9+31.44*T; \n 6000 N REF10 !\n PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;0) 298.15 +1773475.9-516*T; \n 6000 N REF425 !\n PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;1) 298.15 +46774.9-120.37888*T;\n 6000 N REF425 !\n PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;2) 298.15 -500000; 6000 N REF425 !\n PARAMETER G(IONIC_LIQUID,U+4:O-2,O;0) 298.15 -370000; 6000 N REF425 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :U : O,VA% : !\n\n PARAMETER G(BCC_A2,U:O;0) 298.15 +GBCCUU#+GHSEROO#+100000; 6000 N REF70 !\n PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 6000 N REF10 !\n\n\n PHASE C1_MO2 % 3 1 2 1 !\n CONSTITUENT C1_MO2 :U+3,U+4%,U+5 : O-2%,VA : O-2,VA% : !\n\n PARAMETER G(C1_MO2,U+3:O-2:O-2;0) 298.15 +G3OO#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+4:O-2:O-2;0) 298.15 +G4OO#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+5:O-2:O-2;0) 298.15 +G5OO#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+3:VA:O-2;0) 298.15 100000; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+4:VA:O-2;0) 298.15 100000; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+5:VA:O-2;0) 298.15 100000; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+3:O-2:VA;0) 298.15 +G3OV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+4:O-2:VA;0) 298.15 +G4OV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+5:O-2:VA;0) 298.15 +G5OV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+3:VA:VA;0) 298.15 +G3VV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+4:VA:VA;0) 298.15 +G4VV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+5:VA:VA;0) 298.15 +G5VV#; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+4,U+5:O-2:O-2;0) 298.15 -124936.9-21.6838*T; \n 6000 N REF425 !\n PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;0) 298.15 40133.7; 6000 N REF425 !\n PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;1) 298.15 1076.4; 6000 N REF425 !\n\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :U : O,VA : !\n\n PARAMETER G(FCC_A1,U:O;0) 298.15 -504526+100*T+GHSEROO#+GHSERUU#; \n 6000 N REF0 !\n PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3.00000E+03 N REF10 !\n\n\n PHASE ORTHORHOMBIC_A20 % 1 1.0 !\n CONSTITUENT ORTHORHOMBIC_A20 :U% : !\n\n PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 4.00000E+03 N REF10 !\n\n\n PHASE TETRAGONAL_U % 1 1.0 !\n CONSTITUENT TETRAGONAL_U :U% : !\n\n PARAMETER G(TETRAGONAL_U,U;0) 298.15 +GTETUU#; 3.00000E+03 N REF10 !\n\n\n PHASE U3O8_S1 % 2 8 3 !\n CONSTITUENT U3O8_S1 :O : U : !\n\n PARAMETER G(U3O8_S1,O:U;0) 298.15 +GU3O8#; 6000 N REF425 !\n\n\n PHASE U3O8_S2 % 2 8 3 !\n CONSTITUENT U3O8_S2 :O : U : !\n\n PARAMETER G(U3O8_S2,O:U;0) 298.15 +GU3O8#+135-.279503106*T; 6000 N REF212 !\n\n\n PHASE U3O8_S3 % 2 8 3 !\n CONSTITUENT U3O8_S3 :O : U : !\n\n PARAMETER G(U3O8_S3,O:U;0) 298.15 +GU3O8#+283-.540066486*T; 6000 N REF212 !\n\n\n PHASE U3O8_S4 % 2 8 3 !\n CONSTITUENT U3O8_S4 :O : U : !\n\n PARAMETER G(U3O8_S4,O:U;0) 298.15 +GU3O8#+597-.918379739*T; 6000 N REF212 !\n\n\n PHASE U4O9_S1 % 2 9 4 !\n CONSTITUENT U4O9_S1 :O : U : !\n\n PARAMETER G(U4O9_S1,O:U;0) 298.15 +GU4O9#; 6000 N REF425 !\n\n\n PHASE U4O9_S2 % 2 9 4 !\n CONSTITUENT U4O9_S2 :O : U : !\n\n PARAMETER G(U4O9_S2,O:U;0) 298.15 +GU4O9#+2594-7.45402299*T; 6000 N REF213 !\n\n\n PHASE U4O9_S3 % 2 9 4 !\n CONSTITUENT U4O9_S3 :O : U : !\n\n PARAMETER G(U4O9_S3,O:U;0) 298.15 +GU4O9#+2684.25-7.5602*T; 6000 N REF213 !\n\n\n PHASE UO3 % 2 3 1 !\n CONSTITUENT UO3 :O : U : !\n\n PARAMETER G(UO3,O:U;0) 298.15 -1260394.62+616.475675*T\n -105.7368*T*LN(T)+.0104274*T**2-3.18099167E-06*T**3+868736*T**(-1); \n 3.00000E+03 N REF211 !\n\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF174 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN , from SSUB'\n REF175 'O2 T.C.R.A.S. Class: 1 OXYGEN , from SSUB'\n REF176 'O3 T.C.R.A.S. Class: 4 OZONE , from SSUB'\n REF10 'A T Dinsdale, SGTE Data for Pure Elements, Calphad 15(1991)4 p \n 317-425; also in NPL Report DMA(A)195 Rev. August 1990'\n REF160 'U1 T.C.R.A.S Class: 4 Data provided by T.C.R.A.S. in 2000, \n from SSUB'\n REF208 'O1U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, \n from SSUB, different of Tbase'\n REF209 'O2U1 T.C.R.A.S. Class: 6 URANIUM DIOXIDE , from SSUB, \n slightly different of Tbase'\n REF210 'O3U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, \n from SSUB, different of Tbase'\n REF425 'C. Guéneau, N. Dupin, B. Sundman, C. Martial, J.-C. Dumas, S. \n Gossé,2 S. Chatain, F. De Bruycker, D. Manara, R.J.M. Konings, J. \n Nucl. Mat. 419 (1-3), 145-167 (2011); C-O-Pu-U'\n REF70 'fixing some parameters of low importance'\n REF211 'O3U1 T.C.R.A.S. Class: 7 URANIUM TRIOXIDE, from SSUB'\n REF212 'SSUB 3-URANIUM 8-OXIDE : M.H.Rand March 1994, taken from \n Cordfunke. In the fuelbase, the expression relative to the alpha \n form has been kept identical to SSUB for the higher temperatures \n forms but the alpha form expression has been modified in 11GUE'\n REF213 'SSUB 4-URANIUM 9-OXIDE : M.H.Rand March 1994, taken from \n Cordfunke. In the fuelbase, the expression relative to the alpha \n form has been kept identical to SSUB for beta and to 08GUE for \n gamma but the alpha form expression has been modified in 11GUE'\n ! \n \n" }, { "path": "examples/macros/SGTE-unary1991-2010.TDB", "content": "\n$ Database file written 2021- 5- 4\n$ From database: PURE5 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AC 1_MOLE_AC(AC_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01!\n ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01!\n ELEMENT AM DHCP 2.4306E+02 0.0000E+00 0.0000E+00!\n ELEMENT AR 1_MOLE_AR(GAS) 3.9948E+01 0.0000E+00 3.6982E+01!\n ELEMENT AS RHOMBOHEDRAL_A7 7.4922E+01 0.0000E+00 0.0000E+00!\n ELEMENT AT 1/2_MOLE_AT2(AT2_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AU FCC_A1 1.9697E+02 6.0166E+03 4.7488E+01!\n ELEMENT B BETA_RHOMBO_B 1.0811E+01 1.2220E+03 5.9000E+00!\n ELEMENT BA BCC_A2 1.3733E+02 0.0000E+00 0.0000E+00!\n ELEMENT BE HCP_A3 9.0122E+00 0.0000E+00 0.0000E+00!\n ELEMENT BI RHOMBOHEDRAL_A7 2.0898E+02 6.4266E+03 5.6735E+01!\n ELEMENT BR 1/2_MOLE_BR2(LIQ) 7.9904E+01 1.2260E+04 7.6105E+01!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT CA FCC_A1 4.0078E+01 6.1965E+03 4.1589E+01!\n ELEMENT CD HCP_A3 1.1241E+02 6.2509E+03 5.1798E+01!\n ELEMENT CE FCC_A1 1.4011E+02 0.0000E+00 0.0000E+00!\n ELEMENT CF 1_MOLE_CF(CF_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT CL 1/2_MOLE_CL2(GAS) 3.5453E+01 4.5900E+03 1.1148E+02!\n ELEMENT CM 1_MOLE_CM(CM_S) 2.4700E+02 0.0000E+00 1.7200E+01!\n ELEMENT CO HCP_A3 5.8933E+01 0.0000E+00 0.0000E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT CS BCC_A2 1.3291E+02 7.7153E+03 8.5149E+01!\n ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01!\n ELEMENT D 1/2_MOLE_D2_GAS 2.0140E+00 0.0000E+00 1.7310E+01!\n ELEMENT DY HCP_A3 1.6250E+02 0.0000E+00 0.0000E+00!\n ELEMENT ER HCP_A3 1.6726E+02 7.3923E+03 7.3178E+01!\n ELEMENT ES 1_MOLE_ES(ES_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT EU BCC_A2 1.5197E+02 0.0000E+00 8.0793E+01!\n ELEMENT F 1/2_MOLE_F2(GAS) 1.8998E+01 4.4125E+03 1.0134E+02!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT FM 1_MOLE_FM(FM_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT FR 1_MOLE_FR(FR_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT GA ORTHORHOMBIC_GA 6.9723E+01 5.5731E+03 4.0828E+01!\n ELEMENT GD HCP_A3 1.5725E+02 0.0000E+00 0.0000E+00!\n ELEMENT GE DIAMOND_A4 7.2610E+01 4.6275E+03 3.1087E+01!\n ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01!\n ELEMENT HE 1_MOLE_HE(GAS) 4.0026E+00 0.0000E+00 3.0124E+01!\n ELEMENT HF HCP_A3 1.7849E+02 0.0000E+00 0.0000E+00!\n ELEMENT HG LIQUID 2.0059E+02 0.0000E+00 0.0000E+00!\n ELEMENT HO HCP_A3 1.6493E+02 0.0000E+00 0.0000E+00!\n ELEMENT I 1/2_MOLE_I2(I2_S) 1.2690E+02 6.5980E+03 1.1614E+02!\n ELEMENT IN TETRAGONAL_A6 1.1482E+02 6.6100E+03 5.7650E+01!\n ELEMENT IR FCC_A1 1.9222E+02 5.2677E+03 3.5505E+01!\n ELEMENT K BCC_A2 3.9098E+01 7.0835E+03 6.4672E+01!\n ELEMENT KR 1_MOLE_KR(GAS) 8.3800E+01 0.0000E+00 3.9191E+01!\n ELEMENT LA DHCP 1.3891E+02 0.0000E+00 0.0000E+00!\n ELEMENT LI BCC_A2 6.9410E+00 4.6233E+03 2.9095E+01!\n ELEMENT LU HCP_A3 1.7497E+02 0.0000E+00 0.0000E+00!\n ELEMENT MG HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01!\n ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT N 1/2_MOLE_N2(GAS) 1.4007E+01 4.3350E+03 9.5751E+01!\n ELEMENT NA BCC_A2 2.2990E+01 6.4475E+03 5.1447E+01!\n ELEMENT NB BCC_A2 9.2906E+01 5.2200E+03 3.6270E+01!\n ELEMENT ND DHCP 1.4424E+02 0.0000E+00 0.0000E+00!\n ELEMENT NE 1_MOLE_NE(GAS) 2.0179E+01 0.0000E+00 3.4947E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n ELEMENT NP ORTHORHOMBIC_AC 2.3705E+02 0.0000E+00 0.0000E+00!\n ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02!\n ELEMENT OS HCP_A3 1.9020E+02 0.0000E+00 3.2635E+01!\n ELEMENT P WHITE_P 3.0974E+01 0.0000E+00 0.0000E+00!\n ELEMENT PA BCT_AA 2.3104E+02 0.0000E+00 0.0000E+00!\n ELEMENT PB FCC_A1 2.0720E+02 6.8785E+03 6.4785E+01!\n ELEMENT PD FCC_A1 1.0642E+02 5.4685E+03 3.7823E+01!\n ELEMENT PM 1_MOLE_PM(PM_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT PO 1_MOLE_PO(PO_S) 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT PR DHCP 1.4091E+02 0.0000E+00 0.0000E+00!\n ELEMENT PT FCC_A1 1.9508E+02 5.7237E+03 4.1631E+01!\n ELEMENT PU ALPHA_PU 2.4406E+02 0.0000E+00 0.0000E+00!\n ELEMENT RA 1_MOLE_RA(RA_S) 2.2603E+02 0.0000E+00 0.0000E+00!\n ELEMENT RB BCC_A2 8.5468E+01 7.4894E+03 7.6776E+01!\n ELEMENT RE HCP_A3 1.8621E+02 5.3555E+03 3.6526E+01!\n ELEMENT RH FCC_A1 1.0291E+02 4.9204E+03 3.1505E+01!\n ELEMENT RN 1_MOLE_RN(GAS) 2.2200E+02 0.0000E+00 4.2100E+01!\n ELEMENT RU HCP_A3 1.0107E+02 4.6024E+03 2.8535E+01!\n ELEMENT S ORTHORHOMBIC_S 3.2066E+01 0.0000E+00 0.0000E+00!\n ELEMENT SB RHOMBOHEDRAL_A7 1.2175E+02 5.8702E+03 4.5522E+01!\n ELEMENT SC HCP_A3 4.4956E+01 0.0000E+00 0.0000E+00!\n ELEMENT SE HEXAGONAL_A8 7.8960E+01 5.5145E+03 4.1966E+01!\n ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01!\n ELEMENT SM RHOMBOHEDRAL_C19 1.5036E+02 0.0000E+00 0.0000E+00!\n ELEMENT SN BCT_A5 1.1871E+02 6.3220E+03 5.1195E+01!\n ELEMENT SR FCC_A1 8.7620E+01 0.0000E+00 0.0000E+00!\n ELEMENT T 1/2_MOLE_T2(GAS) 3.0160E+00 0.0000E+00 0.0000E+00!\n ELEMENT TA BCC_A2 1.8095E+02 5.6819E+03 4.1472E+01!\n ELEMENT TB HCP_A3 1.5893E+02 0.0000E+00 0.0000E+00!\n ELEMENT TC HCP_A3 9.7907E+01 0.0000E+00 0.0000E+00!\n ELEMENT TE HEXAGONAL_A8 1.2760E+02 6.1212E+03 4.9497E+01!\n ELEMENT TH FCC_A1 2.3204E+02 0.0000E+00 0.0000E+00!\n ELEMENT TI HCP_A3 4.7880E+01 4.8100E+03 3.0648E+01!\n ELEMENT TL HCP_A3 2.0438E+02 6.8283E+03 6.4183E+01!\n ELEMENT TM HCP_A3 1.6893E+02 7.3973E+03 7.4015E+01!\n ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 0.0000E+00 0.0000E+00!\n ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01!\n ELEMENT W BCC_A2 1.8385E+02 4.9700E+03 3.2620E+01!\n ELEMENT XE 1_MOLE_XE(GAS) 1.3129E+02 0.0000E+00 4.0519E+01!\n ELEMENT Y HCP_A3 8.8906E+01 0.0000E+00 0.0000E+00!\n ELEMENT YB FCC_A1 1.7304E+02 0.0000E+00 0.0000E+00!\n ELEMENT ZN HCP_A3 6.5390E+01 5.6568E+03 4.1631E+01!\n ELEMENT ZR HCP_A3 9.1224E+01 5.5663E+03 3.9181E+01!\n \n SPECIES AT2 AT2!\n SPECIES BR2 BR2!\n SPECIES CL2 CL2!\n SPECIES D2 D2!\n SPECIES F2 F2!\n SPECIES FR2 FR2!\n SPECIES H2 H2!\n SPECIES I2 I2!\n SPECIES N2 N2!\n SPECIES O2 O2!\n SPECIES S2 S2!\n SPECIES T2 T2!\n SPECIES T3 T3!\n SPECIES XE2 XE2!\n \n \n FUNCTION GHSERAC 298.15 -7572.61519+100.596131*T-23.799*T*LN(T)\n -.00536685*T**2-20*T**(-1); 1323 Y\n -22258.8152+235.419006*T-42*T*LN(T); 5000 N !\n FUNCTION GGASAC1 298.15 +394647.668-60.6626295*T-19.162*T*LN(T)\n +.00210035*T**2-3.30984E-06*T**3-52110*T**(-1); 500 Y\n +404538.095-237.073904*T+8.974*T*LN(T)-.0333095*T**2\n +5.00220167E-06*T**3-701330*T**(-1); 900 Y\n +361650.543+216.644574*T-56.947*T*LN(T)+.0117893*T**2\n -7.96733333E-07*T**3+4533895*T**(-1); 1700 Y\n +407253.396-43.3903783*T-22.778*T*LN(T)+6.1595E-04*T**2\n -1.2757E-07*T**3-6712740*T**(-1); 3300 Y\n +448231.858-220.95179*T-.374*T*LN(T)-.0047424005*T**2\n +1.09546667E-07*T**3-20498780*T**(-1); 6000 N !\n FUNCTION GLIQAG 298.15 +GHSERAG#+11025.076-8.89102*T-1.033905E-20*T**7;\n 1234.93 Y\n -3587.111+180.964656*T-33.472*T*LN(T); 3000 N !\n FUNCTION GHSERAG 298.15 -7209.512+118.202013*T-23.8463314*T*LN(T)\n -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1234.93 Y\n -15095.252+190.266404*T-33.472*T*LN(T)+1.411773E+29*T**(-9); 3000 N !\n FUNCTION GBCCAG 298.15 +GHSERAG#+3400-1.05*T; 3000 N !\n FUNCTION GHCPAG 298.15 +GHSERAG#+300+.3*T; 3000 N !\n FUNCTION GLIQAL 298.15 +GHSERAL#+11005.045-11.84185*T+7.9337E-20*T**7;\n 933.47 Y\n -795.991+177.430209*T-31.748192*T*LN(T); 2900 N !\n FUNCTION GHSERAL 298.15 -7976.15+137.093038*T-24.3671976*T*LN(T)\n -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 700 Y\n -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2\n -5.764227E-06*T**3+74092*T**(-1); 933.47 Y\n -11278.361+188.684136*T-31.748192*T*LN(T)-1.230622E+28*T**(-9); 2900 N\n !\n FUNCTION GBCCAL 298.15 +GHSERAL#+10083-4.813*T; 2900 N !\n FUNCTION GHCPAL 298.15 +GHSERAL#+5481-1.8*T; 2900 N !\n FUNCTION GLIQAM 298.15 +GHSERAM#+19910.7-14.1205*T; 3000 N !\n FUNCTION GFCCAM 298.15 -5224.899+99.204329*T-23.1377*T*LN(T)\n -.00294694*T**2-6.64773E-07*T**3-18507*T**(-1); 1018 Y\n -2935.853+73.800069*T-19.4406*T*LN(T)-.005418*T**2-3.75233E-07*T**3\n -260435*T**(-1); 1548.70 Y\n -22179.593+241.353807*T-41.84*T*LN(T); 3000 N !\n FUNCTION GBCCAM 298.15 -665.396+85.114354*T-21.1868*T*LN(T)\n -.0055995*T**2-5.41033E-07*T**3-30424*T**(-1); 999 Y\n -7800.332+63.93115*T-15.8832*T*LN(T)-.0190671*T**2+2.291117E-06*T**3\n +2287195*T**(-1); 1339 Y\n -13153.887+219.600832*T-39.748*T*LN(T); 1449 Y\n +70352.138-326.394464*T+33.413*T*LN(T)-.02736485*T**2\n +1.801717E-06*T**3-17379450*T**(-1); 2183.60 Y\n -16925.244+237.367028*T-41.84*T*LN(T); 3000 N !\n FUNCTION GHSERAM 298.15 -6639.201+89.645685*T-21.1868*T*LN(T)\n -.00559955*T**2-5.41038E-07*T**3-30424*T**(-1); 1329 Y\n -21702.938+241.107269*T-41.84*T*LN(T); 3000 N !\n FUNCTION GHSERAR 298.15 -6197.37857-15.6250184*T-20.78611*T*LN(T); 6000 N\n !\n FUNCTION GLIQAS 298.15 +GHSERAS#+24442.9-22.424679*T; 1200 N !\n FUNCTION GFCCAS 298.15 +GHSERAS#+24874-14.74*T; 1200 N !\n FUNCTION GBCCAS 298.15 +GHSERAS#+24874-16.1*T; 1200 N !\n FUNCTION GHCPAS 298.15 +GHSERAS#+24874-14*T; 1200 N !\n FUNCTION GHSERAS 298.15 -7270.447+122.211069*T-23.3144*T*LN(T)\n -.00271613*T**2+11600*T**(-1); 1090 Y\n -10454.913+163.457433*T-29.216037*T*LN(T); 1200 N !\n FUNCTION GHSERAT 298.15 +.5*GSOLAT2#; 1000 N !\n FUNCTION GGASAT1 298.15 +107251.654-47.8507551*T-20.786*T*LN(T); 2200 Y\n +106809.233-44.861522*T-21.185*T*LN(T)+1.413E-04*T**2\n -8.74833333E-09*T**3+68430*T**(-1); 6000 N !\n FUNCTION GGASAT2 298.15 +98748.2165-26.3818276*T-37.39*T*LN(T)\n -3.393E-04*T**2-7.28666667E-08*T**3+10425*T**(-1); 1400 Y\n +90660.8304+12.5493655*T-42.258*T*LN(T)+2.9515E-04*T**2\n +9.71333333E-09*T**3+2088660*T**(-1); 3200 Y\n +93624.973-9.03098507*T-39.433*T*LN(T)-5.026E-04*T**2\n +4.55333333E-08*T**3+2495695*T**(-1); 6000 N !\n FUNCTION GLIQAU 298.15 +GHSERAU#+12552-9.385866*T; 3200 N !\n FUNCTION GHSERAU 298.15 -6938.856+106.830098*T-22.75455*T*LN(T)\n -.00385924*T**2+3.79625E-07*T**3-25097*T**(-1); 929.40 Y\n -93586.481+1021.69543*T-155.706745*T*LN(T)+.08756015*T**2\n -1.1518713E-05*T**3+10637210*T**(-1); 1337.33 Y\n +314067.829-2016.37825*T+263.252259*T*LN(T)-.118216828*T**2\n +8.923844E-06*T**3-67999832*T**(-1); 1735.80 Y\n -12133.783+165.272524*T-30.9616*T*LN(T); 3200 N !\n FUNCTION GBCCAU 298.15 +GHSERAU#+4250-1.1*T; 3200 N !\n FUNCTION GHCPAU 298.15 +GHSERAU#+240.75+1.6*T; 3200 N !\n FUNCTION GLIQBB 298.15 +40723.275+86.843839*T-15.6641*T*LN(T)\n -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 500 Y\n +41119.703+82.101722*T-14.9827763*T*LN(T)-.007095669*T**2\n +5.07347E-07*T**3+335484*T**(-1); 2348 Y\n +28842.012+200.94731*T-31.4*T*LN(T); 6000 N !\n FUNCTION GFCCBB 298.15 +GHSERBB#+43514-12.217*T; 6000 N !\n FUNCTION GBCCBB 298.15 +GHSERBB#+43514-12.217*T; 3000 N !\n FUNCTION GHCPBB 298.15 +GHSERBB#+50208-9.706*T; 6000 N !\n FUNCTION GHSERBB 298.15 -7735.284+107.111864*T-15.6641*T*LN(T)\n -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1100 Y\n -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3\n +1748270*T**(-1); 2348 Y\n -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2\n +1.34719E-07*T**3+11205883*T**(-1); 3000 Y\n -21530.653+222.396264*T-31.4*T*LN(T); 6000 N !\n FUNCTION GLIQBA 298.15 -9738.988+229.540143*T-43.4961089*T*LN(T)\n -.002346416*T**2+9.91223E-07*T**3+723016*T**(-1); 1000 Y\n -7381.093+235.49642*T-45.103*T*LN(T)+.002154*T**2+2.7E-11*T**3\n -365*T**(-1); 2995 Y\n +11940.282+132.212*T-32.2*T*LN(T); 4000 N !\n FUNCTION GFCCBA 298.15 +GHSERBA#+1800+.6*T; 4000 N !\n FUNCTION GHSERBA 298.15 -17685.226+233.78606*T-42.889*T*LN(T)\n -.0018314*T**2-9.5E-11*T**3+705880*T**(-1); 1000 Y\n -64873.614+608.188389*T-94.2824199*T*LN(T)+.019504772*T**2\n -1.051353E-06*T**3+8220192*T**(-1); 2995 Y\n +8083.889+136.780042*T-32.2*T*LN(T); 4000 N !\n FUNCTION GHCPBA 298.15 +GHSERBA#+2000+1.3*T; 4000 N !\n FUNCTION GLIQBE 298.15 +7511.838+120.362788*T-20.0497038*T*LN(T)\n -.004821347*T**2+4.15958E-07*T**3+281044*T**(-1); 1560 Y\n +5364.713+156.961141*T-25.486*T*LN(T)-.0010572*T**2-1.117E-09*T**3\n +15920*T**(-1); 3000 N !\n FUNCTION GFCCBE 298.15 +GHSERBE#+6349-1.085*T; 3000 N !\n FUNCTION GBCCBE 298.15 -1076.057+109.411712*T-17.1727841*T*LN(T)\n -.008672487*T**2+9.61427E-07*T**3+242309*T**(-1); 1527 Y\n -6970.378+196.411689*T-30*T*LN(T); 1560 Y\n -2609.973+178.131722*T-27.7823769*T*LN(T)-1.03629E-04*T**2\n -5.9331E-08*T**3-1250847*T**(-1); 3000 N !\n FUNCTION GHSERBE 298.15 -8553.651+137.560219*T-21.204*T*LN(T)\n -.00284715*T**2-1.60413E-07*T**3+293690*T**(-1); 1527 Y\n -121305.858+772.405844*T-103.9843*T*LN(T)+.021078651*T**2\n -1.119065E-06*T**3+27251743*T**(-1); 3000 N !\n FUNCTION GLIQBI 298.15 +GHSERBI#+11246.017-20.636399*T-5.9608E-19*T**7;\n 544.55 Y\n +40629.667-400.415652*T+49.678*T*LN(T)-.0730245*T**2\n +1.3052833E-05*T**3-3544705*T**(-1); 800 Y\n +250.689+162.14485*T-36.041*T*LN(T)+.0074641*T**2-1.05047E-06*T**3\n +5175*T**(-1); 1200 Y\n +3755.434+103.960336*T-27.196*T*LN(T); 3000 N !\n FUNCTION GFCCBI 298.15 +GHSERBI#+9900-12.5*T; 3000 N !\n FUNCTION GBCCBI 298.15 +GHSERBI#+11297-13.9*T; 3000 N !\n FUNCTION GHCPBI 298.15 +GHSERBI#+9900-11.8*T; 3000 N !\n FUNCTION GHSERBI 298.15 -7817.776+128.418925*T-28.4096529*T*LN(T)\n +.012338888*T**2-8.381598E-06*T**3; 544.55 Y\n +29293.369-379.605174*T+49.678*T*LN(T)-.0730245*T**2\n +1.3052833E-05*T**3-3544705*T**(-1)+1.66309E+25*T**(-9); 800 Y\n -11085.609+182.955328*T-36.041*T*LN(T)+.0074641*T**2-1.05047E-06*T**3\n +5175*T**(-1)+1.66309E+25*T**(-9); 1200 Y\n -7580.864+124.770814*T-27.196*T*LN(T)+1.66309E+25*T**(-9); 3000 N !\n FUNCTION GGASBR2 298.15 +19077.8949+9.66580068*T-37.98897*T*LN(T)\n +3.824891E-04*T**2-1.125315E-07*T**3+79565.75*T**(-1); 2100 Y\n +61807.3693-219.344992*T-8.183614*T*LN(T)-.008666065*T**2\n +3.90366833E-07*T**3-11184485*T**(-1); 4300 Y\n -203404.068+619.894219*T-109.6234*T*LN(T)+.008605745*T**2\n -1.61313517E-07*T**3+1.1921565E+08*T**(-1); 6000 N !\n FUNCTION GHSERBR 298.15 +.5*GLIQBR2#; 6000 N !\n FUNCTION GLIQCC 298.15 +GHSERCC#+117369-24.63*T; 6000 N !\n FUNCTION GHSERCC 298.15 -17368.441+170.73*T-24.3*T*LN(T)-4.723E-04*T**2\n +2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); 6000 N !\n FUNCTION GDIACC 298.15 -16359.441+175.61*T-24.31*T*LN(T)-4.723E-04*T**2\n +2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3); 6000 N !\n FUNCTION GGASC1 298.15 +710430.933-17.7062919*T-20.97529*T*LN(T)\n +1.998237E-04*T**2-3.34617167E-08*T**3+1680.6515*T**(-1); 3400 Y\n +698015.711+2.57175186*T-23.05071*T*LN(T)-6.04604E-05*T**2\n +6.74291667E-10*T**3+8558245*T**(-1); 10000 Y\n +736197.571-32.7975309*T-19.44529*T*LN(T)-1.5396035E-04*T**2\n -6.15402167E-11*T**3-56188350*T**(-1); 20000 N !\n FUNCTION GLIQCA 298.15 +5844.846+62.4838*T-16.3138*T*LN(T)\n -.01110455*T**2-133574*T**(-1); 500 Y\n +7838.856+18.2979*T-8.9874787*T*LN(T)-.02266537*T**2+3.338303E-06*T**3\n -230193*T**(-1); 1115 Y\n -2654.938+188.9223*T-35*T*LN(T); 3001 N !\n FUNCTION GHSERCA 298.15 -4955.062+72.794266*T-16.3138*T*LN(T)\n -.01110455*T**2-133574*T**(-1); 1115 Y\n -107304.428+799.982066*T-114.292247*T*LN(T)+.023733814*T**2\n -1.2438E-06*T**3+18245540*T**(-1); 3000 Y\n -3703.12+192.63995*T-35*T*LN(T); 3001 N !\n FUNCTION GBCCCA 298.15 -7020.852+142.970155*T-28.2541*T*LN(T)\n +.0072326*T**2-4.500217E-06*T**3+60578*T**(-1); 716 Y\n +1640.475+1.999694*T-6.276*T*LN(T)-.0161921*T**2-523000*T**(-1); 1115 Y\n -142331.096+1023.54905*T-143.872698*T*LN(T)+.032543127*T**2\n -1.704079E-06*T**3+25353771*T**(-1); 3000 Y\n +321.63+189.433057*T-35*T*LN(T); 3001 N !\n FUNCTION GHCPCA 298.15 +GHSERCA#+500+.7*T; 3001 N !\n FUNCTION GLIQCD 298.15 -955.025+89.209282*T-22.0442408*T*LN(T)\n -.006273908*T**2-6966*T**(-1); 400 Y\n +21716.884-371.046869*T+53.1313898*T*LN(T)-.115159917*T**2\n +2.8899781E-05*T**3-1271815*T**(-1); 594.22 Y\n -3252.303+138.251107*T-29.7064*T*LN(T); 1600 N !\n FUNCTION GFCCCD 298.15 +GHSERCD#+892.3-.92*T; 1600 N !\n FUNCTION GBCCCD 298.15 +GHSERCD#+1000; 1600 N !\n FUNCTION GHSERCD 298.15 -7083.469+99.506198*T-22.0442408*T*LN(T)\n -.006273908*T**2-6966*T**(-1); 594.22 Y\n -20064.971+256.812233*T-45.1611543*T*LN(T)+.008832011*T**2\n -8.99604E-07*T**3+1241290*T**(-1); 1500 Y\n -9027.489+148.20548*T-29.7064*T*LN(T); 1600 N !\n FUNCTION GLIQCE 298.15 +4117.865-11.423898*T-7.5383948*T*LN(T)\n -.02936407*T**2+4.827734E-06*T**3-198834*T**(-1); 1000 Y\n -6730.605+183.023193*T-37.6978*T*LN(T); 4000 N !\n FUNCTION GHSERCE 298.15 -7160.519+84.23022*T-22.3664*T*LN(T)\n -.0067103*T**2-3.20773E-07*T**3-18117*T**(-1); 1000 Y\n -79678.506+659.4604*T-101.32248*T*LN(T)+.026046487*T**2\n -1.930297E-06*T**3+11531707*T**(-1); 2000 Y\n -14198.639+190.370192*T-37.6978*T*LN(T); 4000 N !\n FUNCTION GBCCCE 298.15 -1354.69-5.21501*T-7.7305867*T*LN(T)\n -.029098402*T**2+4.784299E-06*T**3-196303*T**(-1); 1000 Y\n -12101.106+187.449688*T-37.6142*T*LN(T); 1072 Y\n -11950.375+186.333811*T-37.4627992*T*LN(T)-5.7145E-05*T**2\n +2.348E-09*T**3-25897*T**(-1); 4000 N !\n FUNCTION GHCPCE 298.15 +GHSERCE#+300; 4000 N !\n FUNCTION GHSERCF 298.15 -8469.90215+104.280719*T-27.49949*T*LN(T)\n +7.74221E-04*T**2-3.00430667E-06*T**3+26908.455*T**(-1); 700 Y\n -8395.62854+100.938938*T-26.83568*T*LN(T)-.0012952475*T**2\n -2.20727333E-06*T**3; 1000 Y\n +38885.0956-780.991201*T+110.0211*T*LN(T)-.13316665*T**2\n +1.89404E-05*T**3; 1173 N !\n FUNCTION GHSERCL 298.15 +.5*GGASCL2#; 6000 N !\n FUNCTION GHSERCM 298.15 -7869.70506+98.7537088*T-25.104*T*LN(T)\n -.00433044*T**2; 1550 Y\n -10436.223+155.168758*T-33.472*T*LN(T); 1618 Y\n -21267.7622+211.327719*T-40.1664*T*LN(T); 4000 N !\n FUNCTION GGASCM1 298.15 +377291.101+12.0602152*T-31.00442*T*LN(T)\n -.001280547*T**2+1.43695533E-06*T**3+129049.4*T**(-1); 700 Y\n +380454.248-.173822933*T-30.03214*T*LN(T)+.0034346335*T**2\n -4.32347E-07*T**3-380009.4*T**(-1); 1700 Y\n +380329.187-11.3576458*T-28.24452*T*LN(T)+.0018205105*T**2\n -2.34110667E-07*T**3; 4200 Y\n +837692.339-1379.89321*T+135.9805*T*LN(T)-.02460472*T**2\n +5.694885E-07*T**3-2.4083855E+08*T**(-1); 6000 N !\n FUNCTION GLIQCO 298.15 +GHSERCO#+15085.037-8.931932*T-2.19801E-21*T**7;\n 1768 Y\n -846.61+243.599944*T-40.5*T*LN(T); 6000 N !\n FUNCTION GFCCCO 298.15 +GHSERCO#+427.591-.615248*T; 6000 N !\n FUNCTION GBCCCO 298.15 +GHSERCO#+2938-.7138*T; 6000 N !\n FUNCTION GHSERCO 298.15 +310.241+133.36601*T-25.0861*T*LN(T)\n -.002654739*T**2-1.7348E-07*T**3+72527*T**(-1); 1768 Y\n -17197.666+253.28374*T-40.5*T*LN(T)+9.3488E+30*T**(-9); 6000 N !\n FUNCTION GLIQCR 298.15 +GHSERCR#+24339.955-11.420225*T+2.37615E-21*T**7;\n 2180 Y\n -16459.984+335.616316*T-50*T*LN(T); 6000 N !\n FUNCTION GFCCCR 298.15 +GHSERCR#+7284+.163*T; 6000 N !\n FUNCTION GHSERCR 298.15 -8856.94+157.48*T-26.908*T*LN(T)+.00189435*T**2\n -1.47721E-06*T**3+139250*T**(-1); 2180 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6000 N !\n FUNCTION GHCPCR 298.15 +GHSERCR#+4438; 6000 N !\n FUNCTION GLIQCS 200 +GHSERCS#+2091.141-6.931035*T-3.56867E-18*T**7;\n 301.59 Y\n -11454.038+211.728844*T-46.7273304*T*LN(T)+.02043269*T**2\n -4.074846E-06*T**3+181528*T**(-1); 2000 N !\n FUNCTION GFCCCS 200 +GHSERCS#+500+1.3*T; 2000 N !\n FUNCTION GHSERCS 200 -17373.82+436.899787*T-90.5212584*T*LN(T)\n +.2029422*T**2-1.27907669E-04*T**3+245245*T**(-1); 301.59 Y\n -13553.817+218.689955*T-46.7273304*T*LN(T)+.02043269*T**2\n -4.074846E-06*T**3+181528*T**(-1)+7.8016E+21*T**(-9); 2000 N !\n FUNCTION GHCPCS 200 +GHSERCS#+500+2*T; 2000 N !\n FUNCTION GLIQCU 298.15 +GHSERCU#+12964.735-9.511904*T-5.8489E-21*T**7;\n 1357.77 Y\n -46.545+173.881484*T-31.38*T*LN(T); 3200 N !\n FUNCTION GHSERCU 298.15 -7770.458+130.485235*T-24.112392*T*LN(T)\n -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1357.77 Y\n -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); 3200 N !\n FUNCTION GBCCCU 298.15 +GHSERCU#+4017-1.255*T; 3200 N !\n FUNCTION GHCPCU 298.15 +GHSERCU#+600+.2*T; 3200 N !\n FUNCTION GHSERD1 298.15 +215521.121+15.8679816*T-20.78611*T*LN(T); 6000 N\n !\n FUNCTION GHSERD2 298.15 -8456.47704+47.5447764*T-28.79321*T*LN(T)\n +5.47726E-04*T**2-6.60612667E-07*T**3-17075.99*T**(-1); 900 Y\n -9253.29324+36.5549968*T-26.69957*T*LN(T)-.003286203*T**2\n +1.54000683E-07*T**3+326416.2*T**(-1); 2700 Y\n -486.276998+31.4394622*T-26.65651*T*LN(T)-.002130387*T**2\n +4.763655E-08*T**3-5629765*T**(-1); 6200 Y\n -229545.933+430.175622*T-71.05596*T*LN(T)+.0014570765*T**2\n -7.21575833E-10*T**3+2.0713865E+08*T**(-1); 10000 Y\n -111522.548+359.343028*T-64.5573*T*LN(T)+.0017405465*T**2\n -1.28457033E-08*T**3-37551550*T**(-1); 19000 Y\n +667049.587-289.343336*T+1.813887*T*LN(T)-7.82167E-04*T**2\n +5.17027667E-09*T**3-1.757773E+09*T**(-1); 20000 N !\n FUNCTION GLIQDY 100 +5259.45264+94.7630477*T-26.3917167*T*LN(T)\n -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y\n +300126.971-2519.78614*T+341.302578*T*LN(T)-.196153225*T**2\n +1.76197799E-05*T**3-43071677.5*T**(-1); 1685.15 Y\n -21864.7344+282.205014*T-49.9151*T*LN(T); 3000 N !\n FUNCTION GBCCDY 100 -6428.98566+101.740796*T-26.3917167*T*LN(T)\n -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y\n +327500.062-2868.04585*T+391.515418*T*LN(T)-.224042148*T**2\n +2.04076075E-05*T**3-48652656.5*T**(-1); 1654.15 Y\n -33708.7949+291.409631*T-50.208*T*LN(T); 1685.15 Y\n -40775.4966+330.318068*T-55.2811171*T*LN(T)+.0015254673*T**2\n -7.7437116E-08*T**3+1776589.32*T**(-1); 3000 N !\n FUNCTION GHSERDY 100 -7937.16586+102.307412*T-26.3917167*T*LN(T)\n -7.61683657E-04*T**2-5.86914125E-07*T**3+4010.90565*T**(-1); 1000 Y\n -13733.328+214.012934*T-43.8283359*T*LN(T)+.0166909801*T**2\n -3.49702836E-06*T**3+.0173619874*T**(-1); 1654.15 Y\n -404681.371+2032.1415*T-272.123952*T*LN(T)+.0578301681*T**2\n -2.76169148E-06*T**3+1.09616238E+08*T**(-1); 3000 N !\n FUNCTION GLIQER 298.15 +10892.966+106.457118*T-28.3846744*T*LN(T)\n +9.95792E-04*T**2-9.52557E-07*T**3+9581*T**(-1); 500 Y\n +17912.678+.355564*T-12.0761776*T*LN(T)-.014414687*T**2\n +1.316517E-06*T**3-528122*T**(-1); 1802 Y\n +747.131+187.623024*T-38.702*T*LN(T); 3200 N !\n FUNCTION GBCCER 298.15 +GHSERER#+4600-2.494353*T; 3200 N !\n FUNCTION GHSERER 298.15 -8489.136+116.698964*T-28.3846744*T*LN(T)\n +9.95792E-04*T**2-9.52557E-07*T**3+9581*T**(-1); 1802 Y\n -445688.206+2233.10212*T-298.135131*T*LN(T)+.065950553*T**2\n -3.041405E-06*T**3+1.23973199E+08*T**(-1); 3200 N !\n FUNCTION GHSERES 298.15 -9603.70094+106.74523*T-28.99*T*LN(T)\n -9.010025E-04*T**2-2.21979333E-07*T**3+129467.6*T**(-1); 1133 Y\n -16595.0333+167.712355*T-36.95309*T*LN(T); 1500 N !\n FUNCTION GGASES1 298.15 +126680.446-61.4481604*T-20.83157*T*LN(T)\n +1.038889E-04*T**2-3.12514333E-08*T**3; 1300 N !\n FUNCTION GLIQEU 298.15 -1482.46+128.661522*T-32.8418896*T*LN(T)\n +.00931735*T**2-4.006564E-06*T**3+102717*T**(-1); 400 Y\n +10972.726-103.688201*T+4.3501554*T*LN(T)-.036811218*T**2\n +5.452934E-06*T**3-646908*T**(-1); 1095 Y\n -6890.641+175.517247*T-38.11624*T*LN(T); 1901 N !\n FUNCTION GHSEREU 298.15 -9864.965+135.836737*T-32.8418896*T*LN(T)\n +.00931735*T**2-4.006564E-06*T**3+102717*T**(-1); 1095 Y\n -287423.476+2174.73304*T-309.357101*T*LN(T)+.114530917*T**2\n -8.809866E-06*T**3+48455305*T**(-1); 1900 Y\n -13663.125+182.113799*T-38.11624*T*LN(T); 1901 N !\n FUNCTION GHSERFF 298.15 +.5*GGASF2#; 6000 N !\n FUNCTION GLIQFE 298.15 +GHSERFE#+12040.17-6.55843*T-3.67516E-21*T**7;\n 1811 Y\n -10838.83+291.302*T-46*T*LN(T); 6000 N !\n FUNCTION GFCCFE 298.15 -236.7+132.416*T-24.6643*T*LN(T)-.00375752*T**2\n -5.8927E-08*T**3+77359*T**(-1); 1811 Y\n -27097.3963+300.252559*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)-.00439752*T**2\n -5.8927E-08*T**3+77359*T**(-1); 1811 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N !\n FUNCTION GHCPFE 298.15 -2480.08+136.725*T-24.6643*T*LN(T)-.00375752*T**2\n -5.8927E-08*T**3+77359*T**(-1); 1811 Y\n -29340.776+304.561559*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N !\n FUNCTION GHSERFM 298.15 -7435.38424+71.2921434*T-23.12029*T*LN(T)\n -.006376645*T**2+4.673305E-07*T**3; 1000 N !\n FUNCTION GGASFM1 298.15 +136850.723-58.060785*T-21.16418*T*LN(T)\n +.0010578665*T**2-4.90770333E-07*T**3; 1000 N !\n FUNCTION GHSERFR 298.15 -2896.15699+22.135833*T-18.686*T*LN(T)\n -.00552445*T**2+5.66666667E-11*T**3-471995*T**(-1); 2000 N !\n FUNCTION GGASFR1 298.15 +66719.3128-41.3859151*T-21.013*T*LN(T)\n +2.238E-04*T**2-3.54933333E-08*T**3+5020*T**(-1); 1900 Y\n +59158.2746+20.6311478*T-29.573*T*LN(T)+.0041483005*T**2\n -3.5509E-07*T**3+1031265*T**(-1); 3800 Y\n +447653.276-1219.99948*T+120.623*T*LN(T)-.0218429*T**2\n +4.94483333E-07*T**3-1.886411E+08*T**(-1); 6000 N !\n FUNCTION GGASFR2 298.15 +98312.5778-122.431698*T-24.748*T*LN(T)\n -.0260224*T**2+7.70755833E-06*T**3-121475*T**(-1); 600 Y\n +72099.8189+267.174378*T-84.831*T*LN(T)+.0351034*T**2-3.9412E-06*T**3\n +2019320*T**(-1); 1400 Y\n +198967.692-664.832058*T+42.754*T*LN(T)-.02224225*T**2\n +9.24891667E-07*T**3-21739545*T**(-1); 2300 Y\n +105542.311-327.058899*T+1.646*T*LN(T)-.0159264*T**2+8.78035E-07*T**3\n +14080215*T**(-1); 3500 Y\n -169012.039+764.904246*T-134.43*T*LN(T)+.0135291*T**2\n -3.01303333E-07*T**3+1.1556265E+08*T**(-1); 6000 N !\n FUNCTION GLIQGA 200 +GHSERGA#+5491.298-18.073995*T-7.0171E-17*T**7;\n 302.91 Y\n -1389.188+114.049043*T-26.0692906*T*LN(T)+1.506E-04*T**2\n -4.0173E-08*T**3-118332*T**(-1); 4000 N !\n FUNCTION GFCCGA 200 +GHSERGA#+3800-10.2*T; 4000 N !\n FUNCTION GBCCGA 200 +GHSERGA#+4500-11.7*T; 4000 N !\n FUNCTION GHCPGA 200 +GHSERGA#+4500-9.5*T; 4000 N !\n FUNCTION GHSERGA 200 -21312.331+585.263691*T-108.228783*T*LN(T)\n +.227155636*T**2-1.18575257E-04*T**3+439954*T**(-1); 302.91 Y\n -7055.643+132.73019*T-26.0692906*T*LN(T)+1.506E-04*T**2\n -4.0173E-08*T**3-118332*T**(-1)+1.64547E+23*T**(-9); 4000 N !\n FUNCTION GLIQGD 100 +6225.4407+88.8092103*T-24.7214131*T*LN(T)\n -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y\n +146262.037-1208.70685*T+159.352082*T*LN(T)-.108247135*T**2\n +1.06945505E-05*T**3-19678357*T**(-1); 1508.15 Y\n -5397.314+192.336215*T-38.5075*T*LN(T); 3600 N !\n FUNCTION GFCCGD 200 +GHSERGD#+500; 3600 N !\n FUNCTION GBCCGD 100 -3600.77684+95.0191641*T-24.721413*T*LN(T)\n -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y\n +152792.743-1349.58873*T+180.097094*T*LN(T)-.119550229*T**2\n +1.17915728E-05*T**3-22038836*T**(-1); 1508.15 Y\n -15783.7618+202.222183*T-38.960425*T*LN(T); 1586.15 Y\n -19850.5562+224.818035*T-41.904333*T*LN(T)+8.58222759E-04*T**2\n -3.77570269E-08*T**3+995428.573*T**(-1); 3600 N !\n FUNCTION GHSERGD 200 -6834.5855+97.13101*T-24.7214131*T*LN(T)\n -.00285240521*T**2-3.14674076E-07*T**3-8665.73348*T**(-1); 1000 Y\n -6483.25362+95.6919924*T-24.6598297*T*LN(T)-.00185225011*T**2\n -6.61211607E-07*T**3; 1508.15 Y\n -123124.992+699.125537*T-101.800197*T*LN(T)+.0150644246*T**2\n -6.39165948E-07*T**3+29356890.3*T**(-1); 3600 N !\n FUNCTION GLIQGE 298.15 +GHSERGE#+37141.489-30.687043*T+8.56632E-21*T**7;\n 1211.40 Y\n +27243.473+126.324186*T-27.6144*T*LN(T); 3200 N !\n FUNCTION GFCCGE 298.15 +GHSERGE#+36000-22.3*T; 3200 N !\n FUNCTION GBCCGE 298.15 +GHSERGE#+34100-23.5*T; 3200 N !\n FUNCTION GHCPGE 298.15 +GHSERGE#+35000-21.5*T; 3200 N !\n FUNCTION GHSERGE 298.15 -9486.153+165.635573*T-29.5337682*T*LN(T)\n +.005568297*T**2-1.513694E-06*T**3+163298*T**(-1); 900 Y\n -5689.239+102.86087*T-19.8536239*T*LN(T)-.003672527*T**2; 1211.40 Y\n -9548.204+156.708024*T-27.6144*T*LN(T)-8.59809E+28*T**(-9); 3200 N !\n FUNCTION GHSERHH 298.15 +.5*GGASH2#; 6000 N !\n FUNCTION GHSERHE 298.15 -6197.37857+13.0649816*T-20.78611*T*LN(T); 6000 N\n !\n FUNCTION GLIQHF 298.15 +20414.959+99.790933*T-22.7075*T*LN(T)\n -.004146145*T**2-4.77E-10*T**3-22590*T**(-1); 1000 Y\n +49731.499-149.91739*T+12.116812*T*LN(T)-.021262021*T**2\n +1.376466E-06*T**3-4449699*T**(-1); 2506 Y\n -4247.217+265.470523*T-44*T*LN(T); 3001 N !\n FUNCTION GFCCHF 298.15 +GHSERHF#+10000-2.2*T; 3001 N !\n FUNCTION GBCCHF 298.15 +5370.703+103.836026*T-22.8995*T*LN(T)\n -.004206605*T**2+8.71923E-07*T**3-22590*T**(-1)-1.446E-10*T**4; 2506 Y\n +1912456.77-8624.20573*T+1087.61412*T*LN(T)-.286857065*T**2\n +1.3427829E-05*T**3-6.10085091E+08*T**(-1); 3000 Y\n -32498.178+276.723247*T-44*T*LN(T); 3001 N !\n FUNCTION GHSERHF 298.15 -6987.297+110.744026*T-22.7075*T*LN(T)\n -.004146145*T**2-4.77E-10*T**3-22590*T**(-1); 2506 Y\n -1446776.33+6193.60999*T-787.536383*T*LN(T)+.1735215*T**2\n -7.575759E-06*T**3+5.01742495E+08*T**(-1); 3000 Y\n -34274.698+277.882368*T-44*T*LN(T); 3001 N !\n FUNCTION GHSERHG 200 +82356.855-3348.19466*T+618.193308*T*LN(T)\n -2.0282337*T**2+.00118398213*T**3-2366612*T**(-1); 234.32 Y\n -8961.207+135.232291*T-32.257*T*LN(T)+.0097977*T**2-3.20695E-06*T**3\n +6670*T**(-1); 400 Y\n -7970.627+112.33345*T-28.414*T*LN(T)+.00318535*T**2-1.077802E-06*T**3\n -41095*T**(-1); 700 Y\n -7161.338+90.797305*T-24.87*T*LN(T)-.00166775*T**2+8.737E-09*T**3\n -27495*T**(-1); 2000 N !\n FUNCTION GFCCHG 298.15 +GHSERHG#+5+8.368*T; 2000 N !\n FUNCTION GHCPHG 200 -10468.401+123.974598*T-28.847*T*LN(T)\n +.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y\n -11225.394+136.628158*T-30.2091*T*LN(T)+.00107555*T**2\n -2.28298E-07*T**3+35545*T**(-1); 2000 N !\n FUNCTION GRHOMBHG 200 -10668.401+123.274598*T-28.847*T*LN(T)\n +.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y\n -11425.394+135.928158*T-30.2091*T*LN(T)+.00107555*T**2\n -2.28298E-07*T**3+35545*T**(-1); 2000 N !\n FUNCTION GLIQHO 298.15 +9770.9926+76.600977*T-23.4879*T*LN(T)\n -.00827315*T**2+2.375467E-06*T**3; 600 Y\n +6465.7336+172.483497*T-39.6932*T*LN(T)+.01820065*T**2\n -4.829733E-06*T**3; 900 Y\n +64029.2496-431.466667*T+48.0595*T*LN(T)-.0424634*T**2\n +3.233133E-06*T**3-7185900*T**(-1); 1000 Y\n +124827.533-994.683024*T+127.957778*T*LN(T)-.088196514*T**2\n +8.008222E-06*T**3-15727191*T**(-1); 1703 Y\n -9688.5314+230.793918*T-43.932*T*LN(T); 3001 N !\n FUNCTION GBCCHO 298.15 -3773.06+84.546902*T-23.4879*T*LN(T)\n -.00827315*T**2+2.375467E-06*T**3; 600 Y\n -7078.318+180.429422*T-39.6932*T*LN(T)+.01820065*T**2\n -4.829733E-06*T**3; 900 Y\n +50485.557-423.520743*T+48.0595*T*LN(T)-.0424634*T**2\n +3.233133E-06*T**3-7185900*T**(-1); 1000 Y\n +185620.196-1635.72662*T+218.937249*T*LN(T)-.13516576*T**2\n +1.2168911E-05*T**3-26729747*T**(-1); 1703 Y\n -28759.761+272.961035*T-48.116*T*LN(T); 1745 Y\n -152646.008+939.778244*T-134.793064*T*LN(T)+.025544089*T**2\n -1.287517E-06*T**3+32050889*T**(-1); 3000 Y\n -19066.44+236.390471*T-43.932*T*LN(T); 3001 N !\n FUNCTION GHSERHO 298.15 -7612.429+86.593171*T-23.4879*T*LN(T)\n -.00827315*T**2+2.375467E-06*T**3; 600 Y\n -10917.688+182.475691*T-39.6932*T*LN(T)+.01820065*T**2\n -4.829733E-06*T**3; 900 Y\n +46646.188-421.474473*T+48.0595*T*LN(T)-.0424634*T**2\n +3.233133E-06*T**3-7185900*T**(-1); 1200 Y\n +27786.061-156.162846*T+8.28608*T*LN(T)-.01082725*T**2\n -1.112352E-06*T**3-6183850*T**(-1); 1703 Y\n -825364.662+4248.37906*T-558.950682*T*LN(T)+.139111904*T**2\n -6.824652E-06*T**3+2.19952973E+08*T**(-1); 3000 Y\n -17149.229+235.898104*T-43.932*T*LN(T); 3001 N !\n FUNCTION GHSERII 298.15 +.5*GSOLI2#; 1000 N !\n FUNCTION GGASI2 298.15 +50783.8025-4.98552933*T-38.14594*T*LN(T)\n +5.89305E-04*T**2-1.96143167E-07*T**3+45464.01*T**(-1); 2000 Y\n +31804.6912+32.349576*T-41.67339*T*LN(T)-.001681544*T**2\n +1.53575317E-07*T**3+8481775*T**(-1); 4000 Y\n -34016.1051+280.938545*T-72.42007*T*LN(T)+.004574158*T**2\n -8.10419167E-08*T**3+34270380*T**(-1); 6000 N !\n FUNCTION GLIQIN 298.15 +GHSERIN#+3282.091-7.636885*T-5.59405E-20*T**7;\n 429.74 Y\n -3749.808+116.835756*T-27.4562*T*LN(T)+5.4607E-04*T**2-8.367E-08*T**3\n -211708*T**(-1); 3800 N !\n FUNCTION GFCCIN 298.15 +GHSERIN#+162.061; 3800 N !\n FUNCTION GBCCIN 298.15 +GHSERIN#+800-.8*T; 3800 N !\n FUNCTION GHCPIN 298.15 +GHSERIN#+533-.6868*T; 3800 N !\n FUNCTION GHSERIN 298.15 -6978.89+92.338115*T-21.8386*T*LN(T)\n -.00572566*T**2-2.120321E-06*T**3-22906*T**(-1); 429.75 Y\n -7033.514+124.476588*T-27.4562*T*LN(T)+5.4607E-04*T**2-8.367E-08*T**3\n -211708*T**(-1)+3.53332E+22*T**(-9); 3800 N !\n FUNCTION GLIQIR 298.15 +16518.956+112.46806*T-22.7944*T*LN(T)\n -.003091976*T**2-20083*T**(-1); 1000 Y\n +102217.789-587.632815*T+73.9517579*T*LN(T)-.04638802*T**2\n +2.761831E-06*T**3-13382612*T**(-1); 2719 Y\n -38347.217+411.234043*T-59.418*T*LN(T); 4000 N !\n FUNCTION GHSERIR 298.15 -6936.288+118.780119*T-22.7944*T*LN(T)\n -.003091976*T**2-20083*T**(-1); 1215 Y\n -8123.73+140.066697*T-26.085*T*LN(T)-4.7969E-07*T**3; 2719 Y\n +290529.037-1258.35297*T+152.498874*T*LN(T)-.047176402*T**2\n +1.844977E-06*T**3-92987250*T**(-1); 4000 N !\n FUNCTION GBCCIR 298.15 +GHSERIR#+32000-6.9*T; 4000 N !\n FUNCTION GHCPIR 298.15 +GHSERIR#+4000-.6*T; 4000 N !\n FUNCTION GLIQKK 200 +GHSERKK#+2318.096-6.886859*T-9.44E-19*T**7; 336.53 Y\n -8799.422+185.684327*T-39.2885968*T*LN(T)+.012167386*T**2\n -2.64387E-06*T**3+43251*T**(-1); 2200 N !\n FUNCTION GHSERKK 200 -16112.929+389.624197*T-77.0571464*T*LN(T)\n +.146211135*T**2-8.4949147E-05*T**3+243385*T**(-1); 336.53 Y\n -11122.441+192.586544*T-39.2885968*T*LN(T)+.012167386*T**2\n -2.64387E-06*T**3+43251*T**(-1)+1.19223E+22*T**(-9); 2200 N !\n FUNCTION GFCCKK 200 +GHSERKK#+50+1.3*T; 2200 N !\n FUNCTION GHCPKK 200 +GHSERKK#+50+2*T; 2200 N !\n FUNCTION GHSERKR 298.15 -6197.37857-24.8680184*T-20.78611*T*LN(T); 6000 N\n !\n FUNCTION GLIQLA 298.15 +5332.653+18.23012*T-11.0188191*T*LN(T)\n -.020171603*T**2+2.93775E-06*T**3-133541*T**(-1); 1134 Y\n -3942.004+171.018431*T-34.3088*T*LN(T); 4000 N !\n FUNCTION GFCCLA 298.15 -6109.797+89.878761*T-21.7919*T*LN(T)\n -.004045175*T**2-5.25865E-07*T**3; 1134 Y\n -124598.976+955.878375*T-139.346741*T*LN(T)+.042032405*T**2\n -3.066199E-06*T**3+20994153*T**(-1); 2000 Y\n -12599.386+178.54399*T-34.3088*T*LN(T); 4000 N !\n FUNCTION GBCCLA 298.15 -3952.161+88.072353*T-21.7919*T*LN(T)\n -.004045175*T**2-5.25865E-07*T**3; 800 Y\n +321682.673-3565.08252*T+513.440708*T*LN(T)-.387295093*T**2\n +4.9547989E-05*T**3-36581228*T**(-1); 1134 Y\n -16377.894+218.492988*T-39.5388*T*LN(T); 1193 Y\n -136609.91+1123.34397*T-163.413074*T*LN(T)+.053968535*T**2\n -4.056395E-06*T**3+21167204*T**(-1); 2000 Y\n -8205.988+174.836315*T-34.3088*T*LN(T); 4000 N !\n FUNCTION GHSERLA 298.15 -7968.403+120.284604*T-26.34*T*LN(T)\n -.001295165*T**2; 550 Y\n -3381.413+59.06113*T-17.1659411*T*LN(T)-.008371705*T**2\n +6.8932E-07*T**3-399448*T**(-1); 2000 Y\n -15608.882+181.390071*T-34.3088*T*LN(T); 4000 N !\n FUNCTION GLIQLI 200 -7883.612+211.841861*T-38.940488*T*LN(T)\n +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 250 Y\n +12015.027-362.187078*T+61.6104424*T*LN(T)-.182426463*T**2\n +6.3955671E-05*T**3-559968*T**(-1); 453.60 Y\n -6057.31+172.652183*T-31.2283718*T*LN(T)+.002633221*T**2\n -4.38058E-07*T**3-102387*T**(-1); 3000 N !\n FUNCTION GFCCLI 200 +GHSERLI#-108+1.3*T; 3000 N !\n FUNCTION GHSERLI 200 -10583.817+217.637482*T-38.940488*T*LN(T)\n +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 453.60 Y\n -559579.123+10547.8799*T-1702.88865*T*LN(T)+2.25832944*T**2\n -5.71066077E-04*T**3+33885874*T**(-1); 500 Y\n -9062.994+179.278285*T-31.2283718*T*LN(T)+.002633221*T**2\n -4.38058E-07*T**3-102387*T**(-1); 3000 N !\n FUNCTION GHCPLI 200 +GHSERLI#-154+2*T; 3000 N !\n FUNCTION GLIQLU 298.15 +3983.791+141.5374*T-29.812*T*LN(T)\n +.00519165*T**2-1.790717E-06*T**3+39723*T**(-1); 600 Y\n +30389.863-198.378793*T+20.9392663*T*LN(T)-.034238743*T**2\n +2.890636E-06*T**3-2398650*T**(-1); 1936 Y\n -18994.687+292.091104*T-47.9068*T*LN(T); 3700 N !\n FUNCTION GHSERLU 298.15 -8788.329+146.536283*T-29.812*T*LN(T)\n +.00519165*T**2-1.790717E-06*T**3+39723*T**(-1); 700 Y\n -9043.057+142.327643*T-29.0095*T*LN(T)+.00371416*T**2-1.50147E-06*T**3\n +141549*T**(-1); 1700 Y\n +6940.092-46.91844*T-1.83986*T*LN(T)-.0119001*T**2; 1936 Y\n -404023.691+1829.37943*T-239.019502*T*LN(T)+.041800748*T**2\n -1.661174E-06*T**3+1.24825465E+08*T**(-1); 3700 N !\n FUNCTION GLIQMG 298.15 +GHSERMG#+8202.243-8.83693*T-8.0176E-20*T**7; 923\n Y\n -5439.869+195.324057*T-34.3088*T*LN(T); 3000 N !\n FUNCTION GFCCMG 298.15 +GHSERMG#+2600-.9*T; 3000 N !\n FUNCTION GBCCMG 298.15 +GHSERMG#+3100-2.1*T; 3000 N !\n FUNCTION GHSERMG 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T)\n +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 923 Y\n -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); 3000 N !\n FUNCTION GLIQMN 298.15 +GHSERMN#+17859.91-12.6208*T-4.41929E-21*T**7;\n 1519 Y\n -9993.9+299.036*T-48*T*LN(T); 2000 N !\n FUNCTION GFCCMN 298.15 -3439.3+131.884*T-24.5177*T*LN(T)-.006*T**2\n +69600*T**(-1); 1519 Y\n -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2000 N !\n FUNCTION GBCCMN 298.15 -3235.3+127.85*T-23.7*T*LN(T)-.00744271*T**2\n +60000*T**(-1); 1519 Y\n -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2000 N !\n FUNCTION GHCPMN 298.15 -4439.3+133.007*T-24.5177*T*LN(T)-.006*T**2\n +69600*T**(-1); 1519 Y\n -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 2000 N !\n FUNCTION GHSERMN 298.15 -8115.28+130.059*T-23.4582*T*LN(T)-.00734768*T**2\n +69827*T**(-1); 1519 Y\n -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2000 N !\n FUNCTION GLIQMO 298.15 +GHSERMO#+41831.347-14.694912*T+4.24519E-22*T**7;\n 2896 Y\n +3538.963+271.6697*T-42.63829*T*LN(T); 5000 N !\n FUNCTION GFCCMO 298.15 +GHSERMO#+15200+.63*T; 5000 N !\n FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; 2896 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); 5000 N !\n FUNCTION GHCPMO 298.15 +GHSERMO#+11550; 5000 N !\n FUNCTION GHSERNN 298.15 -3750.675-9.45425*T-12.7819*T*LN(T)\n -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 950 Y\n -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3\n +563070*T**(-1); 3350 Y\n -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3\n +4596375*T**(-1); 6000 N !\n FUNCTION GLIQNN 298.15 +GHSERNN#+29950+59.02*T; 6000 N !\n FUNCTION GLIQNA 200 +GHSERNA#+2581.02-6.95218*T-2.76132E-18*T**7; 370.87\n Y\n -8400.44+192.587343*T-38.1198801*T*LN(T)+.009745854*T**2\n -1.70664E-06*T**3+34342*T**(-1); 2300 N !\n FUNCTION GFCCNA 200 +GHSERNA#-50+1.3*T; 2300 N !\n FUNCTION GHSERNA 200 -11989.434+260.548732*T-51.0393608*T*LN(T)\n +.072306633*T**2-4.3638283E-05*T**3+132154*T**(-1); 370.87 Y\n -11009.884+199.619999*T-38.1198801*T*LN(T)+.009745854*T**2\n -1.70664E-06*T**3+34342*T**(-1)+1.65071E+23*T**(-9); 2300 N !\n FUNCTION GHCPNA 200 +GHSERNA#+104+2*T; 2300 N !\n FUNCTION GLIQNB 298.15 +GHSERNB#+29781.555-10.816418*T-3.06098E-23*T**7;\n 2750 Y\n -7499.398+260.756148*T-41.77*T*LN(T); 6000 N !\n FUNCTION GFCCNB 298.15 +GHSERNB#+13500+1.7*T; 6000 N !\n FUNCTION GHSERNB 298.15 -8519.353+142.045475*T-26.4711*T*LN(T)\n +2.03475E-04*T**2-3.5012E-07*T**3+93399*T**(-1); 2750 Y\n -37669.3+271.720843*T-41.77*T*LN(T)+1.528238E+32*T**(-9); 6000 N !\n FUNCTION GHCPNB 298.15 +GHSERNB#+10000+2.4*T; 6000 N !\n FUNCTION GLIQND 298.15 -3351.187+109.517314*T-27.0858*T*LN(T)\n +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 300 Y\n +5350.01-86.593963*T+5.357301*T*LN(T)-.046955463*T**2\n +6.860782E-06*T**3-374380*T**(-1); 1128 Y\n -16335.232+268.625903*T-48.7854*T*LN(T); 1800 N !\n FUNCTION GFCCND 298.15 +GHSERND#+500; 1800 N !\n FUNCTION GBCCND 298.15 -6965.635+110.556109*T-27.0858*T*LN(T)\n +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 400 Y\n +7312.2-153.033976*T+14.9956777*T*LN(T)-.050479*T**2+7.287217E-06*T**3\n -831810*T**(-1); 1128 Y\n -18030.266+239.677322*T-44.5596*T*LN(T); 1289 Y\n +334513.017-2363.9199*T+311.409193*T*LN(T)-.156030778*T**2\n +1.2408421E-05*T**3-64319604*T**(-1); 1799 Y\n -24495.579+274.879155*T-48.7854*T*LN(T); 1800 N !\n FUNCTION GHCPND 298.15 +GHSERND#+1500-.415725*T; 1800 N !\n FUNCTION GHSERND 298.15 -8402.93+111.10239*T-27.0858*T*LN(T)\n +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 900 Y\n -6984.083+83.662617*T-22.7536*T*LN(T)-.00420402*T**2-1.802E-06*T**3;\n 1128 Y\n -225610.846+1673.04075*T-238.182873*T*LN(T)+.078615997*T**2\n -6.048207E-06*T**3+38810350*T**(-1); 1799 Y\n -25742.331+276.257088*T-48.7854*T*LN(T); 1800 N !\n FUNCTION GHSERNE 298.15 -6197.37857-7.11101836*T-20.78611*T*LN(T); 6000 N\n !\n FUNCTION GLIQNI 298.15 +GHSERNI#+16414.686-9.397*T-3.82318E-21*T**7;\n 1728 Y\n -9549.817+268.597977*T-43.1*T*LN(T); 3000 N !\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2;\n 1728 Y\n -27840.62+279.134977*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N !\n FUNCTION GBCCNI 298.15 +GHSERNI#+8715.084-3.556*T; 3000 N !\n FUNCTION GHCPNI 298.15 +GHSERNI#+1046+1.2552*T; 3000 N !\n FUNCTION GLIQNP 298.15 -4627.18+160.024959*T-31.229*T*LN(T)\n -.0163885*T**2+2.941883E-06*T**3+439915*T**(-1); 917 Y\n -7415.255+247.671446*T-45.3964*T*LN(T); 4000 N !\n FUNCTION GBCCNP 298.15 -3224.664+174.911817*T-35.177*T*LN(T)\n -.00251865*T**2+5.14743E-07*T**3+302225*T**(-1); 856 Y\n -2366.486+180.807719*T-36.401*T*LN(T); 917 Y\n +50882.281-297.324358*T+30.7734*T*LN(T)-.0343483*T**2\n +2.707217E-06*T**3-7500100*T**(-1); 1999 Y\n -14879.686+254.773087*T-45.3964*T*LN(T); 4000 N !\n FUNCTION GHSERNP 298.15 +241.888-57.531347*T+4.0543*T*LN(T)\n -.04127725*T**2-402857*T**(-1); 553 Y\n -57015.112+664.27337*T-102.523*T*LN(T)+.0284592*T**2-2.483917E-06*T**3\n +4796910*T**(-1); 1799 Y\n -12092.736+255.780866*T-45.3964*T*LN(T); 4000 N !\n FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.1355*T*LN(T)\n -.005098875*T**2+6.61845833E-07*T**3-38365*T**(-1); 1000 Y\n -6568.763+12.659879*T-16.8138*T*LN(T)-5.957975E-04*T**2+6.781E-09*T**3\n +262905*T**(-1); 3300 Y\n -13986.728+31.259624*T-18.9536*T*LN(T)-4.25243E-04*T**2\n +1.0721E-08*T**3+4383200*T**(-1); 6000 N !\n FUNCTION GLIQOO 298.15 +GHSEROO#-2648.9+31.44*T; 6000 N !\n FUNCTION GFCCOO 298.15 +GHSEROO#+30000; 6000 N !\n FUNCTION GBCCOO 298.15 +GHSEROO#+30000; 6000 N !\n FUNCTION GLIQOS 298.15 +29263.192+117.895788*T-23.5710242*T*LN(T)\n -.00190427*T**2; 1000 Y\n +68715.318-198.324341*T+19.9382156*T*LN(T)-.020464464*T**2\n +1.014279E-06*T**3-6237261*T**(-1); 3306 Y\n -15903.192+336.874526*T-50*T*LN(T); 5500 N !\n FUNCTION GFCCOS 298.15 +GHSEROS#+13000-2.5*T; 5500 N !\n FUNCTION GBCCOS 298.15 +GHSEROS#+27500-4.4*T; 5500 N !\n FUNCTION GHSEROS 298.15 -7196.978+126.369531*T-23.5710242*T*LN(T)\n -.00190427*T**2; 3306 Y\n +644910.07-1935.2137*T+224.998034*T*LN(T)-.042489827*T**2\n +1.173861E-06*T**3-3.12569031E+08*T**(-1); 5500 N !\n FUNCTION GLIQPP 250 -26316.111+434.930931*T-70.7440584*T*LN(T)\n -.002898936*T**2+3.9049371E-05*T**3+1141147*T**(-1); 317.30 Y\n -7232.449+133.291873*T-26.326*T*LN(T); 3000 N !\n FUNCTION GFCCPP 250 +10842.441+135.534002*T-25.55*T*LN(T)+.0034121*T**2\n -2.418867E-06*T**3+160095*T**(-1); 500 Y\n +15095.279+64.533737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3\n -141375*T**(-1); 852.35 Y\n -82589.413+1012.89162*T-149.449556*T*LN(T)+.067272364*T**2\n -6.651929E-06*T**3+12495943*T**(-1); 1500 Y\n +12294.881+140.701181*T-26.326*T*LN(T); 3000 N !\n FUNCTION GBCCPP 250 +18792.241+135.412002*T-25.55*T*LN(T)+.0034121*T**2\n -2.418867E-06*T**3+160095*T**(-1); 500 Y\n +23045.079+64.411737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3\n -141375*T**(-1); 852.35 Y\n -74639.613+1012.76962*T-149.449556*T*LN(T)+.067272364*T**2\n -6.651929E-06*T**3+12495943*T**(-1); 1500 Y\n +20244.681+140.579181*T-26.326*T*LN(T); 3000 N !\n FUNCTION GHSERPP 250 -43821.799+1026.69389*T-178.426*T*LN(T)+.290708*T**2\n -1.04022667E-04*T**3+1632695*T**(-1); 317.30 Y\n -9587.448+152.341487*T-28.7335301*T*LN(T)+.001715669*T**2\n -2.2829E-07*T**3+172966*T**(-1); 1000 Y\n -8093.075+135.876831*T-26.326*T*LN(T); 3000 N !\n FUNCTION GREDPP 250 -25976.559+148.672002*T-25.55*T*LN(T)+.0034121*T**2\n -2.418867E-06*T**3+160095*T**(-1); 500 Y\n -21723.721+77.671737*T-14.368*T*LN(T)-.00957685*T**2+3.93917E-07*T**3\n -141375*T**(-1); 852.35 Y\n -119408.413+1026.02962*T-149.449556*T*LN(T)+.067272364*T**2\n -6.651929E-06*T**3+12495943*T**(-1); 1500 Y\n -24524.119+153.839181*T-26.326*T*LN(T); 3000 N !\n FUNCTION GLIQPA 298.15 +8499.539+102.429215*T-23.9116*T*LN(T)\n -.00621325*T**2; 1088 Y\n +48013.96-278.789916*T+30.336*T*LN(T)-.0372478*T**2+3.075017E-06*T**3\n -5064250*T**(-1); 1845 Y\n -12508.174+277.955437*T-47.2792*T*LN(T); 4000 N !\n FUNCTION GBCCPA 298.15 +781.847+71.957409*T-18.203*T*LN(T)\n -.01322095*T**2+1.337387E-06*T**3-101600*T**(-1); 1443 Y\n -10955.948+220.478519*T-39.748*T*LN(T); 1845 Y\n +284495.194-1397.15052*T+171.108*T*LN(T)-.0637105*T**2\n +3.343867E-06*T**3-74992000*T**(-1); 2710 Y\n -27885.171+286.096187*T-47.2792*T*LN(T); 4000 N !\n FUNCTION GHSERPA 298.15 -7681.561+111.973215*T-23.9116*T*LN(T)\n -.00621325*T**2; 1443 Y\n +27955.763-177.320253*T+16.305*T*LN(T)-.0263416*T**2+1.884933E-06*T**3\n -5908900*T**(-1); 2176 Y\n -29949.683+288.308639*T-47.2792*T*LN(T); 4000 N !\n FUNCTION GLIQPB 298.15 +GHSERPB#+4672.124-7.750683*T-6.019E-19*T**7;\n 600.61 Y\n -5677.958+146.176046*T-32.4913959*T*LN(T)+.00154613*T**2; 1200 Y\n +9010.753+45.071937*T-18.9640637*T*LN(T)-.002882943*T**2\n +9.8144E-08*T**3-2696755*T**(-1); 2100 N !\n FUNCTION GHSERPB 298.15 -7650.085+101.700244*T-24.5242231*T*LN(T)\n -.00365895*T**2-2.4395E-07*T**3; 600.61 Y\n -10531.095+154.243182*T-32.4913959*T*LN(T)+.00154613*T**2\n +8.05448E+25*T**(-9); 1200 Y\n +4157.616+53.139072*T-18.9640637*T*LN(T)-.002882943*T**2\n +9.8144E-08*T**3-2696755*T**(-1)+8.05448E+25*T**(-9); 2100 N !\n FUNCTION GBCCPB 298.15 +GHSERPB#+2400-1.1*T; 2100 N !\n FUNCTION GHCPPB 298.15 +GHSERPB#+300+T; 2100 N !\n FUNCTION GLIQPD 298.15 +1302.731+170.964153*T-32.211*T*LN(T)\n +.007120975*T**2-1.919875E-06*T**3+168687*T**(-1); 600 Y\n +23405.778-116.918419*T+10.8922031*T*LN(T)-.027266568*T**2\n +2.430675E-06*T**3-1853674*T**(-1); 1828 Y\n -12373.637+251.416903*T-41.17*T*LN(T); 4000 N !\n FUNCTION GHSERPD 298.15 -10204.027+176.076315*T-32.211*T*LN(T)\n +.007120975*T**2-1.919875E-06*T**3+168687*T**(-1); 900 Y\n +917.062+49.659892*T-13.5708*T*LN(T)-.00717522*T**2+1.91115E-07*T**3\n -1112465*T**(-1); 1828 Y\n -67161.018+370.102147*T-54.2067086*T*LN(T)+.002091396*T**2\n -6.2811E-08*T**3+18683526*T**(-1); 4000 N !\n FUNCTION GBCCPD 298.15 +GHSERPD#+10500-1.8*T; 4000 N !\n FUNCTION GHCPPD 298.15 +GHSERPD#+2000+.1*T; 4000 N !\n FUNCTION GHSERPM 298.15 -7422.35903+80.1647685*T-21.79273*T*LN(T)\n -.01040851*T**2+4.84191667E-10*T**3-54.5102*T**(-1); 1163 Y\n -20335.8031+242.978356*T-45*T*LN(T)-4.665112E-15*T**2\n +4.62986667E-19*T**3-1.1469315E-06*T**(-1); 1315 Y\n -19020.8031+234.796764*T-44*T*LN(T)+5.82907E-18*T**2\n -1.53614333E-22*T**3+2.491165E-08*T**(-1); 5000 N !\n FUNCTION GGASPM1 298.15 +250509.452-16.8531368*T-24.78283*T*LN(T)\n -.0047051555*T**2+7.05661167E-07*T**3+131736.9*T**(-1); 800 Y\n +249850.849-5.81954382*T-26.5177*T*LN(T)-.002737541*T**2\n +3.00398167E-07*T**3+177733*T**(-1); 2100 Y\n +193298.956+304.296847*T-67.1114*T*LN(T)+.01034818*T**2\n -4.98411167E-07*T**3+15106220*T**(-1); 4400 Y\n +916726.64-1758.41221*T+178.7423*T*LN(T)-.026972315*T**2\n +5.691155E-07*T**3-3.8600615E+08*T**(-1); 7000 Y\n -1055624.33+1947.2619*T-239.3529*T*LN(T)+.012517975*T**2\n -1.3208175E-07*T**3+1.3629E+09*T**(-1); 10000 N !\n FUNCTION GHSERPO 298.15 -6775.95532+74.9200503*T-19.469*T*LN(T)\n -.01094955*T**2+6.77833333E-09*T**3-255*T**(-1); 527 Y\n -9814.73668+147.18388*T-31*T*LN(T); 2000 N !\n FUNCTION GGASPO1 298.15 +175819.473-49.5734348*T-20.812*T*LN(T)\n +7.33E-05*T**2-2.05916667E-08*T**3-320*T**(-1); 3700 Y\n +190794.983-95.2137296*T-15.324*T*LN(T)-8.2235E-04*T**2+6.93E-09*T**3\n -7665330*T**(-1); 6000 N !\n FUNCTION GLIQPR 298.15 +3848.961-29.099465*T-4.7344931*T*LN(T)\n -.035119723*T**2+5.427467E-06*T**3-207406*T**(-1); 1068 Y\n -10539.574+219.508805*T-42.9697*T*LN(T); 3800 N !\n FUNCTION GBCCPR 298.15 -2863.651+28.274853*T-13.7470527*T*LN(T)\n -.02284377*T**2+3.542468E-06*T**3-87486*T**(-1); 1068 Y\n -11985.919+188.657121*T-38.451*T*LN(T); 1204 Y\n +953.224+100.826281*T-26.6824313*T*LN(T)-.004106833*T**2\n +1.76214E-07*T**3-2473024*T**(-1); 3800 N !\n FUNCTION GHSERPR 298.15 -18803.379+356.587384*T-68.9176*T*LN(T)\n +.072929*T**2-2.5184333E-05*T**3+507385*T**(-1); 500 Y\n -7246.848+82.427384*T-22.8909*T*LN(T)-.00497126*T**2-1.22951E-06*T**3;\n 800 Y\n +95411.023-1073.55111*T+146.764*T*LN(T)-.1288205*T**2\n +1.5592233E-05*T**3-11588800*T**(-1); 1068 Y\n -481663.131+4234.33311*T-606.120311*T*LN(T)+.305181506*T**2\n -3.0994702E-05*T**3+70926840*T**(-1); 1204 Y\n -20014.678+227.685155*T-42.9697*T*LN(T); 3800 N !\n FUNCTION GSOLAT2 298.15 -14787.3759+257.374867*T-45.171*T*LN(T)\n -.0148062*T**2-1.67183333E-08*T**3+385*T**(-1); 500 Y\n -28494.6063+493.832173*T-80*T*LN(T); 1000 N !\n FUNCTION GLIQBR2 298.15 -35828.8251+797.10304*T-155.5776*T*LN(T)\n +.2064111*T**2-9.74919667E-05*T**3+391199.95*T**(-1); 501 Y\n -29842.4162+472.126731*T-92.275*T*LN(T); 1000 N !\n FUNCTION GGASCL2 298.15 -11735.2388+21.6544571*T-36.24619*T*LN(T)\n -9.56635E-04*T**2+7.72473833E-08*T**3+126340.1*T**(-1); 1500 Y\n -14830.9341+52.8425138*T-40.69302*T*LN(T)+.0016038575*T**2\n -1.834645E-07*T**3+446405.05*T**(-1); 3300 Y\n +12605.9761-161.881179*T-12.22677*T*LN(T)-.00734027*T**2\n +2.74869167E-07*T**3+3816431.5*T**(-1); 5600 Y\n -277134.238+658.109036*T-109.5523*T*LN(T)+.00665615*T**2\n -9.27583833E-08*T**3+1.564792E+08*T**(-1); 10000 N !\n FUNCTION GGASF2 298.15 -9757.53536-3.03641497*T-29.08493*T*LN(T)\n -.007466065*T**2+1.16183617E-06*T**3+72117.3*T**(-1); 800 Y\n -10225.5134+17.0719031*T-32.43806*T*LN(T)-.0028914815*T**2\n +2.13090167E-07*T**3-31206.07*T**(-1); 2500 Y\n -75010.7092+286.369351*T-66.19232*T*LN(T)+.004699418*T**2\n -9.36513E-08*T**3+22790040*T**(-1); 6800 Y\n +79866.236-46.25962*T-28.00029*T*LN(T)+4.8653845E-04*T**2\n -6.238305E-09*T**3-96222900*T**(-1); 10000 N !\n FUNCTION GGASH2 298.15 -9522.97393+78.5273873*T-31.35707*T*LN(T)\n +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1000 Y\n +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2\n +3.14618667E-07*T**3-1280036*T**(-1); 2100 Y\n -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2\n +1.14281783E-08*T**3+3561002.5*T**(-1); 6000 N !\n FUNCTION GSOLI2 298.15 +13508.6791-397.468312*T+50.64648*T*LN(T)\n -.1234531*T**2-1398711*T**(-1); 386.70 Y\n -26045.3569+430.072509*T-80.6717*T*LN(T); 1000 N !\n$---------------------------\n FUNCTION GLIQPT 298.15 +12518.385+115.113092*T-24.5526*T*LN(T)\n -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 600 Y\n +19023.491+32.94182*T-12.3403769*T*LN(T)-.011551507*T**2\n +9.31516E-07*T**3-601426*T**(-1); 2041.50 Y\n +1404.468+205.858962*T-36.5*T*LN(T); 4000 N !\n FUNCTION GHSERPT 298.15 -7595.631+124.388275*T-24.5526*T*LN(T)\n -.00248297*T**2-2.0138E-08*T**3+7974*T**(-1); 1300 Y\n -9253.174+161.529615*T-30.2527*T*LN(T)+.002321665*T**2\n -6.56946E-07*T**3-272106*T**(-1); 2041.50 Y\n -222048.216+1019.35892*T-136.192996*T*LN(T)+.020454938*T**2\n -7.59259E-07*T**3+71539020*T**(-1); 4000 N !\n FUNCTION GBCCPT 298.15 +GHSERPT#+15000-2.4*T; 4000 N !\n FUNCTION GHCPPT 298.15 +GHSERPT#+2500+.1*T; 4000 N !\n FUNCTION GLIQPU 298.15 +GHSERPU#+6608.1-12.5133*T; 3000 N !\n FUNCTION GFCCPU 298.15 -3920.781+127.586536*T-28.4781*T*LN(T)\n -.0054035*T**2; 990 Y\n +3528.208+41.52572*T-15.7351*T*LN(T)-.0154772*T**2+1.524942E-06*T**3\n -864940*T**(-1); 1464 Y\n -12865.948+226.18075*T-42.248*T*LN(T); 3000 N !\n FUNCTION GBCCPU 298.15 -1358.984+116.603882*T-27.094*T*LN(T)\n -.009105*T**2+2.061667E-06*T**3+20863*T**(-1); 745 Y\n -2890.817+156.878957*T-33.72*T*LN(T); 956 Y\n +29313.619-132.788248*T+6.921*T*LN(T)-.02023305*T**2+1.426922E-06*T**3\n -4469245*T**(-1); 2071 Y\n -15400.585+227.421855*T-42.248*T*LN(T); 3000 N !\n FUNCTION GHSERPU 298.15 -7396.309+80.301382*T-18.1258*T*LN(T)-.02241*T**2;\n 400 Y\n -16605.962+236.786603*T-42.4187*T*LN(T)-.00134493*T**2\n +2.63443E-07*T**3+579325*T**(-1); 944 Y\n -14462.156+232.961553*T-42.248*T*LN(T); 3000 N !\n FUNCTION GHSERRA 298.15 -7586.80726+84.7267364*T-21.891*T*LN(T)\n -.01192215*T**2-7.05E-10*T**3+25*T**(-1); 969 Y\n -16207.5678+236.497235*T-44.69*T*LN(T)+.0024207*T**2\n +3.08333333E-10*T**3-1065*T**(-1); 1900 Y\n +663665.969-3406.90923*T+429.821*T*LN(T)-.14307925*T**2\n +8.24672667E-06*T**3-1.809125E+08*T**(-1); 2200 Y\n -6524.86128+162.845411*T-35*T*LN(T); 4000 N !\n FUNCTION GGASRA1 298.15 +153759.624-36.4634424*T-20.909*T*LN(T)\n +1.327E-04*T**2-2.35816667E-08*T**3+2520*T**(-1); 1500 Y\n +113415.461+243.449819*T-58.888*T*LN(T)+.0161394*T**2\n -1.29957833E-06*T**3+8085840*T**(-1); 2900 Y\n +740503.588-2269.74719*T+255.137*T*LN(T)-.05399135*T**2\n +1.64816167E-06*T**3-2.274382E+08*T**(-1); 4300 Y\n -464468.83+1071.43441*T-141.421*T*LN(T)+.0039122*T**2\n +6.57833333E-08*T**3+4.579589E+08*T**(-1); 5800 Y\n -1450458.29+3377.99292*T-409.101*T*LN(T)+.0362229*T**2\n -6.65655E-07*T**3+1.1393215E+09*T**(-1); 6000 N !\n FUNCTION GLIQRB 200 +GHSERRB#+2217.552-7.110486*T+1.44078E-17*T**7;\n 312.46 Y\n -5650.532+110.090262*T-29.1775424*T*LN(T)+4.12369E-04*T**2\n -4.6822E-07*T**3-126310*T**(-1); 900 Y\n -37315.276+444.013833*T-77.7006456*T*LN(T)+.033795632*T**2\n -4.829082E-06*T**3+3778006*T**(-1); 1600 Y\n -157569.646+1280.82915*T-191.262774*T*LN(T)+.08161687*T**2\n -8.61653E-06*T**3+27738456*T**(-1); 2100 N !\n FUNCTION GFCCRB 200 +GHSERRB#+200+1.3*T; 2100 N !\n FUNCTION GHSERRB 200 -21669.733+583.580988*T-115.282589*T*LN(T)\n +.26277612*T**2-1.52236932E-04*T**3+385754*T**(-1); 312.46 Y\n -7823.397+117.050578*T-29.1775424*T*LN(T)+4.12369E-04*T**2\n -4.6822E-07*T**3-126310*T**(-1)-5.55029E+22*T**(-9); 900 Y\n -39488.142+450.974149*T-77.7006456*T*LN(T)+.033795632*T**2\n -4.829082E-06*T**3+3778006*T**(-1)-5.55029E+22*T**(-9); 1600 Y\n -159742.511+1287.78947*T-191.262774*T*LN(T)+.08161687*T**2\n -8.61653E-06*T**3+27738456*T**(-1)-5.55029E+22*T**(-9); 2100 N !\n FUNCTION GHCPRB 200 +GHSERRB#+200+2*T; 2100 N !\n FUNCTION GLIQRE 298.15 +16125.604+122.076209*T-24.348*T*LN(T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y\n +8044.885+188.322047*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2000 Y\n +568842.665-2527.83846*T+314.178898*T*LN(T)-.08939817*T**2\n +3.92854E-06*T**3-1.63100987E+08*T**(-1); 3458 Y\n -39044.888+335.723691*T-49.519*T*LN(T); 6000 N !\n FUNCTION GFCCRE 298.15 +GHSERRE#+11000-1.5*T; 6000 N !\n FUNCTION GBCCRE 298.15 +GHSERRE#+17000-3.7*T; 6000 N !\n FUNCTION GHSERRE 298.15 -7695.279+128.421589*T-24.348*T*LN(T)\n -.00253505*T**2+1.92818E-07*T**3+32915*T**(-1); 1200 Y\n -15775.998+194.667426*T-33.586*T*LN(T)+.00224565*T**2-2.81835E-07*T**3\n +1376270*T**(-1); 2400 Y\n -70882.739+462.110749*T-67.956*T*LN(T)+.01184945*T**2-7.88955E-07*T**3\n +18075200*T**(-1); 3458 Y\n +346325.888-1211.37186*T+140.831655*T*LN(T)-.033764567*T**2\n +1.053726E-06*T**3-1.34548866E+08*T**(-1); 5000 Y\n -78564.296+346.997842*T-49.519*T*LN(T); 6000 N !\n FUNCTION GLIQRH 298.15 +11244.082+125.099593*T-24.0178336*T*LN(T)\n -.003424186*T**2-1.68032E-07*T**3+55846*T**(-1); 700 Y\n +35898.508-147.926418*T+15.6492377*T*LN(T)-.028665357*T**2\n +2.100572E-06*T**3-2638940*T**(-1); 2237 Y\n -18208.54+332.974832*T-50.58456*T*LN(T); 2500 N !\n FUNCTION GHSERRH 298.15 -7848.828+132.020923*T-24.0178336*T*LN(T)\n -.003424186*T**2-1.68032E-07*T**3+55846*T**(-1); 1200 Y\n -28367.852+305.771019*T-48.3766632*T*LN(T)+.00966345*T**2\n -1.512774E-06*T**3+3348162*T**(-1); 2237 Y\n -6237470.48+30151.6342*T-3874.21058*T*LN(T)+1.04921361*T**2\n -5.3978814E-05*T**3+1.88036218E+09*T**(-1); 2450 Y\n -44863.489+344.889895*T-50.58456*T*LN(T); 2500 N !\n FUNCTION GBCCRH 298.15 +GHSERRH#+19000-4.7*T; 2500 N !\n FUNCTION GHCPRH 298.15 +GHSERRH#+3000-.5*T; 2500 N !\n FUNCTION GHSERRN 298.15 -6223.28228-36.6929111*T-20.83273*T*LN(T)\n +1.887983E-05*T**2-1.00153433E-09*T**3+2031.768*T**(-1); 7200 Y\n -582791.297+1000.48119*T-137.2327*T*LN(T)+.010524605*T**2\n -1.79927333E-07*T**3+5.383375E+08*T**(-1); 9800 Y\n -804769.059+1450.77695*T-188.0433*T*LN(T)+.01510267*T**2\n -2.52325333E-07*T**3+6.727465E+08*T**(-1); 12500 Y\n +9671336.36-10142.4734*T+1037.633*T*LN(T)-.04865342*T**2\n +3.69745167E-07*T**3-1.612149E+10*T**(-1); 14500 Y\n +17110816.5-17603.9629*T+1817.362*T*LN(T)-.08493845*T**2\n +6.860405E-07*T**3-2.941658E+10*T**(-1); 17000 Y\n -10550925.5+5698.86365*T-569.4259*T*LN(T)+.00660433*T**2\n +2.76204667E-08*T**3+3.0700315E+10*T**(-1); 20000 N !\n FUNCTION GLIQRU 298.15 +19918.743+119.467485*T-22.9143287*T*LN(T)\n -.004062566*T**2+1.7641E-07*T**3+56377*T**(-1); 800 Y\n +50827.232-179.818561*T+19.539341*T*LN(T)-.026524167*T**2\n +1.667839E-06*T**3-3861125*T**(-1); 2607 Y\n -17161.807+349.673561*T-51.8816*T*LN(T); 4500 N !\n FUNCTION GFCCRU 298.15 +GHSERRU#+12500-2.4*T; 4500 N !\n FUNCTION GBCCRU 298.15 +GHSERRU#+21500-5.05*T; 4500 N !\n FUNCTION GHSERRU 298.15 -7561.873+127.866233*T-22.9143287*T*LN(T)\n -.004062566*T**2+1.7641E-07*T**3+56377*T**(-1); 1500 Y\n -59448.103+489.516214*T-72.3241219*T*LN(T)+.018726245*T**2\n -1.952433E-06*T**3+11063885*T**(-1); 2607 Y\n -38588773+168610.517*T-21329.705*T*LN(T)+5.221639*T**2\n -2.40245985E-04*T**3+1.30829926E+10*T**(-1); 2740 Y\n -55768.304+364.482314*T-51.8816*T*LN(T); 4500 N !\n FUNCTION GLIQSS 298.15 -4196.575+85.63027*T-17.413*T*LN(T)\n -.00993935*T**2-7.0062E-08*T**3+1250*T**(-1); 335 Y\n +1790361.98-44195.4514*T+7511.61943*T*LN(T)-13.9855175*T**2\n +.0048387386*T**3-79880891*T**(-1); 388.36 Y\n -876313.954+23366.873*T-4028.756*T*LN(T)+7.954595*T**2\n -.00290851333*T**3+33980035*T**(-1); 432.25 Y\n +454088.687-7814.67023*T+1237.001*T*LN(T)-1.5607295*T**2\n +3.59883667E-04*T**3-31765395*T**(-1); 500 Y\n +18554.561-144.895285*T+16.535*T*LN(T)-.0454119*T**2+8.327402E-06*T**3\n -2705030*T**(-1); 700 Y\n +21243.126-113.298877*T+9.944*T*LN(T)-.0288384*T**2+3.791365E-06*T**3\n -3507570*T**(-1); 900 Y\n +16117.849-32.79523*T-2.425*T*LN(T)-.01712545*T**2+1.84974E-06*T**3\n -3215170*T**(-1); 1300 Y\n -6461.814+175.590536*T-32*T*LN(T); 1301 N !\n FUNCTION GFCCSS 298.15 +GHSERSS#+105000; 1301 N !\n FUNCTION GBCCSS 298.15 +GHSERSS#+105000; 1301 N !\n FUNCTION GHSERSS 298.15 -5198.294+53.913855*T-10.726*T*LN(T)\n -.0273801*T**2+8.179537E-06*T**3; 368.30 Y\n -6475.706+94.182332*T-17.8693298*T*LN(T)-.010936877*T**2\n +1.406467E-06*T**3+36871*T**(-1); 1300 Y\n -12485.546+188.304687*T-32*T*LN(T); 1301 N !\n FUNCTION GGASS2 298.15 +117374.548+2.98629558*T-34.09678*T*LN(T)\n -.002325464*T**2+1.85480167E-07*T**3+128593.6*T**(-1); 1000 Y\n +117352.438+2.50383258*T-34.04744*T*LN(T)-.0021150245*T**2\n +9.16602333E-08*T**3+175718.45*T**(-1); 3400 Y\n +124361.091+14.5182895*T-36.1923*T*LN(T)-5.930925E-04*T**2\n -7.54259333E-09*T**3-7484105*T**(-1); 6000 N !\n FUNCTION GLIQSB 298.15 +GHSERSB#+19822.328-21.923164*T-1.74847E-20*T**7;\n 903.78 Y\n +8175.359+147.455986*T-31.38*T*LN(T); 2000 N !\n FUNCTION GFCCSB 298.15 +GHSERSB#+19874-13.7*T; 2000 N !\n FUNCTION GBCCSB 298.15 +GHSERSB#+19874-15.1*T; 2000 N !\n FUNCTION GHCPSB 298.15 +GHSERSB#+19874-13*T; 2000 N !\n FUNCTION GHSERSB 298.15 -9242.858+156.154689*T-30.5130752*T*LN(T)\n +.007748768*T**2-3.003415E-06*T**3+100625*T**(-1); 903.78 Y\n -11738.83+169.485872*T-31.38*T*LN(T)+1.616849E+27*T**(-9); 2000 N !\n FUNCTION GLIQSC 298.15 +6478.66+45.427539*T-10.7967803*T*LN(T)\n -.020636524*T**2+2.13106E-06*T**3-158106*T**(-1); 1608 Y\n -11832.111+275.871695*T-44.2249*T*LN(T); 3200 N !\n FUNCTION GFCCSC 298.15 +GHSERSC#+5000; 3200 N !\n FUNCTION GBCCSC 298.15 -6709.819+152.456835*T-28.1882*T*LN(T)\n +.00321892*T**2-1.64531E-06*T**3+72177*T**(-1); 800 Y\n -5531.567+131.735447*T-24.9132*T*LN(T)-5.73295E-04*T**2\n -8.59345E-07*T**3; 1000 Y\n +230161.408-2004.05469*T+276.76664*T*LN(T)-.167120107*T**2\n +1.5637371E-05*T**3-33783257*T**(-1); 1608 Y\n -25928.011+283.642312*T-44.2249*T*LN(T); 3200 N !\n FUNCTION GHSERSC 298.15 -8689.547+153.48097*T-28.1882*T*LN(T)\n +.00321892*T**2-1.64531E-06*T**3+72177*T**(-1); 800 Y\n -7511.295+132.759582*T-24.9132*T*LN(T)-5.73295E-04*T**2\n -8.59345E-07*T**3; 1608 Y\n +261143.04-1817.92245*T+241.441051*T*LN(T)-.117529396*T**2\n +8.7398E-06*T**3-50607159*T**(-1); 2000 Y\n -30515.246+286.474338*T-44.2249*T*LN(T); 3200 N !\n FUNCTION GLIQSE 298.15 +50533.347-1178.28824*T+194.107439*T*LN(T)\n -.390268991*T**2+1.19219297E-04*T**3-2224398*T**(-1); 494 Y\n -5228.304+183.72559*T-35.1456*T*LN(T); 1000 N !\n FUNCTION GHSERSE 298.15 -9376.371+174.205877*T-33.6527*T*LN(T)\n +.02424314*T**2-1.5318461E-05*T**3+102249*T**(-1); 494 Y\n -37546.134+507.111538*T-81.2006585*T*LN(T)+.037144892*T**2\n -5.611026E-06*T**3+2614263*T**(-1); 800 Y\n -12193.47+197.770166*T-35.1456*T*LN(T); 1000 N !\n FUNCTION GLIQSI 298.15 +GHSERSI#+50696.36-30.099439*T+2.09307E-21*T**7;\n 1687 Y\n +40370.523+137.722298*T-27.196*T*LN(T); 3600 N !\n FUNCTION GFCCSI 298.15 +GHSERSI#+51000-21.8*T; 3600 N !\n FUNCTION GBCCSI 298.15 +GHSERSI#+47000-22.5*T; 3600 N !\n FUNCTION GHCPSI 298.15 +GHSERSI#+49200-20.8*T; 3600 N !\n FUNCTION GHSERSI 298.15 -8162.609+137.236859*T-22.8317533*T*LN(T)\n -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1687 Y\n -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9); 3600 N !\n FUNCTION GLIQSM 298.15 +3468.783+20.117456*T-11.6968284*T*LN(T)\n -.032418177*T**2+4.544272E-06*T**3+23528*T**(-1); 1190 Y\n -11728.229+273.487076*T-50.208*T*LN(T); 2100 N !\n FUNCTION GBCCSM 298.15 -4368.72+55.972523*T-16.9298494*T*LN(T)\n -.025446016*T**2+3.579527E-06*T**3+94209*T**(-1); 1190 Y\n -15957.862+253.121044*T-46.9445*T*LN(T); 1345 Y\n +111191.653-624.680805*T+71.6856914*T*LN(T)-.047314968*T**2\n +3.329865E-06*T**3-24870276*T**(-1); 2100 N !\n FUNCTION GHCPSM 298.15 +GHSERSM#+69.977-.069491*T; 2100 N !\n FUNCTION GHSERSM 298.15 -3872.013-32.10748*T-1.6485*T*LN(T)-.050254*T**2\n +1.010345E-05*T**3-82168*T**(-1); 700 Y\n -50078.215+627.869894*T-102.665*T*LN(T)+.0474522*T**2\n -7.538383E-06*T**3+3861770*T**(-1); 1190 Y\n +289719.819-2744.50976*T+381.41982*T*LN(T)-.254986338*T**2\n +2.7512152E-05*T**3-40102102*T**(-1); 1345 Y\n -23056.079+282.194375*T-50.208*T*LN(T); 2100 N !\n FUNCTION GLIQSN 100 +GHSERSN#+7103.092-14.087767*T+1.47031E-18*T**7;\n 505.08 Y\n +9496.31-9.809114*T-8.2590486*T*LN(T)-.016814429*T**2\n +2.623131E-06*T**3-1081244*T**(-1); 800 Y\n -1285.372+125.182498*T-28.4512*T*LN(T); 3000 N !\n FUNCTION GFCCSN 100 +GHSERSN#+5510-8.46*T; 3000 N !\n FUNCTION GBCCSN 100 +GHSERSN#+4400-6*T; 3000 N !\n FUNCTION GHCPSN 100 +GHSERSN#+3900-7.646*T; 3000 N !\n FUNCTION GHSERSN 100 -7958.517+122.765451*T-25.858*T*LN(T)\n +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1); 250 Y\n -5855.135+65.443315*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3\n -61960*T**(-1); 505.08 Y\n +2524.724+4.005269*T-8.2590486*T*LN(T)-.016814429*T**2\n +2.623131E-06*T**3-1081244*T**(-1)-1.2307E+25*T**(-9); 800 Y\n -8256.959+138.99688*T-28.4512*T*LN(T)-1.2307E+25*T**(-9); 3000 N !\n FUNCTION GLIQSR 298.15 +2194.997-10.118994*T-5.0668978*T*LN(T)\n -.031840595*T**2+4.981237E-06*T**3-265559*T**(-1); 1050 Y\n -10855.29+213.406219*T-39.463*T*LN(T); 3000 N !\n FUNCTION GHSERSR 298.15 -7532.367+107.183879*T-23.905*T*LN(T)\n -.00461225*T**2-1.67477E-07*T**3-2055*T**(-1); 820 Y\n -13380.102+153.196104*T-30.0905432*T*LN(T)-.003251266*T**2\n +1.84189E-07*T**3+850134*T**(-1); 3000 N !\n FUNCTION GBCCSR 298.15 -6779.234+116.583654*T-25.6708365*T*LN(T)\n -.003126762*T**2+2.2965E-07*T**3+27649*T**(-1); 820 Y\n -6970.594+122.067301*T-26.57*T*LN(T)-.0019493*T**2-1.7895E-08*T**3\n +16495*T**(-1); 1050 Y\n +8168.357+.423037*T-9.7788593*T*LN(T)-.009539908*T**2+5.20221E-07*T**3\n -2414794*T**(-1); 3000 N !\n FUNCTION GHCPSR 298.15 +GHSERSR#+250+.7*T; 3000 N !\n FUNCTION GHSERT1 298.15 +217173.654+10.8312449*T-20.786*T*LN(T); 6000 N !\n FUNCTION GHSERT2 298.15 -7866.66628+27.0791947*T-26.83661*T*LN(T)\n -.0018402735*T**2-3.83766667E-07*T**3-47495.205*T**(-1); 800 Y\n -10075.8547+36.1414244*T-27.73559*T*LN(T)-.003476423*T**2\n +1.94916667E-07*T**3+366681*T**(-1); 2300 Y\n -11704.7696+66.9358*T-32.14505*T*LN(T)-.0012333515*T**2\n +2.081645E-08*T**3-649401*T**(-1); 5800 Y\n -154096.368+295.516281*T-57.15841*T*LN(T)+2.810452E-04*T**2\n +1.757905E-08*T**3+1.356364E+08*T**(-1); 9800 Y\n -142455.129+386.293696*T-68.45016*T*LN(T)+.001927947*T**2\n -1.4502375E-08*T**3+15481045*T**(-1); 18500 Y\n +484422.833-154.39806*T-12.90783*T*LN(T)-2.6700035E-04*T**2\n +1.79437333E-09*T**3-1.31833E+09*T**(-1); 20000 N !\n FUNCTION GLIQTA 298.15 +21875.086+111.561128*T-23.7592624*T*LN(T)\n -.002623033*T**2+1.70109E-07*T**3-3293*T**(-1); 1000 Y\n +43884.339-61.981795*T+.0279523*T*LN(T)-.012330066*T**2\n +6.14599E-07*T**3-3523338*T**(-1); 3290 Y\n -6314.543+258.110873*T-41.84*T*LN(T); 6000 N !\n FUNCTION GFCCTA 298.15 +GHSERTA#+16000+1.7*T; 6000 N !\n FUNCTION GHSERTA 298.15 -7285.889+119.139857*T-23.7592624*T*LN(T)\n -.002623033*T**2+1.70109E-07*T**3-3293*T**(-1); 1300 Y\n -22389.955+243.88676*T-41.137088*T*LN(T)+.006167572*T**2\n -6.55136E-07*T**3+2429586*T**(-1); 2500 Y\n +229382.886-722.59722*T+78.5244752*T*LN(T)-.017983376*T**2\n +1.95033E-07*T**3-93813648*T**(-1); 3290 Y\n -1042384.01+2985.49125*T-362.159132*T*LN(T)+.043117795*T**2\n -1.055148E-06*T**3+5.54714342E+08*T**(-1); 6000 N !\n FUNCTION GHCPTA 298.15 +GHSERTA#+12000+2.4*T; 6000 N !\n FUNCTION GLIQTB 298.15 +3945.831+29.867521*T-14.252646*T*LN(T)\n -.020466105*T**2+2.17475E-06*T**3-160724*T**(-1); 1562 Y\n -13247.649+251.16889*T-46.4842*T*LN(T); 3000 N !\n FUNCTION GBCCTB 298.15 -16674.323+406.656848*T-77.5006*T*LN(T)\n +.0832265*T**2-2.5672833E-05*T**3+562430*T**(-1); 600 Y\n -4604.771+99.958913*T-25.8659*T*LN(T)-.002757005*T**2-8.05838E-07*T**3\n +172355*T**(-1); 1200 Y\n +633060.245-5157.77779*T+706.580596*T*LN(T)-.373763517*T**2\n +3.4100235E-05*T**3-1.03233571E+08*T**(-1); 1562 Y\n -23398.029+257.388486*T-46.4842*T*LN(T); 3000 N !\n FUNCTION GHSERTB 298.15 -20842.158+409.309555*T-77.5006*T*LN(T)\n +.0832265*T**2-2.5672833E-05*T**3+562430*T**(-1); 600 Y\n -8772.606+102.61162*T-25.8659*T*LN(T)-.002757005*T**2-8.05838E-07*T**3\n +172355*T**(-1); 1200 Y\n -7944.942+101.7776*T-25.9584*T*LN(T)-.001676335*T**2-1.067632E-06*T**3;\n 1562 Y\n -265240.309+1456.04268*T-200.215695*T*LN(T)+.041615159*T**2\n -2.044697E-06*T**3+65043790*T**(-1); 3000 N !\n FUNCTION GLIQTC 298.15 +GHSERTC#+30402.134-12.313*T-9.62385E-22*T**7;\n 2430 Y\n -12221.9+303.7538*T-47*T*LN(T); 4000 N !\n FUNCTION GFCCTC 298.15 +GHSERTC#+10000-1.5*T; 4000 N !\n FUNCTION GBCCTC 298.15 +GHSERTC#+18000-4.5*T; 4000 N !\n FUNCTION GHSERTC 298.15 -7947.794+132.5101*T-24.3394*T*LN(T)\n -.002954747*T**2+63855*T**(-1); 2430 Y\n -47759.99+318.286*T-47*T*LN(T)+6.63829E+32*T**(-9); 4000 N !\n FUNCTION GLIQTE 298.15 -17554.731+685.877639*T-126.318*T*LN(T)\n +.2219435*T**2-9.42075E-05*T**3+827930*T**(-1); 626.49 Y\n -3165763.48+46756.357*T-7196.41*T*LN(T)+7.09775*T**2-.00130692833*T**3\n +2.58051E+08*T**(-1); 722.66 Y\n +180326.959-1500.57909*T+202.743*T*LN(T)-.142016*T**2\n +1.6129733E-05*T**3-24238450*T**(-1); 1150 Y\n +6328.687+148.708299*T-32.5596*T*LN(T); 1600 N !\n FUNCTION GHSERTE 298.15 -10544.679+183.372894*T-35.6687*T*LN(T)\n +.01583435*T**2-5.240417E-06*T**3+155015*T**(-1); 722.66 Y\n +9160.595-129.265373*T+13.004*T*LN(T)-.0362361*T**2+5.006367E-06*T**3\n -1286810*T**(-1); 1150 Y\n -12781.349+174.901226*T-32.5596*T*LN(T); 1600 N !\n FUNCTION GLIQTH 298.15 +5031.109+110.886346*T-24.987*T*LN(T)\n -.00168345*T**2-9.09067E-07*T**3+10865*T**(-1); 1499.80 Y\n -15602.847+127.657716*T-24.03*T*LN(T)-.0136421*T**2+1.210117E-06*T**3\n +7111100*T**(-1); 2014.50 Y\n -17273.382+275.001274*T-46.024*T*LN(T); 4000 N !\n FUNCTION GHSERTH 298.15 -7732.08+116.273975*T-24.841*T*LN(T)\n -.00236725*T**2-5.2883E-07*T**3+13010*T**(-1); 1633 Y\n -37352.871+236.906118*T-39.107*T*LN(T)-.00358025*T**2+2.36893E-07*T**3\n +7981000*T**(-1); 2900 Y\n -33353.313+283.231045*T-46.024*T*LN(T); 4000 N !\n FUNCTION GBCCTH 298.15 -2321.06+133.531195*T-28.244*T*LN(T)\n +4.3775E-04*T**2-5.3048E-07*T**3+91190*T**(-1); 1633 Y\n -115978.348+800.909049*T-116.453*T*LN(T)+.03098*T**2-2.536883E-06*T**3\n +27512600*T**(-1); 2023 Y\n -33602.796+208.774709*T-35.813*T*LN(T)-.00346655*T**2+1.66067E-07*T**3\n +11876950*T**(-1); 3600 Y\n -34333.615+283.181494*T-46.024*T*LN(T); 4000 N !\n FUNCTION GLIQTI 298.15 +4134.494+126.63427*T-23.9933*T*LN(T)\n -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 900 Y\n +4382.601+126.00713*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3\n +42680*T**(-1); 1155 Y\n +13103.253+59.9956*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3\n -1477660*T**(-1); 1300 Y\n +369519.198-2554.0225*T+342.059267*T*LN(T)-.163409355*T**2\n +1.2457117E-05*T**3-67034516*T**(-1); 1941 Y\n -19887.066+298.7367*T-46.29*T*LN(T); 4000 N !\n FUNCTION GFCCTI 298.15 +GHSERTI#+6000-.1*T; 4000 N !\n FUNCTION GBCCTI 298.15 -1272.064+134.71418*T-25.5768*T*LN(T)\n -6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1); 1155 Y\n +6667.385+105.366379*T-22.3771*T*LN(T)+.00121707*T**2-8.4534E-07*T**3\n -2002750*T**(-1); 1941 Y\n +26483.26-182.426471*T+19.0900905*T*LN(T)-.02200832*T**2\n +1.228863E-06*T**3+1400501*T**(-1); 4000 N !\n FUNCTION GHSERTI 298.15 -8059.921+133.615208*T-23.9933*T*LN(T)\n -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 900 Y\n -7811.815+132.988068*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3\n +42680*T**(-1); 1155 Y\n +908.837+66.976538*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3\n -1477660*T**(-1); 1941 Y\n -124526.786+638.806871*T-87.2182461*T*LN(T)+.008204849*T**2\n -3.04747E-07*T**3+36699805*T**(-1); 4000 N !\n FUNCTION GLIQTL 200 -946.623+.755649*T-7.44455*T*LN(T)-.044350292*T**2\n +1.4248046E-05*T**3-54228*T**(-1); 577 Y\n -614.74+98.472609*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3\n -612570*T**(-1); 1801 N !\n FUNCTION GFCCTL 200 +GHSERTL#+310; 1801 N !\n FUNCTION GBCCTL 200 -9194.493+150.019517*T-33.0508*T*LN(T)+.0172318*T**2\n -1.0115933E-05*T**3+82153*T**(-1); 577 Y\n -41836.403+482.633817*T-79.2926704*T*LN(T)+.026042993*T**2\n -2.359101E-06*T**3+3507810*T**(-1); 1800 Y\n -623.343+101.120182*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3\n -612570*T**(-1); 1801 N !\n FUNCTION GHSERTL 200 -8104.038+107.140405*T-25.2274*T*LN(T)-.0033063*T**2\n -1.21807E-07*T**3+42058*T**(-1); 577 Y\n -15406.859+196.771926*T-38.4130658*T*LN(T)+.005228106*T**2\n -5.19136E-07*T**3+729665*T**(-1); 1800 Y\n -4885.034+106.361006*T-25.8437*T*LN(T)-8.3662E-04*T**2+9E-12*T**3\n -612570*T**(-1); 1801 N !\n FUNCTION GLIQTM 298.15 +3182.534+144.479977*T-34.3664974*T*LN(T)\n +.012110965*T**2-3.831156E-06*T**3+95982*T**(-1); 600 Y\n +22640.028-126.738485*T+6.8744933*T*LN(T)-.025487085*T**2\n +2.288172E-06*T**3-1585412*T**(-1); 1818 Y\n -10090.305+214.184413*T-41.37976*T*LN(T); 2300 N !\n FUNCTION GHSERTM 298.15 -10016.715+151.037648*T-34.3664974*T*LN(T)\n +.012110965*T**2-3.831156E-06*T**3+95982*T**(-1); 700 Y\n -14701.965+147.957496*T-32.1951269*T*LN(T)+4.44753E-04*T**2\n -3.96694E-07*T**3+1091664*T**(-1); 1600 Y\n -8669.227+97.98144*T-25.1816969*T*LN(T)-.003384563*T**2; 1818 Y\n +727125.608-4147.40063*T+534.082763*T*LN(T)-.19093039*T**2\n +1.1689185E-05*T**3-1.8038222E+08*T**(-1); 2300 N !\n FUNCTION GLIQUU 298.15 +GHSERUU#+12355.5-10.3239*T; 3000 N !\n FUNCTION GFCCUU 298.15 +GHSERUU#+5000; 3000 N !\n FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T)\n -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1049 Y\n -4698.365+202.685635*T-38.2836*T*LN(T); 3000 N !\n FUNCTION GHCPUU 298.15 +4247.233+131.5301*T-27.5152*T*LN(T)\n -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1049 Y\n +301.635+202.677635*T-38.2836*T*LN(T); 2500 N !\n FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T)\n +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 955 Y\n -22521.8+292.121093*T-48.66*T*LN(T); 3000 N !\n FUNCTION GLIQVV 298.15 +GHSERVV#+20764.117-9.455552*T-5.19136E-22*T**7;\n 2183 Y\n -19617.51+311.055983*T-47.43*T*LN(T); 4000 N !\n FUNCTION GFCCVV 298.15 +GHSERVV#+7500+1.7*T; 4000 N !\n FUNCTION GHSERVV 298.15 -7930.43+133.346053*T-24.134*T*LN(T)-.003098*T**2\n +1.2175E-07*T**3+69460*T**(-1); 790 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; 2183 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); 4000 N !\n FUNCTION GHCPVV 298.15 +GHSERVV#+4000+2.4*T; 4000 N !\n FUNCTION GLIQWW 298.15 +GHSERWW#+52160.584-14.10999*T-2.713468E-24*T**7;\n 3695 Y\n -30436.051+375.175*T-54*T*LN(T); 6000 N !\n FUNCTION GFCCWW 298.15 +GHSERWW#+19300+.63*T; 6000 N !\n FUNCTION GHSERWW 298.15 -7646.311+130.4*T-24.1*T*LN(T)-.001936*T**2\n +2.07E-07*T**3+44500*T**(-1)-5.33E-11*T**4; 3695 Y\n -82868.801+389.362335*T-54*T*LN(T)+1.528621E+33*T**(-9); 6000 N !\n FUNCTION GHCPWW 298.15 +GHSERWW#+14750; 6000 N !\n FUNCTION GHSERXE 298.15 -6218.7749-30.2044649*T-20.82368*T*LN(T)\n +1.4072105E-05*T**2-6.82734E-10*T**3+1700.88*T**(-1); 8200 Y\n -704701.42+1081.53707*T-143.6918*T*LN(T)+.00967559*T**2\n -1.44048483E-07*T**3+7.482925E+08*T**(-1); 11000 Y\n -1276720.23+1886.04885*T-231.1446*T*LN(T)+.01552948*T**2\n -2.16645667E-07*T**3+1.43637E+09*T**(-1); 14000 Y\n +9750984.27-9088.96014*T+914.806*T*LN(T)-.037416845*T**2\n +2.42242833E-07*T**3-1.84681E+10*T**(-1); 16500 Y\n +20031412.8-18268.3895*T+1861.258*T*LN(T)-.0761213*T**2\n +5.38855667E-07*T**3-3.939352E+10*T**(-1); 20000 N !\n FUNCTION GGASXE2 298.15 -12203.7597-137.981553*T-20.77691*T*LN(T)\n -4.6678605E-06*T**2+4.43969167E-10*T**3-45209.57*T**(-1); 2000 N !\n FUNCTION GLIQYY 100 +2098.50738+119.41873*T-24.6467508*T*LN(T)\n -.00347023463*T**2-8.12981167E-07*T**3+23713.7332*T**(-1); 1000 Y\n +7386.44846+19.4520171*T-9.0681627*T*LN(T)-.0189533369*T**2\n +1.7595327E-06*T**3; 1795.15 Y\n -12976.5957+257.400783*T-43.0952*T*LN(T); 3700 N !\n FUNCTION GFCCYY 100 +GHSERYY#+6000; 3700 N !\n FUNCTION GBCCYY 100 -833.658863+123.667346*T-25.5832578*T*LN(T)\n -.00237175965*T**2+9.10372497E-09*T**3+27340.0687*T**(-1); 1000 Y\n -1297.79829+134.528352*T-27.3038477*T*LN(T)-5.41757644E-04*T**2\n -3.05012175E-07*T**3; 1795.15 Y\n +15389.4975+.981325399*T-8.88296647*T*LN(T)-.00904576576*T**2\n +4.02944768E-07*T**3-2542575.96*T**(-1); 3700 N !\n FUNCTION GHSERYY 100 -8011.09379+128.572856*T-25.6656992*T*LN(T)\n -.00175716414*T**2-4.17561786E-07*T**3+26911.509*T**(-1); 1000 Y\n -7179.74574+114.497104*T-23.4941827*T*LN(T)-.0038211802*T**2\n -8.2534534E-08*T**3; 1795.15 Y\n -67480.7761+382.124727*T-56.9527111*T*LN(T)+.00231774379*T**2\n -7.22513088E-08*T**3+18077162.6*T**(-1); 3700 N !\n FUNCTION GLIQYB 298.15 +7030.788-40.615571*T-1.8061816*T*LN(T)\n -.03250938*T**2+5.136665E-06*T**3-370554*T**(-1); 1033 Y\n -6445.835+186.690398*T-36.7774*T*LN(T); 2000 N !\n FUNCTION GHSERYB 298.15 -9370.941+189.327664*T-40.0791*T*LN(T)\n +.04227115*T**2-2.2242E-05*T**3; 553 Y\n -8192.154+121.065655*T-26.7591*T*LN(T)-.00256065*T**2; 1033 Y\n +16034.89-89.478241*T+2.7623966*T*LN(T)-.017961331*T**2\n +1.421719E-06*T**3-3631462*T**(-1); 2000 N !\n FUNCTION GBCCYB 298.15 -965.99-21.293677*T-3.8534432*T*LN(T)\n -.030009694*T**2+4.743871E-06*T**3-334650*T**(-1); 1033 Y\n -13368.113+188.313864*T-36.1079*T*LN(T); 1097 Y\n -3911.847+113.174165*T-25.7402233*T*LN(T)-.004743348*T**2\n +3.63044E-07*T**3-1553668*T**(-1); 2000 N !\n FUNCTION GHCPYB 298.15 +GHSERYB#+5000; 2000 N !\n FUNCTION GLIQZN 298.15 +GHSERZN#+7157.222-10.29305*T-3.58949E-19*T**7;\n 692.67 Y\n -3620.385+161.60854*T-31.38*T*LN(T); 1700 N !\n FUNCTION GFCCZN 298.15 +GHSERZN#+2969.82-1.56968*T; 1700 N !\n FUNCTION GBCCZN 298.15 +GHSERZN#+2886.96-2.5104*T; 1700 N !\n FUNCTION GHCPZN 298.15 +GHSERZN#+2969.82-1.56968*T; 1700 N !\n FUNCTION GHSERZN 298.15 -7285.787+118.470069*T-23.701314*T*LN(T)\n -.001712034*T**2-1.264963E-06*T**3; 692.67 Y\n -11070.546+172.345644*T-31.38*T*LN(T)+4.7047E+26*T**(-9); 1700 N !\n FUNCTION GLIQZR 298.15 +GHSERZR#+18147.69-9.080812*T+1.6275E-22*T**7;\n 2128 Y\n -8281.26+253.812609*T-42.144*T*LN(T); 6000 N !\n FUNCTION GFCCZR 298.15 +GHSERZR#+7600-.9*T; 6000 N !\n FUNCTION GBCCZR 298.15 -525.539+124.9457*T-25.607406*T*LN(T)\n -3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1)-7.6143E-11*T**4; 2128 Y\n -30705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N !\n FUNCTION GHSERZR 130 -7827.595+125.64905*T-24.1618*T*LN(T)-.00437791*T**2\n +34971*T**(-1); 2128 Y\n -26085.921+262.724183*T-42.144*T*LN(T)-1.342896E+31*T**(-9); 6000 N !\n\n\nFUNCTION UN_ASS 298.15 +0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE GAS:G % 1 1.0 !\n CONSTITUENT GAS:G :AC,AR,AT,AT2,BR2,C,CL2,CM,D,D2,ES,F2,FM,FR,FR2,H2,HE,\n I2,KR,N2,NE,O2,PM,PO,RA,RN,S2,T,T2,T3,XE,XE2 : !\n\n PARAMETER G(GAS,AC;0) 298.15 +GGASAC1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,AR;0) 298.15 +GHSERAR#+RTLNP#; 6000 N\n REF2 !\n PARAMETER G(GAS,AT;0) 298.15 +GGASAT1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,AT2;0) 298.15 +GGASAT2#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,BR2;0) 298.15 +GGASBR2#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,C;0) 298.15 +GGASC1#+RTLNP#; 6000 N\n REF2 !\n PARAMETER G(GAS,CL2;0) 298.15 +2*GHSERCL#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,CM;0) 298.15 +GGASCM1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,D;0) 298.15 +GHSERD1#+RTLNP#; 6000 N\n REF2 !\n PARAMETER G(GAS,D2;0) 298.15 +GHSERD2#+RTLNP#; 6000 N\n REF2 !\n PARAMETER G(GAS,ES;0) 298.15 +GGASES1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,F2;0) 298.15 +2*GHSERFF#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,FM;0) 298.15 +GGASFM1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,FR;0) 298.15 +GGASFR1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,FR2;0) 298.15 +GGASFR2#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,H2;0) 298.15 +2*GHSERHH#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,HE;0) 298.15 +GHSERHE#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,I2;0) 298.15 +GGASI2#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,KR;0) 298.15 +GHSERKR#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,N2;0) 298.15 +2*GHSERNN#; 6000 N REF2 !\n PARAMETER G(GAS,NE;0) 298.15 +GHSERNE#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,O2;0) 298.15 +2*GHSEROO#; 6000 N REF2 !\n PARAMETER G(GAS,PM;0) 298.15 +GGASPM1#+RTLNP#; 6000 N\n REF3 !\n PARAMETER G(GAS,PO;0) 298.15 +GGASPO1#+RTLNP#; 6000 N\n REF3 !\n\n\n PHASE LIQUID % 1 1.0 !\n CONSTITUENT LIQUID :AC,AG,AL,AM,AS,AT2,AU,B,BA,BE,BI,BR2,C,CA,CD,CE,CM,\n CO,CR,CS,CU,DY,ER,ES,EU,FE,GA,GD,GE,HF,HG,HO,I2,IN,IR,K,LA,LI,LU,MG,MN,\n MO,N,NA,NB,ND,NI,NP,O,OS,P,PA,PB,PD,PM,PO,PR,\n PT,PU,RA,RB,RE,RH,RU,S,SB,SC,SE,SI,SM,SN,SR,TA,TB,\n TC,TE,TH,TI,TL,TM,U,V,W,Y,YB,ZN,ZR : !\n\n PARAMETER G(LIQUID,AC;0) 298.15 +GHSERAC#+12000\n -9.07029478*T; 5000 N REF3 !\n PARAMETER G(LIQUID,AG;0) 298.15 +GLIQAG#; 3000 N REF2 !\n PARAMETER G(LIQUID,AL;0) 298.15 +GLIQAL#; 2900 N REF2 !\n PARAMETER G(LIQUID,AM;0) 298.15 +GLIQAM#; 3000 N REF3 !\n PARAMETER G(LIQUID,AS;0) 298.15 +GLIQAS#; 1200 N REF2 !\n PARAMETER G(LIQUID,AT2;0) 298.15 +2*GHSERAT#+20000-40*T;\n 6000 N REF3 !\n PARAMETER G(LIQUID,AU;0) 298.15 +GLIQAU#; 3200 N REF2 !\n PARAMETER G(LIQUID,B;0) 298.15 +GLIQBB#; 6000 N REF4 !\n PARAMETER G(LIQUID,BA;0) 298.15 +GLIQBA#; 4000 N REF2 !\n PARAMETER G(LIQUID,BE;0) 298.15 +GLIQBE#; 3000 N REF2 !\n PARAMETER G(LIQUID,BI;0) 298.15 +GLIQBI#; 3000 N REF2 !\n PARAMETER G(LIQUID,BR2;0) 298.15 +2*GHSERBR#; 6000 N REF3 !\n PARAMETER G(LIQUID,C;0) 298.15 +GLIQCC#; 6000 N REF2 !\n PARAMETER G(LIQUID,CA;0) 298.15 +GLIQCA#; 3001 N REF4 !\n PARAMETER G(LIQUID,CD;0) 298.15 +GLIQCD#; 1600 N REF2 !\n PARAMETER G(LIQUID,CE;0) 298.15 +GLIQCE#; 4000 N REF2 !\n PARAMETER G(LIQUID,CM;0) 298.15 +GHSERCM#+17886.6\n -11.1426799*T; 6000 N REF3 !\n PARAMETER G(LIQUID,CO;0) 298.15 +GLIQCO#; 6000 N REF2 !\n PARAMETER G(LIQUID,CR;0) 298.15 +GLIQCR#; 6000 N REF2 !\n PARAMETER G(LIQUID,CS;0) 200 +GLIQCS#; 2000 N REF2 !\n PARAMETER G(LIQUID,CU;0) 298.15 +GLIQCU#; 3200 N REF2 !\n PARAMETER G(LIQUID,DY;0) 100 +GLIQDY#; 3000 N REF2 !\n PARAMETER G(LIQUID,ER;0) 298.15 +GLIQER#; 3200 N REF2 !\n PARAMETER G(LIQUID,ES;0) 298.15 +GHSERES#+9405.6\n -8.30150044*T; 6000 N REF3 !\n PARAMETER G(LIQUID,EU;0) 298.15 +GLIQEU#; 1901 N REF2 !\n PARAMETER G(LIQUID,FE;0) 298.15 +GLIQFE#; 6000 N REF2 !\n PARAMETER G(LIQUID,GA;0) 200 +GLIQGA#; 4000 N REF3 !\n PARAMETER G(LIQUID,GD;0) 100 +GLIQGD#; 3600 N REF2 !\n PARAMETER G(LIQUID,GE;0) 298.15 +GLIQGE#; 3200 N REF2 !\n PARAMETER G(LIQUID,HF;0) 298.15 +GLIQHF#; 3001 N REF3 !\n PARAMETER G(LIQUID,HG;0) 200 +GHSERHG#; 2000 N REF1 !\n PARAMETER G(LIQUID,HO;0) 298.15 +GLIQHO#; 3001 N REF3 !\n PARAMETER G(LIQUID,I2;0) 298.15 +2*GHSERII#+15517.2\n -40.1272304*T; 1000 N REF3 !\n PARAMETER G(LIQUID,IN;0) 298.15 +GLIQIN#; 3800 N REF3 !\n PARAMETER G(LIQUID,IR;0) 298.15 +GLIQIR#; 4000 N REF2 !\n PARAMETER G(LIQUID,K;0) 200 +GLIQKK#; 2200 N REF3 !\n PARAMETER G(LIQUID,LA;0) 298.15 +GLIQLA#; 4000 N REF2 !\n PARAMETER G(LIQUID,LI;0) 200 +GLIQLI#; 3000 N REF4 !\n PARAMETER G(LIQUID,LU;0) 298.15 +GLIQLU#; 3700 N REF2 !\n PARAMETER G(LIQUID,MG;0) 298.15 +GLIQMG#; 3000 N REF2 !\n PARAMETER G(LIQUID,MN;0) 298.15 +GLIQMN#; 2000 N REF3 !\n PARAMETER G(LIQUID,MO;0) 298.15 +GLIQMO#; 5000 N REF2 !\n PARAMETER G(LIQUID,N;0) 298.15 +GLIQNN#; 6000 N REF2 !\n PARAMETER G(LIQUID,NA;0) 200 +GLIQNA#; 2300 N REF2 !\n PARAMETER G(LIQUID,NB;0) 298.15 +GLIQNB#; 6000 N REF2 !\n PARAMETER G(LIQUID,ND;0) 298.15 +GLIQND#; 1800 N REF2 !\n PARAMETER G(LIQUID,NI;0) 298.15 +GLIQNI#; 3000 N REF4 !\n PARAMETER G(LIQUID,NP;0) 298.15 +GLIQNP#; 4000 N REF2 !\n PARAMETER G(LIQUID,O;0) 298.15 +GLIQOO#; 6000 N REF2 !\n PARAMETER G(LIQUID,OS;0) 298.15 +GLIQOS#; 5500 N REF2 !\n PARAMETER G(LIQUID,P;0) 250 +GLIQPP#; 3000 N REF2 !\n PARAMETER G(LIQUID,PA;0) 298.15 +GLIQPA#; 4000 N REF2 !\n PARAMETER G(LIQUID,PB;0) 298.15 +GLIQPB#; 2100 N REF2 !\n PARAMETER G(LIQUID,PD;0) 298.15 +GLIQPD#; 4000 N REF2 !\n PARAMETER G(LIQUID,PM;0) 298.15 +GHSERPM#+10900\n -8.60701804*T; 6000 N REF3 !\n PARAMETER G(LIQUID,PO;0) 298.15 +GHSERPO#+10000\n -18.9753321*T; 6000 N REF3 !\n PARAMETER G(LIQUID,PR;0) 298.15 +GLIQPR#; 3800 N REF2 !\n PARAMETER G(LIQUID,PT;0) 298.15 +GLIQPT#; 4000 N REF3 !\n PARAMETER G(LIQUID,PU;0) 298.15 +GLIQPU#; 3000 N REF2 !\n PARAMETER G(LIQUID,RA;0) 298.15 +GHSERRA#+7700-7.94633643*T;\n 6000 N REF3 !\n PARAMETER G(LIQUID,RB;0) 200 +GLIQRB#; 2100 N REF2 !\n PARAMETER G(LIQUID,RE;0) 298.15 +GLIQRE#; 6000 N REF2 !\n PARAMETER G(LIQUID,RH;0) 298.15 +GLIQRH#; 2500 N REF2 !\n PARAMETER G(LIQUID,RU;0) 298.15 +GLIQRU#; 4500 N REF2 !\n PARAMETER G(LIQUID,S;0) 298.15 +GLIQSS#; 1301 N REF3 !\n PARAMETER G(LIQUID,SB;0) 298.15 +GLIQSB#; 2000 N REF2 !\n PARAMETER G(LIQUID,SC;0) 298.15 +GLIQSC#; 3200 N REF3 !\n PARAMETER G(LIQUID,SE;0) 298.15 +GLIQSE#; 1000 N REF3 !\n PARAMETER G(LIQUID,SI;0) 298.15 +GLIQSI#; 3600 N REF2 !\n PARAMETER G(LIQUID,SM;0) 298.15 +GLIQSM#; 2100 N REF2 !\n PARAMETER G(LIQUID,SN;0) 100 +GLIQSN#; 3000 N REF2 !\n PARAMETER G(LIQUID,SR;0) 298.15 +GLIQSR#; 3000 N REF2 !\n PARAMETER G(LIQUID,TA;0) 298.15 +GLIQTA#; 6000 N REF2 !\n PARAMETER G(LIQUID,TB;0) 298.15 +GLIQTB#; 3000 N REF2 !\n PARAMETER G(LIQUID,TC;0) 298.15 +GLIQTC#; 4000 N REF2 !\n PARAMETER G(LIQUID,TE;0) 298.15 +GLIQTE#; 1600 N REF2 !\n PARAMETER G(LIQUID,TH;0) 298.15 +GLIQTH#; 4000 N REF3 !\n PARAMETER G(LIQUID,TI;0) 298.15 +GLIQTI#; 4000 N REF3 !\n PARAMETER G(LIQUID,TL;0) 200 +GLIQTL#; 1801 N REF2 !\n PARAMETER G(LIQUID,TM;0) 298.15 +GLIQTM#; 2300 N REF2 !\n PARAMETER G(LIQUID,U;0) 298.15 +GLIQUU#; 3000 N REF2 !\n PARAMETER G(LIQUID,V;0) 298.15 +GLIQVV#; 4000 N REF2 !\n PARAMETER G(LIQUID,W;0) 298.15 +GLIQWW#; 6000 N REF2 !\n PARAMETER G(LIQUID,Y;0) 100 +GLIQYY#; 3700 N REF2 !\n PARAMETER G(LIQUID,YB;0) 298.15 +GLIQYB#; 2000 N REF2 !\n PARAMETER G(LIQUID,ZN;0) 298.15 +GLIQZN#; 1700 N REF2 !\n PARAMETER G(LIQUID,ZR;0) 298.15 +GLIQZR#; 6000 N REF2 !\n\n\n PHASE AC_S % 1 1.0 !\n CONSTITUENT AC_S :AC : !\n\n PARAMETER G(AC_S,AC;0) 298.15 +GHSERAC#; 5000 N REF3 !\n\n\n PHASE ALPHA_RHOMBO_B % 1 1.0 !\n CONSTITUENT ALPHA_RHOMBO_B :B : !\n\n PARAMETER G(ALPHA_RHOMBO_B,B;0) 298.15 -6076.24+86.648762*T\n -12.942464*T*LN(T)-.007089468*T**2+6.59896E-07*T**3-45*T**(-1); 1400 Y\n +28477.506-106.789208*T+12.1072478*T*LN(T)-.013316875*T**2\n +7.06895E-07*T**3-8002403*T**(-1); 3000 Y\n -25699.64+225.127135*T-31.4*T*LN(T); 6000 N REF4 !\n\n\n PHASE ALPHA_PU % 1 1.0 !\n CONSTITUENT ALPHA_PU :PU : !\n\n PARAMETER G(ALPHA_PU,PU;0) 298.15 +GHSERPU#; 3000 N REF1 !\n\n\n PHASE AT2_S % 1 1.0 !\n CONSTITUENT AT2_S :AT2 : !\n\n PARAMETER G(AT2_S,AT2;0) 298.15 +2*GHSERAT#; 6000 N REF3 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :AG,AL,AM,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,DY,\n 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,\n PB,PD,PR,PT,PU,RB,RE,RH,RU,S,SB,SC,SI,SM,SN,SR,TA,TB,TC,TH,\n TI,TL,U,V,W,Y,YB,ZN,ZR : VA : !\n\n PARAMETER G(BCC_A2,AG:VA;0) 298.15 +GBCCAG#; 3000 N REF2 !\n PARAMETER G(BCC_A2,AL:VA;0) 298.15 +GBCCAL#; 2900 N REF2 !\n PARAMETER G(BCC_A2,AM:VA;0) 298.15 +GBCCAM#; 3000 N REF3 !\n PARAMETER G(BCC_A2,AS:VA;0) 298.15 +GBCCAS#; 1200 N REF2 !\n PARAMETER G(BCC_A2,AU:VA;0) 298.15 +GBCCAU#; 3200 N REF2 !\n PARAMETER G(BCC_A2,B:VA;0) 298.15 +GBCCBB#; 6000 N REF2 !\n PARAMETER G(BCC_A2,BA:VA;0) 298.15 +GHSERBA#; 4000 N REF1 !\n PARAMETER G(BCC_A2,BE:VA;0) 298.15 +GBCCBE#; 3000 N REF2 !\n PARAMETER G(BCC_A2,BI:VA;0) 298.15 +GBCCBI#; 3000 N REF2 !\n PARAMETER G(BCC_A2,CA:VA;0) 298.15 +GBCCCA#; 3001 N REF4 !\n PARAMETER G(BCC_A2,CD:VA;0) 298.15 +GBCCCD#; 1600 N REF4 !\n PARAMETER G(BCC_A2,CE:VA;0) 298.15 +GBCCCE#; 4000 N REF2 !\n PARAMETER G(BCC_A2,CO:VA;0) 298.15 +GBCCCO#; 6000 N REF2 !\n PARAMETER TC(BCC_A2,CO:VA;0) 298.15 +1450; 6000 N REF2 !\n PARAMETER BMAGN(BCC_A2,CO:VA;0) 298.15 +1.35; 6000 N REF2 !\n PARAMETER G(BCC_A2,CR:VA;0) 298.15 +GHSERCR#; 6000 N REF1 !\n PARAMETER TC(BCC_A2,CR:VA;0) 298.15 -311.5; 6000 N REF2 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 298.15 -.008; 6000 N REF2 !\n PARAMETER G(BCC_A2,CS:VA;0) 200 +GHSERCS#; 2000 N REF1 !\n PARAMETER G(BCC_A2,CU:VA;0) 298.15 +GBCCCU#; 3200 N REF2 !\n PARAMETER G(BCC_A2,DY:VA;0) 100 +GBCCDY#; 3000 N REF2 !\n PARAMETER G(BCC_A2,ER:VA;0) 298.15 +GBCCER#; 3200 N REF3 !\n PARAMETER G(BCC_A2,EU:VA;0) 298.15 +GHSEREU#; 1901 N REF4 !\n PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#; 6000 N REF1 !\n PARAMETER TC(BCC_A2,FE:VA;0) 298.15 +1043; 6000 N REF2 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 +2.22; 6000 N REF2 !\n PARAMETER G(BCC_A2,GA:VA;0) 200 +GBCCGA#; 4000 N REF3 !\n PARAMETER G(BCC_A2,GD:VA;0) 100 +GBCCGD#; 3600 N REF4 !\n PARAMETER G(BCC_A2,GE:VA;0) 298.15 +GBCCGE#; 3200 N REF2 !\n PARAMETER G(BCC_A2,HF:VA;0) 298.15 +GBCCHF#; 3001 N REF3 !\n PARAMETER G(BCC_A2,HO:VA;0) 298.15 +GBCCHO#; 3001 N REF3 !\n PARAMETER G(BCC_A2,IN:VA;0) 298.15 +GBCCIN#; 3800 N REF2 !\n PARAMETER G(BCC_A2,IR:VA;0) 298.15 +GBCCIR#; 4000 N REF2 !\n PARAMETER G(BCC_A2,K:VA;0) 200 +GHSERKK#; 2200 N REF1 !\n PARAMETER G(BCC_A2,LA:VA;0) 298.15 +GBCCLA#; 4000 N REF2 !\n PARAMETER G(BCC_A2,LI:VA;0) 200 +GHSERLI#; 3000 N REF4 !\n PARAMETER G(BCC_A2,MG:VA;0) 298.15 +GBCCMG#; 3000 N REF2 !\n PARAMETER G(BCC_A2,MN:VA;0) 298.15 +GBCCMN#; 2000 N REF3 !\n PARAMETER TC(BCC_A2,MN:VA;0) 298.15 -580; 2000 N REF2 !\n PARAMETER BMAGN(BCC_A2,MN:VA;0) 298.15 -.27; 2000 N REF2 !\n PARAMETER G(BCC_A2,MO:VA;0) 298.15 +GHSERMO#; 5000 N REF1 !\n PARAMETER G(BCC_A2,NA:VA;0) 200 +GHSERNA#; 2300 N REF1 !\n PARAMETER G(BCC_A2,NB:VA;0) 298.15 +GHSERNB#; 6000 N REF1 !\n PARAMETER G(BCC_A2,ND:VA;0) 298.15 +GBCCND#; 1800 N REF2 !\n PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GBCCNI#; 3000 N REF4 !\n PARAMETER TC(BCC_A2,NI:VA;0) 298.15 +575; 3000 N REF2 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 +.85; 3000 N REF2 !\n PARAMETER G(BCC_A2,NP:VA;0) 298.15 +GBCCNP#; 4000 N REF2 !\n PARAMETER G(BCC_A2,O:VA;0) 298.15 +GBCCOO#; 6000 N REF2 !\n PARAMETER G(BCC_A2,OS:VA;0) 298.15 +GBCCOS#; 5500 N REF3 !\n PARAMETER G(BCC_A2,P:VA;0) 250 +GBCCPP#; 3000 N REF2 !\n PARAMETER G(BCC_A2,PA:VA;0) 298.15 +GBCCPA#; 4000 N REF2 !\n PARAMETER G(BCC_A2,PB:VA;0) 298.15 +GBCCPB#; 2100 N REF2 !\n PARAMETER G(BCC_A2,PD:VA;0) 298.15 +GBCCPD#; 4000 N REF2 !\n PARAMETER G(BCC_A2,PR:VA;0) 298.15 +GBCCPR#; 3800 N REF2 !\n PARAMETER G(BCC_A2,PT:VA;0) 298.15 +GBCCPT#; 4000 N REF3 !\n PARAMETER G(BCC_A2,PU:VA;0) 298.15 +GBCCPU#; 3000 N REF2 !\n PARAMETER G(BCC_A2,RB:VA;0) 200 +GHSERRB#; 2100 N REF1 !\n PARAMETER G(BCC_A2,RE:VA;0) 298.15 +GBCCRE#; 6000 N REF3 !\n PARAMETER G(BCC_A2,RH:VA;0) 298.15 +GBCCRH#; 2500 N REF2 !\n PARAMETER G(BCC_A2,RU:VA;0) 298.15 +GBCCRU#; 4500 N REF3 !\n PARAMETER G(BCC_A2,S:VA;0) 298.15 +GBCCSS#; 1301 N REF3 !\n PARAMETER G(BCC_A2,SB:VA;0) 298.15 +GBCCSB#; 2000 N REF2 !\n PARAMETER G(BCC_A2,SC:VA;0) 298.15 +GBCCSC#; 3200 N REF3 !\n PARAMETER G(BCC_A2,SI:VA;0) 298.15 +GBCCSI#; 3600 N REF2 !\n PARAMETER G(BCC_A2,SM:VA;0) 298.15 +GBCCSM#; 2100 N REF2 !\n PARAMETER G(BCC_A2,SN:VA;0) 100 +GBCCSN#; 3000 N REF2 !\n PARAMETER G(BCC_A2,SR:VA;0) 298.15 +GBCCSR#; 3000 N REF2 !\n PARAMETER G(BCC_A2,TA:VA;0) 298.15 +GHSERTA#; 6000 N REF1 !\n PARAMETER G(BCC_A2,TB:VA;0) 298.15 +GBCCTB#; 3000 N REF2 !\n PARAMETER G(BCC_A2,TC:VA;0) 298.15 +GBCCTC#; 4000 N REF2 !\n PARAMETER G(BCC_A2,TH:VA;0) 298.15 +GBCCTH#; 4000 N REF3 !\n PARAMETER G(BCC_A2,TI:VA;0) 298.15 +GBCCTI#; 4000 N REF2 !\n PARAMETER G(BCC_A2,TL:VA;0) 200 +GBCCTL#; 1801 N REF2 !\n PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 3000 N REF2 !\n PARAMETER G(BCC_A2,V:VA;0) 298.15 +GHSERVV#; 4000 N REF1 !\n PARAMETER G(BCC_A2,W:VA;0) 298.15 +GHSERWW#; 6000 N REF1 !\n PARAMETER G(BCC_A2,Y:VA;0) 100 +GBCCYY#; 3700 N REF2 !\n PARAMETER G(BCC_A2,YB:VA;0) 298.15 +GBCCYB#; 2000 N REF2 !\n PARAMETER G(BCC_A2,ZN:VA;0) 298.15 +GBCCZN#; 1700 N REF2 !\n PARAMETER G(BCC_A2,ZR:VA;0) 298.15 +GBCCZR#; 6000 N REF2 !\n\n\n PHASE BCT_A5 % 1 1.0 !\n CONSTITUENT BCT_A5 :AG,AL,BI,CD,GA,GE,IN,NI,PB,SB,SN,TI,ZN : !\n\n PARAMETER G(BCT_A5,AG;0) 298.15 +GHSERAG#+4184.1; 3000 N\n REF4 !\n PARAMETER G(BCT_A5,AL;0) 298.15 +GHSERAL#+10083-4.813*T;\n 2900 N REF2 !\n PARAMETER G(BCT_A5,BI;0) 298.15 +GHSERBI#+4184.07; 3000 N\n REF2 !\n PARAMETER G(BCT_A5,CD;0) 298.15 +GHSERCD#+5000; 1600 N REF3 !\n PARAMETER G(BCT_A5,GA;0) 200 +GHSERGA#+3846-9.8*T; 4000 N\n REF2 !\n PARAMETER G(BCT_A5,GE;0) 298.15 +GHSERGE#+28800-16.5*T;\n 3000 N REF3 !\n PARAMETER G(BCT_A5,IN;0) 298.15 +GHSERIN#+5040.87-3.33969*T;\n 3800 N REF3 !\n PARAMETER G(BCT_A5,NI;0) 298.15 +GHSERNI#+10023-4.556*T;\n 3000 N REF4 !\n PARAMETER G(BCT_A5,PB;0) 298.15 +GHSERPB#+489+3.52*T; 2100\n N REF2 !\n PARAMETER G(BCT_A5,SB;0) 298.15 +GHSERSB#+13000-8*T; 2000 N\n REF2 !\n PARAMETER G(BCT_A5,SN;0) 100 +GHSERSN#; 3000 N REF1 !\n PARAMETER G(BCT_A5,TI;0) 298.15 +GHSERTI#+4602.2; 3000 N\n REF2 !\n PARAMETER G(BCT_A5,ZN;0) 298.15 +GHSERZN#+2886.96-2.5104*T;\n 1700 N REF2 !\n\n\n PHASE BCT_AA % 1 1.0 !\n CONSTITUENT BCT_AA :PA : !\n\n PARAMETER G(BCT_AA,PA;0) 298.15 +GHSERPA#; 4000 N REF1 !\n\n\n PHASE BETA_RHOMBO_B % 1 1.0 !\n CONSTITUENT BETA_RHOMBO_B :B : !\n\n PARAMETER G(BETA_RHOMBO_B,B;0) 298.15 +GHSERBB#; 6000 N REF2 !\n\n\n PHASE BETA_PU % 1 1.0 !\n CONSTITUENT BETA_PU :PU : !\n\n PARAMETER G(BETA_PU,PU;0) 298.15 -4873.654+123.249151*T\n -27.416*T*LN(T)-.00653*T**2; 679.50 Y\n +2435.094+43.566585*T-15.7351*T*LN(T)-.0154772*T**2+1.524942E-06*T**3\n -864940*T**(-1); 1464 Y\n -13959.062+228.221615*T-42.248*T*LN(T); 3000 N REF2 !\n\n\n TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %' 2 1 1 !\n CONSTITUENT CBCC_A12 :AL,CO,CR,FE,MG,MN,NI,SI,SN,TI,V,ZN,ZR : VA : !\n\n PARAMETER G(CBCC_A12,AL:VA;0) 298.15 +GHSERAL#+10083.4-4.813*T;\n 2900 N REF2 !\n PARAMETER G(CBCC_A12,CO:VA;0) 298.15 +GHSERCO#+4155; 6000 N REF2 !\n PARAMETER G(CBCC_A12,CR:VA;0) 298.15 +GHSERCR#+11087+2.7196*T;\n 6000 N REF2 !\n PARAMETER G(CBCC_A12,FE:VA;0) 298.15 +GHSERFE#+4745; 6000 N REF2 !\n PARAMETER G(CBCC_A12,MG:VA;0) 298.15 +GHSERMG#+4602.4-3.011*T;\n 3000 N REF2 !\n PARAMETER G(CBCC_A12,MN:VA;0) 298.15 +GHSERMN#; 2000 N REF3 !\n PARAMETER TC(CBCC_A12,MN:VA;0) 298.15 -285; 2000 N REF2 !\n PARAMETER BMAGN(CBCC_A12,MN:VA;0) 298.15 -.66; 2000 N REF2 !\n PARAMETER G(CBCC_A12,NI:VA;0) 298.15 +GHSERNI#+3556; 3000 N REF4 !\n PARAMETER G(CBCC_A12,SI:VA;0) 298.15 +GHSERSI#+50208-20.377*T;\n 3600 N REF2 !\n PARAMETER G(CBCC_A12,SN:VA;0) 100 +GHSERSN#+2000; 3000 N REF3 !\n PARAMETER G(CBCC_A12,TI:VA;0) 298.15 +GHSERTI#+4602.2; 4000 N\n REF2 !\n PARAMETER G(CBCC_A12,V:VA;0) 298.15 +GHSERVV#+9000; 4000 N REF2 !\n PARAMETER G(CBCC_A12,ZN:VA;0) 298.15 +GHSERZN#+2000; 1700 N REF3 !\n PARAMETER G(CBCC_A12,ZR:VA;0) 298.15 +GHSERZR#+4602.2; 6000 N\n REF3 !\n\n\n PHASE CF_S % 1 1.0 !\n CONSTITUENT CF_S :CF : !\n\n PARAMETER G(CF_S,CF;0) 298.15 +GHSERCF#; 6000 N REF3 !\n\n\n PHASE CM_S % 1 1.0 !\n CONSTITUENT CM_S :CM : !\n\n PARAMETER G(CM_S,CM;0) 298.15 +GHSERCM#; 6000 N REF3 !\n\n\n PHASE CM_S2 % 1 1.0 !\n CONSTITUENT CM_S2 :CM : !\n\n PARAMETER G(CM_S2,CM;0) 298.15 +GHSERCM#+3242.6-2.092*T;\n 6000 N REF3 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :AG,AL,CO,CR,FE,MG,MN,NI,SI,SN,TI,V,ZN,ZR : VA : !\n\n PARAMETER G(CUB_A13,AG:VA;0) 298.15 +GHSERAG#+3400-1.05*T; 3000\n N REF4 !\n PARAMETER G(CUB_A13,AL:VA;0) 298.15 +GHSERAL#+10920.44-4.8116*T;\n 2900 N REF2 !\n PARAMETER G(CUB_A13,CO:VA;0) 298.15 +GHSERCO#+3155; 6000 N REF2 !\n PARAMETER G(CUB_A13,CR:VA;0) 298.15 +GHSERCR#+15899+.6276*T;\n 6000 N REF2 !\n PARAMETER G(CUB_A13,FE:VA;0) 298.15 +GHSERFE#+3745; 6000 N REF2 !\n PARAMETER G(CUB_A13,MG:VA;0) 298.15 +GHSERMG#+5000-3*T; 3000 N\n REF2 !\n PARAMETER G(CUB_A13,MN:VA;0) 298.15 -5800.4+135.995*T\n -24.8785*T*LN(T)-.00583359*T**2+70269*T**(-1); 1519 Y\n -28290.76+311.2933*T-48*T*LN(T)+3.96757E+30*T**(-9); 2000 N REF3 !\n PARAMETER G(CUB_A13,NI:VA;0) 298.15 +GHSERNI#+2092; 3000 N REF4 !\n PARAMETER G(CUB_A13,SI:VA;0) 298.15 +GHSERSI#+47279-20.377*T;\n 3600 N REF2 !\n PARAMETER G(CUB_A13,SN:VA;0) 100 +GHSERSN#+2000; 3000 N REF3 !\n PARAMETER G(CUB_A13,TI:VA;0) 298.15 +GHSERTI#+7531.2; 4000 N\n REF2 !\n PARAMETER G(CUB_A13,V:VA;0) 298.15 +GHSERVV#+10000; 4000 N\n REF2 !\n PARAMETER G(CUB_A13,ZN:VA;0) 298.15 +GHSERZN#+2000; 1700 N REF3 !\n PARAMETER G(CUB_A13,ZR:VA;0) 298.15 +GHSERZR#+7531.2; 6000 N\n REF3 !\n\n\n PHASE DHCP % 1 1.0 !\n CONSTITUENT DHCP :AM,AU,CE,IN,LA,ND,PR,SC,SN : !\n\n PARAMETER G(DHCP,AM;0) 298.15 +GHSERAM#; 3000 N REF1 !\n PARAMETER G(DHCP,AU;0) 298.15 +GHSERAU#+5000; 3200 N REF4 !\n PARAMETER G(DHCP,CE;0) 298.15 +GHSERCE#-122.539+.433*T;\n 4000 N REF4 !\n PARAMETER G(DHCP,IN;0) 298.15 +GHSERIN#+520-.384*T; 3800\n N REF4 !\n PARAMETER G(DHCP,LA;0) 298.15 +GHSERLA#; 4000 N REF1 !\n PARAMETER G(DHCP,ND;0) 298.15 +GHSERND#; 1800 N REF1 !\n PARAMETER G(DHCP,PR;0) 298.15 +GHSERPR#; 3800 N REF1 !\n PARAMETER G(DHCP,SC;0) 298.15 +GHSERSC#+1200+.415725*T;\n 3200 N REF3 !\n PARAMETER G(DHCP,SN;0) 100 +GHSERSN#+3803.52-3.46*T; 3000\n N REF4 !\n\n\n PHASE DIAMOND_A4 % 1 1.0 !\n CONSTITUENT DIAMOND_A4 :AL,B,BI,C,CO,GA,GE,SI,SN,TI,ZN : !\n\n PARAMETER G(DIAMOND_A4,AL;0) 298.15 +GHSERAL#+30*T; 2900 N REF2 !\n PARAMETER G(DIAMOND_A4,B;0) 298.15 +GHSERBB#+10; 6000 N REF4 !\n PARAMETER G(DIAMOND_A4,BI;0) 298.15 +GHSERBI#+11296.8\n +9.253655*T; 3000 N REF4 !\n PARAMETER G(DIAMOND_A4,C;0) 298.15 +GDIACC#; 6000 N REF2 !\n PARA G(DIAMOND_A4,CO;0) 298.15 +0; 6000 N!\n PARAMETER G(DIAMOND_A4,GA;0) 200 +GHSERGA#+20900-2*T; 4000 N\n REF4 !\n PARAMETER G(DIAMOND_A4,GE;0) 298.15 +GHSERGE#; 3200 N REF1 !\n PARAMETER G(DIAMOND_A4,SI;0) 298.15 +GHSERSI#; 3600 N REF1 !\n PARAMETER G(DIAMOND_A4,SN;0) 100 -9579.608+114.007785*T\n -22.972*T*LN(T)-.00813975*T**2+2.7288E-06*T**3+25615*T**(-1); 298.15 Y\n -9063.001+104.84654*T-21.5750771*T*LN(T)-.008575282*T**2\n +1.784447E-06*T**3-2544*T**(-1); 800 Y\n -10909.353+147.396537*T-28.4512*T*LN(T); 3000 N REF2 !\n PARAMETER G(DIAMOND_A4,TI;0) 298.15 +GHSERTI#+25000; 4000 N\n REF2 !\n PARAMETER G(DIAMOND_A4,ZN;0) 298.15 +GHSERZN#+30*T; 1700 N REF2 !\n\n\n PHASE ES_S % 1 1.0 !\n CONSTITUENT ES_S :ES : !\n\n PARAMETER G(ES_S,ES;0) 298.15 +GHSERES#; 6000 N REF3 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :AG,AL,AM,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,FE,\n GA,GD,GE,HF,HG,IN,IR,K,LA,LI,MG,MN,MO,NA,NB,ND,NI,O,OS,P,PB,PD,\n PT,PU,RB,RE,RH,RU,S,SB,SC,SI,SN,SR,TA,TC,TH,TI,TL,U,\n V,W,Y,YB,ZN,ZR : VA : !\n\n PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3000 N REF1 !\n PARAMETER G(FCC_A1,AL:VA;0) 298.15 +GHSERAL#; 2900 N REF1 !\n PARAMETER G(FCC_A1,AM:VA;0) 298.15 +GFCCAM#; 3000 N REF3 !\n PARAMETER G(FCC_A1,AS:VA;0) 298.15 +GFCCAS#; 1200 N REF2 !\n PARAMETER G(FCC_A1,AU:VA;0) 298.15 +GHSERAU#; 3200 N REF1 !\n PARAMETER G(FCC_A1,B:VA;0) 298.15 +GFCCBB#; 6000 N REF2 !\n PARAMETER G(FCC_A1,BA:VA;0) 298.15 +GFCCBA#; 4000 N REF2 !\n PARAMETER G(FCC_A1,BE:VA;0) 298.15 +GFCCBE#; 3000 N REF2 !\n PARAMETER G(FCC_A1,BI:VA;0) 298.15 +GFCCBI#; 3000 N REF2 !\n PARAMETER G(FCC_A1,CA:VA;0) 298.15 +GHSERCA#; 3001 N REF1 !\n PARAMETER G(FCC_A1,CD:VA;0) 298.15 +GFCCCD#; 1600 N REF2 !\n PARAMETER G(FCC_A1,CE:VA;0) 298.15 +GHSERCE#; 4000 N REF1 !\n PARAMETER G(FCC_A1,CO:VA;0) 298.15 +GFCCCO#; 6000 N REF4 !\n PARAMETER TC(FCC_A1,CO:VA;0) 298.15 +1396; 6000 N REF2 !\n PARAMETER BMAGN(FCC_A1,CO:VA;0) 298.15 +1.35; 6000 N REF2 !\n PARAMETER G(FCC_A1,CR:VA;0) 298.15 +GFCCCR#; 6000 N REF2 !\n PARAMETER TC(FCC_A1,CR:VA;0) 298.15 -1109; 6000 N REF2 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 298.15 -2.46; 6000 N REF2 !\n PARAMETER G(FCC_A1,CS:VA;0) 200 +GFCCCS#; 2000 N REF2 !\n PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3200 N REF1 !\n PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFCCFE#; 6000 N REF3 !\n PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF2 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF2 !\n PARAMETER G(FCC_A1,GA:VA;0) 200 +GFCCGA#; 4000 N REF3 !\n PARAMETER G(FCC_A1,GD:VA;0) 200 +GFCCGD#; 3600 N REF3 !\n PARAMETER G(FCC_A1,GE:VA;0) 298.15 +GFCCGE#; 3200 N REF2 !\n PARAMETER G(FCC_A1,HF:VA;0) 298.15 +GFCCHF#; 3001 N REF3 !\n PARAMETER G(FCC_A1,HG:VA;0) 200 +GFCCHG#; 2000 N REF4 !\n PARAMETER G(FCC_A1,IN:VA;0) 298.15 +GFCCIN#; 3800 N REF3 !\n PARAMETER G(FCC_A1,IR:VA;0) 298.15 +GHSERIR#; 4000 N REF1 !\n PARAMETER G(FCC_A1,K:VA;0) 200 +GFCCKK#; 2200 N REF2 !\n PARAMETER G(FCC_A1,LA:VA;0) 298.15 +GFCCLA#; 4000 N REF2 !\n PARAMETER G(FCC_A1,LI:VA;0) 200 +GFCCLI#; 3000 N REF4 !\n PARAMETER G(FCC_A1,MG:VA;0) 298.15 +GFCCMG#; 3000 N REF2 !\n PARAMETER G(FCC_A1,MN:VA;0) 298.15 +GFCCMN#; 2000 N REF3 !\n PARAMETER TC(FCC_A1,MN:VA;0) 298.15 -1620; 2000 N REF2 !\n PARAMETER BMAGN(FCC_A1,MN:VA;0) 298.15 -1.86; 2000 N REF2 !\n PARAMETER G(FCC_A1,MO:VA;0) 298.15 +GFCCMO#; 5000 N REF2 !\n PARAMETER G(FCC_A1,NA:VA;0) 200 +GFCCNA#; 2300 N REF2 !\n PARAMETER G(FCC_A1,NB:VA;0) 298.15 +GFCCNB#; 6000 N REF2 !\n PARAMETER G(FCC_A1,ND:VA;0) 298.15 +GFCCND#; 1800 N REF3 !\n PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#; 3000 N REF4 !\n PARAMETER TC(FCC_A1,NI:VA;0) 298.15 +633; 3000 N REF2 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 +.52; 3000 N REF2 !\n PARAMETER G(FCC_A1,O:VA;0) 298.15 +GFCCOO#; 6000 N REF2 !\n PARAMETER G(FCC_A1,OS:VA;0) 298.15 +GFCCOS#; 5500 N REF2 !\n PARAMETER G(FCC_A1,P:VA;0) 250 +GFCCPP#; 3000 N REF2 !\n PARAMETER G(FCC_A1,PB:VA;0) 298.15 +GHSERPB#; 2100 N REF1 !\n PARAMETER G(FCC_A1,PD:VA;0) 298.15 +GHSERPD#; 4000 N REF1 !\n PARAMETER G(FCC_A1,PT:VA;0) 298.15 +GHSERPT#; 4000 N REF1 !\n PARAMETER G(FCC_A1,PU:VA;0) 298.15 +GFCCPU#; 3000 N REF2 !\n PARAMETER G(FCC_A1,RB:VA;0) 200 +GFCCRB#; 2100 N REF2 !\n PARAMETER G(FCC_A1,RE:VA;0) 298.15 +GFCCRE#; 6000 N REF2 !\n PARAMETER G(FCC_A1,RH:VA;0) 298.15 +GHSERRH#; 2500 N REF1 !\n PARAMETER G(FCC_A1,RU:VA;0) 298.15 +GFCCRU#; 4500 N REF2 !\n PARAMETER G(FCC_A1,S:VA;0) 298.15 +GFCCSS#; 1301 N REF3 !\n PARAMETER G(FCC_A1,SB:VA;0) 298.15 +GFCCSB#; 2000 N REF2 !\n PARAMETER G(FCC_A1,SC:VA;0) 298.15 +GFCCSC#; 3200 N REF3 !\n PARAMETER G(FCC_A1,SI:VA;0) 298.15 +GFCCSI#; 3600 N REF2 !\n PARAMETER G(FCC_A1,SN:VA;0) 100 +GFCCSN#; 3000 N REF2 !\n PARAMETER G(FCC_A1,SR:VA;0) 298.15 +GHSERSR#; 3000 N REF1 !\n PARAMETER G(FCC_A1,TA:VA;0) 298.15 +GFCCTA#; 6000 N REF2 !\n PARAMETER G(FCC_A1,TC:VA;0) 298.15 +GFCCTC#; 4000 N REF2 !\n PARAMETER G(FCC_A1,TH:VA;0) 298.15 +GHSERTH#; 4000 N REF3 !\n PARAMETER G(FCC_A1,TI:VA;0) 298.15 +GFCCTI#; 4000 N REF2 !\n PARAMETER G(FCC_A1,TL:VA;0) 200 +GFCCTL#; 1801 N REF2 !\n PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3000 N REF3 !\n PARAMETER G(FCC_A1,V:VA;0) 298.15 +GFCCVV#; 4000 N REF2 !\n PARAMETER G(FCC_A1,W:VA;0) 298.15 +GFCCWW#; 6000 N REF2 !\n PARAMETER G(FCC_A1,Y:VA;0) 100 +GFCCYY#; 3700 N REF3 !\n PARAMETER G(FCC_A1,YB:VA;0) 298.15 +GHSERYB#; 2000 N REF1 !\n PARAMETER G(FCC_A1,ZN:VA;0) 298.15 +GFCCZN#; 1700 N REF2 !\n PARAMETER G(FCC_A1,ZR:VA;0) 298.15 +GFCCZR#; 6000 N REF2 !\n\n\n PHASE FM_S % 1 1.0 !\n CONSTITUENT FM_S :FM : !\n\n PARAMETER G(FM_S,FM;0) 298.15 +GHSERFM#; 6000 N REF3 !\n\n\n PHASE FR_S % 1 1.0 !\n CONSTITUENT FR_S :FR : !\n\n PARAMETER G(FR_S,FR;0) 298.15 +GHSERFR#; 6000 N REF3 !\n\n\n PHASE GAMMA_PU % 1 1.0 !\n CONSTITUENT GAMMA_PU :PU : !\n\n PARAMETER G(GAMMA_PU,PU;0) 298.15 -16766.303+419.402655*T\n -77.5802*T*LN(T)+.0816415*T**2-2.8103833E-05*T**3+574825*T**(-1); 487.90 Y\n -2942.77+88.325069*T-22.0233*T*LN(T)-.0114795*T**2; 593.90 Y\n -9336.967+160.314641*T-32.3405*T*LN(T)-.0070383*T**2+6.92887E-07*T**3\n +630600*T**(-1); 1179 Y\n -12435.75+226.131617*T-42.248*T*LN(T); 3000 N REF2 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :B,C : !\n\n PARAMETER G(GRAPHITE,B;0) 298.15 +GHSERBB#+10000-2*T; 6000 N\n REF4 !\n PARAMETER G(GRAPHITE,C;0) 298.15 +GHSERCC#; 6000 N REF1 !\n\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONSTITUENT HCP_A3 :AG,AL,AS,AU,B,BA,BE,BI,CA,CD,CE,CO,CR,CS,CU,DY,ER,\n FE,GA,GD,GE,HF,HG,HO,IN,IR,K,LI,LU,MG,MN,MO,NA,NB,ND,NI,OS,PB,PD,\n PT,RB,RE,RH,RU,SB,SC,SI,SM,SN,SR,TA,TB,TC,TI,TL,TM,\n U,V,W,Y,YB,ZN,ZR : VA : !\n\n PARAMETER G(HCP_A3,AG:VA;0) 298.15 +GHCPAG#; 3000 N REF2 !\n PARAMETER G(HCP_A3,AL:VA;0) 298.15 +GHCPAL#; 2900 N REF2 !\n PARAMETER G(HCP_A3,AS:VA;0) 298.15 +GHCPAS#; 1200 N REF2 !\n PARAMETER G(HCP_A3,AU:VA;0) 298.15 +GHCPAU#; 3200 N REF2 !\n PARAMETER G(HCP_A3,B:VA;0) 298.15 +GHCPBB#; 6000 N REF2 !\n PARAMETER G(HCP_A3,BA:VA;0) 298.15 +GHCPBA#; 4000 N REF2 !\n PARAMETER G(HCP_A3,BE:VA;0) 298.15 +GHSERBE#; 3000 N REF1 !\n PARAMETER G(HCP_A3,BI:VA;0) 298.15 +GHCPBI#; 3000 N REF2 !\n PARAMETER G(HCP_A3,CA:VA;0) 298.15 +GHCPCA#; 3001 N REF4 !\n PARAMETER G(HCP_A3,CD:VA;0) 298.15 +GHSERCD#; 1600 N REF1 !\n PARAMETER G(HCP_A3,CE:VA;0) 298.15 +GHCPCE#; 4000 N REF4 !\n PARAMETER G(HCP_A3,CO:VA;0) 298.15 +GHSERCO#; 6000 N REF1 !\n PARAMETER TC(HCP_A3,CO:VA;0) 298.15 +1396; 6000 N REF2 !\n PARAMETER BMAGN(HCP_A3,CO:VA;0) 298.15 +1.35; 6000 N REF2 !\n PARAMETER G(HCP_A3,CR:VA;0) 298.15 +GHCPCR#; 6000 N REF2 !\n PARAMETER TC(HCP_A3,CR:VA;0) 298.15 -1109; 6000 N REF2 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 298.15 -2.46; 6000 N REF2 !\n PARAMETER G(HCP_A3,CS:VA;0) 200 +GHCPCS#; 2000 N REF2 !\n PARAMETER G(HCP_A3,CU:VA;0) 298.15 +GHCPCU#; 3200 N REF3 !\n PARAMETER G(HCP_A3,DY:VA;0) 100 +GHSERDY#; 3000 N REF2 !\n PARAMETER TC(HCP_A3,DY:VA;0) 100 +179; 3000 N REF2 !\n PARAMETER BMAGN(HCP_A3,DY:VA;0) 100 +3; 3000 N REF2 !\n PARAMETER G(HCP_A3,ER:VA;0) 298.15 +GHSERER#; 3200 N REF2 !\n PARAMETER G(HCP_A3,FE:VA;0) 298.15 +GHCPFE#; 6000 N REF3 !\n PARAMETER G(HCP_A3,GA:VA;0) 200 +GHCPGA#; 4000 N REF3 !\n PARAMETER G(HCP_A3,GD:VA;0) 200 +GHSERGD#; 3600 N REF2 !\n PARAMETER TC(HCP_A3,GD:VA;0) 200 +293.4; 3600 N REF2 !\n PARAMETER BMAGN(HCP_A3,GD:VA;0) 200 +3; 3600 N REF2 !\n PARAMETER G(HCP_A3,GE:VA;0) 298.15 +GHCPGE#; 3200 N REF2 !\n PARAMETER G(HCP_A3,HF:VA;0) 298.15 +GHSERHF#; 3001 N REF3 !\n PARAMETER G(HCP_A3,HG:VA;0) 200 +GHCPHG#; 2000 N REF3 !\n PARAMETER G(HCP_A3,HO:VA;0) 298.15 +GHSERHO#; 3001 N REF4 !\n PARAMETER G(HCP_A3,IN:VA;0) 298.15 +GHCPIN#; 3800 N REF4 !\n PARAMETER G(HCP_A3,IR:VA;0) 298.15 +GHCPIR#; 4000 N REF2 !\n PARAMETER G(HCP_A3,K:VA;0) 200 +GHCPKK#; 2200 N REF2 !\n PARAMETER G(HCP_A3,LI:VA;0) 200 +GHCPLI#; 3000 N REF4 !\n PARAMETER G(HCP_A3,LU:VA;0) 298.15 +GHSERLU#; 3700 N REF1 !\n PARAMETER G(HCP_A3,MG:VA;0) 298.15 +GHSERMG#; 3000 N REF1 !\n PARAMETER G(HCP_A3,MN:VA;0) 298.15 +GHCPMN#; 2000 N REF3 !\n PARAMETER TC(HCP_A3,MN:VA;0) 298.15 -1620; 2000 N REF2 !\n PARAMETER BMAGN(HCP_A3,MN:VA;0) 298.15 -1.86; 2000 N REF2 !\n PARAMETER G(HCP_A3,MO:VA;0) 298.15 +GHCPMO#; 5000 N REF2 !\n PARAMETER G(HCP_A3,NA:VA;0) 200 +GHCPNA#; 2300 N REF2 !\n PARAMETER G(HCP_A3,NB:VA;0) 298.15 +GHCPNB#; 6000 N REF2 !\n PARAMETER G(HCP_A3,ND:VA;0) 298.15 +GHCPND#; 1800 N REF3 !\n PARAMETER G(HCP_A3,NI:VA;0) 298.15 +GHCPNI#; 3000 N REF4 !\n PARAMETER TC(HCP_A3,NI:VA;0) 298.15 +633; 3000 N REF2 !\n PARAMETER BMAGN(HCP_A3,NI:VA;0) 298.15 +.52; 3000 N REF2 !\n PARAMETER G(HCP_A3,OS:VA;0) 298.15 +GHSEROS#; 5500 N REF1 !\n PARAMETER G(HCP_A3,PB:VA;0) 298.15 +GHCPPB#; 2100 N REF2 !\n PARAMETER G(HCP_A3,PD:VA;0) 298.15 +GHCPPD#; 4000 N REF2 !\n PARAMETER G(HCP_A3,PT:VA;0) 298.15 +GHCPPT#; 4000 N REF3 !\n PARAMETER G(HCP_A3,RB:VA;0) 200 +GHCPRB#; 2100 N REF2 !\n PARAMETER G(HCP_A3,RE:VA;0) 298.15 +GHSERRE#; 6000 N REF2 !\n PARAMETER G(HCP_A3,RH:VA;0) 298.15 +GHCPRH#; 2500 N REF2 !\n PARAMETER G(HCP_A3,RU:VA;0) 298.15 +GHSERRU#; 4500 N REF1 !\n PARAMETER G(HCP_A3,SB:VA;0) 298.15 +GHCPSB#; 2000 N REF2 !\n PARAMETER G(HCP_A3,SC:VA;0) 298.15 +GHSERSC#; 3200 N REF1 !\n PARAMETER G(HCP_A3,SI:VA;0) 298.15 +GHCPSI#; 3600 N REF2 !\n PARAMETER G(HCP_A3,SM:VA;0) 298.15 +GHCPSM#; 2100 N REF3 !\n PARAMETER G(HCP_A3,SN:VA;0) 100 +GHCPSN#; 3000 N REF3 !\n PARAMETER G(HCP_A3,SR:VA;0) 298.15 +GHCPSR#; 3000 N REF2 !\n PARAMETER G(HCP_A3,TA:VA;0) 298.15 +GHCPTA#; 6000 N REF2 !\n PARAMETER G(HCP_A3,TB:VA;0) 298.15 +GHSERTB#; 3000 N REF2 !\n PARAMETER G(HCP_A3,TC:VA;0) 298.15 +GHSERTC#; 4000 N REF1 !\n PARAMETER G(HCP_A3,TI:VA;0) 298.15 +GHSERTI#; 4000 N REF1 !\n PARAMETER G(HCP_A3,TL:VA;0) 200 +GHSERTL#; 1801 N REF1 !\n PARAMETER G(HCP_A3,TM:VA;0) 298.15 +GHSERTM#; 2300 N REF1 !\n PARAMETER G(HCP_A3,U:VA;0) 298.15 +GHCPUU#; 2500 N REF3 !\n PARAMETER G(HCP_A3,V:VA;0) 298.15 +GHCPVV#; 4000 N REF2 !\n PARAMETER G(HCP_A3,W:VA;0) 298.15 +GHCPWW#; 6000 N REF2 !\n PARAMETER G(HCP_A3,Y:VA;0) 100 +GHSERYY#; 3700 N REF2 !\n PARAMETER G(HCP_A3,YB:VA;0) 298.15 +GHCPYB#; 2000 N REF4 !\n PARAMETER G(HCP_A3,ZN:VA;0) 298.15 +GHCPZN#; 1700 N REF2 !\n PARAMETER G(HCP_A3,ZR:VA;0) 298.15 +GHSERZR#; 6000 N REF1 !\n\n\n PHASE HCP_ZN % 2 1 .5 !\n CONSTITUENT HCP_ZN :AG,AL,CR,CU,GA,IN,MG,SI,SN,ZN : VA : !\n\n PARAMETER G(HCP_ZN,AG:VA;0) 298.15 +GHSERAG#+400+.3*T; 3000 N\n REF4 !\n PARAMETER G(HCP_ZN,AL:VA;0) 298.15 +GHSERAL#+5481-1.8*T; 2900\n N REF4 !\n PARAMETER G(HCP_ZN,CR:VA;0) 298.15 +GHSERCR#+4439; 6000 N REF3 !\n PARAMETER G(HCP_ZN,CU:VA;0) 298.15 +GHSERCU#+600+.2*T; 3200 N\n REF3 !\n PARAMETER G(HCP_ZN,GA:VA;0) 200 +GHSERGA#+4501-9.5*T; 4000 N\n REF4 !\n PARAMETER G(HCP_ZN,IN:VA;0) 298.15 +GHSERIN#+533-.6868*T; 3800\n N REF3 !\n PARAMETER G(HCP_ZN,MG:VA;0) 298.15 +GHSERMG#+100; 3000 N REF3 !\n PARAMETER G(HCP_ZN,SI:VA;0) 298.15 +GHSERSI#+49201-20.8*T;\n 3600 N REF3 !\n PARAMETER G(HCP_ZN,SN:VA;0) 100 +GHSERSN#+3905-7.646*T; 3000 N\n REF3 !\n PARAMETER G(HCP_ZN,ZN:VA;0) 298.15 +GHSERZN#; 1700 N REF3 !\n\n\n PHASE HEXAGONAL_A8 % 1 1.0 !\n CONSTITUENT HEXAGONAL_A8 :SE,TE : !\n\n PARAMETER G(HEXAGONAL_A8,SE;0) 298.15 +GHSERSE#; 1000 N REF1 !\n PARAMETER G(HEXAGONAL_A8,TE;0) 298.15 +GHSERTE#; 1600 N REF2 !\n\n\n PHASE I2_S % 1 1.0 !\n CONSTITUENT I2_S :I2 : !\n\n PARAMETER G(I2_S,I2;0) 298.15 +2*GHSERII#; 1000 N REF3 !\n\n\n PHASE LAVES_C14 % 2 2 1 !\n CONSTITUENT LAVES_C14 :MN,TI : MN,TI : !\n\n PARAMETER G(LAVES_C14,MN:MN;0) 298.15 -21345.84+390.177*T\n -70.3746*T*LN(T)-.02204304*T**2+209481*T**(-1); 1519 Y\n -83200.23+936.7944*T-144*T*LN(T)+4.97054E+30*T**(-9); 2000 N REF3 !\n PARAMETER G(LAVES_C14,TI:TI;0) 298.15 -9179.763+400.845624*T\n -71.9799*T*LN(T)-.014333925*T**2+3.20148E-07*T**3+217908*T**(-1); 900 Y\n -8435.445+398.964204*T-71.9661*T*LN(T)-.0126099*T**2-2.72628E-07*T**3\n +128040*T**(-1); 1155 Y\n +17726.511+200.929614*T-44.8398*T*LN(T)-.0244395*T**2+6.08145E-07*T**3\n -4432980*T**(-1); 1941 Y\n -358580.358+1916.42061*T-261.654738*T*LN(T)+.024614547*T**2\n -9.14241E-07*T**3+1.10099415E+08*T**(-1); 4000 N REF2 !\n\n\n PHASE LAVES_C15 % 2 2 1 !\n CONSTITUENT LAVES_C15 :CR,CU,MG,TI,ZR : CR,CU,MG,TI,ZR : !\n\n PARAMETER G(LAVES_C15,CR:CR;0) 298.15 -11570.82+472.44*T\n -80.724*T*LN(T)+.00568305*T**2-4.43163E-06*T**3+417750*T**(-1); 2180 Y\n -89608.032+1032.54*T-150*T*LN(T)-8.65578E+32*T**(-9); 6000 N REF2 !\n PARA G(LAVES_C15,CU:CR;0) 298.15 +0; 6000 N!\n PARA G(LAVES_C15,MG:CR;0) 298.15 +0; 6000 N!\n PARA G(LAVES_C15,CR:CU;0) 298.15 +0; 6000 N!\n PARAMETER G(LAVES_C15,CU:CU;0) 298.15 -8311.374+391.455705*T\n -72.337176*T*LN(T)-.00797052*T**2+3.87669E-07*T**3+157434*T**(-1); 1357.77\n Y\n -25626.078+551.411484*T-94.14*T*LN(T)+1.092501E+30*T**(-9); 3200 N REF2 !\n PARA G(LAVES_C15,MG:CU;0) 298.15 +0; 6000 N!\n PARA G(LAVES_C15,CR:MG;0) 298.15 +0; 6000 N!\n PARA G(LAVES_C15,CU:MG;0) 298.15 +0; 6000 N!\n PARAMETER G(LAVES_C15,MG:MG;0) 298.15 -10102.02+431.026641*T\n -78.5549346*T*LN(T)+.0014574*T**2-4.181007E-06*T**3+236850*T**(-1); 923 Y\n -27390.555+614.148645*T-102.9264*T*LN(T)+3.11458E+28*T**(-9); 3000 N REF3 !\n PARAMETER G(LAVES_C15,TI:TI;0) 298.15 -9179.763+400.845624*T\n -71.9799*T*LN(T)-.014333925*T**2+3.20148E-07*T**3+217908*T**(-1); 900 Y\n -8435.445+398.964204*T-71.9661*T*LN(T)-.0126099*T**2-2.72628E-07*T**3\n +128040*T**(-1); 1155 Y\n +17726.511+200.929614*T-44.8398*T*LN(T)-.0244395*T**2+6.08145E-07*T**3\n -4432980*T**(-1); 1941 Y\n -358580.358+1916.42061*T-261.654738*T*LN(T)+.024614547*T**2\n -9.14241E-07*T**3+1.10099415E+08*T**(-1); 4000 N REF2 !\n\n\n PHASE MONOCLINIC % 1 1.0 !\n CONSTITUENT MONOCLINIC :S : !\n\n PARAMETER G(MONOCLINIC,S;0) 298.15 -5725.422+89.544275*T\n -17.413*T*LN(T)-.00993935*T**2-7.0062E-08*T**3+1250*T**(-1); 388.36 Y\n -7455.008+114.782945*T-21.1531404*T*LN(T)-.008566163*T**2\n +1.112484E-06*T**3+122167*T**(-1); 1300 Y\n -11779.415+186.699065*T-32*T*LN(T); 1301 N REF3 !\n\n\n PHASE OMEGA % 1 1.0 !\n CONSTITUENT OMEGA :ZR : !\n\n PARAMETER G(OMEGA,ZR;0) 298.15 -8878.082+144.432234*T\n -26.8556*T*LN(T)-.002799446*T**2+38376*T**(-1); 2128 Y\n -29500.524+265.290858*T-42.144*T*LN(T)+7.17445E+31*T**(-9); 6000 N REF2 !\n\n\n PHASE ORTHORHOMBIC_A20 % 1 1.0 !\n CONSTITUENT ORTHORHOMBIC_A20 :FE,U,ZR : !\n\n PARAMETER G(ORTHORHOMBIC_A20,FE;0) 298.15 +GHSERFE#+5000; 6000 N REF3 !\n PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 3000 N REF1 !\n PARAMETER G(ORTHORHOMBIC_A20,ZR;0) 298.15 +4474.461+124.9457*T\n -25.607406*T*LN(T)-3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1)\n -7.6143E-11*T**4; 2128 Y\n -25705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N REF3 !\n\n\n PHASE ORTHORHOMBIC_AC % 1 1.0 !\n CONSTITUENT ORTHORHOMBIC_AC :NP : !\n\n PARAMETER G(ORTHORHOMBIC_AC,NP;0) 298.15 +GHSERNP#; 4000 N REF1 !\n\n\n PHASE ORTHORHOMBIC_GA % 1 1.0 !\n CONSTITUENT ORTHORHOMBIC_GA :GA : !\n\n PARAMETER G(ORTHORHOMBIC_GA,GA;0) 200 +GHSERGA#; 4000 N REF2 !\n\n\n PHASE ORTHORHOMBIC_S % 1 1.0 !\n CONSTITUENT ORTHORHOMBIC_S :S : !\n\n PARAMETER G(ORTHORHOMBIC_S,S;0) 298.15 +GHSERSS#; 1301 N REF3 !\n\n\n PHASE PM_S % 1 1.0 !\n CONSTITUENT PM_S :PM : !\n\n PARAMETER G(PM_S,PM;0) 298.15 +GHSERPM#; 6000 N REF3 !\n\n\n PHASE PM_S2 % 1 1.0 !\n CONSTITUENT PM_S2 :PM : !\n\n PARAMETER G(PM_S2,PM;0) 298.15 +GHSERPM#+3200-2.75150473*T;\n 6000 N REF3 !\n\n\n PHASE PO_S % 1 1.0 !\n CONSTITUENT PO_S :PO : !\n\n PARAMETER G(PO_S,PO;0) 298.15 +GHSERPO#; 6000 N REF3 !\n\n\n PHASE RA_S % 1 1.0 !\n CONSTITUENT RA_S :RA : !\n\n PARAMETER G(RA_S,RA;0) 298.15 +GHSERRA#; 6000 N REF3 !\n\n\n PHASE RED_P % 1 1.0 !\n CONSTITUENT RED_P :AS,P : !\n\n PARAMETER G(RED_P,AS;0) 298.15 +GHSERAS#+5782-3.85466*T;\n 1200 N REF3 !\n PARAMETER G(RED_P,P;0) 250 +GREDPP#; 3000 N REF2 !\n\n\n PHASE RHOMBOHEDRAL_A10 % 1 1.0 !\n CONSTITUENT RHOMBOHEDRAL_A10 :CD,HG,PB,ZN : !\n\n PARAMETER G(RHOMBOHEDRAL_A10,CD;0) 298.15 +GHSERCD#+800-.62*T; 1600 N\n REF3 !\n PARAMETER G(RHOMBOHEDRAL_A10,HG;0) 200 +GRHOMBHG#; 2000 N REF4 !\n PARAMETER G(RHOMBOHEDRAL_A10,PB;0) 298.15 +GHSERPB#+10; 2100 N REF4 !\n PARAMETER G(RHOMBOHEDRAL_A10,ZN;0) 200 -2128.565+118.177019*T\n -23.701314*T*LN(T)-.001712034*T**2-1.264963E-06*T**3-3.589488E-19*T**7;\n 692.67 Y\n -5620.385+171.60854*T-31.38*T*LN(T); 1700 N REF2 !\n\n\n PHASE RHOMBOHEDRAL_A7 % 1 1.0 !\n CONSTITUENT RHOMBOHEDRAL_A7 :AS,BI,GE,IN,P,PB,PD,SB,SN,ZN : !\n\n PARAMETER G(RHOMBOHEDRAL_A7,AS;0) 298.15 +GHSERAS#; 1200 N REF1 !\n PARAMETER G(RHOMBOHEDRAL_A7,BI;0) 298.15 +GHSERBI#; 3000 N REF1 !\n PARAMETER G(RHOMBOHEDRAL_A7,GE;0) 298.15 +GHSERGE#+29800-16.5*T;\n 3000 N REF3 !\n PARAMETER G(RHOMBOHEDRAL_A7,IN;0) 298.15 +GHSERIN#+4184; 3800 N REF3 !\n PARAMETER G(RHOMBOHEDRAL_A7,P;0) 250 +GHSERPP#-188+.12527*T; 3000 N\n REF3 !\n PARAMETER G(RHOMBOHEDRAL_A7,PB;0) 298.15 +GHSERPB#+300+T; 2100 N\n REF3 !\n PARAMETER G(RHOMBOHEDRAL_A7,PD;0) 298.15 +GHSERPD#+4000; 4000 N REF4 !\n PARAMETER G(RHOMBOHEDRAL_A7,SB;0) 298.15 +GHSERSB#; 2000 N REF2 !\n PARAMETER G(RHOMBOHEDRAL_A7,SN;0) 100 +GHSERSN#+2035; 3000 N REF2 !\n PARAMETER G(RHOMBOHEDRAL_A7,ZN;0) 298.15 +GHSERZN#+2300+11.5*T; 1700\n N REF3 !\n PARAMETER G(RHOMBOHEDRAL_A7,SB;0) 298.15 +GHSERSB#; 2000 N REF2 !\n PARAMETER G(RHOMBOHEDRAL_A7,SN;0) 100 +GHSERSN#+2035; 3000 N REF2 !\n PARAMETER G(RHOMBOHEDRAL_A7,ZN;0) 298.15 +GHSERZN#+2300+11.5*T; 1700\n N REF3 !\n\n\n PHASE RHOMBOHEDRAL_C19 % 1 1.0 !\n CONSTITUENT RHOMBOHEDRAL_C19 :SM : !\n\n PARAMETER G(RHOMBOHEDRAL_C19,SM;0) 298.15 +GHSERSM#; 2100 N REF1 !\n\n\n PHASE TETRAGONAL_A6 % 1 1.0 !\n CONSTITUENT TETRAGONAL_A6 :BI,CD,GA,HG,IN,PB,PU,SN,ZN : ! : !\n\n PARAMETER G(TETRAGONAL_A6,BI;0) 298.15 +GHSERBI#+4184.07; 3000 N\n REF2 !\n PARAMETER G(TETRAGONAL_A6,CD;0) 298.15 +GHSERCD#+892.3-.92*T; 1600\n N REF2 !\n PARAMETER G(TETRAGONAL_A6,GA;0) 200 +GHSERGA#+3500-10*T; 4000 N\n REF2 !\n PARAMETER G(TETRAGONAL_A6,HG;0) 200 -10459.721+125.04019*T\n -28.847*T*LN(T)+.01699705*T**2-2.4555667E-05*T**3+13330*T**(-1); 234.32 Y\n -11216.714+137.69375*T-30.2091*T*LN(T)+.00107555*T**2-2.28298E-07*T**3\n +35545*T**(-1); 2000 N REF3 !\n PARAMETER G(TETRAGONAL_A6,IN;0) 298.15 +GHSERIN#; 3800 N REF1 !\n PARAMETER G(TETRAGONAL_A6,PB;0) 298.15 +GHSERPB#+4493.235; 2100 N\n REF3 !\n PARAMETER G(TETRAGONAL_A6,PU;0) 298.15 -496.178+54.586547*T\n -16.43*T*LN(T)-.024006*T**2+5.166667E-06*T**3-158470*T**(-1); 736 Y\n -6122.307+173.35008*T-35.56*T*LN(T); 757 Y\n +3982.078+63.890352*T-19.756*T*LN(T)-.00937295*T**2+6.59882E-07*T**3\n -1112565*T**(-1); 2157 Y\n -15200.539+228.05641*T-42.248*T*LN(T); 3000 N REF2 !\n PARAMETER G(TETRAGONAL_A6,SN;0) 100 +GHSERSN#+5387-8.26212*T; 3000\n N REF3 !\n PARAMETER G(TETRAGONAL_A6,ZN;0) 298.15 +GHSERZN#+4184; 1700 N REF4 !\n\n\n PHASE TETRAGONAL_AD % 1 1.0 !\n CONSTITUENT TETRAGONAL_AD :NP : !\n\n PARAMETER G(TETRAGONAL_AD,NP;0) 298.15 -10157.32+183.829213*T\n -34.11*T*LN(T)-.0161186*T**2+4.98465E-06*T**3+532825*T**(-1); 555 Y\n -7873.688+207.01896*T-39.33*T*LN(T); 856 Y\n +19027.98-46.64846*T-3.4265*T*LN(T)-.01921045*T**2+1.52726E-06*T**3\n -3564640*T**(-1); 1999 Y\n -16070.82+256.707037*T-45.3964*T*LN(T); 4000 N REF2 !\n\n\n PHASE TETRAGONAL_U % 1 1.0 !\n CONSTITUENT TETRAGONAL_U :FE,U,ZR : !\n\n PARAMETER G(TETRAGONAL_U,FE;0) 298.15 +GHSERFE#+5000; 6000 N REF3 !\n PARAMETER G(TETRAGONAL_U,U;0) 298.15 -5156.136+106.976316*T\n -22.841*T*LN(T)-.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 941.50 Y\n -14327.309+244.16802*T-42.9278*T*LN(T); 3000 N REF2 !\n PARAMETER G(TETRAGONAL_U,ZR;0) 298.15 +4474.461+124.9457*T\n -25.607406*T*LN(T)-3.40084E-04*T**2-9.729E-09*T**3+25233*T**(-1)\n -7.6143E-11*T**4; 2128 Y\n -25705.955+264.284163*T-42.144*T*LN(T)+1.276058E+32*T**(-9); 6000 N REF3 !\n\n\n PHASE TET_ALPHA1 % 1 1.0 !\n CONSTITUENT TET_ALPHA1 :BI,IN,PB,SN : !\n\n PARAMETER G(TET_ALPHA1,BI;0) 298.15 +GHSERBI#+4234; 3000 N REF2 !\n PARAMETER G(TET_ALPHA1,IN;0) 298.15 +GHSERIN#+123-.1988*T; 3800\n N REF3 !\n PARAMETER G(TET_ALPHA1,PB;0) 298.15 +GHSERPB#+1903.3-2.0602*T;\n 2100 N REF3 !\n PARAMETER G(TET_ALPHA1,SN;0) 100 +GHSERSN#+5510-8.46*T; 3000 N\n REF3 !\n\n\n PHASE WHITE_P % 1 1.0 !\n CONSTITUENT WHITE_P :P : !\n\n PARAMETER G(WHITE_P,P;0) 250 +GHSERPP#; 3000 N REF2 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF3 'PURE4 - SGTE Pure Elements (Unary) Database (Version 4.6),\n developed by SGTE (Scientific Group Thermodata Europe), 1991-2008,\n and provided by TCSAB (Jan. 2008). '\n REF2 'PURE3 - SGTE Pure Elements (Unary) Database (Version 3.0),\n developed by SGTE (Scientific Group Thermodata Europe), 1991-1996,\n and provided by TCSAB (Aug. 1996). '\n REF1 'PURE1 - SGTE Pure Elements (Unary) Database (Version 1.0),\n developed by SGTE (Scientific Group Thermodata Europe), 1991-1992,\n and provided by TCSAB (Jan. 1991). Also in: Dinsdale A. (1991):\n SGTE data for pure elements, Calphad, 15, 317-425.'\n REF4 'PURE5 - SGTE Pure Elements (Unary) Database (Version 5.1),\n developed by SGTE (Scientific Group Thermodata Europe), 1991-2010,\n and provided by TCSAB (Jun. 2010). '\n ! \n \n" }, { "path": "examples/macros/agcu.TDB", "content": "$ Database file written 2014- 2-22\n$ From database: SSOL2 \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01!\n ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01!\n \n \n FUNCTION GHSERAG 298.15 -7209.512+118.200733*T-23.8463314*T*LN(T)\n -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1.23508E+03 Y\n -15095.314+190.265169*T-33.472*T*LN(T)+1.412186E+29*T**(-9); 3000 N !\n FUNCTION GHSERCU 298.15 -7770.458+130.485403*T-24.112392*T*LN(T)\n -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35802E+03 Y\n -13542.33+183.804197*T-31.38*T*LN(T)+3.64643E+29*T**(-9); 3200 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :AG,CU : !\n\n PARAMETER G(LIQUID,AG;0) 298.15 +11025.293-8.890146*T\n -1.0322E-20*T**7+GHSERAG#; 1.23508E+03 Y\n +11507.972-9.300495*T-1.412186E+29*T**(-9)+GHSERAG#; 3000 N REF283 !\n PARAMETER G(LIQUID,CU;0) 298.15 +12964.84-9.510243*T\n -5.83932E-21*T**7+GHSERCU#; 1.35802E+03 Y\n +13495.4-9.920463*T-3.64643E+29*T**(-9)+GHSERCU#; 3.20000E+03 N REF283 !\n PARAMETER G(LIQUID,AG,CU;0) 298.15 +17534.6-4.45479*T; 6000 N REF137 !\n PARAMETER G(LIQUID,AG,CU;1) 298.15 +2251.3-2.6733*T; 6000 N REF137 !\n PARAMETER G(LIQUID,AG,CU;2) 298.15 492.7; 6000 N REF137 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :AG,CU : VA% : !\n\n PARAMETER G(BCC_A2,AG:VA;0) 298.15 +3400-1.05*T+GHSERAG#; 3000 N REF283 !\n PARAMETER G(BCC_A2,CU:VA;0) 298.15 +4017-1.255*T+GHSERCU#; 3200 N REF283 !\n PARAMETER G(BCC_A2,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 !\n\n\n TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %' 2 1 1 !\n CONSTITUENT FCC_A1 :AG%,CU% : VA% : !\n\n PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3.20000E+03 N REF283 !\n PARAMETER G(FCC_A1,AG,CU:VA;0) 298.15 +33819.1-8.1236*T; 6000 N REF137 !\n PARAMETER G(FCC_A1,AG,CU:VA;1) 298.15 -5601.9+1.32997*T; 6000 N REF137 !\n\n\n TYPE_DEFINITION ( GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %( 2 1 .5 !\n CONSTITUENT HCP_A3 :AG,CU : VA% : !\n\n PARAMETER G(HCP_A3,AG:VA;0) 298.15 +300+.3*T+GHSERAG#; 3000 N REF283 !\n PARAMETER G(HCP_A3,CU:VA;0) 298.15 +600+.2*T+GHSERCU#; 3200 N REF283 !\n PARAMETER G(HCP_A3,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF137 'F.H. Hayes, H.L. Lukas, G. Effenberg, G. Petzow,\n Z. fur Metallkde, Vol 77 (1986), No 11, p 749-754; AG-CU-PB'\n REF135 'Unassessed parameter, inserted to make this phase less stable.'\n ! \n \n" }, { "path": "examples/macros/all-from-map19.OCM", "content": "@$\n@$ running all test macros\n@$\n@$\n@$\n@$ Before running this use the command SET ADVANCED WORKSPACE\n@$ to the directory with the \"all.OCM\" file\n@$ That should make all files created to reside on that directory\n@$\n\nset echo Y\n\n@&& *********************************************************\n@$ Test of NaCl-MgCl2 using the MQMQA model\n@$ *********************************************************\n\nmac ./map19\n\n@&& *********************************************************\n@$ Second test of the MQMQA model\n@$ *********************************************************\n\nmac ./cslaf-map\n\n@&& *********************************************************\n@$ Testing the CEF SRO calculations\n@$ *********************************************************\n\nmac ./sro-cef.OCM\n\n@&& *********************************************************\n@$ Testing the UNIQUAC model this model no longer supported\n@$ *********************************************************\n\n@$ mac ./uniquac\n\n@&& *********************************************************\n@$ Calculation for 20 elements and 191 phases using COST507\n@$ *********************************************************\n\nmac ./allcost\n\n@&& *********************************************************\n@$ Calculating 21 equilibria in parallel\n@$ First test of parallel calculations\n@$ *********************************************************\n\nmac ./parallel1\n\n@&& *********************************************************\n@$ Enter a table with many equilibria and calculate all\n@$ Can be used to test parallel calculations\n@$ *********************************************************\n\nmac ./parallel2\n\n@&& *********************************************************\n@$ Assessment using fictitious binary experimental data\n@$ *********************************************************\n\n@$ mac ./opttest1\n\n@&& *********************************************************\n@$ Assessment start of the Cu-Mg case study must be run by itself\n@$ on the directory with the macro files\n@$ *********************************************************\n@$\n@$ mac ./opttest2\n@$\n@&& *********************************************************\n@$ that is all and hopefully enough\n@$ *********************************************************\n\nset inter\n\n" }, { "path": "examples/macros/all-from-map4.OCM", "content": "@$\n@$ running all test macros\n@$\n@$\n@$\n@$ Before running this use the command SET ADVANCED WORKSPACE\n@$ to the directory with the \"all.OCM\" file\n@$ That should make all files created to reside on that directory\n@$\n\nset echo Y\n\n@&& *********************************************************\n@$ Phase diagram for O-U\n@$ *********************************************************\n\nmac ./map4\n\n@&& *********************************************************\n@$ Phase diagram for Fe-Mo\n@$ *********************************************************\n\nmac ./map5\n\n@&& *********************************************************\n@$ The isopleth phase diagram for an 18-8 stainless steel\n@$ *********************************************************\n\nmac ./map6\n\n@&& *********************************************************\n@$ Almost complete isopleth calculation of a HSS\n@$ *********************************************************\n\nmac ./map7\n\n@&& *********************************************************\n@$ Metastable phase diagram for ordered FCC in Fe-Ni\n@$ *********************************************************\n\nmac ./map8\n\n@&& *********************************************************\n@$ Metastable Re-W phase diagram based on First Principles data\n@$ *********************************************************\n\nmac ./map9\n\n@&& *********************************************************\n@$ An isothermal section of Cr-Fe-Ni\n@$ *********************************************************\n\nmac ./map10\n\n@&& *********************************************************\n@$ The Cr-Fe binary phase diagram\n@$ *********************************************************\n\nmac ./map11\n\n@&& *********************************************************\n@$ The Mo-Re binary phase diagram using database in TDBformat\n@$ *********************************************************\n\nmac ./map12\n\n@&& *********************************************************\n@$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models\n@$ *********************************************************\n\nmac ./map13\n\n@&& *********************************************************\n@$ The Cr-Fe-Mo isothermal section at 1400 K\n@$ *********************************************************\n\nmac ./map14\n\n@&& *********************************************************\n@$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K.\n@$ *********************************************************\n\nmac ./map15\n\n@&& *********************************************************\n@$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium\n@$ *********************************************************\n\nmac ./map16\n\n@&& *********************************************************\n@$ The Al-Fe binary with a dashed A2/B2 transition line\n@$ *********************************************************\n\nmac ./map17\n\n@&& *********************************************************\n@$ The Al-Mg-Zn isopleth at x(zn)=0.05\n@$ *********************************************************\n\nmac ./map18\n\n@&& *********************************************************\n@$ Test of NaCl-MgCl2 using the MQMQA model\n@$ *********************************************************\n\nmac ./map19\n\n@&& *********************************************************\n@$ Second test of the MQMQA model\n@$ *********************************************************\n\nmac ./cslaf-map\n\n@&& *********************************************************\n@$ Testing the CEF SRO calculations\n@$ *********************************************************\n\nmac ./sro-cef.OCM\n\n@&& *********************************************************\n@$ Testing the UNIQUAC model this model no longer supported\n@$ *********************************************************\n\n@$ mac ./uniquac\n\n@&& *********************************************************\n@$ Calculation for 20 elements and 191 phases using COST507\n@$ *********************************************************\n\nmac ./allcost\n\n@&& *********************************************************\n@$ Calculating 21 equilibria in parallel\n@$ First test of parallel calculations\n@$ *********************************************************\n\nmac ./parallel1\n\n@&& *********************************************************\n@$ Enter a table with many equilibria and calculate all\n@$ Can be used to test parallel calculations\n@$ *********************************************************\n\nmac ./parallel2\n\n@&& *********************************************************\n@$ Assessment using fictitious binary experimental data\n@$ *********************************************************\n\n@$ mac ./opttest1\n\n@&& *********************************************************\n@$ Assessment start of the Cu-Mg case study must be run by itself\n@$ on the directory with the macro files\n@$ *********************************************************\n@$\n@$ mac ./opttest2\n@$\n@&& *********************************************************\n@$ that is all and hopefully enough\n@$ *********************************************************\n\nset inter\n\n" }, { "path": "examples/macros/all-from-tzero.OCM", "content": "@$\n@$ running all test macros\n@$\n@$\n@$\n@$ Before running this use the command SET ADVANCED WORKSPACE\n@$ to the directory with the \"all.OCM\" file\n@$ That should make all files created to reside on that directory\n@$\n\nset echo Y\n\n@&& *********************************************************\n@$ A T-zero line in a Fe-Cr-Si-C steel\n@$ *********************************************************\n\nmac ./step-tzero\n\n@&& *********************************************************\n@$ A isothermal section, paraequilibrum and T-zero line in a Fe-Mn-Si-C steel\n@$ *********************************************************\n\nmac ./step-epz\n\n@&& *********************************************************\n@$ A Scheil-Gulliver solidification simulation\n@$ *********************************************************\n\nmac ./step-scheil\n\n@&& *********************************************************\n@$ Phase diagram for Ag-Cu with various axis\n@$ *********************************************************\n\nmac ./map1\n\n@&& *********************************************************\n@$ Phase diagram for Cr-Mo\n@$ *********************************************************\n\nmac ./map2\n\n@&& *********************************************************\n@$ Phase diagram for C-Fe\n@$ *********************************************************\n\nmac ./map3\n\n@&& *********************************************************\n@$ Phase diagram for O-U\n@$ *********************************************************\n\nmac ./map4\n\n@&& *********************************************************\n@$ Phase diagram for Fe-Mo\n@$ *********************************************************\n\nmac ./map5\n\n@&& *********************************************************\n@$ The isopleth phase diagram for an 18-8 stainless steel\n@$ *********************************************************\n\nmac ./map6\n\n@&& *********************************************************\n@$ Almost complete isopleth calculation of a HSS\n@$ *********************************************************\n\nmac ./map7\n\n@&& *********************************************************\n@$ Metastable phase diagram for ordered FCC in Fe-Ni\n@$ *********************************************************\n\nmac ./map8\n\n@&& *********************************************************\n@$ Metastable Re-W phase diagram based on First Principles data\n@$ *********************************************************\n\nmac ./map9\n\n@&& *********************************************************\n@$ An isothermal section of Cr-Fe-Ni\n@$ *********************************************************\n\nmac ./map10\n\n@&& *********************************************************\n@$ The Cr-Fe binary phase diagram\n@$ *********************************************************\n\nmac ./map11\n\n@&& *********************************************************\n@$ The Mo-Re binary phase diagram using database in TDBformat\n@$ *********************************************************\n\nmac ./map12\n\n@&& *********************************************************\n@$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models\n@$ *********************************************************\n\nmac ./map13\n\n@&& *********************************************************\n@$ The Cr-Fe-Mo isothermal section at 1400 K\n@$ *********************************************************\n\nmac ./map14\n\n@&& *********************************************************\n@$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K.\n@$ *********************************************************\n\nmac ./map15\n\n@&& *********************************************************\n@$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium\n@$ *********************************************************\n\nmac ./map16\n\n@&& *********************************************************\n@$ The Al-Fe binary with a dashed A2/B2 transition line\n@$ *********************************************************\n\nmac ./map17\n\n@&& *********************************************************\n@$ The Al-Mg-Zn isopleth at x(zn)=0.05\n@$ *********************************************************\n\nmac ./map18\n\n@&& *********************************************************\n@$ Test of NaCl-MgCl2 using the MQMQA model\n@$ *********************************************************\n\nmac ./map19\n\n@&& *********************************************************\n@$ Second test of the MQMQA model\n@$ *********************************************************\n\nmac ./cslaf-map\n\n@&& *********************************************************\n@$ Testing the CEF SRO calculations\n@$ *********************************************************\n\nmac ./sro-cef.OCM\n\n@&& *********************************************************\n@$ Testing the UNIQUAC model\n@$ *********************************************************\n\n@$ mac ./uniquac\n\n@&& *********************************************************\n@$ Calculation for 20 elements and 191 phases using COST507\n@$ *********************************************************\n\nmac ./allcost\n\n@&& *********************************************************\n@$ Calculating 21 equilibria in parallel\n@$ First test of parallel calculations\n@$ *********************************************************\n\nmac ./parallel1\n\n@&& *********************************************************\n@$ Enter a table with many equilibria and calculate all\n@$ Can be used to test parallel calculations\n@$ *********************************************************\n\nmac ./parallel2\n\n@&& *********************************************************\n@$ Assessment using fictitious binary experimental data\n@$ *********************************************************\n\n@$ mac ./opttest1\n\n@&& *********************************************************\n@$ Assessment start of the Cu-Mg case study must be run by itself\n@$ on the directory with the macro files\n@$ *********************************************************\n@$\n@$ mac ./opttest2\n@$\n@&& *********************************************************\n@$ that is all and hopefully enough\n@$ *********************************************************\n\nset inter\n\n" }, { "path": "examples/macros/all.OCM", "content": "@$\n@$ running all test macros\n@$\n@$\n@$\n@$ Before running this use the command SET ADVANCED WORKSPACE\n@$ to the directory with the \"all.OCM\" file\n@$ That should make all files created to reside on that directory\n@$\n\nset echo Y\n\n@$\n@$ *********************************************************\n@$ Equilibria in pure Fe\n@$ *********************************************************\n\nmac ./unary\n\n@&& *********************************************************\n@$ Test setting various conditions for a C-Cr-Fe system\n@$ *********************************************************\n\nmac ./testcond1\n\n@&& *********************************************************\n@$ Equilibria and melting T of a 6 component high speed steel (HSS)\n@$ *********************************************************\n\nmac ./melting\n\n@&& *********************************************************\n@$ Testing a single calculation and save/read it unformatted\n@$ *********************************************************\n\nmac ./save\n\n@&& *********************************************************\n@$ Diagrams for phase fractions, compositions, heat content of a HSS\n@$ *********************************************************\n\nmac ./step1\n\n@&& *********************************************************\n@$ Diagrams for Gibbs energy curves for Ag-Cu\n@$ *********************************************************\n\nmac ./step2\n\n@&& *********************************************************\n@$ Diagrams for gas phase speciation, heat content and heat capacity \n@$ *********************************************************\n\nmac ./step3\n\n@&& *********************************************************\n@$ Diagrams for constituion and Gibbs energy curves for ordered FCC in Fe-Ni\n@$ *********************************************************\n\nmac ./step4\n\n@&& *********************************************************\n@$ Diagrams for constitution and heat capacity for ordered FCC in Fe-Ni\n@$ *********************************************************\n\nmac ./step5\n\n@&& *********************************************************\n@$ Diagram for Gibbs energy curves for Fe-Mo\n@$ *********************************************************\n\nmac ./step6\n\n@&& *********************************************************\n@$ Diagram for phase fractions and PRE for a duplex stainless steel\n@$ *********************************************************\n\nmac ./step7\n\n@&& *********************************************************\n@$ Adiabatic flame temperature for C3H8 as funktion of N(O)\n@$ *********************************************************\n\nmac ./step8\n\n@&& *********************************************************\n@$ Second order transition in a B2 phase with tentative T dependent SRO\n@$ *********************************************************\n\nmac ./step9\n\n@&& *********************************************************\n@$ A T-zero line in a Fe-Cr-Si-C steel\n@$ *********************************************************\n\nmac ./step-tzero\n\n@&& *********************************************************\n@$ A isothermal section, paraequilibrum and T-zero line in a Fe-Mn-Si-C steel\n@$ *********************************************************\n\nmac ./step-epz\n\n@&& *********************************************************\n@$ A Scheil-Gulliver solidification simulation\n@$ *********************************************************\n\nmac ./step-scheil\n\n@&& *********************************************************\n@$ Phase diagram for Ag-Cu with various axis\n@$ *********************************************************\n\nmac ./map1\n\n@&& *********************************************************\n@$ Phase diagram for Cr-Mo\n@$ *************************************\n\n********************\n\nmac ./map2\n\n@&& *********************************************************\n@$ Phase diagram for C-Fe\n@$ *********************************************************\n\nmac ./map3\n\n@&& *********************************************************\n@$ Phase diagram for O-U\n@$ *********************************************************\n\nmac ./map4\n\n@&& *********************************************************\n@$ Phase diagram for Fe-Mo\n@$ *********************************************************\n\nmac ./map5\n\n@&& *********************************************************\n@$ The isopleth phase diagram for an 18-8 stainless steel\n@$ *********************************************************\n\nmac ./map6\n\n@&& *********************************************************\n@$ Almost complete isopleth calculation of a HSS\n@$ *********************************************************\n\nmac ./map7\n\n@&& *********************************************************\n@$ Metastable phase diagram for ordered FCC in Fe-Ni\n@$ *********************************************************\n\nmac ./map8\n\n@&& *********************************************************\n@$ Metastable Re-W phase diagram based on First Principles data\n@$ *********************************************************\n\nmac ./map9\n\n@&& *********************************************************\n@$ An isothermal section of Cr-Fe-Ni\n@$ *********************************************************\n\nmac ./map10\n\n@&& *********************************************************\n@$ The Cr-Fe binary phase diagram\n@$ *********************************************************\n\nmac ./map11\n\n@&& *********************************************************\n@$ The Mo-Re binary phase diagram using database in TDBformat\n@$ *********************************************************\n\nmac ./map12\n\n@&& *********************************************************\n@$ The Al-Ni binary phase diagram with 4 sublattice order/disorder models\n@$ *********************************************************\n\nmac ./map13\n\n@&& *********************************************************\n@$ The Cr-Fe-Mo isothermal section at 1400 K\n@$ *********************************************************\n\nmac ./map14\n\n@&& *********************************************************\n@$ The Mo-Ni-Re EBEF model isothermal section at 2500, 1500 and 500 K.\n@$ *********************************************************\n\nmac ./map15\n\n@&& *********************************************************\n@$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium\n@$ *********************************************************\n\nmac ./map16\n\n@&& *********************************************************\n@$ The Al-Fe binary with a dashed A2/B2 transition line\n@$ *********************************************************\n\nmac ./map17\n\n\n@&& *********************************************************\n@$ The Al-Mg-Zn isopleth at x(zn)=0.05\n@$ *********************************************************\n\nmac ./map18\n\n@&& *********************************************************\n@$ Test of NaCl-MgCl2 using the MQMQA model\n@$ *********************************************************\n\nmac ./map19\n\n@&& *********************************************************\n@$ Second test of the MQMQA model\n@$ *********************************************************\n\nmac ./cslaf-map\n\n@&& *********************************************************\n@$ Testing the CEF SRO calculations\n@$ *********************************************************\n\nmac ./sro-cef.OCM\n\n@&& *********************************************************\n@$ New unary descriptions\n@$ *********************************************************\n\nmac ./AlC-diagrams\n\n@&& *********************************************************\n@$ Testing the UNIQUAC model Removed as it conflicts with the new MQMQA model\n@$ *********************************************************\n\n@$ mac ./uniquac\n\n@&& *********************************************************\n@$ Calculation for 20 elements and 191 phases using COST507\n@$ *********************************************************\n\nmac ./allcost\n\n@&& *********************************************************\n@$ Calculating 21 equilibria in parallel\n@$ First test of parallel calculations\n@$ *********************************************************\n\nmac ./parallel1\n\n@&& *********************************************************\n@$ Enter a table with many equilibria and calculate all\n@$ Can be used to test parallel calculations\n@$ *********************************************************\n\nmac ./parallel2\n\n@&& *********************************************************\n@$ Assessment using fictitious binary experimental data\n@$ *********************************************************\n\n@$ mac ./opttest1\n\n@&& *********************************************************\n@$ Assessment start of the Cu-Mg case study must be run by itself\n@$ on the directory with the macro files\n@$ *********************************************************\n@$\n@$ mac ./opttest2\n@$\n@&& *********************************************************\n@$ that is all and hopefully enough\n@$ *********************************************************\n\nset inter\n\n" }, { "path": "examples/macros/allcost.OCM", "content": "new Y\n\nset echo Y\n\n@$ ==============================================================\n@$\n@$\n@$\n@$\n@$\n@$ This macro calculates some equilibria in a multicomponent system\n@$ using the largest free databases I have, cost507 for light alloys\n@$ which has 20 elements and 191 phases\n@$ \n@$ This database is from 1997 and NOT VERY HIGH QUALITY\n@$ \n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ allcost.OCM\n@$ \n@$ ==============================================================\n\nset echo\n\nr t ./cost507R\n\n\n@&\n\n@$ This should try to enter >9 composition sets\n\nset c t=2000 p=1e5 n=1 \n\nset c w(b)=.001 w(c)=.004 w(ce)=.002 w(cr)=0.0002 w(cu)=.02 w(fe)=0.0001\n\nset c w(li)=.0006 w(mg)=.03 w(mn)=.0002 w(n)=0.001 w(nd)=.01 w(ni)=.01 \n\nset c w(si)=.07 w(sn)=.003 w(ti)=.002 w(v)=.0008 w(y)=.00014\n\nset c w(zn)=.06 w(zr)=.007\n\nl c\n\n@$ Set small grid to speed up calculations\n@$ set adv small DEPRECIATED COMMAND\n\nset adv grid 0\n\n@&\n@$ Just calculate with gridmin, some warnings\n\nc g\n\n@&\n@$ A short listing of the 20 phases selected by gridmin\n\nl sh p\n\n\n@$ Note several composition set for the liquid\n@&\n@$ Then calculate the full equilibrium using this start point\n\nc n\n\n@&\n\nl,,,,,\n\n@$ Only the AlN solid stable together with the liquid\n@$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM\ndebug symbol g -1.4480613E5\n@&\n@$ Then calculte a full equilibrium at 1000 K\n\nset c t=1000\n\nc e\n\n@$ Sometimes it does not converge here because competing liquids ... try again\n@&\n\nc e\n\n\ndebug symbol g -5.2815596E+04\n\n@$ Numerical problems can always occur.\n@$ If you have a presistant problem please provide database and macro file\n@$ to the OC team\n@&\n\nl,,,,,\n\n\n\n@$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM\n\n@&\n\nl sh p\n\n@$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM\n@&\n@$ Calculate at a lower T\n\nset c t=500\n\nc e\n\nl,,,,\n\n@$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM\n@$ Testing result\ndebug symbol g -2.3254708E4\n@&\n\nl sh p\n\n@$ NOTE THE DATABASE IS NOT RELIABLE FOR THIS SYSTEM\n\n@&\n@$ Added test of the command CALCULATE BOSSES_METHOD ...does not work...\n@$ This may be useful if there are convergence problems\n\n@$ c b-m\n\n@$ Or try this step by step method\n@$ First just the grid minimizer\n\nc g\n\n@$ set all phases except those found by the gridminimizer as suspended\n@$ and calculate equilibrium without the gridminimizer\n@$ *U is all unstable phases\n\nset st ph *U=S\n\n@$ use c n is to calculate without gridminimizer\n\nc n\n\n@$ it converges but we cannot be sure we have the most stable equilibrium\n@&\n@$ Then set all suspended phases as dormant and calculate without gridmin\n\nset st ph *S=D\n\nc n\n\n@$ Thus time the driving force for all dormat phases will be calculated\n@&\n\nl r\n\n@$ There are 2 dormant phases listed which want to be stable, add them\n\nset st ph bcc_a2 alcu_theta = E 0\n\n@&\n\nc n\n\n@$ Calculate again without the gridminimizer\n@&\n\nl r\n\n\n@$ When listing no new phases wants to be stable\n@$ set all dormant phases as entered\n\nset st ph *D=E\n\n@$ Continue to use \"c n\" because using \"c e\" will use the gridminimizer\n\nc n\n\n@&\n\nl r\n\n@$ Listing result with all phases as entered, same as before!\n\ndebug symbol g -2.3254708E4\n\n\n\n@$==========================================================================\n@$ end of allcost macro\n@$==========================================================================\n\n\nset inter\n\n@$ gprof oc5prof.exe gmon.out > output_file.txt" }, { "path": "examples/macros/alni-4slx.TDB", "content": "\n$ Database file written 2017- 8- 2\n$ From database: USER \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AL A1 2.6982E+01 4.5773E+03 2.8322E+01!\n ELEMENT NI A1 5.8690E+01 4.7870E+03 2.9796E+01!\n \n \n FUNCTION GLIQAL 298.15 +11005.553-11.840873*T+7.9401E-20*T**7+GHSERAL#; \n 933.60 Y\n +10481.974-11.252014*T+1.234264E+28*T**(-9)+GHSERAL#; 2900 N !\n FUNCTION GHSERAL 298.15 -7976.15+137.071542*T-24.3671976*T*LN(T)\n -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 700 Y\n -11276.24+223.02695*T-38.5844296*T*LN(T)+.018531982*T**2\n -5.764227E-06*T**3+74092*T**(-1); 933.60 Y\n -11277.683+188.661987*T-31.748192*T*LN(T)-1.234264E+28*T**(-9); 2900 N \n !\n FUNCTION GBCCAL 298.15 +10083-4.813*T+GHSERAL#; 6000 N !\n FUNCTION B2ALVA 298.15 +10000-T; 6000 N !\n FUNCTION LB2ALVA 298.15 +200000; 6000 N !\n FUNCTION BALVAB2 298.15 +.5*B2ALVA#-.5*LB2ALVA#; 6000 N !\n FUNCTION BUALVA 298.15 +.25*BALVAB2#; 6000 N !\n FUNCTION GHCPAL 298.15 +5481-1.799*T+GHSERAL#; 6000 N !\n FUNCTION C14AL 298.15 +14000+GHSERAL#; 6000 N !\n FUNCTION B2NIVA 298.15 +162397.3-27.40575*T; 6000 N !\n FUNCTION LB2NIVA 298.15 -64024.38+26.49419*T; 6000 N !\n FUNCTION BNIVAB2 298.15 +.5*B2NIVA#-.5*LB2NIVA#; 6000 N !\n FUNCTION BUNIVA 298.15 +.25*BNIVAB2#; 6000 N !\n FUNCTION C14NI 298.15 +18900+GHSERNI#; 6000 N !\n FUNCTION GDHCNI 298.15 +.5*GHCPNI#+.5*GFCCNI#; 6000 N !\n FUNCTION LLIQ0 298.15 -5*LLIQ2#-9*LLIQ4#; 6000 N !\n FUNCTION LLIQ1 298.15 -7*UNTIER#*LLIQ3#; 6000 N !\n FUNCTION LLIQ2 298.15 +81204.81-31.95713*T; 6000 N !\n FUNCTION LLIQ3 298.15 +4365.35-2.51632*T; 6000 N !\n FUNCTION LLIQ4 298.15 -22101.64+13.16341*T; 6000 N !\n FUNCTION FAL3NI 298.15 -29600; 6000 N !\n FUNCTION FAL2NI2 298.15 -66718+11.64*T; 6000 N !\n FUNCTION FALNI3 298.15 -43590+6.22*T; 6000 N !\n FUNCTION FRALNI 298.15 -34575+13.22*T; 6000 N !\n FUNCTION F0ALNI 298.15 +5310-1.46*T; 6000 N !\n FUNCTION LB2ALNI 298.15 -62104+19.28*T; 6000 N !\n FUNCTION B2ALNI 298.15 -152397.3+26.40575*T; 6000 N !\n FUNCTION BALNIB2 298.15 +.5*B2ALNI#-.5*LB2ALNI#; 6000 N !\n FUNCTION BAL3NI 298.15 +2*BUALNI#; 6000 N !\n FUNCTION BALNI3 298.15 +2*BUALNI#; 6000 N !\n FUNCTION BALNIB32 298.15 +2*BUALNI#; 6000 N !\n FUNCTION BUALNI 298.15 +.25*BALNIB2#; 6000 N !\n FUNCTION HAL3NI 298.15 -29600; 6000 N !\n FUNCTION HAL2NI2 298.15 -66718+11.64*T; 6000 N !\n FUNCTION HALNI3 298.15 -43590+6.22*T; 6000 N !\n FUNCTION HRALNI 298.15 -34575+13.22*T; 6000 N !\n FUNCTION H0ALNI 298.15 +5310-1.46*T; 6000 N !\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-.0048407*T**2; \n 1728 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6000 N !\n FUNCTION GALALNI 298.15 -GALNIVA#+GALALVA#+GALNINI#; 6000 N !\n FUNCTION GALNINI 298.15 +5000+FB2ALNI#; 6000 N !\n FUNCTION GALALVA 298.15 +5000-.5*T+5*UNSURSIX#*GBCCAL#; 6000 N !\n FUNCTION GALNIVA 298.15 -59620.987+11.387*T+3*UNSURSIX#*GBCCAL#\n +2*UNSURSIX#*GBCCNI#; 6000 N !\n FUNCTION L32ALNI 298.15 -32247.363+21.965*T; 6000 N !\n FUNCTION L32NIVA 298.15 -3666.95+1.1722*T; 6000 N !\n FUNCTION GHCPNI 298.15 +1046+1.255*T+GHSERNI#; 3000 N !\n FUNCTION GFCCNI 298.15 +GHSERNI#; 3000 N !\n FUNCTION UNTIER 298.15 +TROIS#**(-1); 6000 N !\n FUNCTION UNSURSIX 298.15 +SIX#**(-1); 6000 N !\n FUNCTION FB2ALNI 298.15 -76198.65+13.202875*T+.5*GBCCAL#+.5*GBCCNI#; 6000 \n N !\n FUNCTION GBCCNI 298.15 +8715.084-3.556*T+GHSERNI#; 3000 N !\n FUNCTION TROIS 298.15 +3; 6000 N !\n FUNCTION SIX 298.15 +6; 6000 N !\n FUNCTION UN_ASS 298.15 +0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n TYPE_DEFINITION ) GES AMEND_PHASE_DESCRIPTION BCC4 DIS_PART A2,,,!\n TYPE_DEFINITION + GES AMEND_PHASE_DESCRIPTION FCC4 DIS_PART A1,,,!\n TYPE_DEFINITION . GES AMEND_PHASE_DESCRIPTION HCP4 DIS_PART A3,,,!\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :AL,NI : !\n\n PARAMETER G(LIQUID,AL;0) 298.15 +GLIQAL#; 2900 N REF2 !\n PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T\n -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1728 Y\n -9549.775+268.598*T-43.1*T*LN(T); 3000 N REF2 !\n PARAMETER G(LIQUID,AL,NI;0) 298.15 +LLIQ0#; 6000 N REF4 !\n PARAMETER G(LIQUID,AL,NI;1) 298.15 +LLIQ1#; 6000 N REF4 !\n PARAMETER G(LIQUID,AL,NI;2) 298.15 +LLIQ2#; 6000 N REF4 !\n PARAMETER G(LIQUID,AL,NI;3) 298.15 +LLIQ3#; 6000 N REF4 !\n PARAMETER G(LIQUID,AL,NI;4) 298.15 +LLIQ4#; 6000 N REF4 !\n\n\n TYPE_DEFINITION & GES A_P_D A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE A1 %& 1 1.0 !\n CONSTITUENT A1 :AL,NI : !\n\n PARAMETER G(A1,AL;0) 298.15 +GHSERAL#; 6000 N REF2 !\n PARAMETER G(A1,NI;0) 298.15 -5179.159+117.854*T\n -22.096*T*LN(T)-.0048407*T**2; 1728 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N REF1 !\n PARAMETER TC(A1,NI;0) 298.15 +633; 3000 N REF1 !\n PARAMETER BMAGN(A1,NI;0) 298.15 +.52; 3000 N REF2 !\n PARAMETER TC(A1,AL,NI;0) 298.15 -1112; 6000 N REF4 !\n PARAMETER TC(A1,AL,NI;1) 298.15 +1745; 6000 N REF4 !\n PARAMETER G(A1,AL,NI;0) 298.15 +FAL3NI#+1.5*FAL2NI2#\n +FALNI3#+1.5*FRALNI#+4*F0ALNI#; 6000 N REF11 !\n PARAMETER G(A1,AL,NI;1) 298.15 +2*FAL3NI#-2*FALNI3#; 6000 \n N REF11 !\n PARAMETER G(A1,AL,NI;2) 298.15 +FAL3NI#-1.5*FAL2NI2#\n +FALNI3#-1.5*FRALNI#; 6000 N REF11 !\n\n\n TYPE_DEFINITION ' GES A_P_D A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE A2 %' 1 1.0 !\n CONSTITUENT A2 :AL,NI,VA : !\n\n PARAMETER G(A2,AL;0) 298.15 +GBCCAL#; 6000 N REF2 !\n PARAMETER TC(A2,NI;0) 298.15 +575; 3000 N REF1 !\n PARAMETER BMAGN(A2,NI;0) 298.15 +.85; 3000 N REF1 !\n PARAMETER G(A2,NI;0) 298.15 +3535.925+114.298*T\n -22.096*T*LN(T)-.0048407*T**2; 1728 Y\n -19125.571+275.579*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 6000 N REF2 !\n PARAMETER G(A2,VA;0) 298.15 +30*T; 6000 N REF20 !\n PARAMETER G(A2,AL,VA;0) 298.15 +B2ALVA#+LB2ALVA#; 6000 N \n REF20 !\n PARAMETER G(A2,AL,NI;0) 298.15 +B2ALNI#+LB2ALNI#; 6000 N \n REF8 !\n PARAMETER G(A2,NI,VA;0) 298.15 +B2NIVA#+LB2NIVA#; 6000 N \n REF8 !\n\n\n TYPE_DEFINITION ( GES A_P_D A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE A3 %( 1 1.0 !\n CONSTITUENT A3 :AL,NI : !\n\n PARAMETER G(A3,AL;0) 298.15 +GHCPAL#; 6000 N REF0 !\n PARAMETER TC(A3,NI;0) 298.15 +633; 6000 N REF1 !\n PARAMETER BMAGN(A3,NI;0) 298.15 +.52; 6000 N REF1 !\n PARAMETER G(A3,NI;0) 298.15 -4133.159+119.109*T\n -22.096*T*LN(T)-.0048407*T**2; 1728 Y\n -26794.655+280.39*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3000 N REF2 !\n PARAMETER G(A3,AL,NI;0) 298.15 +HAL3NI#+1.5*HAL2NI2#\n +HALNI3#+1.5*HRALNI#+4*H0ALNI#; 6000 N REF20 !\n PARAMETER G(A3,AL,NI;1) 298.15 +2*HAL3NI#-2*HALNI3#; 6000 \n N REF20 !\n PARAMETER G(A3,AL,NI;2) 298.15 +HAL3NI#-1.5*HAL2NI2#\n +HALNI3#-1.5*HRALNI#; 6000 N REF20 !\n\n\n PHASE AL3NI1 % 2 .75 .25 !\n CONSTITUENT AL3NI1 :AL : NI : !\n\n PARAMETER G(AL3NI1,AL:NI;0) 298.15 -48483.73+12.29913*T\n +.75*GHSERAL#+.25*GHSERNI#; 6000 N REF4 !\n\n\n PHASE AL3NI2 % 3 3 2 1 !\n CONSTITUENT AL3NI2 :AL : AL,NI% : NI,VA% : !\n\n PARAMETER G(AL3NI2,AL:AL:NI;0) 298.15 +6*GALALNI#; 6000 N REF4 !\n PARAMETER G(AL3NI2,AL:NI:NI;0) 298.15 +6*GALNINI#; 6000 N REF4 !\n PARAMETER G(AL3NI2,AL:AL:VA;0) 298.15 +6*GALALVA#; 6000 N REF4 !\n PARAMETER G(AL3NI2,AL:NI:VA;0) 298.15 +6*GALNIVA#; 6000 N REF4 !\n PARAMETER G(AL3NI2,AL:AL,NI:*;0) 298.15 +6*L32ALNI#; 6000 N REF4 !\n PARAMETER G(AL3NI2,AL:*:NI,VA;0) 298.15 +6*L32NIVA#; 6000 N REF4 !\n\n\n PHASE AL3NI5 % 2 .375 .625 !\n CONSTITUENT AL3NI5 :AL : NI : !\n\n PARAMETER G(AL3NI5,AL:NI;0) 298.15 -66520+18.9*T+.375*GHSERAL#\n +.625*GHSERNI#; 6000 N REF11 !\n\n\n PHASE AL3TI % 2 3 1 !\n CONSTITUENT AL3TI :AL : AL : !\n\n PARAMETER G(AL3TI,AL:AL;0) 298.15 +4*GHSERAL#+400; 6000 N \n REF17 !\n\n\n PHASE AL8FE5_CI52 % 2 8 5 !\n CONSTITUENT AL8FE5_CI52 :AL : AL : !\n\n PARAMETER G(AL8FE5_CI52,AL:AL;0) 298.15 +13*GBCCAL#; 6000 N REF14 !\n\n\n$ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A2 \n TYPE_DEFINITION * GES A_P_D BCC4 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC4:B %)* 4 .25 .25 .25 .25 !\n CONSTITUENT BCC4:B :AL,NI,VA : AL,NI,VA : AL,NI,VA : AL,NI,VA : !\n\n PARAMETER G(BCC4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 !\n PARAMETER G(BCC4,AL:AL:AL:NI;0) 298.15 +BAL3NI#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:NI:AL:NI;0) 298.15 +BALNIB32#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:AL:NI:NI;0) 298.15 +BALNIB2#; 6000 N REF8 !\n PARAMETER G(BCC4,AL:NI:NI:NI;0) 298.15 +BALNI3#; 6000 N REF20 !\n PARAMETER G(BCC4,NI:NI:NI:NI;0) 298.15 +0.0; 6000 N REF0 !\n PARAMETER G(BCC4,AL:VA:NI:NI;0) 298.15 +2*BUALNI#+2*BUNIVA#; 6000 \n N REF19 !\n PARAMETER G(BCC4,AL:AL:AL:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:NI:AL:VA;0) 298.15 +BUALNI#+BUALVA#+BUNIVA#; \n 6000 N REF0 !\n PARAMETER G(BCC4,AL:VA:AL:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:AL:NI:VA;0) 298.15 +2*BUALNI#+2*BUALVA#; 6000 \n N REF0 !\n PARAMETER G(BCC4,AL:NI:NI:VA;0) 298.15 +BUALNI#+BUALVA#+BUNIVA#; \n 6000 N REF0 !\n PARAMETER G(BCC4,NI:NI:NI:VA;0) 298.15 +2*BUNIVA#; 6000 N REF0 !\n PARAMETER G(BCC4,AL:VA:NI:VA;0) 298.15 +BUALNI#+BUNIVA#+BUALVA#; \n 6000 N REF0 !\n PARAMETER G(BCC4,NI:VA:NI:VA;0) 298.15 +2*BUNIVA#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:AL:VA:VA;0) 298.15 +BALVAB2#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:NI:VA:VA;0) 298.15 +2*BUNIVA#+2*BUALVA#; 6000 \n N REF19 !\n PARAMETER G(BCC4,NI:NI:VA:VA;0) 298.15 +BNIVAB2#; 6000 N REF20 !\n PARAMETER G(BCC4,AL:VA:VA:VA;0) 298.15 +2*BUALVA#; 6000 N REF20 !\n PARAMETER G(BCC4,NI:VA:VA:VA;0) 298.15 +2*BUNIVA#; 6000 N REF20 !\n PARAMETER G(BCC4,VA:VA:VA:VA;0) 298.15 +0.0; 6000 N REF0 !\n\n\n PHASE C14 % 3 1 1.5 .5 !\n CONSTITUENT C14 :AL,NI : AL,NI : AL,NI : !\n\n PARAMETER G(C14,AL:AL:AL;0) 298.15 +3*C14AL#; 6000 N REF18 !\n PARAMETER G(C14,NI:AL:AL;0) 298.15 +C14NI#+2*C14AL#; 6000 N \n REF20 !\n PARAMETER G(C14,AL:NI:AL;0) 298.15 +1.5*C14AL#+1.5*C14NI#; \n 6000 N REF20 !\n PARAMETER G(C14,NI:NI:AL;0) 298.15 +2.5*C14NI#+.5*C14AL#; 6000 \n N REF20 !\n PARAMETER G(C14,AL:AL:NI;0) 298.15 +2.5*C14AL#+.5*C14NI#; 6000 \n N REF20 !\n PARAMETER G(C14,NI:AL:NI;0) 298.15 +1.5*C14NI#+1.5*C14AL#; \n 6000 N REF20 !\n PARAMETER G(C14,AL:NI:NI;0) 298.15 +C14AL#+2*C14NI#; 6000 N \n REF20 !\n PARAMETER G(C14,NI:NI:NI;0) 298.15 +3*C14NI#; 6000 N REF18 !\n\n\n$ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A1 \n TYPE_DEFINITION - GES A_P_D FCC4 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC4:F %+- 4 .25 .25 .25 .25 !\n CONSTITUENT FCC4:F :AL,NI : AL,NI : AL,NI : AL,NI : !\n\n PARAMETER G(FCC4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 !\n PARAMETER G(FCC4,AL:AL:AL:NI;0) 298.15 +FAL3NI#; 6000 N REF0 !\n PARAMETER G(FCC4,AL:AL:NI:NI;0) 298.15 +FAL2NI2#; 6000 N REF0 !\n PARAMETER G(FCC4,AL:NI:NI:NI;0) 298.15 +FALNI3#; 6000 N REF0 !\n PARAMETER G(FCC4,NI:NI:NI:NI;0) 298.15 +0.0; 6000 N REF0 !\n PARAMETER G(FCC4,AL,NI:*:*:*;0) 298.15 +F0ALNI#; 6000 N REF11 !\n PARAMETER G(FCC4,AL,NI:AL,NI:*:*;0) 298.15 +FRALNI#; 6000 N REF0 !\n\n\n$ THIS PHASE HAS A DISORDERED CONTRIBUTION FROM A3 \n TYPE_DEFINITION / GES A_P_D HCP4 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP4:F %./ 4 .25 .25 .25 .25 !\n CONSTITUENT HCP4:F :AL,NI : AL,NI : AL,NI : AL,NI : !\n\n PARAMETER G(HCP4,AL:AL:AL:AL;0) 298.15 +0.0; 6000 N REF0 !\n PARAMETER G(HCP4,AL:AL:AL:NI;0) 298.15 +HAL3NI#; 6000 N REF0 !\n PARAMETER G(HCP4,AL:AL:NI:NI;0) 298.15 +HAL2NI2#; 6000 N REF0 !\n PARAMETER G(HCP4,AL:NI:NI:NI;0) 298.15 +HALNI3#; 6000 N REF0 !\n PARA G(HCP4,NI:NI:NI:NI;0) 298.15 +0; 6000 N!\n PARAMETER G(HCP4,AL,NI:*:*:*;0) 298.15 +H0ALNI#; 6000 N REF20 !\n PARAMETER G(HCP4,AL,NI:AL,NI:*:*;0) 298.15 +FRALNI#; 6000 N REF0 !\n\n\n PHASE NI3TI % 2 3 1 !\n CONSTITUENT NI3TI :NI : NI : !\n\n PARAMETER G(NI3TI,NI:NI;0) 298.15 +4*GDHCNI#; 6000 N REF13 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF20 ' at work'\n REF2 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol \n 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August 1990'\n REF18 'M.H.F. Sluiter Calphad 30 (2006) 357-366 and Acta Materialia 55 \n (207) 3707-3718'\n REF1 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report \n DMA(A)195 September 1989'\n REF8 'N. Dupin, Z. Metallkd. 90 (1999) 76-85'\n REF13 'J. De Keyzer, G. Cacciamani, N. Dupin, P. Wollants, CALPHAD 33 \n (2009) 109–123; Fe-Ni-Ti'\n REF14 'B. Sundman, I. Ohnuma, N. Dupin, U. Kattner, S.G. Fries, Acta \n Materialia, 57 (2009) 2896-2908; Al-Fe'\n REF4 'N. DThesis, INP Grenoble 1995'\n REF11 'N. Dupin, B. Sundman, XXVII Jeep, Journees d’Etude des \n Equilibre Entre Phases, 2003. Parameters listed in X.-G. Lu,\n\t B. Sundman and J. Agren, Calphad (2009) 450-456'\n REF19 'Linear combinations on bounds'\n REF17 'B. Sundman, private communication 15/06/2015; Al-Ti'\n ! \n \n" }, { "path": "examples/macros/cost507R.TDB", "content": "$ From COST project 507\n DATABASE_INFO about the COST 507 database\n This thermodynamic database is the result of the European COST 507 project.\n It contains about 70 assessed binary and a few ternary system for 20 elements,\n Many binaries and ternaries have no data and cannot be calculated.\n A simple test is to list the data for the liquid phase: \"list ph liq data\"\n If there are no EXCESS parameters for a system in the liquid\n the system has not been assessed. General reference:\n\n Luxembourg: Office for Official Publications of the European Communities, 1998\n Volume 2: ISBN 92-828-3902-8\n Volumes 1 to 3: ISBN 92-828-3900-1\n\n For the each assessed model parameter a bibliographic reference is provided. !\n$\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT AL FCC_A1 2.6982E+01 4.5773E+03 2.8322E+01!\n ELEMENT B BETA_RHOMBO_B 1.0811E+01 1.2220E+03 5.9000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT CE FCC_A1 1.4012E+02 7.2801E+03 6.9454E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT LI BCC_A2 6.9410E+00 4.6233E+03 2.9095E+01!\n ELEMENT MG HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01!\n ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01!\n ELEMENT N 1/2_MOLE_N2(G) 1.4007E+01 4.3350E+03 9.5751E+01!\n ELEMENT ND DHCP 1.4424E+01 7.1337E+03 7.1086E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9797E+01!\n ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01!\n ELEMENT SN BCT_A5 1.1869E+02 6.3220E+03 5.1195E+01!\n ELEMENT TI HCP_A3 4.7880E+01 4.8240E+03 3.0720E+01!\n ELEMENT V BCC_A2 5.0942E+01 4.5070E+03 3.0890E+01!\n ELEMENT Y HCP_A3 8.8906E+01 5.9664E+03 4.4434E+01!\n ELEMENT ZN HCP_A3 6.5380E+01 5.6567E+03 4.1631E+01!\n ELEMENT ZR HCP_A3 9.1224E+01 5.5663E+03 3.9181E+01!\n \n SPECIES AL2 AL2!\n SPECIES B1N1 B1N1!\n SPECIES B2 B2!\n SPECIES B4 B4!\n SPECIES BC B1C1!\n SPECIES BN B1N1!\n SPECIES C+1 C1/+1!\n SPECIES C-1 C1/-1!\n SPECIES C2 C2!\n SPECIES C2-1 C2/-1!\n SPECIES C2B B1C2!\n SPECIES C2SI C2SI1!\n SPECIES C3 C3!\n SPECIES C4 C4!\n SPECIES C5 C5!\n SPECIES CSI C1SI1!\n SPECIES CSI2 C1SI2!\n SPECIES MG2SN MG2SN1!\n SPECIES N2 N2!\n SPECIES N3 N3!\n SPECIES SI+1 SI1/+1!\n SPECIES SI2 SI2!\n SPECIES SI3 SI3!\n \n FUNCTION GHSERAL 2.98150E+02 -7976.15+137.093038*T-24.3671976*T*LN(T)\n -.001884662*T**2-8.77664E-07*T**3+74092*T**(-1); 7.00000E+02 Y\n -11276.24+223.048446*T-38.5844296*T*LN(T)+.018531982*T**2\n -5.764227E-06*T**3+74092*T**(-1); 9.33470E+02 Y\n -11278.378+188.684153*T-31.748192*T*LN(T)-1.230524E+28*T**(-9); \n 2.90000E+03 N !\n FUNCT GLIQAL \n 298.15 +11005.029-11.841867*T+7.934E-20*T**7+GHSERAL; \n 933.47 Y +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL; \n 6000.00 N REF0!\n FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GHSERMG 2.98150E+02 -8367.34+143.675547*T-26.1849782*T*LN(T)\n +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 9.23000E+02 Y\n -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); \n 3.00000E+03 N !\n FUNCTION GHSERMN 2.98150E+02 -8115.28+130.059*T-23.4582*T*LN(T)\n -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y\n -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 6.00000E+03 N !\n FUNCTION GHSERNN 2.98150E+02 -3750.675-9.45425*T-12.7819*T*LN(T)\n -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 9.50000E+02 Y\n -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3\n +563070*T**(-1); 3.35000E+03 Y\n -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3\n +4596375*T**(-1); 6.00000E+03 N !\n FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 N !\n FUNCTION GHSERSI 2.98150E+02 -8162.609+137.236859*T-22.8317533*T*LN(T)\n -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y\n -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9); \n 3.60000E+03 N !\n FUNCTION GLIQSN 1.00000E+02 -855.425+108.677684*T-25.858*T*LN(T)\n +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1)+1.47031E-18*T**7; \n 2.50000E+02 Y\n +1247.957+51.355548*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3\n -61960*T**(-1)+1.47031E-18*T**7; 5.05080E+02 Y\n +9496.31-9.809114*T-8.2590486*T*LN(T)-.016814429*T**2\n +2.623131E-06*T**3-1081244*T**(-1); 8.00000E+02 Y\n -1285.372+125.182498*T-28.4512*T*LN(T); 3.00000E+03 N !\n FUNCTION GLIQTI 2.98150E+02 +12194.415-6.980938*T+GHSERTI#; \n 1.30000E+03 Y\n +368610.36-2620.99904*T+357.005867*T*LN(T)-.155262855*T**2\n +1.2254402E-05*T**3-65556856*T**(-1)+GHSERTI#; 1.94100E+03 Y\n +104639.72-340.070171*T+40.9282461*T*LN(T)-.008204849*T**2\n +3.04747E-07*T**3-36699805*T**(-1)+GHSERTI#; 6.00000E+03 N !\n FUNCTION GHSERV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 2.18300E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 6.00000E+03 N !\n FUNCTION GHSERZR 1.30000E+02 -7827.595+125.64905*T-24.1618*T*LN(T)\n -.00437791*T**2+34971*T**(-1); 2.12800E+03 Y\n -26085.921+262.724183*T-42.144*T*LN(T)-1.342895E+31*T**(-9); \n 6.00000E+03 N !\n FUNCTION GHSERTI 2.98150E+02 -8059.921+133.615208*T-23.9933*T*LN(T)\n -.004777975*T**2+1.06716E-07*T**3+72636*T**(-1); 9.00000E+02 Y\n -7811.815+132.988068*T-23.9887*T*LN(T)-.0042033*T**2-9.0876E-08*T**3\n +42680*T**(-1); 1.15500E+03 Y\n +908.837+66.976538*T-14.9466*T*LN(T)-.0081465*T**2+2.02715E-07*T**3\n -1477660*T**(-1); 1.94100E+03 Y\n -124526.786+638.806871*T-87.2182461*T*LN(T)+.008204849*T**2\n -3.04747E-07*T**3+36699805*T**(-1); 4.00000E+03 N !\n FUNCTION GHSERCE 2.98150E+02 -7160.519+84.23022*T-22.3664*T*LN(T)\n -.0067103*T**2-3.20773E-07*T**3-18117*T**(-1); 1.00000E+03 Y\n -79678.506+659.4604*T-101.32248*T*LN(T)+.026046487*T**2\n -1.9302976E-06*T**3+11531707*T**(-1); 2.00000E+03 Y\n -14198.639+190.370192*T-37.6978*T*LN(T); 4.00000E+03 N !\n FUNCTION GHSERND 2.98150E+02 -8402.93+111.10239*T-27.0858*T*LN(T)\n +5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); 9.00000E+02 Y\n -6984.083+83.662617*T-22.7536*T*LN(T)-.00420402*T**2-1.802E-06*T**3; \n 1.12800E+03 Y\n -225610.846+1673.04075*T-238.182873*T*LN(T)+.078615997*T**2\n -6.048207E-06*T**3+38810350*T**(-1); 1.80000E+03 N !\n FUNCTION GHSERLI 2.00000E+02 -10583.817+217.637482*T-38.940488*T*LN(T)\n +.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); 4.53600E+02 Y\n -559579.123+10547.8799*T-1702.88865*T*LN(T)+2.25832944*T**2\n -5.71066077E-04*T**3+33885874*T**(-1); 5.00000E+02 Y\n -9062.994+179.278285*T-31.2283718*T*LN(T)+.002633221*T**2\n -4.38058E-07*T**3-102387*T**(-1); 3.00000E+03 N !\n FUNCTION GHSERY 2.98150E+02 -7347.055+117.532124*T-23.8685*T*LN(T)\n -.003845475*T**2+1.1125E-08*T**3-16486*T**(-1); 1.50000E+03 Y\n -15802.62+229.831717*T-40.2851*T*LN(T)+.0068095*T**2-1.14182E-06*T**3; \n 1.79900E+03 Y\n -72946.216+393.885821*T-58.2078433*T*LN(T)+.002436461*T**2\n -7.2627E-08*T**3+20866567*T**(-1); 3.70000E+03 N !\n FUNCTION GHSERBB 2.98150E+02 -7735.284+107.111864*T-15.6641*T*LN(T)\n -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1.10000E+03 Y\n -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3\n +1748270*T**(-1); 2.34800E+03 Y\n -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2\n +1.34719E-07*T**3+11205883*T**(-1); 3.00000E+03 Y\n -21530.653+222.396264*T-31.4*T*LN(T); 6.00000E+03 N !\n FUNCTION GHSERCU 2.98150E+02 -7770.458+130.485235*T-24.112392*T*LN(T)\n -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y\n -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); \n 3.20000E+03 N !\n FUNCTION GBCCCU 2.98150E+02 +4017-1.255*T+GHSERCU#; 6.00000E+03 N !\n FUNCTION GBCCAL 2.98150E+02 +10083-4.813*T+GHSERAL#; 6.00000E+03 N \n !\n FUNCTION GBCCMG 2.98150E+02 +3100-2.1*T+GHSERMG#; 6.00000E+03 N !\n FUNCTION GFCCV 2.98150E+02 +7500+1.7*T+GHSERV#; 6.00000E+03 N !\n FUNCTION GFCCTI 2.98150E+02 +6000-.1*T+GHSERTI#; 6.00000E+03 N !\n FUNCTION GHCPAL 2.98150E+02 +5481-1.8*T+GHSERAL#; 6.00000E+03 N !\n FUNCTION GHCPV 2.98150E+02 +4000+2.4*T+GHSERV#; 6.00000E+03 N !\n FUNCTION GHSERTIC 2.98150E+02 -207709+307.438*T-48.0195*T*LN(T)\n -.00272*T**2+819000*T**(-1)-2.03E+09*T**(-3); 6.00000E+03 N !\n FUNCTION GHSERTIN 2.98150E+02 -357905+330.498*T-52.4587*T*LN(T)\n -9.28E-04*T**2+871000*T**(-1)-2.41E+09*T**(-3); 6.00000E+03 N !\n FUNCTION GHSERSN 1.00000E+02 -7958.517+122.765451*T-25.858*T*LN(T)\n +5.1185E-04*T**2-3.192767E-06*T**3+18440*T**(-1); 2.50000E+02 Y\n -5855.135+65.443315*T-15.961*T*LN(T)-.0188702*T**2+3.121167E-06*T**3\n -61960*T**(-1); 5.05080E+02 Y\n +2524.724+4.005269*T-8.2590486*T*LN(T)-.016814429*T**2\n +2.623131E-06*T**3-1081244*T**(-1)-1.2307E+25*T**(-9); 8.00000E+02 Y\n -8256.959+138.99688*T-28.4512*T*LN(T)-1.2307E+25*T**(-9); 3.00000E+03 \n N !\n FUNCTION GHSERZN 2.98150E+02 -7285.787+118.470069*T-23.701314*T*LN(T)\n -.001712034*T**2-1.264963E-06*T**3; 6.92680E+02 Y\n -11070.559+172.34566*T-31.38*T*LN(T)+4.70514E+26*T**(-9); 1.70000E+03 \n N !\n FUNCTION ALFEW1 2.98150E+02 +860*R#; 6.00000E+03 N !\n FUNCTION LALFEB0 2.98150E+02 -30740+7.9972*T+ALFEW1#; 6.00000E+03 N \n !\n FUNCTION CUZNL0 2.98150E+02 -51595.87+13.06392*T; 6.00000E+03 N !\n FUNCTION CUZNP1 2.98150E+02 -3085; 6.00000E+03 N !\n FUNCTION GBCCZN 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; 6.00000E+03 \n N !\n FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N !\n FUNCTION GBCCSI 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N !\n FUNCTION FESIL0 2.98150E+02 -27809+11.62*T; 6.00000E+03 N !\n FUNCTION GFCCZN 2.98150E+02 +2969.82-1.56968*T+GHSERZN#; 6.00000E+03 \n N !\n FUNCTION CUZNK4 2.98150E+02 -11552.71-1.67824*T; 6.00000E+03 N !\n FUNCTION CUZNK5 2.98150E+02 +15732.3-10.26575*T; 6.00000E+03 N !\n FUNCTION CUZNK6 2.98150E+02 +37289.2-13.05259*T; 6.00000E+03 N !\n FUNCTION GFCCMN 2.98150E+02 -3439.3+131.884*T-24.5177*T*LN(T)\n -.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N !\n FUNCTION GBCCMN 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T)\n -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y\n -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 6.00000E+03 N !\n FUNCTION GLAVTI 2.98150E+02 +5000+GHSERTI#; 6.00000E+03 N !\n FUNCTION GLAVCR 2.98150E+02 +5000+GHSERCR#; 6.00000E+03 N !\n FUNCTION LALFEB1 2.98150E+02 368.15; 6.00000E+03 N !\n FUNCTION CUZNL1 2.98150E+02 +7562.13-6.45432*T; 6.00000E+03 N !\n FUNCTION CUZNL2 2.98150E+02 +30743.74-29.91503*T; 6.00000E+03 N !\n FUNCTION CUZNP2 2.98150E+02 -CUZNP1#; 6.00000E+03 N !\n FUNCTION FESIL1 2.98150E+02 -11544; 6.00000E+03 N !\n FUNCTION FESIL2 2.98150E+02 3890; 6.00000E+03 N !\n FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :AL,B,C,CE,CR,CU,FE,LI,MG,MN,N,ND,NI,SI,SN,TI,V,Y,\n ZN,ZR : !\n\n$ changed to the expression in COST2 180826 /BoS\n PARAMETER G(LIQUID,AL;0) 2.98150E+02 GLIQAL; 6000 N REF1 !\n$ PARAMETER G(LIQUID,AL;0) 2.98150E+02 +11005.029-11.841867*T\n$ +7.934E-20*T**7+GHSERAL#; 9.33600E+02 Y\n$ +10482.382-11.253974*T+1.231E+28*T**(-9)+GHSERAL#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,B;0) 2.98150E+02 +40723.275+86.843839*T\n -15.6641*T*LN(T)-.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); \n 5.00000E+02 Y\n +41119.703+82.101722*T-14.9827763*T*LN(T)-.007095669*T**2\n +5.07347E-07*T**3+335484*T**(-1); 2.34800E+03 Y\n +28842.012+200.94731*T-31.4*T*LN(T); 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,CE;0) 2.98150E+02 +4117.865-11.423898*T\n -7.5383948*T*LN(T)-.02936407*T**2+4.827734E-06*T**3-198834*T**(-1); \n 1.00000E+03 Y\n -6730.605+183.023193*T-37.6978*T*LN(T); 4.00000E+03 N REF1 !\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,CU;0) 2.98150E+02 +5194.277+120.973331*T\n -24.112392*T*LN(T)-.00265684*T**2+1.29223E-07*T**3+52478*T**(-1)\n -5.8489E-21*T**7; 1.35777E+03 Y\n -46.545+173.881484*T-31.38*T*LN(T); 3.20000E+03 N REF1 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +12040.17-6.55843*T\n -3.67516E-21*T**7+GHSERFE#; 1.81100E+03 Y\n +14544.751-8.01055*T+GHSERFE#-2.29603E+31*T**(-9); 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,LI;0) 2.00000E+02 -7883.612+211.841861*T\n -38.940488*T*LN(T)+.035466931*T**2-1.9869816E-05*T**3+159994*T**(-1); \n 2.50000E+02 Y\n +12015.027-362.187078*T+61.6104424*T*LN(T)-.182426463*T**2\n +6.3955671E-05*T**3-559968*T**(-1); 4.53600E+02 Y\n -6057.31+172.652183*T-31.2283718*T*LN(T)+.002633221*T**2-4.38058E-07*T**3\n -102387*T**(-1); 3.00000E+03 N REF1 !\n PARAMETER G(LIQUID,MG;0) 2.98150E+02 +8202.243-8.83693*T+GHSERMG#\n -8.0176E-20*T**7; 9.23000E+02 Y\n +8690.316-9.392158*T+GHSERMG#-1.038192E+28*T**(-9); 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,MN;0) 2.98150E+02 +17859.91-12.6208*T\n -4.41929E-21*T**7+GHSERMN#; 1.51900E+03 Y\n +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,N;0) 2.98150E+02 +29950+59.02*T+GHSERNN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,ND;0) 2.98150E+02 +5350.01-86.593963*T\n +5.357301*T*LN(T)-.046955463*T**2+6.860782E-06*T**3-374380*T**(-1); \n 1.12800E+03 Y\n -16335.232+268.625903*T-48.7854*T*LN(T); 1.80000E+03 N REF1 !\n PARAMETER G(LIQUID,NI;0) 2.98150E+02 +16414.686-9.397*T\n -3.82318E-21*T**7+GHSERNI#; 1.72800E+03 Y\n +18290.88-10.537*T-1.12754E+31*T**(-9)+GHSERNI#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.4-30.0994*T\n +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y\n +49828.2-29.5591*T+4.20369E+30*T**(-9)+GHSERSI#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,SN;0) 2.98150E+02 +GLIQSN#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,TI;0) 2.98150E+02 +GLIQTI#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T\n -5.19136E-22*T**7+GHSERV#; 7.90000E+02 Y\n +20764.117-9.455552*T-5.19136E-22*T**7+GHSERV#; 2.18300E+03 Y\n +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERV#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,Y;0) 2.98150E+02 +3934.121+59.921688*T\n -14.8146562*T*LN(T)-.015623487*T**2+1.442946E-06*T**3-140695*T**(-1); \n 1.79900E+03 Y\n -13337.609+258.004539*T-43.0952*T*LN(T); 3.70000E+03 N REF1 !\n PARAMETER G(LIQUID,ZN;0) 2.98150E+02 -128.574+108.177079*T\n -23.701314*T*LN(T)-.001712034*T**2-1.264963E-06*T**3-3.58958E-19*T**7; \n 6.92680E+02 Y\n -3620.391+161.608594*T-31.38*T*LN(T); 1.70000E+03 N REF1 !\n PARAMETER G(LIQUID,ZR;0) 1.30000E+02 +18147.703-9.080762*T\n +1.6275E-22*T**7+GHSERZR#; 2.12800E+03 Y\n +17804.649-8.91153*T+1.343E+31*T**(-9)+GHSERZR#; 6.00000E+03 N REF1 !\n PARAMETER G(LIQUID,AL,B;0) 2.98150E+02 -12671.16+1.81016*T; \n 6.00000E+03 N REF44 !\n PARAMETER G(LIQUID,AL,B;1) 2.98150E+02 31988.28; 6.00000E+03 N \n REF44 !\n PARAMETER G(LIQUID,AL,B;2) 2.98150E+02 -15873.74; 6.00000E+03 N \n REF44 !\n PARAMETER G(LIQUID,AL,C;0) 2.98150E+02 +13872.76-21.59067*T; \n 6.00000E+03 N REF46 !\n PARAMETER G(LIQUID,AL,CE;0) 2.98150E+02 -167593.1+84.87628*T; \n 6.00000E+03 N REF103 !\n PARAMETER G(LIQUID,AL,CE;1) 2.98150E+02 -36060+5.89346*T; 6.00000E+03 \n N REF103 !\n PARAMETER G(LIQUID,AL,CR;0) 2.98150E+02 -29000; 6.00000E+03 N REF8 !\n PARAMETER G(LIQUID,AL,CR;1) 2.98150E+02 -11000; 6.00000E+03 N REF8 !\n PARAMETER G(LIQUID,AL,CU;0) 2.98150E+02 -66622+8.1*T; 6.00000E+03 N \n REF72 !\n PARAMETER G(LIQUID,AL,CU;1) 2.98150E+02 +46800-90.8*T+10*T*LN(T); \n 6.00000E+03 N REF72 !\n PARAMETER G(LIQUID,AL,CU;2) 2.98150E+02 -2812; 6.00000E+03 N REF72 !\n PARAMETER G(LIQUID,AL,CU,LI;0) 2.98150E+02 -100000; 6.00000E+03 N \n REF119 !\n PARAMETER G(LIQUID,AL,FE;0) 2.98150E+02 -91976.5+22.1314*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(LIQUID,AL,FE;1) 2.98150E+02 -5672.58+4.8728*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(LIQUID,AL,FE;2) 2.98150E+02 121.9; 6.00000E+03 N REF76 !\n PARAMETER G(LIQUID,AL,FE,MN;0) 2.98150E+02 100414; 6.00000E+03 N \n REF109 !\n PARAMETER G(LIQUID,AL,LI;0) 2.98150E+02 -41500+20.96*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(LIQUID,AL,LI;1) 2.98150E+02 +10000-5.8*T; 6.00000E+03 N \n REF105 !\n PARAMETER G(LIQUID,AL,LI;2) 2.98150E+02 +15902-9.368*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(LIQUID,AL,LI;3) 2.98150E+02 -250; 6.00000E+03 N REF105 !\n PARAMETER G(LIQUID,AL,LI,MG;0) 2.98150E+02 -20000; 6.00000E+03 N \n REF105 !\n PARAMETER G(LIQUID,AL,LI,MG;1) 2.98150E+02 -15000; 6.00000E+03 N \n REF105 !\n PARAMETER G(LIQUID,AL,LI,MG;2) 2.98150E+02 -20000; 6.00000E+03 N \n REF105 !\n PARAMETER G(LIQUID,AL,MG;0) 2.98150E+02 -12000+8.566*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(LIQUID,AL,MG;1) 2.98150E+02 +1894-3*T; 6.00000E+03 N \n REF11 !\n PARAMETER G(LIQUID,AL,MG;2) 2.98150E+02 2000; 6.00000E+03 N REF11 !\n PARAMETER G(LIQUID,AL,MG,SI;0) 2.98150E+02 +26860.37-3.35754*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(LIQUID,AL,MG,SI;1) 2.98150E+02 -21007.19+2.6259*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(LIQUID,AL,MG,SI;2) 2.98150E+02 -56273.39+7.03418*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(LIQUID,AL,MN;0) 2.98150E+02 -66174+27.0988*T; 6.00000E+03 \n N REF23 !\n PARAMETER G(LIQUID,AL,MN;1) 2.98150E+02 -7509+5.4836*T; 6.00000E+03 \n N REF23 !\n PARAMETER G(LIQUID,AL,MN;2) 2.98150E+02 -2639; 6.00000E+03 N REF23 !\n PARAMETER G(LIQUID,AL,MN,SI;0) 2.98150E+02 -47000; 6.00000E+03 N \n REF115 !\n PARAMETER G(LIQUID,AL,N;0) 2.98150E+02 -336826.61+103.22478*T; \n 6.00000E+03 N REF48 !\n PARAMETER G(LIQUID,AL,ND;0) 2.98150E+02 -152967.6+34.13746*T; \n 6.00000E+03 N REF80 !\n PARAMETER G(LIQUID,AL,ND;1) 2.98150E+02 -29325-3.34477*T; 6.00000E+03 \n N REF80 !\n PARAMETER G(LIQUID,AL,SI;0) 2.98150E+02 -11655.93-.92934*T; \n 6.00000E+03 N REF50 !\n PARAMETER G(LIQUID,AL,SI;1) 2.98150E+02 -2873.45+.2945*T; 6.00000E+03 \n N REF50 !\n PARAMETER G(LIQUID,AL,SI;2) 2.98150E+02 2520; 6.00000E+03 N REF50 !\n PARAMETER G(LIQUID,AL,SN;0) 2.98150E+02 +16329.85-4.98306*T; \n 6.00000E+03 N REF15 !\n PARAMETER G(LIQUID,AL,SN;1) 2.98150E+02 +4111.97-1.15145*T; \n 6.00000E+03 N REF15 !\n PARAMETER G(LIQUID,AL,SN;2) 2.98150E+02 +1765.43-.5739*T; 6.00000E+03 \n N REF15 !\n PARAMETER G(LIQUID,AL,SN,ZN;0) 2.98150E+02 -2777.03+.59427*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,AL,SN,ZN;1) 2.98150E+02 +15225.63-3.25821*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,AL,SN,ZN;2) 2.98150E+02 -16198.13+3.46632*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,AL,TI;0) 2.98150E+02 -108250+38*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(LIQUID,AL,TI;1) 2.98150E+02 -6000+5*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(LIQUID,AL,TI;2) 2.98150E+02 15000; 6.00000E+03 N REF13 !\n PARAMETER G(LIQUID,AL,TI,V;0) 2.98150E+02 1E-05; 6.00000E+03 N \n REF127 !\n PARAMETER G(LIQUID,AL,V;0) 2.98150E+02 -50725+9*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(LIQUID,AL,V;1) 2.98150E+02 -15000+8*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(LIQUID,AL,Y;0) 2.98150E+02 -202611.28+4.63942*T; \n 2.90000E+03 N REF52 !\n PARAMETER G(LIQUID,AL,Y;1) 2.98150E+02 -54350.11+.28402*T; 2.90000E+03 \n N REF52 !\n PARAMETER G(LIQUID,AL,Y;2) 2.98150E+02 +83347.01-34.76401*T; \n 2.90000E+03 N REF52 !\n PARAMETER G(LIQUID,AL,Y;3) 2.98150E+02 +15488.69-.7988*T; 2.90000E+03 \n N REF52 !\n PARAMETER G(LIQUID,AL,Y;4) 2.98150E+02 -51205.9+30.2161*T; 2.90000E+03 \n N REF52 !\n PARAMETER G(LIQUID,AL,ZN;0) 2.98150E+02 +10465.55-3.39259*T; \n 6.00000E+03 N REF78 !\n PARAMETER G(LIQUID,AL,ZR;0) 2.98150E+02 -125000+35*T; 6.00000E+03 N \n REF74 !\n PARAMETER G(LIQUID,AL,ZR;1) 2.98150E+02 -10000+5.57*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(LIQUID,AL,ZR;2) 2.98150E+02 15750; 6.00000E+03 N REF74 !\n PARAMETER G(LIQUID,B,C;0) 2.98150E+02 -67045.16+4.46969*T; \n 6.00000E+03 N REF54 !\n PARAMETER G(LIQUID,B,C;1) 2.98150E+02 -36682.57+2.44551*T; \n 6.00000E+03 N REF54 !\n PARAMETER G(LIQUID,B,N;0) 2.98150E+02 +30000-4*T; 6.00000E+03 N \n REF56 !\n PARAMETER G(LIQUID,B,SI;0) 2.98150E+02 +17631.92-1.76321*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(LIQUID,B,SI;1) 2.98150E+02 -3526.99+.3527*T; 6.00000E+03 \n N REF58 !\n PARAMETER G(LIQUID,B,TI;0) 2.98150E+02 -265414.4+15.543418*T; \n 6.00000E+03 N REF89 !\n PARAMETER G(LIQUID,B,TI;1) 2.98150E+02 -134303.03+17.709482*T; \n 6.00000E+03 N REF89 !\n PARAMETER G(LIQUID,B,TI;2) 2.98150E+02 61691.479; 6.00000E+03 N \n REF89 !\n PARAMETER G(LIQUID,B,TI;3) 2.98150E+02 52656.13; 6.00000E+03 N \n REF89 !\n PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 +25644.97-6.39115*T; \n 6.00000E+03 N REF60 !\n PARAMETER G(LIQUID,C,TI;0) 2.98150E+02 -214678-14.314*T; 6.00000E+03 \n N REF111 !\n PARAMETER G(LIQUID,CE,MG;0) 2.98150E+02 -39381.19+16.34052*T; \n 6.00000E+03 N REF103 !\n PARAMETER G(LIQUID,CE,MG;1) 2.98150E+02 +25338.56-11.86885*T; \n 6.00000E+03 N REF103 !\n PARAMETER G(LIQUID,CE,MG;2) 2.98150E+02 -15106.9; 6.00000E+03 N \n REF103 !\n PARAMETER G(LIQUID,CR,CU;0) 2.98150E+02 +62797.75-18.95186*T; \n 6.00000E+03 N REF96 !\n PARAMETER G(LIQUID,CR,CU;1) 2.98150E+02 1183.91; 6.00000E+03 N \n REF96 !\n PARAMETER G(LIQUID,CR,MG;0) 2.98150E+02 94500; 6.00000E+03 N REF83 !\n PARAMETER G(LIQUID,CR,MG;1) 2.98150E+02 12500; 6.00000E+03 N REF83 !\n PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 \n N REF2 !\n PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N \n REF2 !\n PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -119216.9+16.11445*T; \n 6.00000E+03 N REF91 !\n PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -47614.7+12.17363*T; \n 6.00000E+03 N REF91 !\n PARAMETER G(LIQUID,CR,TI;0) 2.98150E+02 5250; 6.00000E+03 N REF72 !\n PARAMETER G(LIQUID,CR,TI;1) 2.98150E+02 1500; 6.00000E+03 N REF72 !\n PARAMETER G(LIQUID,CR,ZN;0) 2.98150E+02 19000; 6.00000E+03 N REF83 !\n PARAMETER G(LIQUID,CR,ZN;1) 2.98150E+02 -1000; 6.00000E+03 N REF83 !\n PARAMETER G(LIQUID,CR,ZR;0) 2.98150E+02 -12971.34+1.20015*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(LIQUID,CR,ZR;1) 2.98150E+02 +8025.96-.74259*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(LIQUID,CR,ZR;2) 2.98150E+02 -9984.87+.92383*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(LIQUID,CU,FE;0) 2.98150E+02 +36087.987-2.3296885*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(LIQUID,CU,FE;1) 2.98150E+02 +324.52964-.032700618*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(LIQUID,CU,FE;2) 2.98150E+02 +10355.386-3.6029763*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(LIQUID,CU,LI;0) 2.98150E+02 +66000-44.723*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(LIQUID,CU,MG;0) 2.98150E+02 -36984+4.75612*T; 6.00000E+03 \n N REF20 !\n PARAMETER G(LIQUID,CU,MG;1) 2.98150E+02 -8191.29; 6.00000E+03 N \n REF20 !\n PARAMETER G(LIQUID,CU,MG,NI;0) 2.98150E+02 +163785-122.28*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,CU,NI;0) 2.98150E+02 +12048.61+1.29893*T; \n 6.00000E+03 N REF31 !\n PARAMETER G(LIQUID,CU,NI;1) 2.98150E+02 -1861.61+.94201*T; \n 6.00000E+03 N REF31 !\n PARAMETER G(LIQUID,CU,SI;0) 2.98150E+02 -39688.86+14.27467*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,CU,SI;1) 2.98150E+02 -49937.13+29.7896*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,CU,SI;2) 2.98150E+02 -31810.16+18.00804*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,CU,ZN;0) 2.98150E+02 -40695.54+12.65269*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(LIQUID,CU,ZN;1) 2.98150E+02 +4402.72-6.55425*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(LIQUID,CU,ZN;2) 2.98150E+02 +7818.1-3.25416*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(LIQUID,CU,ZR;0) 2.98150E+02 -61685.53+11.29235*T; \n 6.00000E+03 N REF125 !\n PARAMETER G(LIQUID,CU,ZR;1) 2.98150E+02 -8830.66+5.04565*T; \n 6.00000E+03 N REF125 !\n PARAMETER G(LIQUID,FE,MG;0) 2.98150E+02 +61343+1.5*T; 6.00000E+03 N \n REF29 !\n PARAMETER G(LIQUID,FE,MG;1) 2.98150E+02 -2700; 6.00000E+03 N REF29 !\n PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N \n REF6 !\n PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF6 !\n PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164434.6+41.9773*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N \n REF26 !\n PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821.542+22.07*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9695.8; 6.00000E+03 N REF26 !\n PARAMETER G(LIQUID,LI,MG;0) 2.98150E+02 -14935+10.371*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(LIQUID,LI,MG;1) 2.98150E+02 -1789+1.143*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(LIQUID,LI,MG;2) 2.98150E+02 +6533-6.6915*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(LIQUID,LI,ZR;0) 2.98150E+02 100000; 6.00000E+03 N REF74 !\n PARAMETER G(LIQUID,MG,MN;0) 2.98150E+02 +19125+12.5*T; 6.00000E+03 \n N REF29 !\n PARAMETER G(LIQUID,MG,NI;0) 2.98150E+02 -42304.49+7.45704*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,MG,NI;1) 2.98150E+02 -15611.66+9.11885*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(LIQUID,MG,SI;0) 2.98150E+02 -82462.11+32.43049*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(LIQUID,MG,SI;1) 2.98150E+02 +16617.63-17.7922*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(LIQUID,MG,SI;2) 2.98150E+02 +2331.67-.29146*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(LIQUID,MG,SI;3) 2.98150E+02 +17833.02-2.22914*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(LIQUID,MG,SI;4) 2.98150E+02 -11203.22+1.40041*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(LIQUID,MG,Y;0) 2.98150E+02 -25802.51+4.30042*T; \n 6.00000E+03 N REF64 !\n PARAMETER G(LIQUID,MG,Y;1) 2.98150E+02 -19229.76+3.20497*T; \n 6.00000E+03 N REF64 !\n PARAMETER G(LIQUID,MG,ZN;0) 2.98150E+02 -81439.68+518.25145*T\n -64.714411*T*LN(T); 6.00000E+03 N REF33 !\n PARAMETER G(LIQUID,MG,ZN;1) 2.98150E+02 +2627.54+2.93061*T; \n 6.00000E+03 N REF33 !\n PARAMETER G(LIQUID,MG,ZN;2) 2.98150E+02 -1673.28; 6.00000E+03 N \n REF33 !\n PARAMETER G(LIQUID,MG,ZR;0) 2.98150E+02 +14003.84+29.34205*T; \n 6.00000E+03 N REF68 !\n PARAMETER G(LIQUID,MN,SI;0) 2.98150E+02 -139817+29.86137*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(LIQUID,MN,SI;1) 2.98150E+02 -34917.2+3.20488*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(LIQUID,MN,SI;2) 2.98150E+02 +46782.4-18.18969*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(LIQUID,MN,SI;3) 2.98150E+02 16168.2; 6.00000E+03 N \n REF29 !\n PARAMETER G(LIQUID,MN,TI;0) 2.98150E+02 -34000+21.5*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(LIQUID,MN,TI;1) 2.98150E+02 1400; 6.00000E+03 N REF72 !\n PARAMETER G(LIQUID,N,TI;0) 2.98150E+02 -376736; 6.00000E+03 N \n REF111 !\n PARAMETER G(LIQUID,N,TI;1) 2.98150E+02 -102480; 6.00000E+03 N \n REF111 !\n PARAMETER G(LIQUID,SI,SN;0) 2.98150E+02 25364.6; 3.00000E+03 N REF94 !\n PARAMETER G(LIQUID,SI,SN;1) 2.98150E+02 3148.8; 3.00000E+03 N REF94 !\n PARAMETER G(LIQUID,SI,SN;2) 2.98150E+02 4460.9; 3.00000E+03 N REF94 !\n PARAMETER G(LIQUID,SI,TI;0) 2.98150E+02 -255852.17+21.87411*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,SI,TI;1) 2.98150E+02 +25025.35-2.00203*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,SI,TI;2) 2.98150E+02 +83940.65-6.71526*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,SI,V;0) 2.98150E+02 -180900+40*T; 6.00000E+03 N \n REF117 !\n PARAMETER G(LIQUID,SI,V;1) 2.98150E+02 37000; 6.00000E+03 N REF117 !\n PARAMETER G(LIQUID,SI,V;2) 2.98150E+02 20000; 6.00000E+03 N REF117 !\n PARAMETER G(LIQUID,SI,Y;0) 2.98150E+02 -212656.12+25.83471*T; \n 6.00000E+03 N REF66 !\n PARAMETER G(LIQUID,SI,Y;1) 2.98150E+02 +13977.08-31.08941*T; \n 6.00000E+03 N REF66 !\n PARAMETER G(LIQUID,SI,Y;2) 2.98150E+02 +62049.23-50.31476*T; \n 6.00000E+03 N REF66 !\n PARAMETER G(LIQUID,SI,ZN;0) 2.98150E+02 7829.25; 6.00000E+03 N \n REF94 !\n PARAMETER G(LIQUID,SI,ZN;1) 2.98150E+02 -3338.18; 6.00000E+03 N \n REF94 !\n PARAMETER G(LIQUID,SI,ZN;2) 2.98150E+02 -891.33; 6.00000E+03 N \n REF94 !\n PARAMETER G(LIQUID,SI,ZR;0) 2.98150E+02 -190000+16.895515*T; \n 6.00000E+03 N REF100 !\n PARAMETER G(LIQUID,SI,ZR;1) 2.98150E+02 +14.525747*T; 6.00000E+03 N \n REF100 !\n PARAMETER G(LIQUID,SN,TI;0) 2.98150E+02 -90206.13-5.55089*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(LIQUID,SN,TI;1) 2.98150E+02 +44395.59-6.09746*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(LIQUID,SN,ZN;0) 2.98150E+02 +19314.64-75.89939*T\n +8.751396*T*LN(T); 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,SN,ZN;1) 2.98150E+02 -5696.28+4.20198*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,SN,ZN;2) 2.98150E+02 +1037.22+.98362*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(LIQUID,TI,V;0) 2.98150E+02 1400; 6.00000E+03 N REF13 !\n PARAMETER G(LIQUID,TI,V;1) 2.98150E+02 4100; 6.00000E+03 N REF13 !\n\n\n PHASE AL10V % 2 10 1 !\n CONSTITUENT AL10V :AL : V : !\n\n PARAMETER G(AL10V,AL:V;0) 2.98150E+02 -111221+18.909*T+10*GHSERAL#\n +GHSERV#; 6.00000E+03 N REF13 !\n\n\n PHASE AL11CR2 % 3 10 1 2 !\n CONSTITUENT AL11CR2 :AL : AL : CR : !\n\n PARAMETER G(AL11CR2,AL:AL:CR;0) 2.98150E+02 -175500+25.805*T\n +11*GHSERAL#+2*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE AL11MN4 % 2 11 4 !\n CONSTITUENT AL11MN4 :AL : FE,MN : !\n\n PARAMETER G(AL11MN4,AL:FE;0) 2.98150E+02 -354702+103.031*T+11*GHSERAL#\n +4*GHSERMN#; 6.00000E+03 N REF76 !\n PARAMETER G(AL11MN4,AL:MN;0) 2.98150E+02 -354702+103.031*T+11*GHSERAL#\n +4*GHSERMN#; 6.00000E+03 N REF23 !\n\n\n PHASE AL11TI5 % 2 17 8 !\n CONSTITUENT AL11TI5 :AL : TI : !\n\n PARAMETER G(AL11TI5,AL:TI;0) 2.98150E+02 -971125+236.4*T+17*GHSERAL#\n +8*GHSERTI#; 6.00000E+03 N REF13 !\n\n\n PHASE AL11_CEND3 % 2 11 3 !\n CONSTITUENT AL11_CEND3 :AL : CE,ND : !\n\n PARAMETER G(AL11_CEND3,AL:CE;0) 2.98150E+02 -574000+179.3087*T\n +11*GHSERAL#+3*GHSERCE#; 6.00000E+03 N REF103 !\n PARAMETER G(AL11_CEND3,AL:ND;0) 2.98150E+02 -574000+78.4*T+11*GHSERAL#\n +3*GHSERND#; 6.00000E+03 N REF80 !\n\n\n PHASE AL12MG17 % 3 24 10 24 !\n CONSTITUENT AL12MG17 :LI,MG : AL,LI,MG : AL,MG : !\n\n PARAMETER G(AL12MG17,LI:AL:AL;0) 2.98150E+02 -800000+405*T+34*GHSERAL#\n +24*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:AL:AL;0) 2.98150E+02 -36800-140*T+34*GHSERAL#\n +24*GHSERMG#; 6.00000E+03 N REF11 !\n PARAMETER G(AL12MG17,LI:LI:AL;0) 2.98150E+02 -750000+405*T+24*GHSERAL#\n +34*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:LI:AL;0) 2.98150E+02 -610000+125*T+24*GHSERMG#\n +10*GHSERLI#+24*GHSERAL#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,LI:MG:AL;0) 2.98150E+02 -625000+269*T+10*GHSERMG#\n +24*GHSERLI#+24*GHSERAL#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:MG:AL;0) 2.98150E+02 -123200-56.26*T\n +24*GHSERAL#+34*GHSERMG#; 6.00000E+03 N REF11 !\n PARAMETER G(AL12MG17,LI:AL:MG;0) 2.98150E+02 +24*GHSERMG#+10*GHSERLI#\n +24*GHSERAL#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:AL:MG;0) 2.98150E+02 +151000+10*GHSERAL#\n +48*GHSERMG#; 6.00000E+03 N REF11 !\n PARAMETER G(AL12MG17,LI:LI:MG;0) 2.98150E+02 +290000+34*GHSERLI#\n +24*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:LI:MG;0) 2.98150E+02 +290000+10*GHSERLI#\n +48*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,LI:MG:MG;0) 2.98150E+02 +290000+24*GHSERLI#\n +34*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(AL12MG17,MG:MG:MG;0) 2.98150E+02 +290000+58*GHSERMG#; \n 6.00000E+03 N REF11 !\n PARAMETER G(AL12MG17,LI,MG:AL:AL;0) 2.98150E+02 -220000; 6.00000E+03 \n N REF105 !\n PARAMETER G(AL12MG17,MG:AL,LI:AL;0) 2.98150E+02 -50000; 6.00000E+03 \n N REF105 !\n PARAMETER G(AL12MG17,MG:AL,MG:AL;0) 2.98150E+02 -17000; 6.00000E+03 \n N REF11 !\n PARAMETER G(AL12MG17,MG:AL,MG:MG;0) 2.98150E+02 -17000; 6.00000E+03 \n N REF11 !\n\n\n PHASE AL12MN % 2 12 1 !\n CONSTITUENT AL12MN :AL : FE,MN : !\n\n PARAMETER G(AL12MN,AL:FE;0) 2.98150E+02 -105818+33.5848*T+12*GHSERAL#\n +GHSERMN#; 6.00000E+03 N REF76 !\n PARAMETER G(AL12MN,AL:MN;0) 2.98150E+02 -105818+33.5848*T+12*GHSERAL#\n +GHSERMN#; 6.00000E+03 N REF23 !\n\n\n PHASE AL13CR2 % 2 13 2 !\n CONSTITUENT AL13CR2 :AL : CR : !\n\n PARAMETER G(AL13CR2,AL:CR;0) 2.98150E+02 -174405+22.2*T+13*GHSERAL#\n +2*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE AL13FE4 % 3 .6275 .235 .1375 !\n CONSTITUENT AL13FE4 :AL : FE,MN : AL,SI,VA : !\n\n PARAMETER G(AL13FE4,AL:FE:AL;0) 2.98150E+02 -30714.4+7.44*T\n +.765*GHSERAL#+.235*GHSERFE#; 6.00000E+03 N REF76 !\n PARAMETER G(AL13FE4,AL:MN:AL;0) 2.98150E+02 -20000+10*T+.765*GHSERAL#\n +.235*GHSERMN#; 6.00000E+03 N REF23 !\n PARAMETER G(AL13FE4,AL:FE:SI;0) 2.98150E+02 -22013.336+.6275*GHSERAL#\n +.235*GHSERFE#+.1375*GHSERSI#; 6.00000E+03 N REF121 !\n PARAMETER G(AL13FE4,AL:MN:SI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(AL13FE4,AL:FE:VA;0) 2.98150E+02 -27781.3+7.2566*T\n +.6275*GHSERAL#+.235*GHSERFE#; 6.00000E+03 N REF76 !\n PARAMETER G(AL13FE4,AL:MN:VA;0) 2.98150E+02 -17000+10*T+.6275*GHSERAL#\n +.235*GHSERMN#; 6.00000E+03 N REF23 !\n\n\n PHASE AL23V4 % 2 23 4 !\n CONSTITUENT AL23V4 :AL : V : !\n\n PARAMETER G(AL23V4,AL:V;0) 2.98150E+02 -430650+64.665*T+23*GHSERAL#\n +4*GHSERV#; 6.00000E+03 N REF13 !\n\n\n PHASE AL2FE % 2 2 1 !\n CONSTITUENT AL2FE :AL : FE,MN : !\n\n PARAMETER G(AL2FE,AL:FE;0) 2.98150E+02 -98096.9+18.7503*T+2*GHSERAL#\n +GHSERFE#; 6.00000E+03 N REF76 !\n PARAMETER G(AL2FE,AL:MN;0) 2.98150E+02 -14064+2*GHSERAL#+GHSERMN#; \n 6.00000E+03 N REF23 !\n\n\n PHASE AL2LI3 % 2 2 3 !\n CONSTITUENT AL2LI3 :AL : LI : !\n\n PARAMETER G(AL2LI3,AL:LI;0) 2.98150E+02 -89640+32.79*T+2*GHSERAL#\n +3*GHSERLI#; 6.00000E+03 N REF105 !\n\n\n PHASE AL2TI % 2 2 1 !\n CONSTITUENT AL2TI :AL : TI : !\n\n PARAMETER G(AL2TI,AL:TI;0) 2.98150E+02 -121500+31.2*T+2*GHSERAL#\n +GHSERTI#; 6.00000E+03 N REF13 !\n\n\n PHASE AL2Y1 % 2 2 1 !\n CONSTITUENT AL2Y1 :AL : Y : !\n\n PARAMETER G(AL2Y1,AL:Y;0) 2.98150E+02 -246018+35.32809*T+2*GHSERAL#\n +GHSERY#; 2.90000E+03 N REF52 !\n\n\n PHASE AL2Y3 % 2 2 3 !\n CONSTITUENT AL2Y3 :AL : Y : !\n\n PARAMETER G(AL2Y3,AL:Y;0) 2.98150E+02 -373605+84.4101*T+2*GHSERAL#\n +3*GHSERY#; 2.90000E+03 N REF52 !\n\n\n PHASE AL2ZR1 % 2 2 1 !\n CONSTITUENT AL2ZR1 :AL : LI,ZR : !\n\n PARAMETER G(AL2ZR1,AL:LI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(AL2ZR1,AL:ZR;0) 2.98150E+02 -137430+25.44*T+2*GHSERAL#\n +GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL2ZR3 % 2 2 3 !\n CONSTITUENT AL2ZR3 :AL : ZR : !\n\n PARAMETER G(AL2ZR3,AL:ZR;0) 2.98150E+02 -192135+33*T+2*GHSERAL#\n +3*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL3M_DO22 % 2 3 1 !\n CONSTITUENT AL3M_DO22 :AL : TI,V : !\n\n PARAMETER G(AL3M_DO22,AL:TI;0) 2.98150E+02 -144592+37.024*T+3*GHSERAL#\n +GHSERTI#; 6.00000E+03 N REF13 !\n PARAMETER G(AL3M_DO22,AL:V;0) 2.98150E+02 -104308+15.2*T+3*GHSERAL#\n +GHSERV#; 6.00000E+03 N REF13 !\n\n\n PHASE AL3Y1 % 2 3 1 !\n CONSTITUENT AL3Y1 :AL : Y : !\n\n PARAMETER G(AL3Y1,AL:Y;0) 2.98150E+02 -267460+46.48084*T+3*GHSERAL#\n +GHSERY#; 2.90000E+03 N REF52 !\n\n\n PHASE AL3Y5 % 2 3 5 !\n CONSTITUENT AL3Y5 :AL : Y : !\n\n PARAMETER G(AL3Y5,AL:Y;0) 2.98150E+02 -564479.2+127.7201*T+3*GHSERAL#\n +5*GHSERY#; 2.90000E+03 N REF52 !\n\n\n PHASE AL3ZR1 % 2 3 1 !\n CONSTITUENT AL3ZR1 :AL : LI,ZR : !\n\n PARAMETER G(AL3ZR1,AL:LI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(AL3ZR1,AL:ZR;0) 2.98150E+02 -162500+28.92*T+3*GHSERAL#\n +GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL3ZR2 % 2 3 2 !\n CONSTITUENT AL3ZR2 :AL : ZR : !\n\n PARAMETER G(AL3ZR2,AL:ZR;0) 2.98150E+02 -234700+44.1*T+3*GHSERAL#\n +2*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL3ZR5 % 2 3 5 !\n CONSTITUENT AL3ZR5 :AL : ZR : !\n\n PARAMETER G(AL3ZR5,AL:ZR;0) 2.98150E+02 -289984+48.72*T+3*GHSERAL#\n +5*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL3_CEND % 2 3 1 !\n CONSTITUENT AL3_CEND :AL : CE,ND : !\n\n PARAMETER G(AL3_CEND,AL:CE;0) 2.98150E+02 -176000+54.97964*T+3*GHSERAL#\n +GHSERCE#; 6.00000E+03 N REF103 !\n PARAMETER G(AL3_CEND,AL:ND;0) 2.98150E+02 -184000+28.16*T+3*GHSERAL#\n +GHSERND#; 6.00000E+03 N REF80 !\n\n\n PHASE AL4C3 % 2 4 3 !\n CONSTITUENT AL4C3 :AL : C : !\n\n PARAMETER G(AL4C3,AL:C;0) 2.98150E+02 -224361+54.722*T+4*GHSERAL#\n +3*GHSERCC#; 6.00000E+03 N REF46 !\n\n\n PHASE AL4CR % 2 4 1 !\n CONSTITUENT AL4CR :AL : CR : !\n\n PARAMETER G(AL4CR,AL:CR;0) 2.98150E+02 -89025+19.05*T+4*GHSERAL#\n +GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE AL4LI9 % 2 4 9 !\n CONSTITUENT AL4LI9 :AL : LI : !\n\n PARAMETER G(AL4LI9,AL:LI;0) 2.98150E+02 -185250+67.8*T+4*GHSERAL#\n +9*GHSERLI#; 6.00000E+03 N REF105 !\n\n\n PHASE AL4MN % 2 4 1 !\n CONSTITUENT AL4MN :AL : MN,FE : !\n PARAM G(AL4MN,AL:FE;0) 298.15 -131445+50.0*T+4*GHSERAL\n +GHSERFE; 6000.00 N 93AKE !\n PARAM G(AL4MN,AL:MN;0) 298.15 -100005+30*T+4*GHSERAL\n +GHSERMN; 6000.00 N 93AKE!\n PARAM L(AL4MN,AL:FE,MN;0) 298.15 -10000; 6000.00 N 93AKE !\n\n$ replaced by data from cost2.TDB 180825/BoS\n$ PARAMETER G(AL4MN,AL:MN;0) 2.98150E+02 -105661+34.761*T+4*GHSERAL#\n$ +GHSERMN#; 6.00000E+03 N REF23 !\n\n\n PHASE AL4ZR5 % 2 4 5 !\n CONSTITUENT AL4ZR5 :AL : ZR : !\n\n PARAMETER G(AL4ZR5,AL:ZR;0) 2.98150E+02 -369000+62.55*T+4*GHSERAL#\n +5*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL5FE2 % 2 5 2 !\n CONSTITUENT AL5FE2 :AL : FE,MN : !\n\n PARAMETER G(AL5FE2,AL:FE;0) 2.98150E+02 -228576+48.99503*T+5*GHSERAL#\n +2*GHSERFE#; 6.00000E+03 N REF76 !\n PARAMETER G(AL5FE2,AL:MN;0) 2.98150E+02 +5*GHSERAL#+2*GHSERMN#; \n 6.00000E+03 N REF23 !\n\n\n PHASE AL5FE4 % 1 1.0 !\n CONSTITUENT AL5FE4 :AL,FE,MN : !\n\n PARAMETER G(AL5FE4,AL;0) 2.98150E+02 +12178.9-4.813*T+GHSERAL#; \n 6.00000E+03 N REF76 !\n PARAMETER G(AL5FE4,FE;0) 2.98150E+02 +5009.03+GHSERFE#; 6.00000E+03 \n N REF76 !\n PARAMETER G(AL5FE4,MN;0) 2.98150E+02 -4440+133.007*T-24.5177*T*LN(T)\n -.006*T**2+69600*T**(-1); 6.00000E+03 N REF23 !\n PARAMETER G(AL5FE4,AL,FE;0) 2.98150E+02 -131649+29.4833*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(AL5FE4,AL,FE;1) 2.98150E+02 -18619.5; 6.00000E+03 N \n REF76 !\n\n\n PHASE AL6MN % 2 6 1 !\n CONSTITUENT AL6MN :AL : FE,MN : !\n\n PARAM G(AL6MN,AL:FE;0) 298.15 -130984+38.5*T\n +6.0*GHSERAL+GHSERFE; 6000.00 N 93AKE!\n PARAM G(AL6MN,AL:MN;0) 298.15 -124564.3+53.65930*T+6*GHSERAL\n +GHSERMN; 6000.00 N 93AKE !\n PARAM L(AL6MN,AL:FE,MN;0) 298.15 -32753+21*T; 6000.00 N 93AKE !\n\t\t\t\t \n$ replaced by data in cost2.TDB 180825 /BoS\n$ PARAMETER G(AL6MN,AL:FE;0) 2.98150E+02 -128100+35*T+6*GHSERAL#+GHSERFE#;\n$ 6.00000E+03 N REF76 !\n$ PARAMETER G(AL6MN,AL:MN;0) 2.98150E+02 -105013+32.6593*T+6*GHSERAL#\n$ +GHSERMN#; 6.00000E+03 N REF23 !\n$ PARAMETER G(AL6MN,AL:FE,MN;0) 2.98150E+02 -197015+200.55*T; \n$ 6.00000E+03 N REF109 !\n\n\n PHASE AL7V % 2 7 1 !\n CONSTITUENT AL7V :AL : V : !\n\n PARAMETER G(AL7V,AL:V;0) 2.98150E+02 -108800+16.8*T+7*GHSERAL#+GHSERV#; \n 6.00000E+03 N REF13 !\n\n\n PHASE AL8CR5_H % 2 8 5 !\n CONSTITUENT AL8CR5_H :AL : CR : !\n\n PARAMETER G(AL8CR5_H,AL:CR;0) 2.98150E+02 -147732-58.5*T+8*GHSERAL#\n +5*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE AL8CR5_L % 2 8 5 !\n CONSTITUENT AL8CR5_L :AL : CR : !\n\n PARAMETER G(AL8CR5_L,AL:CR;0) 2.98150E+02 -229515+8*GHSERAL#+5*GHSERCR#;\n 6.00000E+03 N REF8 !\n\n\n PHASE AL8MN5_D810 % 3 12 4 10 !\n CONSTITUENT AL8MN5_D810 :AL,SI : MN : AL,FE,MN : !\n\n PARAMETER G(AL8MN5_D810,AL:MN:AL;0) 2.98150E+02 -308671+56.6497*T\n +22*GHSERAL#+4*GHSERMN#; 6.00000E+03 N REF23 !\n PARAMETER G(AL8MN5_D810,SI:MN:AL;0) 2.98150E+02 +10*GHSERAL#+4*GHSERMN#\n +12*GHSERSI#; 6.00000E+03 N REF115 !\n PARAMETER G(AL8MN5_D810,AL:MN:FE;0) 2.98150E+02 -632554+12*GHSERAL#\n +4*GHSERMN#+10*GHSERFE#; 6.00000E+03 N REF109 !\n PARAMETER G(AL8MN5_D810,SI:MN:FE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(AL8MN5_D810,AL:MN:MN;0) 2.98150E+02 -596867+94.612*T\n +12*GHSERAL#+14*GHSERMN#; 6.00000E+03 N REF23 !\n PARAMETER G(AL8MN5_D810,SI:MN:MN;0) 2.98150E+02 +14*GHSERMN#\n +12*GHSERSI#; 6.00000E+03 N REF29 !\n PARAMETER G(AL8MN5_D810,AL:MN:AL,FE;0) 2.98150E+02 -457834; \n 6.00000E+03 N REF109 !\n PARAMETER G(AL8MN5_D810,AL:MN:AL,MN;0) 2.98150E+02 -546255+387.348*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(AL8MN5_D810,AL:MN:FE,MN;0) 2.98150E+02 -11169.6; \n 6.00000E+03 N REF109 !\n\n\n PHASE AL8V5 % 2 8 5 !\n CONSTITUENT AL8V5 :AL : V : !\n\n PARAMETER G(AL8V5,AL:V;0) 2.98150E+02 -294320-13*T+8*GHSERAL#+5*GHSERV#;\n 6.00000E+03 N REF13 !\n\n\n PHASE AL9CR4_H % 2 9 4 !\n CONSTITUENT AL9CR4_H :AL : CR : !\n\n PARAMETER G(AL9CR4_H,AL:CR;0) 2.98150E+02 -134433-56.16*T+9*GHSERAL#\n +4*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE AL9CR4_L % 2 9 4 !\n CONSTITUENT AL9CR4_L :AL : CR : !\n\n PARAMETER G(AL9CR4_L,AL:CR;0) 2.98150E+02 -230750+16.094*T+9*GHSERAL#\n +4*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE ALB12_ALPHA % 2 1 12 !\n CONSTITUENT ALB12_ALPHA :AL : B : !\n\n PARAMETER G(ALB12_ALPHA,AL:B;0) 2.98150E+02 -198290.69+33.68638*T\n +GHSERAL#+12*GHSERBB#; 6.00000E+03 N REF44 !\n\n\n PHASE ALB12_BETA % 2 1 12 !\n CONSTITUENT ALB12_BETA :AL : B : !\n\n PARAMETER G(ALB12_BETA,AL:B;0) 2.98150E+02 -75292.23-33.66376*T\n +GHSERAL#+12*GHSERBB#; 6.00000E+03 N REF44 !\n\n\n PHASE ALB2 % 2 1 2 !\n CONSTITUENT ALB2 :AL : B : !\n\n PARAMETER G(ALB2,AL:B;0) 2.98150E+02 -85808.76+45.46923*T+GHSERAL#\n +2*GHSERBB#; 6.00000E+03 N REF44 !\n\n\n PHASE ALCR2 % 2 1 2 !\n CONSTITUENT ALCR2 :AL : CR : !\n\n PARAMETER G(ALCR2,AL:CR;0) 2.98150E+02 -32700-8.79*T+GHSERAL#\n +2*GHSERCR#; 6.00000E+03 N REF8 !\n\n\n PHASE ALCULI_R % 3 .55 .117 .333 !\n CONSTITUENT ALCULI_R :AL : CU : LI : !\n\n PARAMETER G(ALCULI_R,AL:CU:LI;0) 2.98150E+02 -20983+6*T+.55*GHSERAL#\n +.117*GHSERCU#+.333*GHSERLI#; 6.00000E+03 N REF119 !\n\n\n PHASE ALCULI_T1 % 3 .5 .25 .25 !\n CONSTITUENT ALCULI_T1 :AL : CU : LI : !\n\n PARAMETER G(ALCULI_T1,AL:CU:LI;0) 2.98150E+02 -24560+6*T+.5*GHSERAL#\n +.25*GHSERCU#+.25*GHSERLI#; 6.00000E+03 N REF119 !\n\n\n PHASE ALCULI_T2 % 3 .57 .11 .32 !\n CONSTITUENT ALCULI_T2 :AL : CU : LI : !\n\n PARAMETER G(ALCULI_T2,AL:CU:LI;0) 2.98150E+02 -20000+5.497*T\n +.57*GHSERAL#+.11*GHSERCU#+.32*GHSERLI#; 6.00000E+03 N REF119 !\n\n\n PHASE ALCULI_TB % 3 .6 .32 .08 !\n CONSTITUENT ALCULI_TB :AL : CU : LI : !\n\n PARAMETER G(ALCULI_TB,AL:CU:LI;0) 2.98150E+02 -19918+4*T+.6*GHSERAL#\n +.32*GHSERCU#+.08*GHSERLI#; 6.00000E+03 N REF119 !\n\n\n PHASE ALCU_DELTA % 2 2 3 !\n CONSTITUENT ALCU_DELTA :AL : CU : !\n\n PARAMETER G(ALCU_DELTA,AL:CU;0) 2.98150E+02 -106700+3*T+2*GHSERAL#\n +3*GHSERCU#; 6.00000E+03 N REF72 !\n\n\n PHASE ALCU_EPSILON % 2 1 1 !\n CONSTITUENT ALCU_EPSILON :AL,CU : CU : !\n\n PARAMETER G(ALCU_EPSILON,AL:CU;0) 2.98150E+02 -36976+1.2*T+GHSERAL#\n +GHSERCU#; 6.00000E+03 N REF72 !\n PARAMETER G(ALCU_EPSILON,CU:CU;0) 2.98150E+02 +2*GBCCCU#; 6.00000E+03 \n N REF72 !\n PARAMETER G(ALCU_EPSILON,AL,CU:CU;0) 2.98150E+02 +7600-24*T; \n 6.00000E+03 N REF72 !\n PARAMETER G(ALCU_EPSILON,AL,CU:CU;1) 2.98150E+02 -72000; 6.00000E+03 \n N REF72 !\n\n\n PHASE ALCU_ETA % 2 1 1 !\n CONSTITUENT ALCU_ETA :AL,CU : CU : !\n\n PARAMETER G(ALCU_ETA,AL:CU;0) 2.98150E+02 -40560+3.14*T+GHSERAL#\n +GHSERCU#; 6.00000E+03 N REF72 !\n PARAMETER G(ALCU_ETA,CU:CU;0) 2.98150E+02 +2*GBCCCU#; 6.00000E+03 N \n REF72 !\n PARAMETER G(ALCU_ETA,AL,CU:CU;0) 2.98150E+02 -25740-20*T; 6.00000E+03 \n N REF72 !\n\n\n PHASE ALCU_PRIME % 2 2 1 !\n CONSTITUENT ALCU_PRIME :AL : CU : !\n\n PARAMETER G(ALCU_PRIME,AL:CU;0) 2.98150E+02 -46500+6.5*T+2*GHSERAL#\n +GHSERCU#; 6.00000E+03 N REF72 !\n\n\n PHASE ALCU_THETA % 2 2 1 !\n CONSTITUENT ALCU_THETA :AL : AL,CU : !\n\n PARAMETER G(ALCU_THETA,AL:AL;0) 2.98150E+02 +3*GBCCAL#; 6.00000E+03 \n N REF72 !\n PARAMETER G(ALCU_THETA,AL:CU;0) 2.98150E+02 -47406+6.75*T+2*GHSERAL#\n +GHSERCU#; 6.00000E+03 N REF72 !\n PARAMETER G(ALCU_THETA,AL:AL,CU;0) 2.98150E+02 2211; 6.00000E+03 N \n REF72 !\n\n\n PHASE ALCU_ZETA % 2 9 11 !\n CONSTITUENT ALCU_ZETA :AL : CU : !\n\n PARAMETER G(ALCU_ZETA,AL:CU;0) 2.98150E+02 -420000+18*T+9*GHSERAL#\n +11*GHSERCU#; 6.00000E+03 N REF72 !\n\n\n PHASE ALFESI_ALPHA % 4 .6612 .19 .0496 .0992 !\n CONSTITUENT ALFESI_ALPHA :AL : FE : SI : AL,SI : !\n\n PARAMETER G(ALFESI_ALPHA,AL:FE:SI:AL;0) 2.98150E+02 -24920.609\n +5.4893676*T+.7604*GHSERAL#+.1901*GHSERFE#+.0496*GHSERSI#; 6.00000E+03 \n N REF121 !\n PARAMETER G(ALFESI_ALPHA,AL:FE:SI:SI;0) 2.98150E+02 -24920.609\n -420.31313+5.4893676*T+.6612*GHSERAL#+.1901*GHSERFE#+.1488*GHSERSI#; \n 6.00000E+03 N REF121 !\n\n\n PHASE ALFESI_BETA % 3 14 3 3 !\n CONSTITUENT ALFESI_BETA :AL : FE : SI : !\n\n PARAMETER G(ALFESI_BETA,AL:FE:SI;0) 2.98150E+02 -391310.9+558.4756*T\n +14*GHSERAL#+3*GHSERFE#+3*GHSERSI#; 6.00000E+03 N REF121 !\n\n\n PHASE ALFESI_DELTA % 3 .55 .15 .3 !\n CONSTITUENT ALFESI_DELTA :AL : FE : SI : !\n\n PARAMETER G(ALFESI_DELTA,AL:FE:SI;0) 2.98150E+02 -14431.105-2.9006199*T\n +.55*GHSERAL#+.15*GHSERFE#+.3*GHSERSI#; 6.00000E+03 N REF121 !\n\n\n PHASE ALFESI_GAMMA % 3 3 1 1 !\n CONSTITUENT ALFESI_GAMMA :AL : FE : SI : !\n\n PARAMETER G(ALFESI_GAMMA,AL:FE:SI;0) 2.98150E+02 -116929.6+8.399833*T\n +3*GHSERAL#+GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 !\n\n\n PHASE ALFESI_TAU1 % 3 2 2 1 !\n CONSTITUENT ALFESI_TAU1 :AL : FE : SI : !\n\n PARAMETER G(ALFESI_TAU1,AL:FE:SI;0) 2.98150E+02 -153000+2*GHSERAL#\n +2*GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 !\n\n\n PHASE ALFESI_TAU3 % 3 2 1 1 !\n CONSTITUENT ALFESI_TAU3 :AL : FE : SI : !\n\n PARAMETER G(ALFESI_TAU3,AL:FE:SI;0) 2.98150E+02 -99325.65+2*GHSERAL#\n +GHSERFE#+GHSERSI#; 6.00000E+03 N REF121 !\n\n\n PHASE AL1LI1 % 2 1 1 !\n CONSTITUENT AL1LI1 :AL,LI,MG : LI,MG,VA : !\n\n PARAMETER G(AL1LI1,AL:LI;0) 2.98150E+02 -41300+16.86*T+GHSERAL#+GHSERLI#; \n 6.00000E+03 N REF105 !\n PARAMETER G(AL1LI1,LI:LI;0) 2.98150E+02 +2*GHSERLI#; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,MG:LI;0) 2.98150E+02 -9168+4.2*T+GBCCMG#+GHSERLI#; \n 6.00000E+03 N REF105 !\n PARAMETER G(AL1LI1,AL:MG;0) 2.98150E+02 +2486-1.75*T+GBCCAL#+GHSERLI#; \n 6.00000E+03 N REF11 !\n PARAMETER G(AL1LI1,LI:MG;0) 2.98150E+02 -9168+4.2*T+GBCCMG#+GHSERLI#; \n 6.00000E+03 N REF105 !\n PARAMETER G(AL1LI1,MG:MG;0) 2.98150E+02 +2*GBCCMG#; 6.00000E+03 N \n REF11 !\n PARAMETER G(AL1LI1,AL:VA;0) 2.98150E+02 +24000+GHSERAL#; 6.00000E+03 \n N REF105 !\n PARAMETER G(AL1LI1,LI:VA;0) 2.98150E+02 +50000+GHSERLI#; 6.00000E+03 \n N REF105 !\n PARAMETER G(AL1LI1,MG:VA;0) 2.98150E+02 +50000+GHSERMG#; 6.00000E+03 \n N REF11 !\n PARAMETER G(AL1LI1,AL,LI:LI;0) 2.98150E+02 20000; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,AL,LI:LI;1) 2.98150E+02 -26000; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,AL,MG:LI;0) 2.98150E+02 +3300-2*T; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,AL,MG:LI,MG;0) 2.98150E+02 -43460+60*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(AL1LI1,AL:LI,MG;0) 2.98150E+02 -25000+10*T; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,AL:LI,VA;0) 2.98150E+02 -24000+10*T; 6.00000E+03 N \n REF105 !\n PARAMETER G(AL1LI1,AL,LI:VA;0) 2.98150E+02 2000; 6.00000E+03 N REF105 !\n\n\n PHASE ALLIMG_TAU % 3 .53 .33 .14 !\n CONSTITUENT ALLIMG_TAU :AL : LI : MG : !\n\n PARAMETER G(ALLIMG_TAU,AL:LI:MG;0) 2.98150E+02 -15500+23.93*T-3*T*LN(T)\n +.53*GHSERAL#+.33*GHSERLI#+.14*GHSERMG#; 6.00000E+03 N REF105 !\n\n\n PHASE ALMGMN_T % 3 18 3 2 !\n CONSTITUENT ALMGMN_T :AL : MG : MN : !\n\n PARAMETER G(ALMGMN_T,AL:MG:MN;0) 2.98150E+02 -206402+11.849833*T; \n 6.00000E+03 N REF126 !\n\n\n PHASE ALMG_BETA % 2 .615 .385 !\n CONSTITUENT ALMG_BETA :AL : LI,MG : !\n\n PARAMETER G(ALMG_BETA,AL:LI;0) 2.98150E+02 -10750+5*T+.615*GHSERAL#\n +.385*GHSERLI#; 6.00000E+03 N REF105 !\n PARAMETER G(ALMG_BETA,AL:MG;0) 2.98150E+02 -1000-3.017*T+.615*GHSERAL#\n +.385*GHSERMG#; 6.00000E+03 N REF11 !\n PARAMETER G(ALMG_BETA,AL:LI,MG;0) 2.98150E+02 -4250; 6.00000E+03 N \n REF105 !\n\n\n PHASE ALMG_DZETA % 2 21 19 !\n CONSTITUENT ALMG_DZETA :AL : MG : !\n\n PARAMETER G(ALMG_DZETA,AL:MG;0) 2.98150E+02 -21040-163.76*T+21*GHSERAL#\n +19*GHSERMG#; 6.00000E+03 N REF11 !\n\n\n PHASE ALMG_UPSILON % 2 14 11 !\n CONSTITUENT ALMG_UPSILON :AL : MG : !\n\n PARAMETER G(ALMG_UPSILON,AL:MG;0) 2.98150E+02 -9275-104*T+14*GHSERAL#\n +11*GHSERMG#; 6.00000E+03 N REF11 !\n\n\n PHASE ALMNSI_ALPHA % 4 16 4 1 2 !\n CONSTITUENT ALMNSI_ALPHA :AL : MN : SI : AL,SI : !\n\n PARAMETER G(ALMNSI_ALPHA,AL:MN:SI:AL;0) 2.98150E+02 -250000+200*T\n -14.42*T*LN(T)+.0464*T**2+18*GHSERAL#+4*GHSERMN#+GHSERSI#; 2.00000E+03 N \n REF115 !\n PARAMETER G(ALMNSI_ALPHA,AL:MN:SI:SI;0) 2.98150E+02 -500000+200*T\n -14.42*T*LN(T)+.0464*T**2+16*GHSERAL#+4*GHSERMN#+3*GHSERSI#; 2.00000E+03 \n N REF115 !\n\n\n PHASE ALMNSI_DELTA % 3 2 1 3 !\n CONSTITUENT ALMNSI_DELTA :AL : MN : SI : !\n\n PARAMETER G(ALMNSI_DELTA,AL:MN:SI;0) 2.98150E+02 -75000-20*T+2*GHSERAL#\n +GHSERMN#+3*GHSERSI#; 6.00000E+03 N REF115 !\n\n\n$ PHASE ALMNSI_BETA % 3 7.5 2.5 3 !\n$ CONSTITUENT ALMNSI_BETA :AL : AL,SI : MN : !\n$ Changed to expression in COST2.TDB 180825 /BoS\n$ PARAMETER G(ALMNSI_NBETA,AL:AL:MN;0) 2.98150E+02 -260000-745*T\n$ +10*GHSERAL#+3*GHSERMN#; 6.00000E+03 N REF115 !\n$ PARAMETER G(ALMNSI_NBETA,AL:SI:MN;0) 2.98150E+02 -230000-745*T\n$ +7.5*GHSERAL#+2.5*GHSERSI#+3*GHSERMN#; 2.00000E+03 N REF115 !\n\n PHASE ALMNSI_BETA % 4 15.0 1.0 4.0 6.0 !\n CONSTITUENT ALMNSI_BETA :AL : SI : AL,SI : MN : !\n\n PARAM G(ALMNSI_BETA,AL:SI:AL:MN;0) 298.15 \n -8.8064800E+05+3.4510400E+03*T-572.749*T*LN(T)\n -.201935*T**2+2.00008E-05*T**3+2184750*T**(-1); \n 6000.00 N REF115!\n PARAM G(ALMNSI_BETA,AL:SI:SI:MN;0) 298.15 \n -7.7998000E+05+3.4510400E+03*T-593.657*T*LN(T)\n -.16164*T**2+1.35092E-05*T**3+2946120*T**(-1);\n 6000.00 N REF115!\n PARAM L(ALMNSI_BETA,AL:SI:AL,SI:MN;0) 298.15 1.0E-4; 6000 N REF115!\n\n\n PHASE ALN % 2 1 1 !\n CONSTITUENT ALN :AL : N : !\n\n PARAMETER G(ALN,AL:N;0) 2.98150E+02 -338005.5+305.211*T\n -46.94867*T*LN(T)-.00189068*T**2+874528*T**(-1)+1.3756E-07*T**3; \n 6.00000E+03 N REF48 !\n\n\n PHASE AL1ND2 % 2 1 2 !\n CONSTITUENT AL1ND2 :AL : ND : !\n\n PARAMETER G(AL1ND2,AL:ND;0) 2.98150E+02 -108540+20.64*T+GHSERAL#\n +2*GHSERND#; 6.00000E+03 N REF80 !\n\n\n PHASE ALPHA_TIMN % 2 1 1 !\n CONSTITUENT ALPHA_TIMN :MN : TI : !\n\n PARAMETER G(ALPHA_TIMN,MN:TI;0) 2.98150E+02 -11478-4*T+GHSERMN#\n +GHSERTI#; 6.00000E+03 N REF72 !\n\n\n PHASE AL1TI1 % 2 1 1 !\n CONSTITUENT AL1TI1 :AL%,TI,V : AL,TI%,V : !\n\n PARAMETER G(AL1TI1,AL:AL;0) 2.98150E+02 +2*GHSERAL#+1000; 6.00000E+03 N \n REF13 !\n PARAMETER G(AL1TI1,TI:AL;0) 2.98150E+02 -79644+19.2*T+GHSERAL#+GHSERTI#; \n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,V:AL;0) 2.98150E+02 -112756+140.9629*T+GHSERAL#+GFCCV#;\n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL:TI;0) 2.98150E+02 -79644+19.2*T+GHSERAL#+GHSERTI#; \n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,TI:TI;0) 2.98150E+02 +2*GFCCTI#; 6.00000E+03 N \n REF13 !\n PARAMETER G(AL1TI1,V:TI;0) 2.98150E+02 +245018.5+GFCCTI#+GFCCV#; \n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL:V;0) 2.98150E+02 -112756+140.9629*T+GHSERAL#+GFCCV#;\n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,TI:V;0) 2.98150E+02 +245018.5+GFCCTI#+GFCCV#; \n 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,V:V;0) 2.98150E+02 +2*GFCCV#; 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL,TI:AL;0) 2.98150E+02 -89892+44*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(AL1TI1,AL,TI:AL;1) 2.98150E+02 30000; 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL,TI:AL;2) 2.98150E+02 20000; 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL:AL,TI;0) 2.98150E+02 -89892+44*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(AL1TI1,AL:AL,TI;1) 2.98150E+02 30000; 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,AL:AL,TI;2) 2.98150E+02 20000; 6.00000E+03 N REF13 !\n PARAMETER G(AL1TI1,TI:AL,TI;0) 2.98150E+02 -15134-2.36*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(AL1TI1,AL,TI:TI;0) 2.98150E+02 -15134-2.36*T; 6.00000E+03 \n N REF13 !\n\n\n PHASE ALTI3 % 2 3 1 !\n CONSTITUENT ALTI3 :AL,TI%,V : AL%,TI,V : !\n\n PARAMETER G(ALTI3,AL:AL;0) 2.98150E+02 +4*GHCPAL#; 6.00000E+03 N \n REF13 !\n PARAMETER G(ALTI3,TI:AL;0) 2.98150E+02 -110080+23.88*T+GHSERAL#\n +3*GHSERTI#; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,V:AL;0) 2.98150E+02 -112566.1+52.28308*T+GHCPAL#\n +3*GHCPV#; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,AL:TI;0) 2.98150E+02 -99120+32.28*T+3*GHSERAL#\n +GHSERTI#; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,TI:TI;0) 2.98150E+02 +4*GHSERTI#; 6.00000E+03 N \n REF13 !\n PARAMETER G(ALTI3,V:TI;0) 2.98150E+02 +82314.05+GHSERTI#+3*GHSERV#; \n 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,AL:V;0) 2.98150E+02 -112566.1+52.28308*T+3*GHCPAL#\n +GHCPV#; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,TI:V;0) 2.98150E+02 +82314.05+3*GHSERTI#+GHSERV#; \n 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,V:V;0) 2.98150E+02 +4*GHCPV#; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,AL,TI:AL;0) 2.98150E+02 -297200+100*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(ALTI3,AL:AL,TI;0) 2.98150E+02 -98968+33.3*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(ALTI3,TI:AL,TI;0) 2.98150E+02 +10656-1.332*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(ALTI3,AL,TI:TI;0) 2.98150E+02 +32000-4*T; 6.00000E+03 N \n REF13 !\n PARAMETER G(ALTI3,TI,V:TI;0) 2.98150E+02 1E-05; 6.00000E+03 N REF13 !\n PARAMETER G(ALTI3,TI:TI,V;0) 2.98150E+02 1E-05; 6.00000E+03 N REF13 !\n\n\n PHASE AL1Y1 % 2 1 1 !\n CONSTITUENT AL1Y1 :AL : Y : !\n\n PARAMETER G(AL1Y1,AL:Y;0) 2.98150E+02 -173810+40.86834*T+GHSERAL#+GHSERY#;\n 2.90000E+03 N REF52 !\n\n\n PHASE ALY2 % 2 1 2 !\n CONSTITUENT ALY2 :AL : Y : !\n\n PARAMETER G(ALY2,AL:Y;0) 2.98150E+02 -190908+44.38629*T+GHSERAL#\n +2*GHSERY#; 2.90000E+03 N REF52 !\n\n\n PHASE AL1ZR1 % 2 1 1 !\n CONSTITUENT AL1ZR1 :AL : ZR : !\n\n PARAMETER G(AL1ZR1,AL:ZR;0) 2.98150E+02 -89000+17.0384*T+GHSERAL#\n +GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE ALZR2 % 2 1 2 !\n CONSTITUENT ALZR2 :AL : ZR : !\n\n PARAMETER G(ALZR2,AL:ZR;0) 2.98150E+02 -100125+17.553*T+GHSERAL#\n +2*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE ALZR3 % 2 1 3 !\n CONSTITUENT ALZR3 :AL : ZR : !\n\n PARAMETER G(ALZR3,AL:ZR;0) 2.98150E+02 -108000+22.38*T+GHSERAL#\n +3*GHSERZR#; 6.00000E+03 N REF74 !\n\n\n PHASE AL_CEND1 % 2 1 1 !\n CONSTITUENT AL_CEND1 :AL : CE,ND : !\n\n PARAMETER G(AL_CEND1,AL:CE;0) 2.98150E+02 -92000+33.90118*T+GHSERAL#\n +GHSERCE#; 6.00000E+03 N REF103 !\n PARAMETER G(AL_CEND1,AL:ND;0) 2.98150E+02 -99880+20.4*T+GHSERAL#\n +GHSERND#; 6.00000E+03 N REF80 !\n\n\n PHASE ALCEND3 % 2 1 3 !\n CONSTITUENT ALCEND3 :AL : CE,ND : !\n\n PARAMETER G(ALCEND3,AL:CE;0) 2.98150E+02 -108000+41.3726*T+GHSERAL#\n +3*GHSERCE#; 6.00000E+03 N REF103 !\n PARAMETER G(ALCEND3,AL:ND;0) 2.98150E+02 -108840+19.52*T+GHSERAL#\n +3*GHSERND#; 6.00000E+03 N REF80 !\n\n\n PHASE B2TI % 2 2 1 !\n CONSTITUENT B2TI :B : TI : !\n\n PARAMETER G(B2TI,B:TI;0) 2.98150E+02 -318253.47-2.5557*T\n +.799221*T*LN(T)+.002843367*T**2+2*GHSERBB#+GHSERTI#; 6.00000E+03 N \n REF89 !\n\n\n PHASE B3SI % 3 6 2 6 !\n CONSTITUENT B3SI :B : SI : B,SI : !\n\n PARAMETER G(B3SI,B:SI:B;0) 2.98150E+02 +112000+12*GHSERBB#+2*GHSERSI#; \n 6.00000E+03 N REF58 !\n PARAMETER G(B3SI,B:SI:SI;0) 2.98150E+02 +1120000+6*GHSERBB#+8*GHSERSI#; \n 6.00000E+03 N REF58 !\n PARAMETER G(B3SI,B:SI:B,SI;0) 2.98150E+02 -2400475+240.0475*T; \n 6.00000E+03 N REF58 !\n\n\n PHASE B4C % 2 12 1 !\n CONSTITUENT B4C :B : B4,C2B,C2SI,C3 : !\n\n PARAMETER G(B4C,B:B4;0) 2.98150E+02 +85617.28+1.82192*T+16*GHSERBB#; \n 6.00000E+03 N REF54 !\n PARAMETER G(B4C,B:C2B;0) 2.98150E+02 -190446-25.02645*T+14*GHSERBB#\n +GHSERCC#; 6.00000E+03 N REF54 !\n PARAMETER G(B4C,B:C2SI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(B4C,B:C3;0) 2.98150E+02 -221960.55-21.50175*T+12*GHSERBB#\n +3*GHSERCC#; 6.00000E+03 N REF54 !\n PARAMETER G(B4C,B:B4,C2B;0) 2.98150E+02 -130000-2*T; 6.00000E+03 N \n REF54 !\n PARAMETER G(B4C,B:C2B,C3;0) 2.98150E+02 -30000+9*T; 6.00000E+03 N \n REF54 !\n\n\n PHASE B4TI3 % 2 4 3 !\n CONSTITUENT B4TI3 :B : TI : !\n\n PARAMETER G(B4TI3,B:TI;0) 2.98150E+02 -660745.8+4.3472923*T\n +2.162216*T*LN(T)+4*GHSERBB#+3*GHSERTI#; 6.00000E+03 N REF89 !\n\n\n PHASE B6SI % 3 210 23 48 !\n CONSTITUENT B6SI :B : SI : B,SI : !\n\n PARAMETER G(B6SI,B:SI:B;0) 2.98150E+02 +729824.4-72.98244*T\n +258*GHSERBB#+23*GHSERSI#; 6.00000E+03 N REF58 !\n PARAMETER G(B6SI,B:SI:SI;0) 2.98150E+02 +5454560-545.456*T+210*GHSERBB#\n +71*GHSERSI#; 6.00000E+03 N REF58 !\n PARAMETER G(B6SI,B:SI:B,SI;0) 2.98150E+02 -15715630+1571.563*T; \n 6.00000E+03 N REF58 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :AL,CE,CR%,CU,FE%,LI,MG,MN,ND,SI,SN,TI%,V%,Y%,ZN,ZR% \n : B,C,N,VA% : !\n\n PARAMETER G(BCC_A2,AL:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CE:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CR:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CU:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,FE:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,LI:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MG:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ND:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SI:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,TI:B;0) 2.98150E+02 -200000+14*T+GHSERTI#+3*GHSERBB#;\n 6.00000E+03 N REF89 !\n PARAMETER G(BCC_A2,V:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,Y:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZR:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,AL:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CU:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,FE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,LI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MG:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ND:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,TI:C;0) 2.98150E+02 +2295533+GHSERTIC#+2*GHSERCC#; \n 6.00000E+03 N REF111 !\n PARAMETER G(BCC_A2,V:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,Y:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,AL:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,CU:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,FE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,LI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MG:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,MN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ND:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,SN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,TI:N;0) 2.98150E+02 +1561293+118.04*T+GHSERTIN#\n +2*GHSERNN#; 6.00000E+03 N REF111 !\n PARAMETER G(BCC_A2,V:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,Y:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,ZR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_A2,AL:VA;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,CE:VA;0) 2.98150E+02 -1354.69-5.21501*T\n -7.7305867*T*LN(T)-.029098402*T**2+4.784299E-06*T**3-196303*T**(-1); \n 1.00000E+03 Y\n -12101.106+187.449688*T-37.6142*T*LN(T); 1.07200E+03 Y\n -11950.375+186.333811*T-37.4627992*T*LN(T)-5.7145E-05*T**2+2.348E-09*T**3\n -25897*T**(-11); 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#; 6.00000E+03 N \n REF1 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_A2,CU:VA;0) 2.98150E+02 +GBCCCU#; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#; 6.00000E+03 N \n REF1 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_A2,LI:VA;0) 2.98150E+02 +GHSERLI#; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_A2,MG:VA;0) 2.98150E+02 +3100-2.1*T+GHSERMG#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T)\n -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y\n -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 6.00000E+03 N \n REF1 !\n PARAMETER TC(BCC_A2,MN:VA;0) 2.98150E+02 -580; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98150E+02 -.27; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_A2,ND:VA;0) 2.98150E+02 -6965.635+110.556109*T\n -27.0858*T*LN(T)+5.56125E-04*T**2-2.6923E-06*T**3+34887*T**(-1); \n 4.00000E+02 Y\n +7312.2-153.033976*T+14.9956777*T*LN(T)-.050479*T**2+7.287217E-06*T**3\n -831810*T**(-1); 1.12800E+03 Y\n -18030.266+239.677322*T-44.5596*T*LN(T); 1.28900E+03 Y\n +334513.017-2363.9199*T+311.409193*T*LN(T)-.156030778*T**2\n +1.2408421E-05*T**3-64319604*T**(-1); 1.80000E+03 N REF1 !\n PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +47000-22.5*T+GHSERSI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,SN:VA;0) 2.98150E+02 +4400-6*T+GHSERSN#; \n 3.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,TI:VA;0) 2.98150E+02 -1272.064+134.71418*T\n -25.5768*T*LN(T)-6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1); \n 1.15500E+03 Y\n +6667.385+105.366379*T-22.3771*T*LN(T)+.00121707*T**2-8.4534E-07*T**3\n -2002750*T**(-1); 1.94100E+03 Y\n +26483.26-182.426471*T+19.0900905*T*LN(T)-.02200832*T**2\n +1.228863E-06*T**3+1400501*T**(-1); 4.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERV#; 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,Y:VA;0) 2.98150E+02 -1861.198+97.522398*T\n -20.940576*T*LN(T)-.007995833*T**2+7.58716E-07*T**3-54349*T**(-1); \n 1.75200E+03 Y\n -10207.724+195.741984*T-35.0201*T*LN(T); 1.79900E+03 Y\n +104813.954-386.167564*T+39.8075986*T*LN(T); 3.70000E+03 N REF1 !\n PARAMETER G(BCC_A2,ZN:VA;0) 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,ZR:VA;0) 2.98150E+02 +7302.056-.70335*T\n -1.445606*T*LN(T)+.004037826*T**2-9.7289735E-09*T**3-7.6142894E-11*T**4\n -9737*T**(-1)+GHSERZR#; 2.12800E+03 Y\n -4620.034+1.55998*T+1.41035E+32*T**(-9); 6.00000E+03 N REF1 !\n PARAMETER G(BCC_A2,TI:B,VA;0) 2.98150E+02 -260162.96+156.48207*T; \n 6.00000E+03 N REF89 !\n PARAMETER G(BCC_A2,TI:C,VA;0) 2.98150E+02 -2590609; 6.00000E+03 N \n REF111 !\n PARAMETER G(BCC_A2,TI:N,VA;0) 2.98150E+02 -2140513; 6.00000E+03 N \n REF111 !\n PARAMETER G(BCC_A2,AL,CE:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF129 !\n PARAMETER G(BCC_A2,AL,CR:VA;0) 2.98150E+02 -54900+10*T; 6.00000E+03 \n N REF8 !\n PARAMETER G(BCC_A2,AL,CU:VA;0) 2.98150E+02 -73554+4*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(BCC_A2,AL,CU:VA;1) 2.98150E+02 +51500-11.84*T; \n 6.00000E+03 N REF72 !\n PARAMETER G(BCC_A2,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(BCC_A2,AL,LI:VA;1) 2.98150E+02 1E-06; 6.00000E+03 N \n REF105 !\n PARAMETER G(BCC_A2,AL,LI:VA;2) 2.98150E+02 3000; 6.00000E+03 N \n REF105 !\n PARAMETER G(BCC_A2,AL,LI,MG:VA;0) 2.98150E+02 -71200+50*T; \n 6.00000E+03 N REF105 !\n PARAMETER G(BCC_A2,AL,MG:VA;0) 2.98150E+02 +4971-3.5*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(BCC_A2,AL,MG:VA;1) 2.98150E+02 +900+.423*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(BCC_A2,AL,MG:VA;2) 2.98150E+02 950; 6.00000E+03 N REF11 !\n PARAMETER G(BCC_A2,AL,MN:VA;0) 2.98150E+02 -120077+52.851*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(BCC_A2,AL,MN:VA;1) 2.98150E+02 -40652+29.2764*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(BCC_A2,AL,TI:VA;0) 2.98150E+02 -128500+39*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(BCC_A2,AL,TI:VA;1) 2.98150E+02 6000; 6.00000E+03 N \n REF13 !\n PARAMETER G(BCC_A2,AL,TI:VA;2) 2.98150E+02 21200; 6.00000E+03 N \n REF13 !\n PARAMETER G(BCC_A2,AL,TI,V:VA;0) 2.98150E+02 32045.963; 6.00000E+03 \n N REF127 !\n PARAMETER G(BCC_A2,AL,V:VA;0) 2.98150E+02 -95000+20*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(BCC_A2,AL,V:VA;1) 2.98150E+02 -6000; 6.00000E+03 N \n REF13 !\n PARAMETER G(BCC_A2,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N \n REF52 !\n PARAMETER G(BCC_A2,AL,ZR:VA;0) 2.98150E+02 -122300+32*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(BCC_A2,AL,ZR:VA;1) 2.98150E+02 -11000; 6.00000E+03 N \n REF74 !\n PARAMETER G(BCC_A2,AL,ZR:VA;2) 2.98150E+02 15000; 6.00000E+03 N \n REF74 !\n PARAMETER G(BCC_A2,CE,MG:VA;0) 2.98150E+02 -27000+3.3*T; 6.00000E+03 \n N REF103 !\n PARAMETER G(BCC_A2,CE,MG:VA;1) 2.98150E+02 +25338.56-11.86885*T; \n 6.00000E+03 N REF103 !\n PARAMETER G(BCC_A2,CE,MG:VA;2) 2.98150E+02 -15106.9; 6.00000E+03 N \n REF103 !\n PARAMETER G(BCC_A2,CR,CU:VA;0) 2.98150E+02 77107.48; 6.00000E+03 N \n REF96 !\n PARAMETER G(BCC_A2,CR,MG:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF83 !\n PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; \n 6.00000E+03 N REF2 !\n PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; \n 6.00000E+03 N REF2 !\n PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N \n REF2 !\n PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N \n REF2 !\n PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N \n REF2 !\n PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N \n REF2 !\n PARAMETER TC(BCC_A2,CR,MN:VA;8) 2.98150E+02 -28117; 6.00000E+03 N \n REF2 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 \n N REF2 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 \n N REF2 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 \n N REF2 !\n PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -104537.94+10.69527*T; \n 6.00000E+03 N REF91 !\n PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -47614.7+12.17363*T; \n 6.00000E+03 N REF91 !\n PARAMETER G(BCC_A2,CR,TI:VA;0) 2.98150E+02 19100; 6.00000E+03 N \n REF72 !\n PARAMETER G(BCC_A2,CR,TI:VA;1) 2.98150E+02 5500; 6.00000E+03 N \n REF72 !\n PARAMETER G(BCC_A2,CR,TI:VA;2) 2.98150E+02 1750; 6.00000E+03 N \n REF72 !\n PARAMETER G(BCC_A2,CR,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF83 !\n PARAMETER G(BCC_A2,CR,ZR:VA;0) 2.98150E+02 +16555.47+4.92028*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,CR,ZR:VA;1) 2.98150E+02 11365.57; 6.00000E+03 N \n REF98 !\n PARAMETER G(BCC_A2,CU,FE:VA;0) 2.98150E+02 +39257.976-4.1498304*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(BCC_A2,CU,LI:VA;0) 2.98150E+02 50000; 6.00000E+03 N \n REF74 !\n PARAMETER G(BCC_A2,CU,MG:VA;0) 2.98150E+02 20000; 6.00000E+03 N \n REF20 !\n PARAMETER G(BCC_A2,CU,ZR:VA;0) 2.98150E+02 -7381.13; 6.00000E+03 N \n REF125 !\n PARAMETER G(BCC_A2,FE,MG:VA;0) 2.98150E+02 65700; 6.00000E+03 N \n REF29 !\n PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 \n N REF6 !\n PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N REF6 !\n PARAMETER G(BCC_A2,LI,MG:VA;0) 2.98150E+02 -18335+8.49*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(BCC_A2,LI,MG:VA;1) 2.98150E+02 3481; 6.00000E+03 N \n REF105 !\n PARAMETER G(BCC_A2,LI,MG:VA;2) 2.98150E+02 +2658-.114*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(BCC_A2,LI,ZR:VA;0) 2.98150E+02 100000; 6.00000E+03 N \n REF74 !\n PARAMETER G(BCC_A2,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N \n REF29 !\n PARAMETER G(BCC_A2,MG,Y:VA;0) 2.98150E+02 -38570+15*T; 6.00000E+03 \n N REF64 !\n PARAMETER G(BCC_A2,MG,Y:VA;1) 2.98150E+02 -8204.21; 6.00000E+03 N \n REF64 !\n PARAMETER G(BCC_A2,MG,ZR:VA;0) 2.98150E+02 +5720.44+50.11642*T; \n 6.00000E+03 N REF68 !\n PARAMETER G(BCC_A2,MN,SI:VA;0) 2.98150E+02 -89620.7+2.94097*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(BCC_A2,MN,SI:VA;1) 2.98150E+02 -7500; 6.00000E+03 N \n REF29 !\n PARAMETER G(BCC_A2,MN,TI:VA;0) 2.98150E+02 -23200+20*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(BCC_A2,MN,TI:VA;1) 2.98150E+02 -1000; 6.00000E+03 N \n REF72 !\n PARAMETER G(BCC_A2,SI,TI:VA;0) 2.98150E+02 -275629.1+42.5094*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,SI,TI:VA;1) 2.98150E+02 +25025.35-2.00203*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,SI,TI:VA;2) 2.98150E+02 +83940.65-6.71526*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,SI,V:VA;0) 2.98150E+02 -164505+30.1*T; 6.00000E+03 \n N REF117 !\n PARAMETER G(BCC_A2,SI,V:VA;1) 2.98150E+02 37000; 6.00000E+03 N \n REF117 !\n PARAMETER G(BCC_A2,SI,V:VA;2) 2.98150E+02 20000; 6.00000E+03 N \n REF117 !\n PARAMETER G(BCC_A2,SI,Y:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF66 !\n PARAMETER G(BCC_A2,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF100 !\n PARAMETER G(BCC_A2,SN,TI:VA;0) 2.98150E+02 -115000+6.77583*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(BCC_A2,SN,TI:VA;1) 2.98150E+02 +45000+1.58018*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(BCC_A2,TI,V:VA;0) 2.98150E+02 +10500-1.5*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(BCC_A2,TI,V:VA;1) 2.98150E+02 2000; 6.00000E+03 N REF13 !\n PARAMETER G(BCC_A2,TI,V:VA;2) 2.98150E+02 1000; 6.00000E+03 N REF13 !\n\n\n TYPE_DEFINITION ' GES A_P_D BCC_B2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_B2 %' 2 .5 .5 !\n CONSTITUENT BCC_B2 :AL,CU,FE,SI,ZN : AL,CU,FE,SI,ZN : !\n\n PARAMETER G(BCC_B2,AL:AL;0) 2.98150E+02 +GBCCAL#; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_B2,CU:AL;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,FE:AL;0) 2.98150E+02 -2*ALFEW1#+.5*GHSERFE#\n +.5*GBCCAL#+LALFEB0#; 6.00000E+03 N REF76 !\n PARAMETER TC(BCC_B2,FE:AL;0) 2.98150E+02 521.5; 6.00000E+03 N REF76 !\n PARAMETER BMAGN(BCC_B2,FE:AL;0) 2.98150E+02 1.11; 6.00000E+03 N \n REF76 !\n PARAMETER G(BCC_B2,SI:AL;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,ZN:AL;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,AL:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,CU:CU;0) 2.98150E+02 +GBCCCU#; 6.00000E+03 N \n REF70 !\n PARAMETER G(BCC_B2,FE:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,SI:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,ZN:CU;0) 2.98150E+02 +.25*CUZNL0#+CUZNP1#+.5*GBCCCU#\n +.5*GBCCZN#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,AL:FE;0) 2.98150E+02 -2*ALFEW1#+.5*GHSERFE#\n +.5*GBCCAL#+LALFEB0#; 6.00000E+03 N REF76 !\n PARAMETER TC(BCC_B2,AL:FE;0) 2.98150E+02 521.5; 6.00000E+03 N REF76 !\n PARAMETER BMAGN(BCC_B2,AL:FE;0) 2.98150E+02 1.11; 6.00000E+03 N \n REF76 !\n PARAMETER G(BCC_B2,CU:FE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,FE:FE;0) 2.98150E+02 +GHSERFE#; 6.00000E+03 N \n REF1 !\n PARAMETER TC(BCC_B2,FE:FE;0) 2.98150E+02 1043; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(BCC_B2,FE:FE;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_B2,SI:FE;0) 2.98150E+02 -2*FESIW1#+.5*GHSERFE#\n +.5*GBCCSI#+FESIL0#; 6.00000E+03 N REF26 !\n PARAMETER TC(BCC_B2,SI:FE;0) 2.98150E+02 521.5; 6.00000E+03 N REF26 !\n PARAMETER BMAGN(BCC_B2,SI:FE;0) 2.98150E+02 1.11; 6.00000E+03 N \n REF26 !\n PARAMETER G(BCC_B2,ZN:FE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,AL:SI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,CU:SI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,FE:SI;0) 2.98150E+02 -2*FESIW1#+.5*GHSERFE#\n +.5*GBCCSI#+FESIL0#; 6.00000E+03 N REF26 !\n PARAMETER TC(BCC_B2,FE:SI;0) 2.98150E+02 521.5; 6.00000E+03 N REF26 !\n PARAMETER BMAGN(BCC_B2,FE:SI;0) 2.98150E+02 1.11; 6.00000E+03 N \n REF26 !\n PARAMETER G(BCC_B2,SI:SI;0) 2.98150E+02 +GBCCSI#; 6.00000E+03 N \n REF1 !\n PARAMETER G(BCC_B2,ZN:SI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,AL:ZN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,CU:ZN;0) 2.98150E+02 +.25*CUZNL0#+CUZNP1#+.5*GBCCCU#\n +.5*GBCCZN#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,FE:ZN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,SI:ZN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(BCC_B2,ZN:ZN;0) 2.98150E+02 +GBCCZN#; 6.00000E+03 N \n REF70 !\n PARAMETER G(BCC_B2,AL,FE:AL;0) 2.98150E+02 +LALFEB0#+3*LALFEB1#; \n 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,AL,FE:AL;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL,FE:AL;0) 2.98150E+02 189; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL,FE:AL;1) 2.98150E+02 63; 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,AL:AL,FE;0) 2.98150E+02 +LALFEB0#+3*LALFEB1#; \n 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,AL:AL,FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL:AL,FE;0) 2.98150E+02 189; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL:AL,FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,FE:AL,FE;0) 2.98150E+02 +LALFEB0#-3*LALFEB1#; \n 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,FE:AL,FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,FE:AL,FE;0) 2.98150E+02 -189; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,FE:AL,FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,CU,ZN:CU;0) 2.98150E+02 +.25*CUZNL0#+.375*CUZNL1#\n +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU,ZN:CU;1) 2.98150E+02 +.125*CUZNL1#+.25*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU,ZN:CU;2) 2.98150E+02 +.0625*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU,ZN:CU,ZN;0) 2.98150E+02 -1.5*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU:CU,ZN;0) 2.98150E+02 +.25*CUZNL0#+.375*CUZNL1#\n +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU:CU,ZN;1) 2.98150E+02 +.125*CUZNL1#+.25*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU:CU,ZN;2) 2.98150E+02 +.0625*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,ZN:CU,ZN;0) 2.98150E+02 +.25*CUZNL0#-.375*CUZNL1#\n +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,ZN:CU,ZN;1) 2.98150E+02 +.125*CUZNL1#-.25*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,ZN:CU,ZN;2) 2.98150E+02 +.0625*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,AL,FE:FE;0) 2.98150E+02 +LALFEB0#-3*LALFEB1#; \n 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,AL,FE:FE;1) 2.98150E+02 +LALFEB1#; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL,FE:FE;0) 2.98150E+02 -189; 6.00000E+03 N \n REF76 !\n PARAMETER TC(BCC_B2,AL,FE:FE;1) 2.98150E+02 63; 6.00000E+03 N REF76 !\n PARAMETER G(BCC_B2,FE,SI:FE;0) 2.98150E+02 +FESIL0#+3*FESIL1#+3*FESIL2#;\n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE,SI:FE;1) 2.98150E+02 +FESIL1#+4*FESIL2#; \n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE,SI:FE;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N \n REF26 !\n PARAMETER TC(BCC_B2,FE,SI:FE;0) 2.98150E+02 +3*ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER TC(BCC_B2,FE,SI:FE;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER G(BCC_B2,FE,SI:FE,SI;0) 2.98150E+02 -24*FESIL2#; \n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE:FE,SI;0) 2.98150E+02 +FESIL0#+3*FESIL1#+3*FESIL2#;\n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE:FE,SI;1) 2.98150E+02 +FESIL1#+4*FESIL2#; \n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE:FE,SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N \n REF26 !\n PARAMETER TC(BCC_B2,FE:FE,SI;0) 2.98150E+02 +3*ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER TC(BCC_B2,FE:FE,SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER G(BCC_B2,SI:FE,SI;0) 2.98150E+02 +FESIL0#-3*FESIL1#+3*FESIL2#;\n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,SI:FE,SI;1) 2.98150E+02 +FESIL1#-4*FESIL2#; \n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,SI:FE,SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N \n REF26 !\n PARAMETER TC(BCC_B2,SI:FE,SI;0) 2.98150E+02 -3*ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER TC(BCC_B2,SI:FE,SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER G(BCC_B2,FE,SI:SI;0) 2.98150E+02 +FESIL0#-3*FESIL1#+3*FESIL2#;\n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE,SI:SI;1) 2.98150E+02 +FESIL1#-4*FESIL2#; \n 6.00000E+03 N REF26 !\n PARAMETER G(BCC_B2,FE,SI:SI;2) 2.98150E+02 +FESIL2#; 6.00000E+03 N \n REF26 !\n PARAMETER TC(BCC_B2,FE,SI:SI;0) 2.98150E+02 -3*ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER TC(BCC_B2,FE,SI:SI;1) 2.98150E+02 +ETCFESI#; 6.00000E+03 \n N REF26 !\n PARAMETER G(BCC_B2,CU,ZN:ZN;0) 2.98150E+02 +.25*CUZNL0#-.375*CUZNL1#\n +.1875*CUZNL2#+CUZNP2#; 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU,ZN:ZN;1) 2.98150E+02 +.125*CUZNL1#-.25*CUZNL2#; \n 6.00000E+03 N REF70 !\n PARAMETER G(BCC_B2,CU,ZN:ZN;2) 2.98150E+02 +.0625*CUZNL2#; \n 6.00000E+03 N REF70 !\n\n\n PHASE BCT_A5 % 1 1.0 !\n CONSTITUENT BCT_A5 :AL,SN,ZN : !\n\n PARAMETER G(BCT_A5,AL;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCT_A5,SN;0) 2.98150E+02 +GHSERSN#; 6.00000E+03 N REF1 !\n PARAMETER G(BCT_A5,ZN;0) 2.98150E+02 +2886.96-2.5104*T+GHSERZN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(BCT_A5,AL,SN;0) 2.98150E+02 +14136.95-4.71231*T; \n 6.00000E+03 N REF15 !\n PARAMETER G(BCT_A5,SN,ZN;0) 2.98150E+02 +6514.76+25.70957*T; \n 6.00000E+03 N REF107 !\n\n\n PHASE BETA_RHOMBO_B % 2 93 12 !\n CONSTITUENT BETA_RHOMBO_B :B : B,SI : !\n\n PARAMETER G(BETA_RHOMBO_B,B:B;0) 2.98150E+02 +105*GHSERBB#; \n 6.00000E+03 N REF58 !\n PARAMETER G(BETA_RHOMBO_B,B:SI;0) 2.98150E+02 -6160.245+.6160245*T\n +93*GHSERBB#+12*GHSERSI#; 6.00000E+03 N REF58 !\n PARAMETER G(BETA_RHOMBO_B,B:B,SI;0) 2.98150E+02 -725614+72.5614*T; \n 6.00000E+03 N REF58 !\n\n\n PHASE BETA_TIMN % 2 .515 .485 !\n CONSTITUENT BETA_TIMN :MN : TI : !\n\n PARAMETER G(BETA_TIMN,MN:TI;0) 2.98150E+02 -5540-2.29*T+.515*GHSERMN#\n +.485*GHSERTI#; 6.00000E+03 N REF72 !\n\n\n PHASE BN_HP4 % 2 1 1 !\n CONSTITUENT BN_HP4 :B : N : !\n\n PARAMETER G(BN_HP4,B:N;0) 2.98150E+02 -250600+91.281942*T+GHSERBB#\n +GHSERNN#; 6.00000E+03 N REF56 !\n\n\n PHASE BTI % 2 1 1 !\n CONSTITUENT BTI :B : TI : !\n\n PARAMETER G(BTI,B:TI;0) 2.98150E+02 -166196.8+3.2968*T+GHSERBB#\n +GHSERTI#; 6.00000E+03 N REF89 !\n\n\n PHASE B_NSI % 3 61 1 8 !\n CONSTITUENT B_NSI :B : SI : B,SI : !\n\n PARAMETER G(B_NSI,B:SI:B;0) 2.98150E+02 -89819.86+8.981986*T\n +69*GHSERBB#+GHSERSI#; 6.00000E+03 N REF58 !\n PARAMETER G(B_NSI,B:SI:SI;0) 2.98150E+02 -176659.7+17.66597*T\n +61*GHSERBB#+9*GHSERSI#; 6.00000E+03 N REF58 !\n PARAMETER G(B_NSI,B:SI:B,SI;0) 2.98150E+02 -281573.6+28.15736*T; \n 6.00000E+03 N REF58 !\n\n\n TYPE_DEFINITION ( GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %( 2 1 1 !\n CONSTITUENT CBCC_A12 :AL,CR,FE,MG,MN,SI,TI : VA : !\n\n PARAMETER G(CBCC_A12,AL:VA;0) 2.98150E+02 +10083-4.813*T+GHSERAL#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 \n N REF1 !\n PARAMETER G(CBCC_A12,MG:VA;0) 2.98150E+02 +4602.4-3.011*T+GHSERMG#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CBCC_A12,MN:VA;0) 2.98150E+02 +GHSERMN#; 6.00000E+03 N \n REF1 !\n PARAMETER TC(CBCC_A12,MN:VA;0) 2.98150E+02 -285; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(CBCC_A12,MN:VA;0) 2.98150E+02 -.66; 6.00000E+03 N \n REF1 !\n PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CBCC_A12,TI:VA;0) 2.98150E+02 +4602.2+GHSERTI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CBCC_A12,AL,FE:VA;0) 2.98150E+02 -114000+20*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(CBCC_A12,AL,MN:VA;0) 2.98150E+02 -101410+43*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(CBCC_A12,CR,MN:VA;0) 2.98150E+02 -36796+20.385*T; \n 6.00000E+03 N REF2 !\n PARAMETER G(CBCC_A12,FE,MG:VA;0) 2.98150E+02 70000; 6.00000E+03 N \n REF29 !\n PARAMETER G(CBCC_A12,FE,MN:VA;0) 2.98150E+02 -10184; 6.00000E+03 N \n REF6 !\n PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -156180+34.81*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -33470-.41*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 +35780-11.08*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CBCC_A12,FE,SI:VA;3) 2.98150E+02 +28800-6.92*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CBCC_A12,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N \n REF29 !\n PARAMETER G(CBCC_A12,MN,SI:VA;0) 2.98150E+02 -142743.62+22.3961*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(CBCC_A12,MN,SI:VA;1) 2.98150E+02 +16440.608-3.5300332*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(CBCC_A12,MN,TI:VA;0) 2.98150E+02 -29500+20*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(CBCC_A12,MN,TI:VA;1) 2.98150E+02 -3635-5*T; 6.00000E+03 \n N REF72 !\n\n\n PHASE CE2MG17 % 2 2 17 !\n CONSTITUENT CE2MG17 :CE : MG : !\n\n PARAMETER G(CE2MG17,CE:MG;0) 2.98150E+02 -217170+104.5*T+2*GHSERCE#\n +17*GHSERMG#; 6.00000E+03 N REF103 !\n\n\n PHASE CE5MG41 % 2 5 41 !\n CONSTITUENT CE5MG41 :CE : MG : !\n\n PARAMETER G(CE5MG41,CE:MG;0) 2.98150E+02 -575000+299*T+5*GHSERCE#\n +41*GHSERMG#; 6.00000E+03 N REF103 !\n\n\n PHASE CE1MG1 % 2 1 1 !\n CONSTITUENT CE1MG1 :CE : MG : !\n\n PARAMETER G(CE1MG1,CE:MG;0) 2.98150E+02 -46000+23.32*T+GHSERCE#+GHSERMG#; \n 6.00000E+03 N REF103 !\n\n\n PHASE CEMG12 % 2 1 12 !\n CONSTITUENT CEMG12 :CE : MG : !\n\n PARAMETER G(CEMG12,CE:MG;0) 2.98150E+02 -139880+84.5*T+GHSERCE#\n +12*GHSERMG#; 6.00000E+03 N REF103 !\n\n\n PHASE CEMG2 % 2 1 2 !\n CONSTITUENT CEMG2 :CE : MG : !\n\n PARAMETER G(CEMG2,CE:MG;0) 2.98150E+02 -52744.6+15.163*T+GHSERCE#\n +2*GHSERMG#; 6.00000E+03 N REF103 !\n\n\n PHASE CEMG3 % 2 1 3 !\n CONSTITUENT CEMG3 :CE : MG : !\n\n PARAMETER G(CEMG3,CE:MG;0) 2.98150E+02 -76800+26.5*T+GHSERCE#\n +3*GHSERMG#; 6.00000E+03 N REF103 !\n\n\n PHASE CR2TI % 2 .645 .355 !\n CONSTITUENT CR2TI :CR : TI : !\n\n PARAMETER G(CR2TI,CR:TI;0) 298.15 UN_ASS; 300 N REF0 !\n\n\n PHASE CR3MN5 % 2 3 5 !\n CONSTITUENT CR3MN5 :CR : MN : !\n\n PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 -72550+21.1732*T+3*GHSERCR#\n +5*GHSERMN#; 6.00000E+03 N REF2 !\n\n\n PHASE CR3SI_A15 % 2 3 1 !\n CONSTITUENT CR3SI_A15 :CR,SI : CR,SI : !\n\n PARAMETER G(CR3SI_A15,CR:CR;0) 2.98150E+02 +20000+10*T+4*GHSERCR#; \n 6.00000E+03 N REF91 !\n PARAMETER G(CR3SI_A15,SI:CR;0) 2.98150E+02 +233507.47-74.15051*T\n +GHSERCR#+3*GHSERSI#; 6.00000E+03 N REF91 !\n PARAMETER G(CR3SI_A15,CR:SI;0) 2.98150E+02 -126369.35+4.15051*T\n +3*GHSERCR#+GHSERSI#; 6.00000E+03 N REF91 !\n PARAMETER G(CR3SI_A15,SI:SI;0) 2.98150E+02 +208000-80*T+4*GHSERSI#; \n 6.00000E+03 N REF91 !\n PARAMETER G(CR3SI_A15,CR,SI:CR;0) 2.98150E+02 -107840.95; 6.00000E+03 \n N REF91 !\n PARAMETER G(CR3SI_A15,CR:CR,SI;0) 2.98150E+02 -13020.93; 6.00000E+03 \n N REF91 !\n PARAMETER G(CR3SI_A15,SI:CR,SI;0) 2.98150E+02 -13020.93; 6.00000E+03 \n N REF91 !\n PARAMETER G(CR3SI_A15,CR,SI:SI;0) 2.98150E+02 -107840.95; 6.00000E+03 \n N REF91 !\n\n\n PHASE CR5SI3 % 2 5 3 !\n CONSTITUENT CR5SI3 :CR : SI : !\n\n PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -316433+1065.82816*T\n -182.578184*T*LN(T)-.023919688*T**2-2.31728E-06*T**3; 6.00000E+03 N \n REF91 !\n\n\n PHASE CR1SI1 % 2 1 1 !\n CONSTITUENT CR1SI1 :CR : SI : !\n\n PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -78732.28+311.58392*T\n -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF91 !\n\n\n PHASE CRSI2 % 2 1 2 !\n CONSTITUENT CRSI2 :CR,SI : CR,SI : !\n\n PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000-T+3*GHSERCR#; \n 6.00000E+03 N REF91 !\n PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +148569.93-12.65342*T+2*GHSERCR#\n +GHSERSI#; 6.00000E+03 N REF91 !\n PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96694.43+333.33835*T\n -57.855747*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF91 !\n PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +78860.26-15.77206*T+3*GHSERSI#; \n 6.00000E+03 N REF91 !\n PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -35879.97+7.17599*T; \n 6.00000E+03 N REF91 !\n PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -35879.97+7.17599*T; \n 6.00000E+03 N REF91 !\n\n\n PHASE CRZN13 % 2 1 13 !\n CONSTITUENT CRZN13 :CR : ZN : !\n\n PARAMETER G(CRZN13,CR:ZN;0) 2.98150E+02 -9800+GHSERCR#+13*GHSERZN#; \n 6.00000E+03 N REF83 !\n\n\n PHASE CRZN17 % 2 1 17 !\n CONSTITUENT CRZN17 :CR : ZN : !\n\n PARAMETER G(CRZN17,CR:ZN;0) 2.98150E+02 -11700+GHSERCR#+17*GHSERZN#; \n 6.00000E+03 N REF83 !\n\n\n PHASE CSI % 2 1 1 !\n CONSTITUENT CSI :C : SI : !\n\n PARAMETER G(CSI,C:SI;0) 2.98150E+02 -88583.96+271.1462*T\n -41.27945*T*LN(T)-.00436266*T**2+800000*T**(-1)+2E-07*T**3; 6.00000E+03 \n N REF60 !\n\n\n PHASE CU10ZR7 % 2 10 7 !\n CONSTITUENT CU10ZR7 :CU : ZR : !\n\n PARAMETER G(CU10ZR7,CU:ZR;0) 2.98150E+02 -241750+10*GHSERCU#+7*GHSERZR#;\n 6.00000E+03 N REF125 !\n\n\n PHASE CU19SI6_ETA % 2 19 6 !\n CONSTITUENT CU19SI6_ETA :CU : SI : !\n\n PARAMETER G(CU19SI6_ETA,CU:SI;0) 2.98150E+02 -137488.5+3119.537*T\n -595.1259*T*LN(T)-.0619575*T**2+2.434E-06*T**3+2057075*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU33SI7_DELTA % 2 33 7 !\n CONSTITUENT CU33SI7_DELTA :CU : SI : !\n\n PARAMETER G(CU33SI7_DELTA,CU:SI;0) 2.98150E+02 -200372.4+4985.675*T\n -955.5312*T*LN(T)-.101066*T**2+4.2396E-06*T**3+2968440*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU4SI_EPSILON % 2 4 1 !\n CONSTITUENT CU4SI_EPSILON :CU : SI : !\n\n PARAMETER G(CU4SI_EPSILON,CU:SI;0) 2.98150E+02 -39974.35+858.5047*T\n -154.6764*T*LN(T)+.01074864*T**2+5.1335E-07*T**3+386580*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU51ZR14 % 2 51 14 !\n CONSTITUENT CU51ZR14 :CU : ZR : !\n\n PARAMETER G(CU51ZR14,CU:ZR;0) 2.98150E+02 -843412.7+51*GHSERCU#\n +14*GHSERZR#; 6.00000E+03 N REF125 !\n\n\n PHASE CU56SI11_GAMMA % 2 56 11 !\n CONSTITUENT CU56SI11_GAMMA :CU : SI : !\n\n PARAMETER G(CU56SI11_GAMMA,CU:SI;0) 2.98150E+02 -455415+9222.496*T\n -1709.412*T*LN(T)-.1698242*T**2+7.19714E-06*T**3+4882290*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU5ZR % 2 5 1 !\n CONSTITUENT CU5ZR :CU : ZR : !\n\n PARAMETER G(CU5ZR,CU:ZR;0) 2.98150E+02 -61794+5*GHSERCU#+GHSERZR#; \n 6.00000E+03 N REF125 !\n\n\n PHASE CU85SI15_BETA % 2 .85 .15 !\n CONSTITUENT CU85SI15_BETA :CU : SI : !\n\n PARAMETER G(CU85SI15_BETA,CU:SI;0) 2.98150E+02 -4021.08+123.92192*T\n -23.920296*T*LN(T)-.00254525*T**2+1.0931E-07*T**3+71106*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU87SI13_KAPPA % 2 .87 .13 !\n CONSTITUENT CU87SI13_KAPPA :CU : SI : !\n\n PARAMETER G(CU87SI13_KAPPA,CU:SI;0) 2.98150E+02 -5368.51+125.36694*T\n -23.945909*T*LN(T)-.00256013*T**2+1.1196E-07*T**3+68623*T**(-1); \n 6.00000E+03 N REF94 !\n\n\n PHASE CU8ZR3 % 2 8 3 !\n CONSTITUENT CU8ZR3 :CU : ZR : !\n\n PARAMETER G(CU8ZR3,CU:ZR;0) 2.98150E+02 -148063.1+8*GHSERCU#+3*GHSERZR#;\n 6.00000E+03 N REF125 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :AL,CR,FE,MN,SI,TI : VA : !\n\n PARAMETER G(CUB_A13,AL:VA;0) 2.98150E+02 +10920.44-4.8116*T+GHSERAL#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 \n N REF1 !\n PARAMETER G(CUB_A13,MN:VA;0) 2.98150E+02 +2314.88+5.936*T\n -1.4203*T*LN(T)+.00151409*T**2+442*T**(-1)+GHSERMN#; 1.51900E+03 Y\n +442.65-.9715*T+2.3107229E+30*T**(-9)+GHSERMN#; 6.00000E+03 N REF1 !\n PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CUB_A13,TI:VA;0) 2.98150E+02 +7531.2+GHSERTI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(CUB_A13,AL,FE,MN:VA;0) 2.98150E+02 13906; 6.00000E+03 N \n REF109 !\n PARAMETER G(CUB_A13,AL,FE,MN:VA;1) 2.98150E+02 13906; 6.00000E+03 N \n REF109 !\n PARAMETER G(CUB_A13,AL,FE,MN:VA;2) 2.98150E+02 13906; 6.00000E+03 N \n REF109 !\n PARAMETER G(CUB_A13,AL,MN:VA;0) 2.98150E+02 -119022+52.507*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(CUB_A13,AL,MN:VA;1) 2.98150E+02 -1763; 6.00000E+03 N \n REF23 !\n PARAMETER G(CUB_A13,CR,MN:VA;0) 2.98150E+02 -31260+16.4919*T; \n 6.00000E+03 N REF2 !\n PARAMETER G(CUB_A13,FE,MN:VA;0) 2.98150E+02 -11518+2.819*T; \n 6.00000E+03 N REF6 !\n PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -156180+34.81*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -33470-.41*T; 6.00000E+03 \n N REF26 !\n PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 +35780-11.08*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CUB_A13,FE,SI:VA;3) 2.98150E+02 +28800-6.92*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(CUB_A13,MN,SI:VA;0) 2.98150E+02 -142343.62+21.89261*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(CUB_A13,MN,SI:VA;1) 2.98150E+02 +16440.608-3.5300332*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(CUB_A13,MN,TI:VA;0) 2.98150E+02 -34000+20*T; 6.00000E+03 \n N REF72 !\n\n\n PHASE CUMG2 % 2 1 2 !\n CONSTITUENT CUMG2 :CU : MG : !\n\n PARAMETER G(CUMG2,CU:MG;0) 2.98150E+02 -28620+1.85973*T+GHSERCU#\n +2*GHSERMG#; 6.00000E+03 N REF20 !\n\n\n PHASE CUZN_EPS % 2 1 1 !\n CONSTITUENT CUZN_EPS :CU,ZN : VA : !\n\n PARAMETER G(CUZN_EPS,CU:VA;0) 2.98150E+02 +GHSERCU#+10; 6.00000E+03 \n N REF70 !\n PARAMETER G(CUZN_EPS,ZN:VA;0) 2.98150E+02 +GFCCZN#; 6.00000E+03 N \n REF70 !\n PARAMETER G(CUZN_EPS,CU,ZN:VA;0) 2.98150E+02 -35433.3+5.24516*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(CUZN_EPS,CU,ZN:VA;1) 2.98150E+02 +25276.81-9.96989*T; \n 6.00000E+03 N REF70 !\n\n\n PHASE CUZN_GAMMA % 4 .15385 .15385 .23076 .46154 !\n CONSTITUENT CUZN_GAMMA :CU,ZN : CU,ZN : CU : ZN : !\n\n PARAMETER G(CUZN_GAMMA,CU:CU:CU:ZN;0) 2.98150E+02 +CUZNK4#\n +.15385*CUZNK5#+.53846*GHSERCU#+.46154*GHSERZN#; 6.00000E+03 N REF70 !\n PARAMETER G(CUZN_GAMMA,ZN:CU:CU:ZN;0) 2.98150E+02 +CUZNK4#\n +.15385*CUZNK5#+.15385*CUZNK6#+.38462*GHSERCU#+.61538*GHSERZN#; \n 6.00000E+03 N REF70 !\n PARAMETER G(CUZN_GAMMA,CU:ZN:CU:ZN;0) 2.98150E+02 +CUZNK4#\n +.38462*GHSERCU#+.61538*GHSERZN#; 6.00000E+03 N REF70 !\n PARAMETER G(CUZN_GAMMA,ZN:ZN:CU:ZN;0) 2.98150E+02 +CUZNK4#\n +.15385*CUZNK6#+.23076*GHSERCU#+.76924*GHSERZN#; 6.00000E+03 N REF70 !\n\n\n PHASE CU1ZR1 % 2 1 1 !\n CONSTITUENT CU1ZR1 :CU : ZR : !\n\n PARAMETER G(CU1ZR1,CU:ZR;0) 2.98150E+02 -20104.24-7.63196*T+GHSERCU#\n +GHSERZR#; 6.00000E+03 N REF125 !\n\n\n PHASE CU1ZR2 % 2 1 2 !\n CONSTITUENT CU1ZR2 :CU : ZR : !\n\n PARAMETER G(CU1ZR2,CU:ZR;0) 2.98150E+02 -43904.01+5.19051*T+GHSERCU#\n +2*GHSERZR#; 6.00000E+03 N REF125 !\n\n\n PHASE DHCP % 1 1.0 !\n CONSTITUENT DHCP :CE,ND : !\n\n PARAMETER G(DHCP,CE;0) 2.98150E+02 -190+.56886*T+GHSERCE#; \n 6.00000E+03 N REF1 !\n PARAMETER G(DHCP,ND;0) 2.98150E+02 +GHSERND#; 6.00000E+03 N REF1 !\n\n\n PHASE DIAMOND_A4 % 1 1.0 !\n CONSTITUENT DIAMOND_A4 :AL,B,C,SI%,SN,TI,ZN : !\n\n PARAMETER G(DIAMOND_A4,AL;0) 2.98150E+02 +30*T+GHSERAL#; 6.00000E+03 \n N REF1 !\n PARAMETER G(DIAMOND_A4,B;0) 2.98150E+02 +GHSERBB#; 6.00000E+03 N \n REF1 !\n PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T\n -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)\n +1.11E+10*T**(-3); 6.00000E+03 N REF1 !\n PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 6.00000E+03 N \n REF1 !\n PARAMETER G(DIAMOND_A4,SN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(DIAMOND_A4,TI;0) 2.98150E+02 +25000+GHSERTI#; 6.00000E+03 \n N REF1 !\n PARAMETER G(DIAMOND_A4,ZN;0) 2.98150E+02 +30*T+GHSERZN#; 6.00000E+03 \n N REF1 !\n PARAMETER G(DIAMOND_A4,AL,SI;0) 2.98150E+02 +111417.7-46.1392*T; \n 6.00000E+03 N REF50 !\n PARAMETER G(DIAMOND_A4,AL,ZN;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF129 !\n PARAMETER G(DIAMOND_A4,B,SI;0) 2.98150E+02 57978.16; 6.00000E+03 N \n REF58 !\n PARAMETER G(DIAMOND_A4,C,SI;0) 2.98150E+02 93386.78; 6.00000E+03 N \n REF60 !\n PARAMETER G(DIAMOND_A4,SI,SN;0) 2.98150E+02 +25265.65+23.84*T; \n 3.00000E+03 N REF94 !\n PARAMETER G(DIAMOND_A4,SI,TI;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF123 !\n PARAMETER G(DIAMOND_A4,SI,ZN;0) 2.98150E+02 +100*T; 6.00000E+03 N \n REF94 !\n\n\n TYPE_DEFINITION ) GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %) 2 1 1 !\n CONSTITUENT FCC_A1 :AL%,B,CE,CR,CU%,FE%,LI,MG,MN,ND,NI,SI,SN,TI,V,Y,ZN,\n ZR : C,N,VA% : !\n\n PARAMETER G(FCC_A1,AL:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,B:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CU:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,FE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,LI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,MG:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,MN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ND:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,NI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,SN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,TI:C;0) 2.98150E+02 +GHSERTIC#; 6.00000E+03 N \n REF111 !\n PARAMETER G(FCC_A1,V:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,Y:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ZN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ZR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,AL:N;0) 2.98150E+02 +80*T; 6.00000E+03 N REF129 !\n PARAMETER G(FCC_A1,B:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,CU:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,FE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,LI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,MG:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,MN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ND:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,NI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,SI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,SN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,TI:N;0) 2.98150E+02 +GHSERTIN#; 6.00000E+03 N \n REF111 !\n PARAMETER G(FCC_A1,V:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,Y:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ZN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ZR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,AL:VA;0) 2.98150E+02 +GHSERAL#; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,B:VA;0) 2.98150E+02 +43514-12.217*T+GHSERBB#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,CE:VA;0) 2.98150E+02 +GHSERCE#; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +7284+.163*T+GHSERCR#; \n 6.00000E+03 N REF1 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,CU:VA;0) 2.98150E+02 +GHSERCU#; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 -236.7+132.416*T\n -24.6643*T*LN(T)-.00375752*T**2-5.8927E-08*T**3+77359*T**(-1); \n 1.81100E+03 Y\n -27097.396+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n REF1 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,LI:VA;0) 2.98150E+02 -108+1.3*T+GHSERLI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,MG:VA;0) 2.98150E+02 +2600-.9*T+GHSERMG#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 -3439.3+131.884*T\n -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N REF1 !\n PARAMETER TC(FCC_A1,MN:VA;0) 2.98150E+02 -1620; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98150E+02 -1.86; 6.00000E+03 N \n REF1 !\n PARAMETER G(FCC_A1,ND:VA;0) 2.98150E+02 +500+GHSERND#; 6.00000E+03 \n N REF1 !\n PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 6.00000E+03 N \n REF1 !\n PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,SN:VA;0) 2.98150E+02 +5510-8.46*T+GHSERSN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,TI:VA;0) 2.98150E+02 +6000-.1*T+GHSERTI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERV#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,Y:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(FCC_A1,ZN:VA;0) 2.98150E+02 +2969.82-1.56968*T+GHSERZN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,ZR:VA;0) 2.98150E+02 +7600-.9*T+GHSERZR#; \n 6.00000E+03 N REF1 !\n PARAMETER G(FCC_A1,AL:C,VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF46 !\n PARAMETER G(FCC_A1,TI:C,VA;0) 2.98150E+02 -85115+6.756*T; 6.00000E+03 \n N REF111 !\n PARAMETER G(FCC_A1,TI:C,VA;1) 2.98150E+02 -129429+31.79*T; \n 6.00000E+03 N REF111 !\n PARAMETER G(FCC_A1,TI:N,VA;0) 2.98150E+02 -47739; 6.00000E+03 N \n REF111 !\n PARAMETER G(FCC_A1,TI:N,VA;1) 2.98150E+02 -9877; 6.00000E+03 N \n REF111 !\n PARAMETER G(FCC_A1,AL,B:VA;0) 2.98150E+02 +12242.44-1.74891*T; \n 6.00000E+03 N REF44 !\n PARAMETER G(FCC_A1,AL,CE:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF129 !\n PARAMETER G(FCC_A1,AL,CR:VA;0) 2.98150E+02 -45900+6*T; 6.00000E+03 \n N REF8 !\n PARAMETER G(FCC_A1,AL,CU:VA;0) 2.98150E+02 -53520+2*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(FCC_A1,AL,CU:VA;1) 2.98150E+02 +38590-2*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(FCC_A1,AL,CU:VA;2) 2.98150E+02 1170; 6.00000E+03 N \n REF72 !\n PARAMETER G(FCC_A1,AL,FE:VA;0) 2.98150E+02 -76066.1+18.6758*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(FCC_A1,AL,FE:VA;1) 2.98150E+02 +21167.4+1.3398*T; \n 6.00000E+03 N REF76 !\n PARAMETER G(FCC_A1,AL,FE,MN:VA;1) 2.98150E+02 -63652; 6.00000E+03 N \n REF109 !\n PARAMETER G(FCC_A1,AL,FE,MN:VA;2) 2.98150E+02 -26753; 6.00000E+03 N \n REF109 !\n PARAMETER G(FCC_A1,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(FCC_A1,AL,LI:VA;1) 2.98150E+02 1E-06; 6.00000E+03 N \n REF105 !\n PARAMETER G(FCC_A1,AL,LI:VA;2) 2.98150E+02 +3000+T; 6.00000E+03 N \n REF105 !\n PARAMETER G(FCC_A1,AL,LI,MG:VA;0) 2.98150E+02 -63650+50*T; \n 6.00000E+03 N REF105 !\n PARAMETER G(FCC_A1,AL,MG:VA;0) 2.98150E+02 +4971-3.5*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(FCC_A1,AL,MG:VA;1) 2.98150E+02 +900+.423*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(FCC_A1,AL,MG:VA;2) 2.98150E+02 950; 6.00000E+03 N REF11 !\n PARAMETER G(FCC_A1,AL,MN:VA;0) 2.98150E+02 -69300+25*T; 6.00000E+03 \n N REF23 !\n PARAMETER G(FCC_A1,AL,MN:VA;1) 2.98150E+02 8800; 6.00000E+03 N \n REF23 !\n PARAMETER G(FCC_A1,AL,SI:VA;0) 2.98150E+02 -3423.91-.09584*T; \n 6.00000E+03 N REF50 !\n PARAMETER G(FCC_A1,AL,SN:VA;0) 2.98150E+02 +45297.84-8.39814*T; \n 6.00000E+03 N REF15 !\n PARAMETER G(FCC_A1,AL,TI:VA;0) 2.98150E+02 -128970+39*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(FCC_A1,AL,TI:VA;1) 2.98150E+02 -5000; 6.00000E+03 N \n REF13 !\n PARAMETER G(FCC_A1,AL,TI:VA;2) 2.98150E+02 20000; 6.00000E+03 N \n REF13 !\n PARAMETER G(FCC_A1,AL,V:VA;0) 2.98150E+02 -69800+15*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(FCC_A1,AL,V:VA;1) 2.98150E+02 -8000; 6.00000E+03 N \n REF13 !\n PARAMETER G(FCC_A1,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N \n REF52 !\n PARAMETER G(FCC_A1,AL,ZN:VA;0) 2.98150E+02 +7297.48+.47512*T; \n 6.00000E+03 N REF78 !\n PARAMETER G(FCC_A1,AL,ZN:VA;1) 2.98150E+02 +6612.88-4.5911*T; \n 6.00000E+03 N REF78 !\n PARAMETER G(FCC_A1,AL,ZN:VA;2) 2.98150E+02 -3097.19+3.30635*T; \n 6.00000E+03 N REF78 !\n PARAMETER G(FCC_A1,AL,ZR:VA;0) 2.98150E+02 -120000+30*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(FCC_A1,AL,ZR:VA;1) 2.98150E+02 -10000; 6.00000E+03 N \n REF74 !\n PARAMETER G(FCC_A1,AL,ZR:VA;2) 2.98150E+02 15000; 6.00000E+03 N \n REF74 !\n PARAMETER G(FCC_A1,CE,MG:VA;0) 2.98150E+02 -15000+.5*T; 6.00000E+03 \n N REF103 !\n PARAMETER G(FCC_A1,CR,CU:VA;0) 2.98150E+02 +53195.87-3.31182*T; \n 6.00000E+03 N REF96 !\n PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; \n 6.00000E+03 N REF2 !\n PARAMETER G(FCC_A1,CR,TI:VA;0) 2.98150E+02 +66300-27.7*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(FCC_A1,CU,FE:VA;0) 2.98150E+02 +48232.565-8.6095425*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(FCC_A1,CU,FE:VA;1) 2.98150E+02 +8861.8816-5.2897513*T; \n 6.00000E+03 N REF85 !\n PARAMETER G(FCC_A1,CU,LI:VA;0) 2.98150E+02 +2750+13*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(FCC_A1,CU,LI:VA;1) 2.98150E+02 -1000; 6.00000E+03 N \n REF74 !\n PARAMETER G(FCC_A1,CU,MG:VA;0) 2.98150E+02 -22279.28+5.868*T; \n 6.00000E+03 N REF20 !\n PARAMETER G(FCC_A1,CU,NI:VA;0) 2.98150E+02 +8047.72+3.42217*T; \n 6.00000E+03 N REF31 !\n PARAMETER G(FCC_A1,CU,NI:VA;1) 2.98150E+02 -2041.3+.99714*T; \n 6.00000E+03 N REF31 !\n PARAMETER TC(FCC_A1,CU,NI:VA;0) 2.98150E+02 -935.5; 6.00000E+03 N \n REF31 !\n PARAMETER TC(FCC_A1,CU,NI:VA;1) 2.98150E+02 -594.9; 6.00000E+03 N \n REF31 !\n PARAMETER BMAGN(FCC_A1,CU,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N \n REF31 !\n PARAMETER BMAGN(FCC_A1,CU,NI:VA;1) 2.98150E+02 -.7316; 6.00000E+03 \n N REF31 !\n PARAMETER BMAGN(FCC_A1,CU,NI:VA;2) 2.98150E+02 -.3174; 6.00000E+03 \n N REF31 !\n PARAMETER G(FCC_A1,CU,SI:VA;0) 2.98150E+02 -34105.96-1.908*T; \n 6.00000E+03 N REF94 !\n PARAMETER G(FCC_A1,CU,ZN:VA;0) 2.98150E+02 -42803.75+10.02258*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(FCC_A1,CU,ZN:VA;1) 2.98150E+02 +2936.39-3.05323*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(FCC_A1,CU,ZN:VA;2) 2.98150E+02 +9034.2-5.39314*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(FCC_A1,CU,ZR:VA;0) 2.98150E+02 2058; 6.00000E+03 N \n REF125 !\n PARAMETER G(FCC_A1,FE,MG:VA;0) 2.98150E+02 65200; 6.00000E+03 N \n REF29 !\n PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 \n N REF6 !\n PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N REF6 !\n PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N \n REF6 !\n PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N \n REF6 !\n PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125247.7+41.166*T; \n 6.00000E+03 N REF26 !\n PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142707.6; 6.00000E+03 N \n REF26 !\n PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907.3; 6.00000E+03 N \n REF26 !\n PARAMETER G(FCC_A1,LI,MG:VA;0) 2.98150E+02 7500; 6.00000E+03 N \n REF105 !\n PARAMETER G(FCC_A1,MG,MN:VA;0) 2.98150E+02 70000; 6.00000E+03 N \n REF29 !\n PARAMETER G(FCC_A1,MG,NI:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF94 !\n PARAMETER G(FCC_A1,MG,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF68 !\n PARAMETER G(FCC_A1,MN,SI:VA;0) 2.98150E+02 -95600+2.94097*T; \n 6.00000E+03 N REF29 !\n PARAMETER G(FCC_A1,MN,SI:VA;1) 2.98150E+02 -7500; 6.00000E+03 N \n REF29 !\n PARAMETER G(FCC_A1,MN,TI:VA;0) 2.98150E+02 -26200+20*T; 6.00000E+03 \n N REF72 !\n PARAMETER G(FCC_A1,SI,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF94 !\n PARAMETER G(FCC_A1,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF100 !\n PARAMETER G(FCC_A1,SN,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF107 !\n PARAMETER G(FCC_A1,TI,V:VA;0) 2.98150E+02 23400; 6.00000E+03 N \n REF13 !\n\n\n PHASE FE2SI % 2 2 1 !\n CONSTITUENT FE2SI :FE : SI : !\n\n PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 -71256.6-10.62*T+2*GHSERFE#\n +GHSERSI#; 6.00000E+03 N REF26 !\n\n\n PHASE FE5SI3 % 2 5 3 !\n CONSTITUENT FE5SI3 :FE : SI : !\n\n PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 -241144+2.16*T+5*GHSERFE#\n +3*GHSERSI#; 6.00000E+03 N REF26 !\n\n\n PHASE FE1SI1 % 2 1 1 !\n CONSTITUENT FE1SI1 :FE : SI : !\n\n PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 -72761.2+4.44*T+GHSERFE#+GHSERSI#;\n 6.00000E+03 N REF26 !\n\n\n PHASE FESI2_H % 2 3 7 !\n CONSTITUENT FESI2_H :FE : SI : !\n\n PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 -196490-9.2*T+3*GHSERFE#\n +7*GHSERSI#; 6.00000E+03 N REF26 !\n\n\n PHASE FESI2_L % 2 1 2 !\n CONSTITUENT FESI2_L :FE : SI : !\n\n PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 -82149+10.44*T+GHSERFE#\n +2*GHSERSI#; 6.00000E+03 N REF26 !\n\n\n PHASE GAMMA_D83 % 3 4 1 8 !\n CONSTITUENT GAMMA_D83 :AL : AL,CU : CU : !\n\n PARAMETER G(GAMMA_D83,AL:AL:CU;0) 2.98150E+02 -300716+390*T-52*T*LN(T)\n +5*GHSERAL#+8*GHSERCU#; 6.00000E+03 N REF72 !\n PARAMETER G(GAMMA_D83,AL:CU:CU;0) 2.98150E+02 -280501+379.6*T\n -52*T*LN(T)+4*GHSERAL#+9*GHSERCU#; 6.00000E+03 N REF72 !\n\n\n PHASE GAMMA_H % 3 4 1 8 !\n CONSTITUENT GAMMA_H :AL : AL,CU : CU : !\n\n PARAMETER G(GAMMA_H,AL:AL:CU;0) 2.98150E+02 -219258-45.5*T+5*GHSERAL#\n +8*GHSERCU#; 6.00000E+03 N REF72 !\n PARAMETER G(GAMMA_H,AL:CU:CU;0) 2.98150E+02 -200460-58.5*T+4*GHSERAL#\n +9*GHSERCU#; 6.00000E+03 N REF72 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :B,C : !\n\n PARAMETER G(GRAPHITE,B;0) 2.98150E+02 +5000+GHSERBB#; 6.00000E+03 N \n REF1 !\n PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#; 6.00000E+03 N REF1 !\n PARAMETER G(GRAPHITE,B,C;0) 2.98150E+02 +34385.95+8.6792*T; \n 6.00000E+03 N REF54 !\n\n\n TYPE_DEFINITION * GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %* 2 1 .5 !\n CONSTITUENT HCP_A3 :AL,CE,CR,CU,FE,LI,MG%,MN,NI,SI,SN,TI%,V,Y,ZN%,ZR% : \n B,C,N,VA% : !\n\n PARAMETER G(HCP_A3,AL:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CE:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CR:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CU:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,FE:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,LI:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MG:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,NI:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SI:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,TI:B;0) 2.98150E+02 -50000+15*T+GHSERTI#+.5*GHSERBB#;\n 6.00000E+03 N REF89 !\n PARAMETER G(HCP_A3,V:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,Y:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZN:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZR:B;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,AL:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CU:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,FE:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,LI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MG:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,NI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,TI:C;0) 2.98150E+02 -1432-4.1241*T+.5*GHSERTI#\n +.5*GHSERTIC#; 6.00000E+03 N REF111 !\n PARAMETER G(HCP_A3,V:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,Y:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZN:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,AL:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,CU:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,FE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,LI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MG:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,MN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,NI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,SN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,TI:N;0) 2.98150E+02 -9888.08-3.0822*T+.5*GHSERTI#\n +.5*GHSERTIN#; 6.00000E+03 N REF111 !\n PARAMETER G(HCP_A3,V:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,Y:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,ZR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,AL:VA;0) 2.98150E+02 +5481-1.8*T+GHSERAL#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,CE:VA;0) 2.98150E+02 +50000+GHSERCE#; 4.00000E+03 \n N REF1 !\n PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#; 6.00000E+03 \n N REF1 !\n PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,CU:VA;0) 2.98150E+02 +600+.2*T+GHSERCU#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE#; 1.81100E+03 Y\n -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#; 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,LI:VA;0) 2.98150E+02 -154+2*T+GHSERLI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,MG:VA;0) 2.98150E+02 +GHSERMG#; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,MN:VA;0) 2.98150E+02 -4439.3+133.007*T\n -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 6.00000E+03 N REF1 !\n PARAMETER TC(HCP_A3,MN:VA;0) 2.98150E+02 -1620; 6.00000E+03 N REF1 !\n PARAMETER BMAGN(HCP_A3,MN:VA;0) 2.98150E+02 -1.86; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,NI:VA;0) 2.98150E+02 +1046+1.2552*T+GHSERNI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,SN:VA;0) 2.98150E+02 +3900-4.4*T+GHSERSN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,TI:VA;0) 2.98150E+02 +GHSERTI#; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERV#; \n 6.00000E+03 N REF1 !\n PARAMETER G(HCP_A3,Y:VA;0) 2.98150E+02 +GHSERY#; 3.70000E+03 N REF1 !\n PARAMETER G(HCP_A3,ZN:VA;0) 2.98150E+02 +GHSERZN#; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,ZR:VA;0) 2.98150E+02 +GHSERZR#; 6.00000E+03 N \n REF1 !\n PARAMETER G(HCP_A3,TI:B,VA;0) 2.98150E+02 -21213.442; 6.00000E+03 N \n REF89 !\n PARAMETER G(HCP_A3,TI:N,VA;0) 2.98150E+02 -4743; 6.00000E+03 N \n REF111 !\n PARAMETER G(HCP_A3,AL,FE:VA;0) 2.98150E+02 -106903+20*T; 6.00000E+03 \n N REF76 !\n PARAMETER G(HCP_A3,AL,LI:VA;0) 2.98150E+02 -27000+8*T; 6.00000E+03 \n N REF105 !\n PARAMETER G(HCP_A3,AL,LI,MG:VA;2) 2.98150E+02 -80000+50*T; \n 6.00000E+03 N REF105 !\n PARAMETER G(HCP_A3,AL,MG:VA;0) 2.98150E+02 +1950-2*T; 6.00000E+03 N \n REF11 !\n PARAMETER G(HCP_A3,AL,MG:VA;1) 2.98150E+02 +1480-2.08*T; 6.00000E+03 \n N REF11 !\n PARAMETER G(HCP_A3,AL,MG:VA;2) 2.98150E+02 3500; 6.00000E+03 N \n REF11 !\n PARAMETER G(HCP_A3,AL,MN:VA;0) 2.98150E+02 -108066+43.83*T; \n 6.00000E+03 N REF23 !\n PARAMETER G(HCP_A3,AL,MN:VA;1) 2.98150E+02 -54519.6+40*T; 6.00000E+03 \n N REF23 !\n PARAMETER G(HCP_A3,AL,SN:VA;0) 2.98150E+02 1E-05; 6.00000E+03 N \n REF15 !\n PARAMETER G(HCP_A3,AL,TI:VA;0) 2.98150E+02 -133500+39*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(HCP_A3,AL,TI:VA;1) 2.98150E+02 750; 6.00000E+03 N REF13 !\n PARAMETER G(HCP_A3,AL,TI:VA;2) 2.98150E+02 17500; 6.00000E+03 N \n REF13 !\n PARAMETER G(HCP_A3,AL,V:VA;0) 2.98150E+02 -95000+20*T; 6.00000E+03 \n N REF13 !\n PARAMETER G(HCP_A3,AL,V:VA;1) 2.98150E+02 -6000; 6.00000E+03 N \n REF13 !\n PARAMETER G(HCP_A3,AL,Y:VA;0) 2.98150E+02 +90*T; 6.00000E+03 N \n REF52 !\n PARAMETER G(HCP_A3,AL,ZN:VA;0) 2.98150E+02 +18820.95-8.95255*T; \n 6.00000E+03 N REF78 !\n PARAMETER G(HCP_A3,AL,ZN:VA;1) 2.98150E+02 +1E-06; 6.00000E+03 N \n REF78 !\n PARAMETER G(HCP_A3,AL,ZN:VA;2) 2.98150E+02 +1E-06; 6.00000E+03 N \n REF78 !\n PARAMETER G(HCP_A3,AL,ZN:VA;3) 2.98150E+02 -702.79; 6.00000E+03 N \n REF78 !\n PARAMETER G(HCP_A3,AL,ZR:VA;0) 2.98150E+02 -122300+32*T; 6.00000E+03 \n N REF74 !\n PARAMETER G(HCP_A3,AL,ZR:VA;1) 2.98150E+02 -8000; 6.00000E+03 N \n REF74 !\n PARAMETER G(HCP_A3,AL,ZR:VA;2) 2.98150E+02 17000; 6.00000E+03 N \n REF74 !\n PARAMETER G(HCP_A3,CE,MG:VA;0) 2.98150E+02 -94337.51+79.95155*T; \n 6.00000E+03 N REF103 !\n PARAMETER G(HCP_A3,CR,CU:VA;0) 2.98150E+02 +81100-25*T; 6.00000E+03 \n N REF96 !\n PARAMETER G(HCP_A3,CR,MG:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF83 !\n PARAMETER G(HCP_A3,CR,MN:VA;0) 2.98150E+02 41800; 6.00000E+03 N \n REF2 !\n PARAMETER G(HCP_A3,CR,TI:VA;0) 2.98150E+02 32500; 6.00000E+03 N \n REF72 !\n PARAMETER G(HCP_A3,CR,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF83 !\n PARAMETER G(HCP_A3,CR,ZR:VA;0) 2.98150E+02 15800; 6.00000E+03 N \n REF98 !\n PARAMETER G(HCP_A3,CU,LI:VA;0) 2.98150E+02 +2042+10.9617*T; \n 6.00000E+03 N REF74 !\n PARAMETER G(HCP_A3,CU,MG:VA;0) 2.98150E+02 +184.5*T; 6.00000E+03 N \n REF20 !\n PARAMETER G(HCP_A3,CU,NI:VA;0) 2.98150E+02 +12048.61+1.29893*T; \n 6.00000E+03 N BO2021 !\n PARAMETER G(HCP_A3,CU,ZN:VA;0) 2.98150E+02 -14432.17-10.7814*T; \n 6.00000E+03 N REF70 !\n PARAMETER G(HCP_A3,CU,ZR:VA;0) 2.98150E+02 5668.425; 6.00000E+03 N \n REF125 !\n PARAMETER G(HCP_A3,FE,MG:VA;0) 2.98150E+02 92400; 6.00000E+03 N \n REF29 !\n PARAMETER G(HCP_A3,FE,MN:VA;0) 2.98150E+02 -5582+3.865*T; 6.00000E+03 \n N REF6 !\n PARAMETER G(HCP_A3,FE,MN:VA;1) 2.98150E+02 273; 6.00000E+03 N REF6 !\n PARAMETER G(HCP_A3,LI,MG:VA;0) 2.98150E+02 -6856; 6.00000E+03 N \n REF105 !\n PARAMETER G(HCP_A3,LI,MG:VA;1) 2.98150E+02 4000; 6.00000E+03 N \n REF105 !\n PARAMETER G(HCP_A3,LI,MG:VA;2) 2.98150E+02 4000; 6.00000E+03 N \n REF105 !\n PARAMETER G(HCP_A3,LI,ZR:VA;0) 2.98150E+02 200000; 6.00000E+03 N \n REF74 !\n PARAMETER G(HCP_A3,MG,MN:VA;0) 2.98150E+02 +32985+2.5*T; 6.00000E+03 \n N REF29 !\n PARAMETER G(HCP_A3,MG,NI:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF94 !\n PARAMETER G(HCP_A3,MG,SI:VA;0) 2.98150E+02 -5063.7+.63297*T; \n 6.00000E+03 N REF62 !\n PARAMETER G(HCP_A3,MG,Y:VA;0) 2.98150E+02 -16582.94+4.77482*T; \n 6.00000E+03 N REF64 !\n PARAMETER G(HCP_A3,MG,Y:VA;1) 2.98150E+02 -7077.87; 6.00000E+03 N \n REF64 !\n PARAMETER G(HCP_A3,MG,ZN:VA;0) 2.98150E+02 -1600.77+7.62441*T; \n 6.00000E+03 N REF33 !\n PARAMETER G(HCP_A3,MG,ZN:VA;1) 2.98150E+02 -3823.03+8.02575*T; \n 6.00000E+03 N REF33 !\n PARAMETER G(HCP_A3,MG,ZR:VA;0) 2.98150E+02 +42063.55+1.01789*T; \n 6.00000E+03 N REF68 !\n PARAMETER G(HCP_A3,MG,ZR:VA;1) 2.98150E+02 -2885.9; 6.00000E+03 N \n REF68 !\n PARAMETER G(HCP_A3,MN,TI:VA;0) 2.98150E+02 22100; 6.00000E+03 N \n REF72 !\n PARAMETER G(HCP_A3,SI,TI:VA;0) 2.98150E+02 -302731.04+69.08469*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(HCP_A3,SI,TI:VA;1) 2.98150E+02 +25025.35-2.00203*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(HCP_A3,SI,TI:VA;2) 2.98150E+02 +83940.65-6.71526*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(HCP_A3,SI,Y:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF66 !\n PARAMETER G(HCP_A3,SI,ZN:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF94 !\n PARAMETER G(HCP_A3,SI,ZR:VA;0) 2.98150E+02 +80*T; 6.00000E+03 N \n REF100 !\n PARAMETER G(HCP_A3,SN,TI:VA;0) 2.98150E+02 -111502.08+1.8068*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(HCP_A3,SN,TI:VA;1) 2.98150E+02 +43871.41+2.08175*T; \n 3.00000E+03 N REF39 !\n PARAMETER G(HCP_A3,SN,ZN:VA;0) 2.98150E+02 +33438.94-11.14466*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(HCP_A3,TI,V:VA;0) 2.98150E+02 20000; 6.00000E+03 N \n REF13 !\n\n\n PHASE HIGH_SIGMA % 3 8 4 18 !\n CONSTITUENT HIGH_SIGMA :MN : CR : CR,MN : !\n\n PARAMETER G(HIGH_SIGMA,MN:CR:CR;0) 2.98150E+02 -192369+152.4742*T\n +8*GFCCMN#+22*GHSERCR#; 6.00000E+03 N REF2 !\n PARAMETER G(HIGH_SIGMA,MN:CR:MN;0) 2.98150E+02 +18*GBCCMN#-74263\n -10.7082*T+8*GFCCMN#+4*GHSERCR#; 6.00000E+03 N REF2 !\n PARAMETER G(HIGH_SIGMA,MN:CR:CR,MN;0) 2.98150E+02 90000; 6.00000E+03 \n N REF2 !\n\n\n PHASE LAVES_C14 % 2 2 1 !\n CONSTITUENT LAVES_C14 :CR%,MN,TI,ZR : CR,MN,TI,ZR% : !\n\n PARAMETER G(LAVES_C14,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; \n 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C14,MN:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,TI:CR;0) 2.98150E+02 +2*GLAVTI#+GLAVCR#; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C14,ZR:CR;0) 2.98150E+02 +8114+11.652*T+30000\n +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C14,CR:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,MN:MN;0) 2.98150E+02 +3000+3*GHSERMN#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LAVES_C14,TI:MN;0) 2.98150E+02 +3000+GHSERMN#+2*GHSERTI#; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C14,ZR:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,CR:TI;0) 2.98150E+02 -1440-6.75*T+GHSERTI#\n +2*GHSERCR#; 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C14,MN:TI;0) 2.98150E+02 -26400+2*GHSERMN#+GHSERTI#; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C14,TI:TI;0) 2.98150E+02 +15000+3*GHSERTI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LAVES_C14,ZR:TI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,CR:ZR;0) 2.98150E+02 -8114-11.652*T+2*GHSERCR#\n +GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C14,MN:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,TI:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C14,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; \n 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C14,CR,TI:CR;0) 2.98150E+02 60000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,CR,ZR:CR;0) 2.98150E+02 52299; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C14,CR:CR,TI;0) 2.98150E+02 60000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,CR:CR,ZR;0) 2.98150E+02 26060; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C14,TI:CR,TI;0) 2.98150E+02 60000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,ZR:CR,ZR;0) 2.98150E+02 26060; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C14,MN,TI:MN;0) 2.98150E+02 27000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,MN:MN,TI;0) 2.98150E+02 15000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,TI:MN,TI;0) 2.98150E+02 15000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,CR,TI:TI;0) 2.98150E+02 60000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,MN,TI:TI;0) 2.98150E+02 27000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C14,CR,ZR:ZR;0) 2.98150E+02 52299; 6.00000E+03 N \n REF98 !\n\n\n PHASE LAVES_C15 % 2 2 1 !\n CONSTITUENT LAVES_C15 :AL,CR%,CU%,MG,TI,ZR : CE,CR,CU,MG%,ND,TI,ZR : !\n\n PARAMETER G(LAVES_C15,AL:CE;0) 2.98150E+02 -150000+45.66405*T\n +2*GHSERAL#+GHSERCE#; 6.00000E+03 N REF103 !\n PARAMETER G(LAVES_C15,CR:CE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CU:CE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,MG:CE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,TI:CE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,ZR:CE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,AL:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LAVES_C15,CU:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,MG:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,TI:CR;0) 2.98150E+02 +2*GLAVTI#+GLAVCR#; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C15,ZR:CR;0) 2.98150E+02 +87272.834-29.915156*T+30000\n +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C15,AL:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CR:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CU:CU;0) 2.98150E+02 +21014.88+3*GHSERCU#; \n 6.00000E+03 N REF20 !\n PARAMETER G(LAVES_C15,MG:CU;0) 2.98150E+02 +105000-16.5*T+2*GHSERMG#\n +GHSERCU#; 6.00000E+03 N REF20 !\n PARAMETER G(LAVES_C15,TI:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,ZR:CU;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,AL:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CR:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CU:MG;0) 2.98150E+02 -54720.03+364.76678*T\n -69.27641*T*LN(T)-5.19246E-04*T**2+143502*T**(-1)-5.65953E-06*T**3; \n 6.00000E+03 N REF20 !\n PARAMETER G(LAVES_C15,MG:MG;0) 2.98150E+02 +27359.33+3*GHSERMG#; \n 6.00000E+03 N REF20 !\n PARAMETER G(LAVES_C15,TI:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,ZR:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,AL:ND;0) 2.98150E+02 -165400+26.1*T+2*GHSERAL#\n +GHSERND#; 6.00000E+03 N REF80 !\n PARAMETER G(LAVES_C15,CR:ND;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CU:ND;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,MG:ND;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,TI:ND;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,ZR:ND;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,AL:TI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CR:TI;0) 2.98150E+02 -1780-6.3*T+2*GHSERCR#\n +GHSERTI#; 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C15,CU:TI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,MG:TI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,TI:TI;0) 2.98150E+02 +15000+3*GHSERTI#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LAVES_C15,ZR:TI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,AL:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,CR:ZR;0) 2.98150E+02 -87272.834+29.915156*T\n +2*GHSERCR#+GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C15,CU:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,MG:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,TI:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C15,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; \n 6.00000E+03 N REF1 !\n PARAMETER G(LAVES_C15,CR,TI:CR;0) 2.98150E+02 +10800+27*T; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C15,CR,ZR:CR;0) 2.98150E+02 70327.735; 6.00000E+03 \n N REF98 !\n PARAMETER G(LAVES_C15,CR:CR,TI;0) 2.98150E+02 50000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C15,CR:CR,ZR;0) 2.98150E+02 62909.158; 6.00000E+03 \n N REF98 !\n PARAMETER G(LAVES_C15,TI:CR,TI;0) 2.98150E+02 50000; 6.00000E+03 N \n REF72 !\n PARAMETER G(LAVES_C15,ZR:CR,ZR;0) 2.98150E+02 62909.158; 6.00000E+03 \n N REF98 !\n PARAMETER G(LAVES_C15,CR,TI:TI;0) 2.98150E+02 +10800+27*T; \n 6.00000E+03 N REF72 !\n PARAMETER G(LAVES_C15,CR,ZR:ZR;0) 2.98150E+02 70327.735; 6.00000E+03 \n N REF98 !\n\n\n PHASE LAVES_C36 % 2 2 1 !\n CONSTITUENT LAVES_C36 :CR%,NI,ZR : CR,MG,ZR% : !\n\n PARAMETER G(LAVES_C36,CR:CR;0) 2.98150E+02 +15000+3*GHSERCR#; \n 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C36,NI:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C36,ZR:CR;0) 2.98150E+02 +70026-20.901*T+30000\n +GHSERCR#+2*GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C36,CR:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C36,NI:MG;0) 2.98150E+02 -74136+293.9216*T\n -54.35385*T*LN(T)-.03329235*T**2-99*T**(-1)+5.14203E-06*T**3; \n 6.00000E+03 N REF94 !\n PARAMETER G(LAVES_C36,ZR:MG;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C36,CR:ZR;0) 2.98150E+02 -70026+20.901*T+2*GHSERCR#\n +GHSERZR#; 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C36,NI:ZR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(LAVES_C36,ZR:ZR;0) 2.98150E+02 +15000+3*GHSERZR#; \n 6.00000E+03 N REF98 !\n PARAMETER G(LAVES_C36,CR,ZR:CR;0) 2.98150E+02 52614; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C36,CR:CR,ZR;0) 2.98150E+02 29399; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C36,ZR:CR,ZR;0) 2.98150E+02 29399; 6.00000E+03 N \n REF98 !\n PARAMETER G(LAVES_C36,CR,ZR:ZR;0) 2.98150E+02 52614; 6.00000E+03 N \n REF98 !\n\n\n PHASE MG24Y5 % 2 24 5 !\n CONSTITUENT MG24Y5 :MG : MG,Y : !\n\n PARAMETER G(MG24Y5,MG:MG;0) 2.98150E+02 +44506.01+29*GHSERMG#; \n 6.00000E+03 N REF64 !\n PARAMETER G(MG24Y5,MG:Y;0) 2.98150E+02 -227282.28+36.52985*T\n +24*GHSERMG#+5*GHSERY#; 6.00000E+03 N REF64 !\n\n\n PHASE MG2NI % 2 2 1 !\n CONSTITUENT MG2NI :MG : NI : !\n\n PARAMETER G(MG2NI,MG:NI;0) 2.98150E+02 -82211.2+571.0183*T\n -95.992*T*LN(T); 6.00000E+03 N REF94 !\n\n\n PHASE MG2SI % 2 2 1 !\n CONSTITUENT MG2SI :MG : SI : !\n\n PARAMETER G(MG2SI,MG:SI;0) 2.98150E+02 -82500+348*T-62.46*T*LN(T)\n -.0096*T**2; 6.00000E+03 N REF62 !\n\n\n PHASE MG2SN % 2 2 1 !\n CONSTITUENT MG2SN :MG : SN : !\n\n PARAMETER G(MG2SN,MG:SN;0) 298.15 UN_ASS; 300 N REF0 !\n\n\n PHASE MG2Y % 2 2 1 !\n CONSTITUENT MG2Y :MG : Y : !\n\n PARAMETER G(MG2Y,MG:Y;0) 2.98150E+02 -39075.78+6.51258*T+2*GHSERMG#\n +GHSERY#; 6.00000E+03 N REF0 !\n\n\n PHASE MG2ZN11 % 2 2 11 !\n CONSTITUENT MG2ZN11 :MG : ZN : !\n\n PARAMETER G(MG2ZN11,MG:ZN;0) 2.98150E+02 -75699.65+25.262*T+2*GHSERMG#\n +11*GHSERZN#; 6.00000E+03 N REF33 !\n\n\n PHASE MG2ZN3 % 2 2 3 !\n CONSTITUENT MG2ZN3 :MG : ZN : !\n\n PARAMETER G(MG2ZN3,MG:ZN;0) 2.98150E+02 -55070+18.35755*T+2*GHSERMG#\n +3*GHSERZN#; 6.00000E+03 N REF33 !\n\n\n PHASE MG7ZN3 % 2 51 20 !\n CONSTITUENT MG7ZN3 :MG : ZN : !\n\n PARAMETER G(MG7ZN3,MG:ZN;0) 2.98150E+02 -341794+71*T+51*GHSERMG#\n +20*GHSERZN#; 6.00000E+03 N REF33 !\n\n\n PHASE MGY_GAMMA % 2 1 1 !\n CONSTITUENT MGY_GAMMA :MG : MG,Y : !\n\n PARAMETER G(MGY_GAMMA,MG:MG;0) 2.98150E+02 +9891.48+2*GHSERMG#; \n 6.00000E+03 N REF64 !\n PARAMETER G(MGY_GAMMA,MG:Y;0) 2.98150E+02 -32162.76+8*T+GHSERMG#\n +GHSERY#; 6.00000E+03 N REF64 !\n\n\n PHASE MG1ZN1 % 2 12 13 !\n CONSTITUENT MG1ZN1 :MG : ZN : !\n\n PARAMETER G(MG1ZN1,MG:ZN;0) 2.98150E+02 -239761+79.92025*T+12*GHSERMG#\n +13*GHSERZN#; 6.00000E+03 N REF33 !\n\n\n PHASE MGZN2 % 2 1 2 !\n CONSTITUENT MGZN2 :MG : ZN : !\n\n PARAMETER G(MGZN2,MG:ZN;0) 2.98150E+02 -35048.16+10.60683*T+GHSERMG#\n +2*GHSERZN#; 6.00000E+03 N REF33 !\n\n\n PHASE MN11SI19 % 2 11 19 !\n CONSTITUENT MN11SI19 :MN : SI : !\n\n PARAMETER G(MN11SI19,MN:SI;0) 2.98150E+02 -636300.49+1624.9288*T\n -378.69397*T*LN(T)-.16391259*T**2-15432618*T**(-1); 6.00000E+03 N \n REF29 !\n\n\n PHASE MN3SI % 2 3 1 !\n CONSTITUENT MN3SI :MN : SI : !\n\n PARAMETER G(MN3SI,MN:SI;0) 2.98150E+02 -124189.87+782.4373*T\n -131.682*T*LN(T)-.007770061*T**2+1657200*T**(-1); 9.50000E+02 Y\n -119740.6+777.7538*T-131.682*T*LN(T)-.007770061*T**2+1657200*T**(-1); \n 6.00000E+03 N REF29 !\n\n\n PHASE MN3TI % 2 3 1 !\n CONSTITUENT MN3TI :MN : TI : !\n\n PARAMETER G(MN3TI,MN:TI;0) 2.98150E+02 -18552-9.12*T+3*GHSERMN#\n +GHSERTI#; 6.00000E+03 N REF72 !\n\n\n PHASE MN4TI % 2 .815 .185 !\n CONSTITUENT MN4TI :MN : TI : !\n\n PARAMETER G(MN4TI,MN:TI;0) 2.98150E+02 -2445-2.9*T+.815*GHSERMN#\n +.185*GHSERTI#; 6.00000E+03 N REF72 !\n\n\n PHASE MN5SI3 % 2 5 3 !\n CONSTITUENT MN5SI3 :MN : SI : !\n\n PARAMETER G(MN5SI3,MN:SI;0) 2.98150E+02 -261930.32+1170.7779*T\n -211.15016*T*LN(T)-.01529344*T**2-149263.11*T**(-1); 6.00000E+03 N \n REF29 !\n\n\n PHASE MN6SI % 2 17 3 !\n CONSTITUENT MN6SI :MN : SI : !\n\n PARAMETER G(MN6SI,MN:SI;0) 2.98150E+02 -250180.6+84.8444*T\n -.02850984*T**2-12.07755*T*LN(T)+7514*T**(-1)+17*GHSERMN#+3*GHSERSI#; \n 1.51900E+03 Y\n -282008.6-32.58304*T+12.06754*T*LN(T)-.05879165*T**2+3.928228E+31*T**(-9)\n +17*GHSERMN#+3*GHSERSI#; 6.00000E+03 N REF29 !\n\n\n PHASE MN9SI2 % 2 33 7 !\n CONSTITUENT MN9SI2 :MN : SI : !\n\n PARAMETER G(MN9SI2,MN:SI;0) 2.98150E+02 -578208.4+381.294*T\n -56.86988*T*LN(T)-.0500355*T**2+1458600*T**(-1)+33*GHSERMN#+7*GHSERSI#; \n 1.51900E+03 Y\n -639992+153.3464*T-10*T*LN(T)-.1*T**2+7.625384E+31*T**(-9)+33*GHSERMN#\n +7*GHSERSI#; 6.00000E+03 N REF29 !\n\n\n PHASE MNSI % 2 1 1 !\n CONSTITUENT MNSI :MN : SI : !\n\n PARAMETER G(MNSI,MN:SI;0) 2.98150E+02 -78135.144+308.2488*T\n -52.42121*T*LN(T)-.006903355*T**2+876442.9*T**(-1); 6.00000E+03 N \n REF29 !\n\n\n PHASE OMEGA % 1 1.0 !\n CONSTITUENT OMEGA :ZR : !\n\n PARAMETER G(OMEGA,ZR;0) 2.98150E+02 -8878.082+144.432234*T\n -26.8556*T*LN(T)-.002799446*T**2+38376*T**(-1); 2.12800E+03 Y\n -29500.524+265.290858*T-42.144*T*LN(T)+7.17445E+31*T**(-9); 6.00000E+03 \n N REF1 !\n\n\n PHASE SI2TI % 2 2 1 !\n CONSTITUENT SI2TI :SI : TI : !\n\n PARAMETER G(SI2TI,SI:TI;0) 2.98150E+02 -175038.5+4.548*T+GHSERTI#\n +2*GHSERSI#; 6.00000E+03 N REF123 !\n\n\n PHASE SI2V % 2 2 1 !\n CONSTITUENT SI2V :SI : V : !\n\n PARAMETER G(SI2V,SI:V;0) 2.98150E+02 -143160+401.98*T-67.8*T*LN(T)\n -.0075*T**2+330000*T**(-1); 6.00000E+03 N REF117 !\n\n\n PHASE SI2Y_H % 2 2 1 !\n CONSTITUENT SI2Y_H :SI : Y : !\n\n PARAMETER G(SI2Y_H,SI:Y;0) 2.98150E+02 -214632+28.5*T+2*GHSERSI#\n +GHSERY#; 6.00000E+03 N REF66 !\n\n\n PHASE SI2Y_R % 2 2 1 !\n CONSTITUENT SI2Y_R :SI : Y : !\n\n PARAMETER G(SI2Y_R,SI:Y;0) 2.98150E+02 -219201+31.5*T+2*GHSERSI#\n +GHSERY#; 6.00000E+03 N REF66 !\n\n\n PHASE SI2ZR1 % 2 2 1 !\n CONSTITUENT SI2ZR1 :SI : ZR : !\n\n PARAMETER G(SI2ZR1,SI:ZR;0) 2.98150E+02 -189332.05+354.93695*T\n -63.16867*T*LN(T)-.00767745*T**2+139751.1*T**(-1)-1.97204833E-11*T**3; \n 6.00000E+03 N REF100 !\n\n\n PHASE SI2ZR3 % 2 2 3 !\n CONSTITUENT SI2ZR3 :SI : ZR : !\n\n PARAMETER G(SI2ZR3,SI:ZR;0) 2.98150E+02 -493990.62+844.44793*T\n -140.103*T*LN(T)-.003701*T**2+1.02833333E-07*T**3+1167755*T**(-1); \n 6.00000E+03 N REF100 !\n\n\n PHASE SI3TI5 % 3 2 3 3 !\n CONSTITUENT SI3TI5 :SI,TI : SI,TI : TI : !\n\n PARAMETER G(SI3TI5,SI:SI:TI;0) 2.98150E+02 -206191.45+16.49531*T\n +5*GHSERSI#+3*GHSERTI#; 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,TI:SI:TI;0) 2.98150E+02 -583564.31+2.68514*T\n +5*GHSERTI#+3*GHSERSI#; 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,SI:TI:TI;0) 2.98150E+02 +417372.85+33.81017*T\n +2*GHSERSI#+6*GHSERTI#; 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,TI:TI:TI;0) 2.98150E+02 +40000+20*T+8*GHSERTI#; \n 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,SI,TI:SI:TI;0) 2.98150E+02 -500000+40*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,SI:SI,TI:TI;0) 2.98150E+02 +43024.29-3.44194*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,TI:SI,TI:TI;0) 2.98150E+02 +43024.29-3.44194*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(SI3TI5,SI,TI:TI:TI;0) 2.98150E+02 -500000+40*T; \n 6.00000E+03 N REF123 !\n\n\n PHASE SI3V5 % 2 3 5 !\n CONSTITUENT SI3V5 :SI : V : !\n\n PARAMETER G(SI3V5,SI:V;0) 2.98150E+02 -504000+1259.03*T-211.04*T*LN(T)\n -.00748*T**2+1680000*T**(-1); 6.00000E+03 N REF117 !\n\n\n PHASE SI3Y5 % 2 3 5 !\n CONSTITUENT SI3Y5 :SI : Y : !\n\n PARAMETER G(SI3Y5,SI:Y;0) 2.98150E+02 -588000+76*T+3*GHSERSI#+5*GHSERY#;\n 6.00000E+03 N REF66 !\n\n\n PHASE SI3ZR5 % 2 3 5 !\n CONSTITUENT SI3ZR5 :SI : ZR : !\n\n PARAMETER G(SI3ZR5,SI:ZR;0) 2.98150E+02 -685146.78+1044.78*T\n -187*T*LN(T)-.0161754*T**2+5.22283E-08*T**3+381210*T**(-1); 6.00000E+03 \n N REF100 !\n\n\n PHASE SI4TI5 % 2 4 5 !\n CONSTITUENT SI4TI5 :SI : TI : !\n\n PARAMETER G(SI4TI5,SI:TI;0) 2.98150E+02 -711000+22.37355*T+4*GHSERSI#\n +5*GHSERTI#; 6.00000E+03 N REF123 !\n\n\n PHASE SI4Y5 % 2 4 5 !\n CONSTITUENT SI4Y5 :SI : Y : !\n\n PARAMETER G(SI4Y5,SI:Y;0) 2.98150E+02 -697950+86.72688*T+4*GHSERSI#\n +5*GHSERY#; 6.00000E+03 N REF66 !\n\n\n PHASE SI4ZR5 % 2 4 5 !\n CONSTITUENT SI4ZR5 :SI : ZR : !\n\n PARAMETER G(SI4ZR5,SI:ZR;0) 2.98150E+02 -880743.11+1433.658*T\n -240.256*T*LN(T)-.0109481*T**2+6.59118333E-07*T**3+2006425*T**(-1); \n 6.00000E+03 N REF100 !\n\n\n PHASE SI5V6 % 2 5 6 !\n CONSTITUENT SI5V6 :SI : V : !\n\n PARAMETER G(SI5V6,SI:V;0) 2.98150E+02 -641675+1665.98*T-280.28*T*LN(T)\n -.013915*T**2+2310000*T**(-1); 6.00000E+03 N REF117 !\n\n\n PHASE SI5Y3_H % 2 5 3 !\n CONSTITUENT SI5Y3_H :SI : Y : !\n\n PARAMETER G(SI5Y3_H,SI:Y;0) 2.98150E+02 -601572+76*T+5*GHSERSI#\n +3*GHSERY#; 6.00000E+03 N REF66 !\n\n\n PHASE SI5Y3_R % 2 5 3 !\n CONSTITUENT SI5Y3_R :SI : Y : !\n\n PARAMETER G(SI5Y3_R,SI:Y;0) 2.98150E+02 -607356+84*T+5*GHSERSI#\n +3*GHSERY#; 6.00000E+03 N REF66 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :MN : CR : CR,MN : !\n\n PARAMETER G(SIGMA,MN:CR:CR;0) 2.98150E+02 +65859.5+8*GFCCMN#\n +22*GHSERCR#; 6.00000E+03 N REF2 !\n PARAMETER G(SIGMA,MN:CR:MN;0) 2.98150E+02 -172946+69.0245*T+8*GFCCMN#\n +4*GHSERCR#+18*GBCCMN#; 6.00000E+03 N REF2 !\n PARAMETER G(SIGMA,MN:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; \n 6.00000E+03 N REF2 !\n\n\n PHASE SI1TI1 % 2 1 1 !\n CONSTITUENT SI1TI1 :SI : TI : !\n\n PARAMETER G(SI1TI1,SI:TI;0) 2.98150E+02 -155061.7+7.6345*T+GHSERSI#\n +GHSERTI#; 6.00000E+03 N REF123 !\n\n\n PHASE SITI3 % 2 1 3 !\n CONSTITUENT SITI3 :SI : TI : !\n\n PARAMETER G(SITI3,SI:TI;0) 2.98150E+02 -200000+3.19924*T+GHSERSI#\n +3*GHSERTI#; 6.00000E+03 N REF123 !\n\n\n PHASE SIV3 % 2 1 3 !\n CONSTITUENT SIV3 :SI%,V : SI,V% : !\n\n PARAMETER G(SIV3,SI:SI;0) 2.98150E+02 +208000-80*T+4*GHSERSI#; \n 6.00000E+03 N REF117 !\n PARAMETER G(SIV3,V:SI;0) 2.98150E+02 +166000-60*T+3*GHSERSI#+GHSERV#; \n 6.00000E+03 N REF117 !\n PARAMETER G(SIV3,SI:V;0) 2.98150E+02 -216397+516.532*T-90.44*T*LN(T)\n -.008346*T**2+358000*T**(-1); 6.00000E+03 N REF117 !\n PARAMETER G(SIV3,V:V;0) 2.98150E+02 +18000+10*T+4*GHSERV#; \n 6.00000E+03 N REF117 !\n PARAMETER G(SIV3,SI,V:SI;0) 2.98150E+02 +9794.5-21.8*T; 3.00000E+03 N \n REF117 !\n PARAMETER G(SIV3,SI:SI,V;0) 2.98150E+02 -150000; 3.00000E+03 N REF117 !\n PARAMETER G(SIV3,V:SI,V;0) 2.98150E+02 0.0 ; 3.00000E+03 N REF117 !\n PARAMETER G(SIV3,SI,V:V;0) 2.98150E+02 +9794.5-21.8*T; 3.00000E+03 N \n REF117 !\n\n\n PHASE SIY % 2 1 1 !\n CONSTITUENT SIY :SI : Y : !\n\n PARAMETER G(SIY,SI:Y;0) 2.98150E+02 -160700+19.8*T+GHSERSI#+GHSERY#; \n 6.00000E+03 N REF66 !\n\n\n PHASE SI1ZR1 % 2 1 1 !\n CONSTITUENT SI1ZR1 :SI : ZR : !\n\n PARAMETER G(SI1ZR1,SI:ZR;0) 2.98150E+02 -182203.4+258.51454*T\n -45.18631*T*LN(T)-.004393865*T**2+5.49699E-11*T**3+148517.5*T**(-1); \n 6.00000E+03 N REF100 !\n\n\n PHASE SIZR2 % 2 1 2 !\n CONSTITUENT SIZR2 :SI : ZR : !\n\n PARAMETER G(SIZR2,SI:ZR;0) 2.98150E+02 -255317.83+411.76673*T\n -72.43244*T*LN(T)-.00546177*T**2-4.0442633E-09*T**3+306730.45*T**(-1); \n 6.00000E+03 N REF100 !\n\n\n PHASE SIZR3 % 2 1 3 !\n CONSTITUENT SIZR3 :SI : ZR : !\n\n PARAMETER G(SIZR3,SI:ZR;0) 2.98150E+02 -270398.16+457.33*T\n -82.328*T*LN(T)-.0263963*T**2+1.54326E-06*T**3-34700*T**(-1); \n 6.00000E+03 N REF100 !\n\n\n PHASE SN3TI5 % 2 3 5 !\n CONSTITUENT SN3TI5 :SN : TI : !\n\n PARAMETER G(SN3TI5,SN:TI;0) 2.98150E+02 -398000+64.8*T+3*GLIQSN#\n +5*GLIQTI#; 3.00000E+03 N REF39 !\n\n\n PHASE SN5TI6 % 2 5 6 !\n CONSTITUENT SN5TI6 :SN : TI : !\n\n PARAMETER G(SN5TI6,SN:TI;0) 2.98150E+02 -525800+77*T+5*GLIQSN#\n +6*GLIQTI#; 3.00000E+03 N REF39 !\n\n\n PHASE SNTI2 % 2 1 2 !\n CONSTITUENT SNTI2 :SN : TI : !\n\n PARAMETER G(SNTI2,SN:TI;0) 2.98150E+02 -152700+26.80539*T+GLIQSN#\n +2*GLIQTI#; 3.00000E+03 N REF39 !\n\n\n PHASE SNTI3 % 2 1 3 !\n CONSTITUENT SNTI3 :SN,TI% : SN%,TI : !\n\n PARAMETER G(SNTI3,SN:SN;0) 2.98150E+02 +4*GHSERSN#+5; 3.00000E+03 N \n REF39 !\n PARAMETER G(SNTI3,TI:SN;0) 2.98150E+02 +300000-200*T+3*GLIQSN#+GLIQTI#; \n 3.00000E+03 N REF39 !\n PARAMETER G(SNTI3,SN:TI;0) 2.98150E+02 -193466.8+35.74052*T+GLIQSN#\n +3*GLIQTI#; 3.00000E+03 N REF39 !\n PARAMETER G(SNTI3,TI:TI;0) 2.98150E+02 +4*GHSERTI#; 3.00000E+03 N \n REF39 !\n PARAMETER G(SNTI3,SN,TI:SN;0) 2.98150E+02 +400000; 3.00000E+03 N \n REF39 !\n PARAMETER G(SNTI3,SN:SN,TI;0) 2.98150E+02 +400000-40*T; 3.00000E+03 N \n REF39 !\n PARAMETER G(SNTI3,TI:SN,TI;0) 2.98150E+02 +600000+40*T; 3.00000E+03 N \n REF39 !\n PARAMETER G(SNTI3,SN,TI:TI;0) 2.98150E+02 +200000-108*T; 3.00000E+03 \n N REF39 !\n\n\n PHASE TI2N % 2 2 1 !\n CONSTITUENT TI2N :TI : C,N : !\n\n PARAMETER G(TI2N,TI:C;0) 2.98150E+02 -17349+GHSERTI#+GHSERTIC#; \n 6.00000E+03 N REF111 !\n PARAMETER G(TI2N,TI:N;0) 2.98150E+02 -63220.14+22.42085*T+GHSERTI#\n +GHSERTIN#; 6.00000E+03 N REF111 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF1 'S.G.T.E., solution data-base (1991), unaries'\n REF13 'N. Saunders, Rep. Univ. of Surrey, (1990), Al-Ti, Al-V, Ti-V '\n REF8 'N. Saunders and V.G. Rivlin, Z. f\\\"{u}r Metallkde, 78, 11, 795-801 \n (1987), Al-Cr '\n REF76 'M. Seiersten, private communication, Al-Fe '\n REF23 'A. Jansson, Trita-Mac-0462, Materials Research Center, \n The Royal Institute of Technology, Stockholm (1991), Al-Mn '\n REF103 'G. Cacciamani, private communication, Al-Ce, Ce-Mg '\n REF80 'G. Cacciamani, G. Borzone, R. Ferro, L. Battezzati, and M. Baricco,\n Calphad XXII - Salou, 15-21/5/93, poster (1993), Al-Nd '\n REF105 'T.G. Chart, private communication, Al-Li-Mg '\n REF11 'N. Saunders, Calphad, 14, 1, 61-70, (1990), Al-Mg, Mg-Li '\n REF121 'M. Seiersten, private communication, Al-Fe-Si '\n REF52 'H.L. Lukas 1992, private communication, Al-Y'\n REF74 'N. Saunders, private communication, Al-Cu, Al-Zr, Cu-Li, Li-Zr '\n REF46 'H.L. Lukas 1992, private communication, Al-C'\n REF115 'P. Kolby, private communication, Al-Mn-Si'\n REF109 'A. Jansson, private communication, Al-Fe-Mn '\n REF29 'J. Tibballs, private communication, Fe-Mg Mg-Mn Mn-Si'\n REF44 'H.L. Lukas 1992, private communication, Al-B'\n REF119 'N. Saunders, private communication, Al-Cu-Li '\n REF72 'N. Saunders, Rep. ThermoTech, (1992), Cr-Ti, Mn-Ti '\n REF126 'U Nknown, Al-Mg-Mn'\n REF48 'H.L. Lukas 1992, private communication, Al-N '\n REF89 'C. Baetzner, Thesis, M.P.I. Stuttgart (1994), B-Ti '\n REF58 'H.L. Lukas 1992, private communication, B-Si'\n REF54 'H.L. Lukas 1992, private communication, B-C'\n REF111 'S. Jonsson, private communication, C-Ti N-Ti '\n REF70 'Marek, and P. Spencer, private communication, Cu-Zn '\n REF26 'J. Lacaze, and B. Sundman, Met. Trans., 22A, 10, 2211-2223 (1991),\n Fe-Si '\n REF56 'H.L. Lukas 1992, private communication, B-N'\n REF2 'B Lee, KTH Cr-Mn'\n REF91 'C.A. Coughnanowr, I. Ansara, and H.L. Lukas, Calphad, 18, 2, 125-140\n (1994). Cr-Si '\n REF83 'I. Ansara, private communication, Cr-Mg '\n REF60 'H.L. Lukas 1992, private communication, C-Si'\n REF125 'U Nknown, Cu-Zr' \n REF94 'M. Jacobs, Cost507 Final Report (1994) Cu-Si, Si-Sn, Si-Zn, \n Al-Si-Zn, Cu-Mg-Ni '\n REF20 'C.A. Coughnanowr, I. Ansara, R. Luoma, M. Hamalainen, and H.L. Lukas,\n Zeit. fur Metallkde., 82, 7, 574-581 (1991), Cu-Mg '\n REF129 'I Ansara, added to make phase unstable'\n REF98 'K. Zeng, M. Hamalainen, and I. Ansara, Cr-Zr '\n REF64 'H.L. Lukas 1992, private communication, Mg-Y '\n REF62 'H.L. Lukas 1992, private communication, Mg-Si'\n REF33 'R. Agarwal, S.G. Fries, H.L. Lukas, G. Petzow, F. Sommer, T.G. Chart,\n G. Effenberg, Zeit. fur Metallkde., 83, 4, 216-223 (1992), Mg-Zn'\n REF123 'H. Seiffert, Thesis, MPI, Stuttgart, (1994), Si-Ti '\n REF117 'M.H. Rand, private communication, Si-V '\n REF66 'H.L. Lukas 1992, private communication, Si-Y'\n REF100 'C. Gueneau, C. Servant, I. Ansara, and N. Dupin, Calphad, 18, \n 3 319-328 (1994), Si-Zr '\n REF39 'F. Hayes, private communication, Sn-Ti '\n REF50 'H.L. Lukas 1992, private communication, Al-Si'\n REF15 'N. Chakraborti, G. Effenberg, S. G.-Fries, S. Kuang, H.L. Lukas, and \n H.L. Petzow, Vortr. Poster Symp. Materialforsch., 1991, 2nd, 3, \n 2692-2693 (1991). Al-Sn '\n REF78 'S. an Mey, Zeit. fur Metallkde, 84, (7), 451-455 (1993), Al-Zn '\n REF96 'K. Zeng, M. Hamalainen, private communication, Cr-Cu '\n REF85 'I. Ansara, A. Jansson, Trita-Mac-0533, Materials Research Center,\n The Royal Institute of Technology, Stockholm (Sweden) (1993), Cu-Fe '\n REF31 'S. an Mey, Calphad, 16, 3, 255-260 (1992), Cu-Ni '\n REF6 'W Huang, KTH Fe-Mn '\n REF68 'M. Hamalainen, private communication, Mg-Zr '\n REF107 'M. Jacobs, private communication, Al-Sn-Zn '\n REF113 'H.L. Lukas, private communication, Al-Mg-Si '\n REF127 'F Hayes, Al-Ti-V'\n 93AKE 'Å Jansson, KTH 1993'\n BO2021 'B Sundman, Same excess as liquid to prevent HCP to be stable, 2021'\n REF0 'Not assessed'\n ! \n \n" }, { "path": "examples/macros/cslaf-excess.TDB", "content": "$ CSLAF FROM DAT WITH SPLIT REFERENCE ENERGEIS\n\nELEMENT CS SER 132.9 0 0 0 !\nELEMENT F GAS 18.9984 0 0 0 !\nELEMENT LA SER 138.9055 0 0 0 !\n\nSPECIES CSF CSF !\nSPECIES LAF3 LAF3 !\n\nSPECIES LA/F LA/F 6.0 2.0 2.4 !\nSPECIES CS/F CS/F 6.0 6.0 2.4 !\nSPECIES LACS/F LA,CS/F 9.0 6.0 4.0 !\n\nFUNCTION GLIQLAF 298.15 -1674170.0+806.53663*T-135*T*LN(T); 2500 N!\nFUNCTION GLIQCSF 298.15 -565946.80+405.89131*T-74.057*T*LN(T); 2000 N!\n\n$ FUNCTION GLIQLAF 298.15 0; 2500 N !\n$ FUNCTION GLIQCSF 298.15 0; 2500 N !\n\n TYPE_DEFINITION % SEQ * !\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\nPHASE LIQUID:Q % 1 1.0 !\n$ bond fractions as in order of sublattice species\nCONST LIQUID:Q : LA/F-Q CS/F-Q LACS/F-Q : !\n\n$ LA1/6 F1/2 is 2/3+2/2= 1/3 mole LaF3\nPARAMETER G(LIQUID,LA/F-Q) 298.15 0.33333333*GLIQLAF; 6000 N 08Ben !\n$ PARAMETER G(LIQUID,LA/F-Q) 298.15 GLIQLAF; 6000 N 08Ben !\n\n$ Cs1/6 F1/6 is 2/6+2/6= 1/3 mole CsF\nPARAMETER G(LIQUID,CS/F-Q) 298.15 0.3333333*GLIQCSF; 6000 N 08Ben !\n$ PARAMETER G(LIQUID,CS/F-Q) 298.15 GLIQCSF; 6000 N 08Ben !\n\n$ NO REFERENCE STATE addded as that is calculated using the FNN\n$ The DAT file has twice this value\n$ 0 0 -21625.146 0.00000000 0.00000000 0.00000000\nPARAMETER G(LIQUID,LACS/F-Q) 298.15 -10812.573; 6000 N bo!\n\n$ THESE PARAMETERS SHOULD BE HALFED ALSO ...\n$ 0 0 -1398.2896 -14.232842 0.00000000 0.00000000 \n$ 0 0 -2977.6120 4.9256711 0.00000000 0.00000000\nPARAMETER G(LIQUID,LACS/F-Q,CS/F-Q) 298.15 -699.1448-7.1164*T; 6000 N 08Ben!\n\nPARAMETER G(LIQUID,LACS/F-Q,LA/F-Q) 298.15 -1488.806+2.4628355*T; 6000 N 08Ben !\n\n\nPHASE LAF3 % 2 1.0 3.0 !\nCONST LAF3 :LA:F: !\nPARAMETER G(LAF3,LA:F) 298.15 GLAF3; 2500 N 08Ben !\nFUNCTION GLAF3 298.15 -1712105.5+715.96122*T-122.11880*T*LN(T)\n +0.11233700E-01*T**2+0.27182333E-05*T**3+1085690.0*T**(-1)\n -.23478833E-08*T**4; 2500.0000 N 08Ben !\n\nPHASE CSF % 2 1.0 1.0 !\nCONST CSF :CS:F: !\nPARAMETER G(CSF,CS:F) 298.15 GCSF; 2000 N 08Ben !\nFUNCTION GCSF 298.15 -569439.00+230.50900*T-46.810600*T*LN(T)\n -.87950000E-02*T**2+4110.7635*T**(-1); 2000.0000 N 08Ben !\n\nPHASE CS3LAF6 % 3 3.0 1.0 6.0 !\nCONST :CS:LA:F: !\nPARAMETER G(CS3LAF6,CS:LA:F) 298.15 GCSLAF; 2000 N 08Ben !\nFUNCTION GCSLAF 298.15 -3524425.5+1383.1064*T-262.7*T*LN(T)\n +0.75E-02*T**2; 2000.0000 N 08Ben!\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n 08Ben 'O Benes, R J M Konings, Calphad 32 (2008) 121-128'\n !\n" }, { "path": "examples/macros/cslaf-map.OCM", "content": "new Y\r\n\r\nset echo Y\r\n\r\n@$=================================================================\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$ Testing CsLaF with reference states\r\n@$\r\n@$=================================================================\r\n\r\n\r\nr t ./cslaf-excess\r\n\r\n\r\n\r\n@&\r\n\r\nset c t=1600 p=1e5 n(la)=.2 n(cs)+n(la)=1 ac(f)=1\r\n\r\nc e\r\n\r\n\r\nl , 2\r\n\r\n\r\n@&\r\n\r\nset ax 1 n(la) 0 1 .01\r\n\r\nset ax 2 t 300 2000 10\r\n\r\n\r\nmap\r\n\r\n\r\n@&\r\n\r\nplot x(*,la)\r\nt\r\npos left\r\n\r\ntitle Fig 1: CsF-LaF3 phase diagram\r\nextra axis-factor x 4\r\ntext .42 400 .9 0 n\r\nNote fraction scale multiplied by 4, compound composition not correct\r\n\r\n\r\n@&\r\n\r\n@$ No more for the moment\r\n\r\n\r\n\r\n@$==========================================================================\r\n@$ end of cslaf-map macro\r\n@$==========================================================================\r\n\r\nset inter\r\n" }, { "path": "examples/macros/hogas.TDB", "content": "\n$ Database file written 2012- 5-31\n$ From database: USER \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01!\n ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02!\n \n SPECIES H1O1 H1O1!\n SPECIES H1O2 H1O2!\n SPECIES H2 H2!\n SPECIES H2O1 H2O1!\n SPECIES H2O2 H2O2!\n SPECIES O2 O2!\n SPECIES O3 O3!\n \n FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); \n 6.00000E+03 N !\n FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T)\n +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y\n +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2\n +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y\n +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2\n +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y\n -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2\n -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y\n +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2\n -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T)\n -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y\n -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2\n +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y\n -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2\n -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N !\n FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T)\n +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y\n +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2\n +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y\n -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2\n +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N !\n FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T)\n -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y\n -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2\n +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y\n -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2\n +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y\n -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2\n -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y\n -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2\n -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N !\n FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T)\n -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y\n -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2\n +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N !\n FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T)\n +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 \n Y\n +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2\n +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N !\n FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T)\n -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y\n -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2\n +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y\n +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2\n +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y\n -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2\n -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y\n -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3\n +.25153895*T**(-1); 2.00000E+04 N !\n FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T)\n -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y\n +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2\n -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y\n +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2\n -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y\n +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2\n +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y\n +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2\n +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y\n -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2\n -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y\n +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2\n -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N !\n FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T)\n +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y\n -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2\n +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y\n -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2\n -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y\n -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N !\n FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); \n 1.50000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE GAS:G % 1 1.0 !\n CONSTITUENT GAS:G :H,H2,H2O1,O,O2,O3 : !\n$ CONSTITUENT GAS:G :H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : !\n\n PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF86 !\n$ PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); \n$ 6.00000E+03 N REF93 !\n$ PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); \n$ 6.00000E+03 N REF94 !\n PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF95 !\n PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF101 !\n$ PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); \n$ 6.00000E+03 N REF102 !\n PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF116 !\n PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF117 !\n PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); \n 6.00000E+03 N REF118 !\n\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF86 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN <\n MONATOMIC GAS>'\n REF93 'H1O1 T.C.R.A.S. Class: 1'\n REF94 'H1O2 T.C.R.A.S. Class: 4'\n REF95 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD \n STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61'\n REF101 'H2O1 T.C.R.A.S. Class: 1 WATER '\n REF102 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE '\n REF116 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN '\n REF117 'O2 T.C.R.A.S. Class: 1 OXYGEN '\n REF118 'O3 T.C.R.A.S. Class: 4 OZONE '\n REF128 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by \n atd 12/9/94'\n REF129 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93'\n ! \n \n" }, { "path": "examples/macros/iron4cd.TDB", "content": "$\n$ Database for cast iron (Fe-Cr-Cu-Mg-Mn-Mo-Nb-Ni-Si-Ti-V-C-N),\n$ Version 4c.\n$ Compiled by Bengt Hallstedt, July 2020, (version 04b in December 2017,\n$ 04a in October 2017, 03 in June 2017, 02b in February 2017,\n$ 02a in August 2015, 01c in May 2008).\n$\n$ ------------------------------------------------------------------------------\n$\n$ This database is open access under the CC BY license. \n$ https://creativecommons.org/licenses/by/4.0/\n$\n$ For comments and questions please contact:\n$\n$ Dr. Bengt Hallstedt\n$ Institute for Materials Applications in Mechanical Engineering (IWM)\n$ RWTH Aachen University, Aachen, Germany\n$ b.hallstedt@iwm.rwth-aachen.de\n$\n$ To cite the database, please use:\n$\n$ B. Hallstedt, A thermodynamic database for cast iron, Calphad XLVI,\n$ June 11-16, 2017, Saint-Malo, France.\n$\n$ ------------------------------------------------------------------------------\n$\n$ Open issues:\n$ Cr-Ni: C14_LAVES parameters\n$ Cr-Si: B2_BCC parameters\n$\n$ Version information\n$ ===================\n$\n$ Changes from version 04a to 04c:\n$\n$ Modifications by Bo Sundman for use with OpenCalphad.\n$\n$--------------------------------------------------\n$ Modification for use by OC 2020-07-28:/BoS\n$ Moved DEFAULT section before PHASES to have TYPE_DEFS defined\n$ Changed phase CU4TI to CU4TI1 as ambiguous with CU4TI3\n$ Changed phase FENBSI to FENBSI1 as ambiguous with FENBSI2\n$ Changed phase NI2V to NI2V1 as ambigous with NI2V7_A15\n$ Changed property Identifier BM to BMAG\n$\n$ 2020.07.28: Modified for use with GES6.\n$\n$ Changes from version 04a to 04b:\n$\n$ Cr-Fe-Si: Estimated ternary fcc interaction.\n$\n$ Changes from version 03 to 04a:\n$\n$ Mostly checks and modifications in ternary systems.\n$\n$ Cu-C: New parameters for FCC_A1 and BCC_A2.\n$ Ni-Si: 12Yua changed back to 99Du, except fcc ordering parameters.\n$ Cr-Mo-Ni: Modified sigma and P-phase parameters.\n$ Cr-Ni-Si: Acceptable, but would need more work.\n$ Cr-V-C: Modified liquid interaction.\n$ Cu-Fe-C: Added from Hallstedt 2017.\n$ Cu-Fe-Nb: Added from Wang 2000.\n$ Fe-Nb-Ti: Added from Hallstedt 2017.\n$ Mo-Nb-C: Added from Zhang 2015.\n$ Ti-V-C: Updated from 08Mar to 15Zha.\n$\n$ 2017.07.07: Error in the parameters for FE2SI and FESI2_L corrected.\n$\n$ Changes from version 02b to 03:\n$\n$ This is a major rebuild, using more modern datasets for several systems.\n$ In particular all relevant systems from mpea-2 and PrecHiMn-4 were included.\n$ Note that Fe-Si-C in PrecHiMn-4 uses an unfortunate combination of Si-C and\n$ ternary liquid interaction (which is not used here).\n$\n$ Ordering models for fcc (FCC_4SL) and bcc (B2_BCC) are now included. They\n$ are deactivated by default and have to be activated when needed.\n$ They are needed for FeNi3 (L1_2), FeSi (B2), FeTi (B2), MnNi (B2, L1_0),\n$ MnNi3 (L1_2), NiTi (B2).\n$\n$ Only the 10:4:16 model is included for sigma and high-sigma. The old 8:4:18\n$ model is not included.\n$\n$ Cr-C: Modified from Lee 1992 to Khvan 2012.\n$ Cr-Nb: Updated from Costa Neto 1993 to Schmetterer 2014.\n$ Cr-Ni: Updated from Lee 1992 to Tang 2016.\n$ Cr-Ti: Updated from 98Sau to 10Pav.\n$ Cu-Mg: Updated from Coughanowr 1998 to Hallstedt 2016.\n$ Cu-Si: Updated from Yan 2000 to Hallstedt 2016.\n$ Fe-C: Cementite modified.\n$ Fe-Mo: New model for MU_D85, modified models for SIGMA_D8B and C14_LAVES.\n$ Fe-Mn: HCP_A3 interaction slightly modified.\n$ Fe-Nb: Updated from Lee 2001 to Liu 2012/Khvan 2013/Jacob 2016.\n$ Fe-Ni: Updated from Xing 1985 to Dupin 2003.\n$ Fe-Ti: Updated from Dumitrescu 1998 to Bo 2012.\n$ Mg-Mn: Updated from Tibballs 1998 to Groebner 2005.\n$ Mg-N: Added from Hallstedt 2015.\n$ Mg-Nb: Added from Hallstedt 2015.\n$ Mg-Si: Updated from Kevorkov 2004 to Liang 2016.\n$ Mg-Ti: Added from Murray 1986.\n$ Mg-V: Added from Hallstedt 2015.\n$ Mn-C: Updated from Huang 1990 to Djurovic 2010.\n$ Mn-Nb: Added from Liu 2012.\n$ Mn-Ni: Updated from Guo 2005 to Franke 2007.\n$ Mo-Nb: Added from Xiong 2004.\n$ Nb-C: Bcc modified.\n$ Nb-N: Updated from Huang 1996 to Khvan 2013.\n$ Nb-Ni: Updated from Bolcavage 1996 to Chen 2006 with modified MU_D85.\n$ Nb-Si: Updated from Fernandes 2002 to Geng 2009.\n$ Cr-Fe-C: Updated from Lee 1992 to Khvan 2014.\n$ Cr-Fe-Mn: New model for SIGMA_D8B and HIGH_SIGMA.\n$ Cr-Fe-Mo: New model for MU_D85 and SIGMA_D8B, modified model for C14_LAVES.\n$ Cr-Fe-Nb: Added from Jacob 2016.\n$ Cr-Fe-Ni: New model for SIGMA_D8B.\n$ Cr-Fe-Si: New model for SIGMA_D8B.\n$ Cr-Fe-V: New model for SIGMA_D8B.\n$ Cr-Mn-Ni: Added from Hallstedt 2016.\n$ Cr-Nb-C: Added from Khvan 2012.\n$ Fe-Mn-C: Updated from Huang 1990 to Djurovic 2011.\n$ Fe-Mn-Nb: Added from Khvan 2013.\n$ Fe-Mo-Ni: New model for MU_D85 and SIGMA_D8B, modified model for C14_LAVES.\n$ Fe-Mo-Ti: New model for MU_D85, modified model for C14_LAVES.\n$ Fe-Nb-C: Updated from Lee 2001 to Khvan 2013.\n$ Fe-Nb-N: Updated from Lee 2001 to Khvan 2013.\n$ Fe-Nb-Si: Added from Jacob 2016.\n$ Fe-Nb-V: Added from Khvan 2013.\n$ Fe-Ti-C: Changed from Lee 2001 to Dumitrescu 1999.\n$ Fe-Ti-N: Modified.\n$ Mn-Nb-C: Added from Khvan 2012.\n$ Mn-Nb-N: Added from Khvan 2013.\n$ Nb-C-N: Updated from Lee 2001 to Khvan 2013.\n$\n$ Changes from version 02a to 02b:\n$\n$ Si is included in M6C. M6C is found to form in Mo containing casts.\n$ The calculated Si content in M6C is considerably higher than measured,\n$ but similar to TCFE7/TCFE8.\n$ Si-C is changed from 96Gro to 91Lac in order to reproduce Fe-Si-C\n$ from J. Miettinen 1998.\n$\n$ Changes from version 01c to 02a:\n$\n$ Nb, Ti, V and N are added to the database.\n$ Most of the data concerning Nb, V and N are taken from PrecHiMn-01 and\n$ most of the data concerning Ti are taken from PrecHiMn-04.\n$ Several Fe-systems in PrecHiMn-04 are not compatible with iron-01c.\n$\n$ ------------------------------------------------------------------------------\n DATABASE_INFO '\n Welcome to version 4c of the iron database for alloyed and unalloyed'\n cast iron.''\n Created by Bengt Hallstedt in May 2008, updated in August 2015,'\n February 2017, March 2017 and September 2017.''\n The database contains the elements Fe, Cr, Cu, Mg, Mn, Mo, Nb, Ni, Si,'\n Ti, V, C and N.'''\n A few notes on phases in the database:''\n FCC_A1 is both austenite and cubic (Nb,Ti,V)(C,N).'\n HCP_A3 is both the epsilon-phase (epsilon-martensite) and the M2X'\n hexagonal carbide/nitride.''\n At high contents of Si the BCC_A2 phase (ferrite) may order.'\n This is described by the B2_BCC phase, which is deactivated by default.'\n To activate it, the following commands are needed in the database module:'\n RESTORE PHASE A2_BCC B2_BCC'\n REJECT PHASE BCC_A2'\n All equilibria with BCC_A2 will be reproduced as before, but the phase'\n name will now be B2_BCC.''\n If you suspend the GRAPHITE to calculate equilibria with CEMENTITE,'\n you should also suspend DIAMOND. Otherwise DIAMOND may become more stable'\n than CEMENTITE at low temperature.''\n The GAS phase is deactivated by default, so if you need it activate it'\n in the database module:\n RESTORE PHASE GAS''\n The database contains quite a large number of phases that will be of'\n little interest in most cases. For calculations with several elements'\n it is recommended to suspend all phases except those actually needed'\n in order to speed up the calculations.'''\n All binary systems are included in the database, except Mg-Mo.'\n The ternary systems'\n Cr-Cu-Fe, Cr-Fe-C, Cr-Fe-Mn, Cr-Fe-Mo, Cr-Fe-N, Cr-Fe-Nb, Cr-Fe-Ni,'\n Cr-Fe-Si, Cr-Fe-V, Cr-Mn-C, Cr-Mn-Ni, Cr-Mo-C, Cr-Mo-Ni, Cr-Nb-C, Cr-Ni-C,'\n Cr-Ni-Si, Cr-Si-C, Cr-V-C, Cu-Fe-C, Cu-Fe-Mn, Cu-Fe-Mo, Cu-Fe-Nb, Cu-Fe-Ni,'\n Cu-Fe-Si, Fe-C-N, Fe-Mn-C, Fe-Mn-N, Fe-Mn-Nb, Fe-Mn-Ni, Fe-Mn-Si, Fe-Mn-V,'\n Fe-Mo-C, Fe-Mo-N, Fe-Mo-Ni, Fe-Mo-Ti, Fe-Nb-C, Fe-Nb-N, Fe-Nb-Si, Fe-Nb-Ti,'\n Fe-Nb-V, Fe-Ni-C, Fe-Ni-N, Fe-Ni-Si, Fe-Si-C, Fe-Ti-C, Fe-Ti-N, Fe-V-C,'\n 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,'\n 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'\n are included.''\n !\n$\n$ ------------------------------------------------------------------------------\n TEMP-LIM 298.15 6000.00 !\n$\n$ELEMENT NAME REF. STATE ATOMIC MASS H298-H0 S298 !\n$\n ELEMENT VA VACUUM 0.0 0.0 0.0 ! \n ELEMENT C GRAPHITE_A9 12.011 1054.0 5.7423 ! \n ELEMENT CR BCC_A2 51.996 4050.0 23.5429 ! \n ELEMENT CU FCC_A1 63.546 5004. 33.15 !\n ELEMENT FE BCC_A2 55.847 4489.0 27.2797 ! \n ELEMENT MG HCP_A3 24.305 4998. 32.671 !\n ELEMENT MN CBCC_A12 54.9380 4995.696 32.2206 ! \n ELEMENT MO BCC_A2 95.94 4589.0 28.56 ! \n ELEMENT N 1/2_MOLE_N2(G) 14.007 4335.0 95.751 ! \n ELEMENT NB BCC_A2 92.9064 5220.0 36.27 ! \n ELEMENT NI FCC_A1 58.69 4787.0 29.7955 ! \n ELEMENT SI DIAMOND_A4 28.0855 3217. 18.81 ! \n ELEMENT TI HCP_A3 47.88 4824. 30.72 ! \n ELEMENT V BCC_A2 50.9415 4507.0 30.89 ! \n$ ------------------------------------------------------------------------------\n$ Species\n$\n SPECIE FE2 FE2 !\n SPECIE MG2 MG2 !\n SPECIE N2 N2 !\n SPECIE N3 N3 !\n SPECIE SI2 SI2 !\n SPECIE SI3 SI3 !\n SPECIE SIN SI1N1 !\n SPECIE SI2N SI2N1 !\n$ ------------------------------------------------------------------------------\n$ Defaults and TYPE_DEF\n$\n DEFINE-SYSTEM-DEFAULT ELEMENT 2 !\n DEFAULT-COM DEFINE_SYSTEM_ELEMENT VA !\n$\n$ with the default reject no ordering in FCC and BCC\n DEFAULT-COM REJECT_PHASE A1_FCC FCC_4SL A2_BCC B2_BCC GAS !\n$ with this default reject include ordering in BCC and FCC\n$DEFAULT-COM REJECT_PHASE FCC_A1 BCC_A2 GAS !\n$\n TYPE-DEF % SEQ * !\n TYPE-DEF A GES AMEND_PHASE_DESCRIPTION @ MAGNETIC -3 0.28 !\n TYPE-DEF B GES AMEND_PHASE_DESCRIPTION @ MAGNETIC -1 0.4 !\n TYPE-DEF O GES AMEND_PHASE_DESCRIPTION B2_BCC DIS_PART A2_BCC !\n TYPE-DEF Y GES AMEND_PHASE_DESCRIPTION FCC_4SL DIS_PART A1_FCC !\n TYPE-DEF S IF((NB OR TI OR V) AND (C OR N)) THEN\n GES AMEND_PHASE_DESCRIPTION @ COMP-SETS,, NB TI V : C N : !\n FUNCTION ZERO 298.15 0; 6000 N !\n FUNCTION UN_ASS 298.15 0; 6000 N !\n FUNCTION R 298.15 +8.31451; 6000 N !\n FUNCTION RTLNP 298.15 +8.31451*T*LN(1E-05*P); 6000 N !\n$ ------------------------------------------------------------------------------\n$ Phase definitions\n$\n PHASE LIQUID:L % 1 1 !\n CONST LIQUID:L : C CR CU FE MG MN MO N NB NI SI TI V : !\n$\n$ Fcc (cF4, Fm-3m) and MeX (cF8, Fm-3m)\n$\n PHASE FCC_A1 %AS 2 1 1 !\n CONST FCC_A1 : CR CU% FE% MG MN% MO NB NI% SI TI V : C N VA% : !\n$\n$ Disordered part of FCC_4SL, identical to FCC_A1\n$\n PHASE A1_FCC %A 2 1 1 !\n CONST A1_FCC : CR CU% FE% MG MN% MO NB NI% SI TI V : C N VA% : !\n$\n$ Prototype AuCu3 (cP4, Pm-3m, L1_2) and AuCu (tP4, P4/mmm, L1_0)\n$\n PHASE FCC_4SL:F %AY 5 0.25 0.25 0.25 0.25 1 !\n CONST FCC_4SL:F : CR CU FE MG MN MO NB NI SI TI V\n : CR CU FE MG MN MO NB NI SI TI V \n : CR CU FE MG MN MO NB NI SI TI V\n : CR CU FE MG MN MO NB NI SI TI V : C N VA% : !\n$\n$ Bcc (cI2, Im-3m)\n$\n PHASE BCC_A2 %B 2 1 3 !\n CONST BCC_A2 : CR% CU FE% MG MN MO% NB% NI SI TI% V% : C N VA% : !\n$\n$ Disordered part of B2_BCC, identical to BCC_A2\n$\n PHASE A2_BCC %B 2 1 3 !\n CONST A2_BCC : CR% CU FE% MG MN MO% NB% NI SI TI% V% : C N VA% : !\n$\n$ Prototype CsCl (cP2, Pm-3m)\n$\n PHASE B2_BCC %BO 3 0.5 0.5 3 !\n CONST B2_BCC : CR CU FE MG MN MO NB NI SI TI V\n : CR CU FE MG MN MO NB NI SI TI V : C N VA% : !\n$\n$ Hcp (hP2, P6_3/mmc) and Me2X (NiAs-type, hP4, P6_3/mmc, B8_1)\n$\n PHASE HCP_A3 %A 2 1 0.5 !\n CONST HCP_A3 : CR CU FE MG% MN MO NB NI SI TI% V : C N VA% : !\n$\n$ Prototype alpha-Mn (cI58, I-43m)\n$\n PHASE CBCC_A12 %A 2 1 1 !\n CONST CBCC_A12 : CR CU FE MG MN% MO NB NI SI TI V : C N VA% : !\n$\n$ Prototype beta-Mn (cP20, P4_132)\n$\n PHASE CUB_A13 % 2 1 1 !\n CONST CUB_A13 : CR CU FE MG MN% MO NB NI SI TI V : C N VA% : !\n$\n$ Prototype C (cF8, Fd-3m)\n$\n PHASE DIAMOND_A4 % 1 1 !\n CONST DIAMOND_A4 : C MG SI% : !\n$\n$ Prototype C (hP4, P6_3/mmc)\n$\n PHASE GRAPHITE_A9 % 1 1 !\n CONST GRAPHITE_A9 : C : !\n$\n$ Prototype Fe3C (oP16, Pnma)\n$\n PHASE CEMENTITE_D011 %A 2 3 1 !\n CONST CEMENTITE_D011 : CR FE MN MO NB NI V : C N : !\n$\n$ Prototype alpha-Mn (cI58, I-43m)\n$\n PHASE CHI_A12 % 3 24 10 24 !\n CONST CHI_A12 : CR FE NI : CR MO : CR FE MO NI : !\n$\n$ Prototype Cr3C2 (oP20, Pnma)\n$\n PHASE CR3C2_D510 % 2 3 2 !\n CONST CR3C2_D510 : CR MO V : C : !\n$\n$ Similar to alpha-Mn (cI58, I-43m)\n$\n PHASE CR3MN5 % 2 3 5 !\n CONST CR3MN5 : CR : MN : !\n$\n$ Prototype MoPt2 (oP6, Immm, ordered fcc)\n$\n PHASE CRNI2_C11B % 2 1 2 !\n CONST CRNI2_C11B : CR MO : MO NI% : !\n$\n$ Prototype AlAu4 (cP20, P2_13) also pi\n$\n PHASE CR3NI5SI2 % 3 3 5 2 !\n CONST CR3NI5SI2 : CR : NI : SI : !\n$\n$ Unknown structure\n$\n PHASE CR5NI5SI3 % 3 5 5 3 !\n CONST CR5NI5SI3 : CR : NI : SI : !\n$\n$ Prototype Cr3Si (cP8, Pm-3n)\n$\n PHASE CR3SI_A15 % 3 3 1 3 !\n CONST CR3SI_A15 : CR% FE% NI SI : CR SI% : C VA% : !\n$\n$ Prototype W5Si3 (tI32, I4/mcm)\n$\n PHASE CR5SI3_D8M % 2 5 3 !\n CONST CR5SI3_D8M : CR% FE : SI : !\n$\n$ Prototype CrSi2 (hP9, P6_222)\n$\n PHASE CRSI2_C40 % 2 1 2 !\n CONST CRSI2_C40 : CR% SI : CR SI% : !\n$\n$ Prototype Cr2VC2 (oC20, Cmcm)\n$\n PHASE CR2VC2 % 3 2 1 2 !\n CONST CR2VC2 : CR : V : C : !\n$\n$ Prototype CuMg2 (oF48, Fddd)\n$\n PHASE CUMG2_CB % 2 1 2 !\n CONST CUMG2_CB : CU : MG : !\n$\n$ Prototype beta-Mn (cP20, P4_132), gamma\n$\n PHASE CU33SI7_A13 % 2 33 7 !\n CONST CU33SI7_A13 : CU : SI : !\n$\n$ Pearson tP* or hP* (delta)\n$\n PHASE CU33SI7_HT % 2 33 7 !\n CONST CU33SI7_HT : CU : SI : !\n$\n$ Prototype Cu15Si4 (cI76, I-43d), epsilon\n$\n PHASE CU15SI4_D86 % 2 15 4 !\n CONST CU15SI4_D86 : CU : SI : !\n$\n$ Pearson hR* (R-3m), distorted bcc?, eta\n$\n PHASE CU3SI_LT % 2 0.77 0.23 !\n CONST CU3SI_LT : CU : SI : !\n$\n$ Prototype Cu3Si (it) (hR9, R-3), eta-prime\n$\n PHASE CU3SI_MT % 2 0.765 0.235 !\n CONST CU3SI_MT : CU : SI : !\n$\n$ Long-period superlattice, Pearson oC*, eta-doubleprime\n$\n PHASE CU3SI_HT % 2 0.76 0.24 !\n CONST CU3SI_HT : CU : SI : !\n$\n$ Prototype Au4Zr (oP20, Pnma); beta-Cu4Ti?\n$ According to LB, alpha-Cu4Ti has prototype MoNi4 (tI10, I4/m, D1_a)\n$ Only Au4Zr is in the Pauling file.\n$\n PHASE CU4TI1 % 2 4 1 !\n CONST CU4TI1 : CU% TI : CU TI% : !\n$\n$ Prototype Au2V (oC12, Cmcm)\n$\n PHASE CU2TI % 2 2 1 !\n CONST CU2TI : CU : TI : !\n$\n$ Prototype Cu3Ti2 (tP10, P4/nmm)\n$\n PHASE CU3TI2 % 2 3 2 !\n CONST CU3TI2 : CU : TI : !\n$\n$ Prototype Cu4Ti3 (tI14, I4/mmm)\n$\n PHASE CU4TI3 % 2 4 3 !\n CONST CU4TI3 : CU : TI : !\n$\n$ Prototype gamma-CuTi (tP4, P4/nmm)\n$\n PHASE CUTI_B11 % 2 1 1 !\n CONST CUTI_B11 : CU% TI : CU TI% : !\n$\n$ Prototype MoSi2 (tI6, I4/mmm)\n$\n PHASE CUTI2_C11B % 2 1 2 !\n CONST CUTI2_C11B : CU : TI : !\n$\n$ Prototype Mn5C2 (mC28, C2/c), Haegg carbide, chi\n$ Should probably be modelled as M5C2\n$\n PHASE FECN_CHI % 2 5 2 !\n CONST FECN_CHI : FE : C N : !\n$\n$ Prototype Fe4N (cP5, Pm-3m, L'1)\n$\n PHASE FE4N_L1 % 2 4 1 !\n CONST FE4N_L1 : CR FE MN NI : C N VA : !\n$\n$ Prototype CrSi2Zr (oP48, Pbam)\n$\n PHASE FENBSI2 % 3 1 1 2 !\n CONST FENBSI2 : FE : NB : SI : !\n$\n$ Prototype Co4Ge7Zr4 (tI60, I4/mmm)\n$\n PHASE FE4NB4SI7 % 3 4 4 7 !\n CONST FE4NB4SI7 : FE : NB : SI : !\n$\n$ Prototype NiSiTi (oP12, Pnma)\n$\n PHASE FENBSI1 % 3 1 1 1 !\n CONST FENBSI1 : FE : NB : SI : !\n$\n$ Prototype FeNb2Si2 (tP198, P4_2/mcm)\n$\n PHASE FENB2SI2 % 3 1 2 2 !\n CONST FENB2SI2 : FE : NB : SI : !\n$\n$ Prototype MgZn2 (hP12, P63/mmc), low-T\n$ Prototype Fe3Nb4Si5 (oP72, Pmn2_1), high-T\n$\n PHASE FE3NB4SI5 % 3 3 4 5 !\n CONST FE3NB4SI5 : FE : NB : SI : !\n$\n$ Prototype CoNb4Si (tP12, P4/mcc)\n$\n PHASE FENB4SI % 3 1 4 1 !\n CONST FENB4SI : FE : NB : SI : !\n$\n$ Prototype AlNi2 (hP6, P-3m1)\n$\n PHASE FE2SI % 2 2 1 !\n CONST FE2SI : FE : SI : !\n$\n$ Prototype FeSi2-h (oC48, Cmca)\n$\n PHASE FESI2_H % 2 0.3 0.7 !\n CONST FESI2_H : FE : SI : !\n$\n$ Prototype FeSi2-l (tP3, P4/mmm)\n$\n PHASE FESI2_L % 2 1 2 !\n CONST FESI2_L : FE : SI : !\n$\n$ Prototype Mn8Si2C3 (aP*, P1)\n$\n PHASE FE8SI2C % 3 8 2 1 !\n CONST FE8SI2C : FE : SI : C : !\n$\n$ Prototype Fe11Mo6C5 (mC44, C2/m)\n$\n PHASE KSI_CARBIDE % 2 3 1 !\n CONST KSI_CARBIDE : CR FE MO : C : !\n$\n$ Prototype MgZn2 (hP12, P6_3/mmc)\n$\n PHASE C14_LAVES % 2 2 1 !\n CONST C14_LAVES : CR% FE% MN% MO NB NI% SI% TI V%\n : CR FE MN MO% NB% NI SI TI% V : !\n$\n$ Prototype Cu2Mg (cF24, Fd-3m)\n$\n PHASE C15_LAVES % 2 2 1 !\n CONST C15_LAVES : CR% CU% FE MG NB SI TI : CR CU FE MG% NB% SI TI% : !\n$\n$ Prototype MgNi2 (hP24, P6_3/mmc)\n$\n PHASE C36_LAVES % 2 2 1 !\n CONST C36_LAVES : CR% MG NI% TI : CR MG% NI TI% : !\n$\n$ Prototype TiP (hP8, P6_3/mmc, SB: Bi)\n$\n PHASE MC_ETA % 2 1 1 !\n CONST MC_ETA : MO NB TI V : C% VA : !\n$\n$ Prototype WC (hP2, P-6m2, SB: Bh)\n$\n PHASE MC_SHP % 2 1 1 !\n CONST MC_SHP : MO : C N : !\n$\n$ Prototype Mn5C2 (mC28, C2/c)\n$\n PHASE M5C2 % 2 5 2 !\n CONST M5C2 : FE MN NB V : C : !\n$\n$ Prototype Fe3W3C (cF112, Fd-3m)\n$\n PHASE M6C_E93 % 4 2 2 2 1 !\n CONST M6C_E93 : FE : MO : CR FE MO SI : C : !\n$\n$ Prototype Cr7C3 (oP40, Pnma)\n$\n PHASE M7C3_D101 % 2 7 3 !\n CONST M7C3_D101 : CR FE MN MO NB NI V : C : !\n$\n$ Prototype Cr23C6 (cF116, Fm-3m)\n$\n PHASE M23C6_D84 % 3 20 3 6 !\n CONST M23C6_D84 : CR FE MN NI V : CR FE MN MO NB NI V : C : !\n$\n$ Prototype Mn5Si3 (hP16, P6_3/mcm)\n$\n PHASE M5SI3_D88 % 3 5 3 1 !\n CONST M5SI3_D88 : CR FE MN : SI : C VA% : !\n$\n$ Prototype Si3W5 (tI32, I4/mcm) alpha\n$\n PHASE M5SI3_D8M % 2 5 3 !\n CONST M5SI3_D8M : MO : SI : !\n$\n$ Unknown structure\n$\n PHASE M4SI3 % 2 4 3 !\n CONST M4SI3 : CR NI : SI : !\n$\n$ Prototype FeSi (cP8, P2_13)\n$\n PHASE MSI_B20 % 2 1 1 !\n CONST MSI_B20 : CR% FE% MN% NI : SI : !\n$\n$ Prototype Mg2C3 (oP10, Pnnm)\n$\n PHASE MG2C3 % 2 2 3 !\n CONST MG2C3 : MG : C : !\n$\n$ Prototype MgC2 (tP6, P4_2/mnm)\n$\n PHASE MGC2 % 2 1 2 !\n CONST MGC2 : MG : C : !\n$\n$ Prototype alpha-Mn2O3 (cI80, Ia-3)\n$\n PHASE MG3N2_D53 % 2 3 2 !\n CONST MG3N2_D53 : MG : N : !\n$\n$ Prototype Mg2Ni (hP18, P6_222)\n$\n PHASE MG2NI % 2 2 1 !\n CONST MG2NI : MG : NI : !\n$\n$ Prototype CaF2 (cF12, Fm-3m)\n$\n PHASE MG2SI_C1 % 2 2 1 !\n CONST MG2SI_C1 : MG : SI : !\n$\n$ Prototype Mn3N2 (tI10, I4/mmm)\n$\n PHASE MN3N2 % 2 3 2 !\n CONST MN3N2 : MN : N :!\n$\n$ Prototype CoO (tI4, I4/mmm); distorted NaCl\n$\n PHASE MN6N5 % 2 6 5 !\n CONST MN6N5 : MN : N :!\n$\n$ Prototype R-(Co,Cr,Mo) (hR53, R-3) or possibly Fe7W6 (hR13, R-3m)\n$\n PHASE MN6SI % 2 17 3 !\n CONST MN6SI : MN : SI : !\n$\n$ Prototype Mn9Si2 (oI186, Immm)\n$\n PHASE MN9SI2 % 2 33 7 !\n CONST MN9SI2 : MN : SI : !\n$\n$ The structure of alpha-Mn3Si is unknown.\n$ Beta-Mn3Si is D0_3 (prototype BiF3 (cF16, Fm-3m)), should be modelled\n$ as an ordered bcc-phase. The transformation is at 950 K.\n$\n PHASE MN3SI % 2 3 1 !\n CONST MN3SI : FE MN : SI : !\n$\n$ Prototype Mn11Si19 (tP120, P-4n2)\n$\n PHASE MN11SI19 % 2 11 19 !\n CONST MN11SI19 : MN : SI : !\n$\n$ Prototype R-(Co,Cr,Mo) (hR53, R-3)\n$\n PHASE MN4TI % 2 0.815 0.185 !\n CONST MN4TI : MN : TI : !\n$\n$ Pearson o**\n$\n PHASE MN3TI % 2 3 1 !\n CONST MN3TI : MN : TI : !\n$\n$ Prototype Re25Zr21 (hR92, R-3c)\n$\n PHASE MNTI_ALPHA % 2 1 1 !\n CONST MNTI_ALPHA : MN : TI : !\n$\n$ Unknown structure\n$\n PHASE MNTI_BETA % 2 0.515 0.485 !\n CONST MNTI_BETA : MN : TI : !\n$\n$ Prototype MoNi (oP56, P2_12_12_1)\n$\n PHASE MONI % 3 6 5 3 !\n CONST MONI : CR FE NI : CR FE MO NI : MO : !\n$\n$ Prototype MoSi2 (tI6, I4/mmm, ordered fcc)\n$\n PHASE MOSI2_C11B % 2 1 2 !\n CONST MOSI2_C11B : MO : SI : !\n$\n$ Prototype Cr3Si (cP8, Pm-3n)\n$\n PHASE MO3SI_A15 % 2 3 1 !\n CONST MO3SI_A15 : MO : SI : !\n$\n$ Prototype Fe7W6 (hR13, R-3m)\n$\n PHASE MU_D85 % 4 1 4 2 6 !\n CONST MU_D85 : CR FE% MN% NB NI% SI V : MO% NB% TI\n : CR FE MO% NB% NI SI TI V : CR FE% MN% MO NB NI% SI V : !\n$\n$ Prototype Fe7W6 (hR13, R-3m)\n$\n$PHASE MU_D85 % 3 7 2 4 !\n$CONST MU_D85 : CR FE MN NI% : MO NB TI : CR FE MO% NB% NI TI : !\n$\n$ Unknown structure\n$\n PHASE NBNI8 % 2 1 8 !\n CONST NBNI8 : NB : NI : !\n$\n$ Prototype Cu3Ti (oP8, Pmmn)\n$\n PHASE NBNI3_D0A % 2 1 3 !\n CONST NBNI3_D0A : NB% NI : NB NI% : !\n$\n$ Prototype Ti3P (tP32, P4_2/n)\n$\n PHASE NB3SI % 2 3 1 !\n CONST NB3SI : NB : SI : !\n$\n$ Prototype Cr5B3 (tI32, I4/mcm), alpha-Nb5Si3\n$\n PHASE NB5SI3_D8L % 2 5 3 !\n CONST NB5SI3_D8L : NB% SI : SI : !\n$\n$ Prototype W5Si3 (tI32, I4/mcm), beta-Nb5Si3\n$\n PHASE NB5SI3_D8M % 3 4 1 3 !\n CONST NB5SI3_D8M : NB : NB SI : SI : !\n$\n$ Prototype CrSi2 (hP9, P6_222)\n$\n PHASE NBSI2_C40 % 2 1 2 !\n CONST NBSI2_C40 : NB% SI : SI : !\n$\n$ Prototype Ge9Pd25 (hP34, P-3), also beta-2\n$\n PHASE NI3SI_M % 2 3 1 !\n CONST NI3SI_M : NI : SI : !\n$\n$ Prototype CsCl (cP2, Pm-3m, B2) or BiF3 (cF16, Fm-3m, D0_3), also beta-3\n$\n PHASE NI3SI_H % 2 3 1 !\n CONST NI3SI_H : NI : SI : !\n$\n$ Prototype Ni31Si12 (hP43, P321), also gamma\n$\n PHASE NI5SI2 % 2 5 2 !\n CONST NI5SI2 : CR NI% : SI : !\n$\n$ Prototype Co2Si (oP12, Pnma), also delta\n$\n PHASE NI2SI_C37 % 2 2 1 !\n CONST NI2SI_C37 : CR NI% : SI : !\n$\n$ Prototype Ni2Si (hP6, P6_322)\n$\n PHASE NI2SI_THETA % 3 1 1 1 !\n CONST NI2SI_THETA : NI : NI% VA : SI : !\n$\n$ Prototype Ni3Si2 (oC80, Cmc2_1), also epsilon\n$\n PHASE NI3SI2 % 2 3 2 !\n CONST NI3SI2 : NI : SI : !\n$\n$ Prototype MnP (oP8, Pnma)\n$\n PHASE NISI_B31 % 2 1 1 !\n CONST NISI_B31 : NI : SI : !\n$\n$ Prototype CaF2 (cF12, Fm-3m)\n$\n PHASE NISI2_C1 % 2 1 2 !\n CONST NISI2_C1 : NI : SI : !\n$\n$ Prototype Ni3Ti (hP16, P6_3/mmc)\n$\n PHASE NI3TI_D024 % 2 0.75 0.25 !\n CONST NI3TI_D024 : NI% : NI TI% : !\n$\n$ Prototype NiTi2 (cF96, Fd-3m)\n$\n PHASE NITI2 % 2 1 2 !\n CONST NITI2 : NI% TI : NI TI% : !\n$\n$ Prototype Al3Ti (tI8, I4/mmm)\n$\n PHASE NI3V_D022 % 2 3 1 !\n CONST NI3V_D022 : NI : V : !\n$\n$ Prototype MoPt2 (oI6, Immm)\n$\n PHASE NI2V1 % 2 2 1 !\n CONST NI2V1 : NI : V : !\n$\n$ Prototype Cr3Si (cP8, Pm-3n)\n$\n PHASE NI2V7_A15 % 2 2 7 !\n CONST NI2V7_A15 : NI : V : !\n$\n$ Prototype beta-Cu3Ti (oP8, Pmmn)\n$\n PHASE NI3X_D0A % 2 3 1 !\n CONST NI3X_D0A : NI : MO : !\n$\n$ Prototype MoNi4 (tI10, I4/m)\n$\n PHASE NI4X_D1A % 2 4 1 !\n CONST NI4X_D1A : NI : MO : !\n$\n$ Prototype Cr9Mo21Ni20 (oP56, Pnma)\n$\n PHASE P_PHASE % 3 24 20 12 !\n CONST P_PHASE : CR FE NI : CR FE MO NI : MO : !\n$\n$ Prototype Al2Mo3C (cP24, P4_132)\n$ Proper model would be Cr3(Fe,Ni)2N\n$\n PHASE PI_CRFENIN % 3 12.8 7.2 4 !\n CONST PI_CRFENIN : CR : FE : N : !\n$\n$ Prototype R-(Co,Cr,Mo) (hR159, R-3, also appears as Fe3Mo2)\n$\n PHASE R_PHASE % 3 27 14 12 !\n CONST R_PHASE : CR FE MN NI : MO : CR FE MN MO NI : !\n$\n$ Prototype ZnS (cF8, F-43m)\n$\n PHASE SIC_B3 % 2 1 1 !\n CONST SIC_B3 : SI : C : !\n$\n$ Prototype CrFe (tP30, P4_2/mnm)\n$ Cr on first sublattice added by Schuster and Du (00Sch).\n$ They also removed Ni on the third sublattice.\n$\n PHASE SIGMA_D8B % 3 10 4 16 !\n CONST SIGMA_D8B : FE% MN% MO NI% V : CR MO NB TI V\n : CR FE MN MO NB NI SI TI V : !\n$\n$ Prototype CrFe (tP30, P4_2/mnm, D8_b) Sigma in TCFE 2000 and SSOL V4\n$\n$PHASE SIGMA_OLD % 3 8 4 18 !\n$CONST SIGMA_OLD : FE MN NI : CR MO NB TI V : CR% FE MN MO NB NI SI TI V : !\n$\n$ Prototype CrFe (tP30, P4_2/mnm, D8_b)\n$\n PHASE HIGH_SIGMA % 3 10 4 16 !\n CONST HIGH_SIGMA : FE MN NI V : CR MO NB V : CR FE MN MO NB NI SI V : !\n$\n$ Prototype Si3N4; alpha: (hP28, p31c), beta: (hP14, P6_3)\n$\n PHASE SI3N4 % 2 3 4 !\n CONST SI3N4 : SI : N : !\n$\n$ Prototype Si2Ti (oF24, Fddd)\n$\n PHASE SI2TI_C54 % 2 2 1 !\n CONST SI2TI_C54 : SI : TI : !\n$\n$ Prototype FeB (oP8, Pnma)\n$\n PHASE SITI_B27 % 2 1 1 !\n CONST SITI_B27 : SI : TI : !\n$\n$ Prototype Si4Zr5 (tP36, P4_12_12)\n$\n PHASE SI4TI5 % 2 4 5 !\n CONST SI4TI5 : SI : TI : !\n$\n$ Prototype Mn5Si3 (hP16, P6_3/mcm)\n$\n PHASE SI3TI5_D88 % 3 2 3 3 !\n CONST SI3TI5_D88 : SI TI : SI TI : TI : !\n$\n$ Prototype Ti3P (tP32, P4_2/n)\n$\n PHASE SITI3 % 2 1 3 !\n CONST SITI3 : SI : TI : !\n$\n$ Prototype CrSi2 (hP9, P6_222)\n$\n PHASE SI2V_C40 % 2 2 1 !\n CONST SI2V_C40 : SI : V : !\n$\n$ Prototype W5Si3 (tI32, I4/mcm)\n$\n PHASE SI3V5_D8M % 2 3 5 !\n CONST SI3V5_D8M : SI : V : !\n$\n$ Prototype Si5V6 (oI44, Ibam)\n$\n PHASE SI5V6 % 2 5 6 !\n CONST SI5V6 : SI : V : !\n$\n$ Prototype Cr3Si (cP8, Pm-3n)\n$\n PHASE SIV3_A15 % 2 1 3 !\n CONST SIV3_A15 : SI% V : SI V% : !\n$\n$ Prototype TiO2 (tP6, P4_2/mnm)\n$\n PHASE TI2N_C4 % 2 2 1 !\n CONST TI2N_C4 : TI V : C N% : !\n$\n$ Unknown structure\n$\n PHASE TI3N2 % 2 0.71 0.29 !\n CONST TI3N2 : TI : N : !\n$\n$ Unknown structure\n$\n PHASE TI4N3 % 2 0.685 0.315 !\n CONST TI4N3 : TI : N : !\n$ \n$ Prototype Sc2Te3 (hR24, R-3m), zeta-carbide\n$ (Prototype V4C3 (hR20, R-3m) seems to be obsolete)\n$\n PHASE V3C2 % 2 3 2 !\n CONST V3C2 : FE MN V : C : !\n$\n PHASE N2GAS % 1 1 !\n CONST N2GAS : N2 : !\n$\n PHASE GAS:G % 1 1 !\n CONST GAS:G : FE FE2 MG MG2 MN N N2 N3 SI SI2 SI3 SIN SI2N : !\n$ ------------------------------------------------------------------------------\n$ Element data\n$ ------------------------------------------------------------------------------\n$ C\n$\n PAR G(GRAPHITE_A9,C),, +GHSERCC;,, N 91Din !\n PAR G(DIAMOND_A4,C),, +GDIACC;,, N 91Din !\n PAR G(LIQUID,C),, +GHSERCC+117369-24.63*T;,, N 91Din !\n$\n FUNCTION GHSERCC 298.15 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3);\n 6000.00 N !\n FUNCTION GDIACC 298.15 -16359.441+175.61*T-24.31*T*LN(T)\n -4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)+1.11E+10*T**(-3);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Cr\n$\n PAR G(BCC_A2,CR:VA),, +GHSERCR;,, N 91Din !\n PAR TC(BCC_A2,CR:VA),, -311.50;,, N 91Din !\n PAR BMAG(BCC_A2,CR:VA),, -0.008;,, N 91Din !\n PAR G(A2_BCC,CR:VA),, +GHSERCR;,, N 91Din !\n PAR TC(A2_BCC,CR:VA),, -311.50;,, N 91Din !\n PAR BMAG(A2_BCC,CR:VA),, -0.008;,, N 91Din !\n PAR G(FCC_A1,CR:VA),, +GHSERCR+7284+0.163*T;,, N 91Din !\n PAR TC(FCC_A1,CR:VA),, -1109.00;,, N 91Din !\n PAR BMAG(FCC_A1,CR:VA),, -2.46;,, N 91Din !\n PAR G(A1_FCC,CR:VA),, +GHSERCR+7284+0.163*T;,, N 91Din !\n PAR TC(A1_FCC,CR:VA),, -1109.00;,, N 91Din !\n PAR BMAG(A1_FCC,CR:VA),, -2.46;,, N 91Din !\n PAR G(HCP_A3,CR:VA),, +GHSERCR+4438;,, N 91Din !\n PAR TC(HCP_A3,CR:VA),, -1109.00;,, N 91Din !\n PAR BMAG(HCP_A3,CR:VA),, -2.46;,, N 91Din !\n PAR G(CBCC_A12,CR:VA),, +GHSERCR+11087+2.7196*T;,, N 91Din !\n PAR G(CUB_A13,CR:VA),, +GHSERCR+15899+0.6276*T;,, N 91Din !\n PAR G(LIQUID,CR),, +GLIQCR;,, N 91Din !\n$\n PAR G(CHI_A12,CR:CR:CR),, +48*GFCCCR+10*GHSERCR\n +109000+123*T;,, N 88Gus4 !\n PAR G(CR3SI_A15,CR:CR:VA),, +4*GHSERCR+20000+10*T;,, N 94Cou !\n PAR G(CRSI2_C40,CR:CR),, +3*GHSERCR+10000-T;,, N 94Cou !\n PAR G(FE4N_L1,CR:VA),, +4*GFCCCR;,, N 17Hal12 !\n PAR G(C14_LAVES,CR:CR),, +3*GHSERCR+82440;,, N 16Jac1 !\n PAR G(C15_LAVES,CR:CR),, +3*GHSERCR+79200;,, N 06Slu !\n PAR G(C36_LAVES,CR:CR),, +3*GHSERCR+75600;,, N 13Slu !\n$\n FUNCTION GHSERCR 298.15 -8856.94+157.48*T-26.908*T*LN(T)\n +0.00189435*T**2-1.47721E-06*T**3+139250*T**(-1);\n 2180.00 Y -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9);\n 6000.00 N !\n FUNCTION GLIQCR 298.15 +24339.955-11.420225*T+GHSERCR+2.37615E-21*T**7;\n 2180.00 Y -16459.984+335.616316*T-50*T*LN(T);\n 6000.00 N !\n FUNCTION GFCCCR 298.15 +GHSERCR+7284+0.163*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Cu\n$\n$ BCT_A5 from 00Moo not included in unary\n$ CBCC_A12 and CUB_A13 not included in unary\n$\n PAR G(FCC_A1,CU:VA),, +GHSERCU; 3200 N 91Din !\n PAR G(A1_FCC,CU:VA),, +GHSERCU; 3200 N 91Din !\n PAR G(BCC_A2,CU:VA),, +GHSERCU+4017-1.255*T; 3200 N 91Din !\n PAR G(A2_BCC,CU:VA),, +GHSERCU+4017-1.255*T; 3200 N 91Din !\n PAR G(HCP_A3,CU:VA),, +GHSERCU+600+0.2*T; 3200 N 91Din !\n$PAR G(BCT_A5,CU),, +GHSERCU+4184; 3200 N 00Moo !\n PAR G(CBCC_A12,CU:VA),, +GHSERCU+3556; 2000 N 03Mie2 !\n PAR G(CUB_A13,CU:VA),, +GHSERCU+2092; 2000 N 03Mie2 !\n PAR G(LIQUID,CU),, +GLIQCU; 3200 N 91Din !\n$\n PAR G(CU4TI1,CU:CU),, +5*GHSERCU+25000;,, N 96Har2 !\n PAR G(CUTI_B11,CU:CU),, +2*GHSERCU+10000;,, N 96Har2 !\n PAR G(C15_LAVES,CU:CU),, +3*GHSERCU+15000;,, N REFLAV !\n$\n FUNCTION GHSERCU 298.15 -7770.458+130.485235*T-24.112392*T*LN(T)\n -0.00265684*T**2+1.29223E-07*T**3+52478*T**(-1);\n 1357.77 Y -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9);\n 3200.00 N !\n FUNCTION GLIQCU 298.15 +12964.735-9.511904*T+GHSERCU-5.8489E-21*T**7;\n 1357.77 Y -46.545+173.881484*T-31.38*T*LN(T);\n 3200.00 N !\n FUNCTION GBCCCU 298.15 +GHSERCU+4017-1.255*T; 3200 N !\n$ ------------------------------------------------------------------------------\n$ Fe\n$\n$ ORTHORHOMBIC_A20 and TETRAGONAL_U added im unary 4.1\n$\n PAR G(BCC_A2,FE:VA),, +GHSERFE;,, N 91Din !\n PAR TC(BCC_A2,FE:VA),, 1043.00;,, N 91Din !\n PAR BMAG(BCC_A2,FE:VA),, 2.22;,, N 91Din !\n PAR G(A2_BCC,FE:VA),, +GHSERFE;,, N 91Din !\n PAR TC(A2_BCC,FE:VA),, 1043.00;,, N 91Din !\n PAR BMAG(A2_BCC,FE:VA),, 2.22;,, N 91Din !\n PAR G(FCC_A1,FE:VA),, +GFCCFE;,, N 91Din !\n PAR TC(FCC_A1,FE:VA),, -201.00;,, N 91Din !\n PAR BMAG(FCC_A1,FE:VA),, -2.10;,, N 91Din !\n PAR G(A1_FCC,FE:VA),, +GFCCFE;,, N 91Din !\n PAR TC(A1_FCC,FE:VA),, -201.00;,, N 91Din !\n PAR BMAG(A1_FCC,FE:VA),, -2.10;,, N 91Din !\n PAR G(HCP_A3,FE:VA),, +GHCPFE;,, N 91Din !\n PAR G(CBCC_A12,FE:VA),, +GHSERFE+4745;,, N 91Din !\n PAR G(CUB_A13,FE:VA),, +GHSERFE+3745;,, N 91Din !\n$PAR G(ORTHORHOMBIC_A20,FE),, +GHSERFE+5000;,, N 99SGUN !\n$PAR G(TETRAGONAL_U,FE),, +GHSERFE+5000;,, N 99SGUN !\n PAR G(LIQUID,FE),, +GLIQFE;,, N 91Din !\n$\n PAR G(GAS,FE),, +F9886T+RTLNP;,, N 97SUB !\n PAR G(GAS,FE2),, +F10090T+RTLNP;,, N 97SUB !\n$\n PAR G(FE4N_L1,FE:VA),, +4*GFCCFE+20000;,, N 17Hal12 !\n PAR G(C14_LAVES,FE:FE),, +3*GHSERFE+44130;,, N 12Liu !\n PAR G(C15_LAVES,FE:FE),, +3*GHSERFE+110290;,, N 16Jac1 !\n$\n FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T)\n -0.00439752*T**2-5.8927E-08*T**3+77359*T**(-1);\n 1811.00 Y -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9);\n 6000.00 N !\n FUNCTION GFCCFE 298.15 -1462.4+8.282*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE;\n 1811.00 Y -1713.815+0.940009*T+GHSERFE+4.9251E+30*T**(-9);\n 6000.00 N !\n FUNCTION GHCPFE 298.15 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE;\n 1811.00 Y -3957.195+5.249009*T+GHSERFE+4.9251E+30*T**(-9);\n 6000.00 N !\n FUNCTION GLIQFE 298.15 +12040.17-6.55843*T+GHSERFE-3.67516E-21*T**7;\n 1811.00 Y -10838.83+291.302*T-46*T*LN(T);\n 6000.00 N !\n$ Fe(g)\n FUNCTION F9886T 298.15 +405563.032+35.536443*T-32.8261*T*LN(T)\n +0.00908265*T**2-1.34845667E-06*T**3+108791.4*T**(-1);\n 900.00 Y +414134.539-53.8401478*T-19.84276*T*LN(T)\n +6.959445E-05*T**2-1.30682983E-07*T**3-976411.5*T**(-1);\n 2400.00 Y +410389.799-49.3269727*T-20.12513*T*LN(T)\n -5.66549E-04*T**2-5.290265E-08*T**3+887592*T**(-1);\n 5500.00 Y +521855.538-375.147472*T+18.70844*T*LN(T)\n -0.00634452*T**2+1.038655E-07*T**3-55487750*T**(-1);\n 10000.00 N !\n$ Fe2(g)\n FUNCTION F10090T 298.15 +704549.823+89.2549323*T-50.743*T*LN(T)\n +0.00803125*T**2-2.18098667E-06*T**3+169270*T**(-1);\n 800.00 Y +717674.096-87.8134515*T-23.957*T*LN(T)\n -0.0157846*T**2+1.723485E-06*T**3-1006505*T**(-1);\n 1700.00 Y +655211.274+352.671354*T-83.82001*T*LN(T)\n +0.0095931*T**2-2.85336667E-07*T**3+11147285*T**(-1);\n 4500.00 Y +780963.168-41.3623277*T-36.245*T*LN(T)\n +0.00155795*T**2-3.05716667E-08*T**3-51729450*T**(-1);\n 6000.00 N ! \n$ ------------------------------------------------------------------------------\n$ Mg\n$\n$ DHCP from 04Guo (included in SGSOL 5.0; this value is not particularly good)\n$ DIAMOND_A4 from 16Lia not included in unary\n$\n PAR G(HCP_A3,MG:VA),, +GHSERMG; 3000 N 91Din !\n PAR G(FCC_A1,MG:VA),, +GHSERMG+2600-0.9*T; 3000 N 91Din !\n PAR G(A1_FCC,MG:VA),, +GHSERMG+2600-0.9*T; 3000 N 91Din !\n PAR G(BCC_A2,MG:VA),, +GHSERMG+3100-2.1*T; 3000 N 91Din !\n PAR G(A2_BCC,MG:VA),, +GHSERMG+3100-2.1*T; 3000 N 91Din !\n$PAR G(DHCP,MG),, +GHSERMG+5000; 3000 N 04Guo !\n PAR G(DIAMOND_A4,MG),, +GHSERMG+74780; 3000 N 16Lia !\n PAR G(CBCC_A12,MG:VA),, +GHSERMG\n +4602.4-3.011*T; 3000 N 91Din !\n PAR G(CUB_A13,MG:VA),, +GHSERMG+5000-3*T; 3000 N 91Din !\n PAR G(LIQUID,MG),, +GLIQMG; 3000 N 91Din !\n$\n PAR G(C15_LAVES,MG:MG),, +3*GHSERMG+15000;,, N REFLAV !\n PAR G(C36_LAVES,MG:MG),, +3*GHSERMG+15000;,, N REFLAV !\n$\n PAR G(GAS,MG),, +F12309T+RTLNP;,, N 97SUB !\n PAR G(GAS,MG2),, +F12397T+RTLNP;,, N 97SUB !\n$\n FUNCTION GHSERMG 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T)\n +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1);\n 923.00 Y -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9);\n 3000.00 N !\n FUNCTION GLIQMG 298.15 +8202.243-8.83693*T+GHSERMG-8.0176E-20*T**7;\n 923.00 Y -5439.869+195.324057*T-34.3088*T*LN(T);\n 3000.00 N !\n$ Mg(g)\n FUNCTION F12309T 298.15 +140825.883-8.26177982*T-20.96302*T*LN(T)\n +1.331861E-04*T**2-1.51554617E-08*T**3+5221.91*T**(-1);\n 2900.00 Y +141959.02+20.1923541*T-25.1271*T*LN(T)\n +0.002179723*T**2-1.502275E-07*T**3-3744678*T**(-1);\n 5400.00 Y +458455.469-794.05688*T+70.54811*T*LN(T)\n -0.010649025*T**2+1.716475E-07*T**3-1.996814E+08*T**(-1);\n 9200.00 Y -315972.848+423.179252*T-63.73726*T*LN(T)\n -2.847232E-04*T**2+2.15099667E-08*T**3+6.39436E+08*T**(-1);\n 10000.00 N !\n$ Mg2(g)\n FUNCTION F12397T 298.15 +281408.793-104.38489*T-20.63169*T*LN(T)\n -6.14869E-05*T**2+4.25457833E-09*T**3-156733.25*T**(-1);\n 3000.00 N !\n$ ------------------------------------------------------------------------------\n$ Mn\n$\n$ RHOMB_C19 from 09Wan not included in unary\n$\n PAR G(CBCC_A12,MN:VA),, +GHSERMN; 2000 N 91Din !\n PAR TC(CBCC_A12,MN:VA),, -285.00; 2000 N 91Din !\n PAR BMAG(CBCC_A12,MN:VA),, -0.66; 2000 N 91Din !\n PAR G(CUB_A13,MN:VA),, +GCUBMN; 2000 N 91Din !\n PAR G(FCC_A1,MN:VA),, +GFCCMN; 2000 N 91Din !\n PAR TC(FCC_A1,MN:VA),, -1620.00; 2000 N 91Din !\n PAR BMAG(FCC_A1,MN:VA),, -1.86; 2000 N 91Din !\n PAR G(A1_FCC,MN:VA),, +GFCCMN; 2000 N 91Din !\n PAR TC(A1_FCC,MN:VA),, -1620.00; 2000 N 91Din !\n PAR BMAG(A1_FCC,MN:VA),, -1.86; 2000 N 91Din !\n PAR G(BCC_A2,MN:VA),, +GBCCMN; 2000 N 91Din !\n PAR TC(BCC_A2,MN:VA),, -580.00; 2000 N 91Din !\n PAR BMAG(BCC_A2,MN:VA),, -0.27; 2000 N 91Din !\n PAR G(A2_BCC,MN:VA),, +GBCCMN; 2000 N 91Din !\n PAR TC(A2_BCC,MN:VA),, -580.00; 2000 N 91Din !\n PAR BMAG(A2_BCC,MN:VA),, -0.27; 2000 N 91Din !\n PAR G(HCP_A3,MN:VA),, +GHCPMN; 2000 N 91Din !\n PAR TC(HCP_A3,MN:VA),, -1620.00; 2000 N 91Din !\n PAR BMAG(HCP_A3,MN:VA),, -1.86; 2000 N 91Din !\n$PAR G(RHOMB_C19,MN),, +GHSERMN+1000; 2100 N 09Wan !\n PAR G(LIQUID,MN),, +GLIQMN; 2000 N 91Din !\n$\n PAR G(GAS,MN),, +F12439T+RTLNP;,, N 97SUB !\n$\n PAR G(C14_LAVES,MN:MN),, +3*GHSERMN+20700;,, N 12Liu !\n PAR G(FE4N_L1,MN:VA),, +4*GFCCMN+20000;,, N 17Hal12 !\n$\n FUNCTION GHSERMN 298.15 -8115.28+130.059*T-23.4582*T*LN(T)\n -0.00734768*T**2+69827*T**(-1);\n 1519.00 Y -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9);\n 2000.00 N !\n FUNCTION GCUBMN 298.15 -5800.4+135.995*T-24.8785*T*LN(T)\n -0.00583359*T**2+70269*T**(-1);\n 1519.00 Y +442.65-0.9715*T+GHSERMN+2.310723E+30*T**(-9);\n 2000.00 N !\n FUNCTION GFCCMN 298.15 -3439.3+131.884*T-24.5177*T*LN(T)\n -0.006*T**2+69600*T**(-1);\n 1519.00 Y +2663.31-2.5984*T+GHSERMN+2.205113E+30*T**(-9);\n 2000.00 N !\n FUNCTION GBCCMN 298.15 -3235.3+127.85*T-23.7*T*LN(T)\n -0.00744271*T**2+60000*T**(-1);\n 1519.00 Y +5544.58-4.5605*T+GHSERMN-3.91695E+29*T**(-9);\n 2000.00 N !\n FUNCTION GHCPMN 298.15 -4439.3+133.007*T-24.5177*T*LN(T)\n -0.006*T**2+69600*T**(-1);\n 1519.00 Y +1663.31-1.4754*T+GHSERMN+2.205113E+30*T**(-9);\n 2000.00 N !\n FUNCTION GLIQMN 298.15 +17859.91-12.6208*T+GHSERMN-4.41929E-21*T**7;\n 1519.00 Y -9993.9+299.036*T-48*T*LN(T);\n 2000.00 N !\n$ Mn(g)\n FUNCTION F12439T 298.15 +276164.054-34.4987547*T-20.786*T*LN(T);\n 1575.00 Y +275547.585-29.2480566*T-21.52064*T*LN(T)\n +3.819474E-04*T**2-3.66030333E-08*T**3+95180.95*T**(-1);\n 2100.00 Y +274521.741-16.3844926*T-23.35302*T*LN(T)\n +0.0013469965*T**2-1.18903067E-07*T**3;\n 2400.00 N !\n$ ------------------------------------------------------------------------------\n$ Mo\n$\n$ CBCC_A12 and CUB_A13 from unknown source not included in unary\n$\n PAR G(BCC_A2,MO:VA),, +GHSERMO; 5000 N 91Din !\n PAR G(A2_BCC,MO:VA),, +GHSERMO; 5000 N 91Din !\n PAR G(FCC_A1,MO:VA),, +GHSERMO+15200+0.63*T; 5000 N 91Din !\n PAR G(A1_FCC,MO:VA),, +GHSERMO+15200+0.63*T; 5000 N 91Din !\n PAR G(HCP_A3,MO:VA),, +GHSERMO+11550; 5000 N 91Din !\n PAR G(CBCC_A12,MO:VA),, +GHSERMO+11087+2.7196*T;,, N Null !\n PAR G(CUB_A13,MO:VA),, +GHSERMO+15899+0.6276*T;,, N Null !\n PAR G(LIQUID,MO),, +GLIQMO; 5000 N 91Din !\n$\n PAR G(CRNI2_C11B,MO:MO),, +ZERO;,, N 06Tur !\n PAR G(C14_LAVES,MO:MO),, +3*GHSERMO+109200;,, N 06Slu !\n PAR G(MC_ETA,MO:VA),, +GHSERMO+15200+0.63*T;,, N 88And1 !\n PAR G(SIGMA_D8B,MO:MO:MO),, +30*GHSERMO+552000;,, N 06Slu !\n$\n FUNCTION GHSERMO 298.15 -7746.302+131.9197*T-23.56414*T*LN(T)\n -0.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4;\n 2896.00 Y -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9);\n 5000.00 N !\n FUNCTION GLIQMO 298.15 +41831.347-14.694912*T+GHSERMO+4.24519E-22*T**7;\n 2896.00 Y +3538.963+271.6697*T-42.63829*T*LN(T);\n 5000.00 N !\n FUNCTION GFCCMO 298.15 +GHSERMO+15200+0.63*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ N\n$\n$ There is a small change in G(GAS,N) from SGSUB 1992 to 1994\n$ G(GAS,N2) has a completely different expression in SGSUB 1994 and 1997\n$ compared to the unary database.\n$ G(GAS,N3) is considerably changed from SGSUB 1992 to 1994.\n$\n PAR G(N2GAS,N2),, +2*GHSERNN+RTLNP;,, N 91Din !\n PAR G(LIQUID,N),, +GHSERNN+29950+59.02*T;,, N 91Din !\n$\n PAR G(GAS,N),, +F12658T+RTLNP;,, N 97SUB !\n PAR G(GAS,N2),, +2*GHSERNN+RTLNP;,, N 91Din !\n PAR G(GAS,N3),, +F12909T+RTLNP;,, N 97SUB !\n$\n FUNCTION GHSERNN 298.15 -3750.675-9.45425*T-12.7819*T*LN(T)\n -0.00176686*T**2+2.681E-09*T**3-32374*T**(-1);\n 950.00 Y -7358.85+17.2003*T-16.3699*T*LN(T)\n -6.5107E-04*T**2+3.0097E-08*T**3+563070*T**(-1);\n 3350.00 Y -16392.8+50.26*T-20.4695*T*LN(T)\n +2.39754E-04*T**2-8.333E-09*T**3+4596375*T**(-1);\n 6000.00 N !\n$ N(g)\n FUNCTION F12658T 298.15 +466446.153-13.3752574*T-20.89393*T*LN(T)\n +8.45521E-05*T**2-1.0018685E-08*T**3+2788.7865*T**(-1);\n 2950.00 Y +481259.035-52.5441353*T-16.37613*T*LN(T)\n -2.283738E-04*T**2-2.78997167E-08*T**3-7559105*T**(-1);\n 6000.00 N !\n$ N2(g) from SGSUB 1997\n FUNCTION F12845T 298.15 -8000.12556-8.81620364*T-27.22332*T*LN(T)\n -0.0012599175*T**2-5.39381E-07*T**3-38326.695*T**(-1);\n 800.00 Y -10569.6463+2.77534156*T-28.42384*T*LN(T)\n -0.003189275*T**2+2.06638E-07*T**3+416969.05*T**(-1);\n 2200.00 Y -22468.6305+71.8176271*T-37.55014*T*LN(T)\n -6.158995E-06*T**2-4.22547E-09*T**3+3427512*T**(-1);\n 6000.00 N !\n$ N3(g)\n FUNCTION F12909T 298.15 +426260.222-44.8788468*T-24.40177*T*LN(T)\n -0.02510581*T**2+3.41313667E-06*T**3+61652.95*T**(-1);\n 800.00 Y +409926.892+144.323862*T-52.34995*T*LN(T)\n -0.0035522355*T**2+2.39819667E-07*T**3+1869491.5*T**(-1);\n 2200.00 Y +398090.062+216.588607*T-61.96494*T*LN(T)\n -5.55378E-05*T**2+1.47712917E-09*T**3+4654831*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Nb\n$\n$ CBCC_A12 and CUB_A13 from 06Slu not included in unary\n$\n PAR G(BCC_A2,NB:VA),, +GHSERNB;,, N 91Din !\n PAR G(A2_BCC,NB:VA),, +GHSERNB;,, N 91Din !\n PAR G(FCC_A1,NB:VA),, +GHSERNB+13500+1.7*T;,, N 91Din !\n PAR G(A1_FCC,NB:VA),, +GHSERNB+13500+1.7*T;,, N 91Din !\n PAR G(HCP_A3,NB:VA),, +GHSERNB+10000+2.4*T;,, N 91Din !\n PAR G(CBCC_A12,NB:VA),, +GHSERNB+17600;,, N 06Slu !\n PAR G(CUB_A13,NB:VA),, +GHSERNB+22000;,, N 06Slu !\n PAR G(LIQUID,NB),, +GLIQNB;,, N 91Din !\n$\n PAR G(C14_LAVES,NB:NB),, +3*GHSERNB+49620;,, N 12Liu !\n PAR G(C15_LAVES,NB:NB),, +3*GHSERNB+48600;,, N 06Slu !\n PAR G(MC_ETA,NB:VA),, +GHSERNB+15200+0.63*T;,, N 15Zha1 !\n PAR G(MU_D85,NB:NB:NB:NB),, +13*GHSERNB+227500;,, N 12Liu !\n PAR G(NBNI3_D0A,NB:NB),, +4*GHSERNB+20000;,, N 96Bol !\n$PAR G(OMEGA_C32,NB),, +GHSERNB+15000+2.4*T;,, N 01Zha !\n$\n FUNCTION GHSERNB 298.15 -8519.353+142.045475*T-26.4711*T*LN(T)\n +2.03475E-04*T**2-3.5012E-07*T**3+93399*T**(-1);\n 2750.00 Y -37669.3+271.720843*T-41.77*T*LN(T)+1.528238E+32*T**(-9);\n 6000.00 N !\n FUNCTION GLIQNB 298.15 +29781.555-10.816418*T+GHSERNB-3.06098E-23*T**7;\n 2750.00 Y -7499.398+260.756148*T-41.77*T*LN(T);\n 6000.00 N !\n FUNCTION GFCCNB 298.15 +GHSERNB+13500+1.7*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Ni\n$\n$ FCC_A1 and LIQUID modified in unary 5.0 (slight change in upper T interval)\n$ BCT_A5 added in unary 5.0\n$\n PAR G(FCC_A1,NI:VA),, +GHSERNI; 3000 N 91Din !\n PAR TC(FCC_A1,NI:VA),, 633.00; 3000 N 91Din !\n PAR BMAG(FCC_A1,NI:VA),, 0.52; 3000 N 91Din !\n PAR G(A1_FCC,NI:VA),, +GHSERNI; 3000 N 91Din !\n PAR TC(A1_FCC,NI:VA),, 633.00; 3000 N 91Din !\n PAR BMAG(A1_FCC,NI:VA),, 0.52; 3000 N 91Din !\n PAR G(BCC_A2,NI:VA),, +GHSERNI\n +8715.084-3.556*T; 3000 N 91Din !\n PAR TC(BCC_A2,NI:VA),, 575.00; 3000 N 91Din !\n PAR BMAG(BCC_A2,NI:VA),, 0.85; 3000 N 91Din !\n PAR G(A2_BCC,NI:VA),, +GHSERNI\n +8715.084-3.556*T; 3000 N 91Din !\n PAR TC(A2_BCC,NI:VA),, 575.00; 3000 N 91Din !\n PAR BMAG(A2_BCC,NI:VA),, 0.85; 3000 N 91Din !\n PAR G(HCP_A3,NI:VA),, +GHSERNI+1046+1.255*T; 3000 N 91Din !\n$PAR G(BCT_A5,NI),, +GHSERNI+10023-4.556*T; 3000 N 99Gho !\n PAR G(CUB_A13,NI:VA),, +GHSERNI+2092; 3000 N 91Din !\n PAR G(CBCC_A12,NI:VA),, +GHSERNI+3556; 3000 N 91Din !\n PAR G(LIQUID,NI),, +GLIQNI; 3000 N 91Din !\n$\n PAR G(FE4N_L1,NI:VA),, +4*GHSERNI+20000;,, N 17Hal12 !\n PAR G(C14_LAVES,NI:NI),, +3*GHSERNI+56700;,, N 06Slu !\n PAR G(C36_LAVES,NI:NI),, +ZERO;,, N 98Jac2 !\n PAR G(NBNI3_D0A,NI:NI),, +4*GHSERNI+20000;,, N 96Bol !\n PAR G(NI3TI_D024,NI:NI),, +GHCPNI;,, N 91Din !\n PAR G(NITI2,NI:NI),, +3*GHSERNI+15000;,, N 99Dup2 !\n$\n FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T)-0.0048407*T**2;\n 1728.00 Y -27840.62+279.134977*T-43.1*T*LN(T)+1.12754E+31*T**(-9);\n 3000.00 N !\n FUNCTION GLIQNI 298.15 +16414.686-9.397*T+GHSERNI-3.82318E-21*T**7;\n 1728.00 Y -9549.817+268.597977*T-43.1*T*LN(T);\n 3000.00 N !\n FUNCTION GBCCNI 298.15 +GHSERNI+8715.084-3.556*T; 6000 N !\n FUNCTION GHCPNI 298.15 +GHSERNI+1046+1.255*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Si\n$\n PAR G(DIAMOND_A4,SI),, +GHSERSI; 3600 N 91Din !\n PAR G(FCC_A1,SI:VA),, +GHSERSI+51000-21.8*T; 3600 N 91Din !\n PAR G(A1_FCC,SI:VA),, +GHSERSI+51000-21.8*T; 3600 N 91Din !\n PAR G(BCC_A2,SI:VA),, +GHSERSI+47000-22.5*T; 3600 N 91Din !\n PAR G(A2_BCC,SI:VA),, +GHSERSI+47000-22.5*T; 3600 N 91Din !\n PAR G(HCP_A3,SI:VA),, +GHSERSI+49200-20.8*T; 3600 N 91Din !\n PAR G(CBCC_A12,SI:VA),, +GHSERSI+50208-20.377*T; 3600 N 91Din !\n PAR G(CUB_A13,SI:VA),, +GHSERSI+47279-20.377*T; 3600 N 91Din !\n PAR G(LIQUID,SI),, +GLIQSI; 3600 N 91Din !\n$\n PAR G(GAS,SI),, +F8197T+RTLNP;,, N 90SUB !\n PAR G(GAS,SI2),, +F8227T+RTLNP;,, N 90SUB !\n PAR G(GAS,SI3),, +F8245T+RTLNP;,, N 90SUB !\n$\n$PAR G(CR3SI_A15,SI:SI:VA),, +4*GHSERSI+24543.3+4*T;,, N 91Ans !\n PAR G(CR3SI_A15,SI:SI:VA),, +4*GHSERSI+208000-80*T;,, N 94Cou !\n PAR G(CRSI2_C40,SI:SI),, +3*GHSERSI\n +82389.75-24.68504*T;,, N 00Du1 !\n PAR G(C14_LAVES,SI:SI),, +3*GHSERSI+142380;,, N 17Jac !\n PAR G(C15_LAVES,SI:SI),, +3*GHSERSI+15000;,, N REFLAV !\n PAR G(NB5SI3_D8L,SI:SI),, +8*GHSERSI+40000;,, N 09Gen !\n PAR G(NBSI2_C40,SI:SI),, +3*GHSERSI+15000;,, N 09Gen !\n PAR G(SIV3_A15,SI:SI),, +4*GHSERSI+208000-80*T;,, N 98Ran !\n$\n FUNCTION GHSERSI 298.15 -8162.609+137.236859*T-22.8317533*T*LN(T)\n -0.001912904*T**2-3.552E-09*T**3+176667*T**(-1);\n 1687.00 Y -9457.642+167.281367*T-27.196*T*LN(T)-4.20369E+30*T**(-9);\n 3600.00 N !\n FUNCTION GLIQSI 298.15 +50696.36-30.099439*T+GHSERSI+2.09307E-21*T**7;\n 1687.00 Y +40370.523+137.722298*T-27.196*T*LN(T);\n 3600.00 N !\n FUNCTION GBCCSI 298.15 +GHSERSI+47000-22.5*T; 3600 N 91Din !\n FUNCTION GFCCSI 298.15 +GHSERSI+51000-21.8*T; 3600 N 91Din !\n$ Si(g)\n FUNCTION F8197T 298.15 +444772.786-60709.2124*T**(-1)-27.6547439*T\n -21.0681554*T*LN(T)+3.99285396E-04*T**2-9.9554096E-08*T**3;\n 2000.00 Y +444116.957+762762.028*T**(-1)-38.3214094*T\n -19.3609998*T*LN(T)-9.76258996E-04*T**2+4.14151845E-08*T**3;\n 4000.00 Y +400678.285+22825602.8*T**(-1)+96.3062503*T\n -35.5990619*T*LN(T)+0.00175586581*T**2-4.58426236E-08*T**3;\n 6000.00 N !\n$ Si2(g)\n FUNCTION F8227T 298.15 +580605.171-8227.81508*T**(-1)-31.8482492*T\n -28.7155033*T*LN(T)-0.0094705886*T**2+1.76928808E-07*T**3;\n 600.00 Y +576928.698+444960.032*T**(-1)-3.54867845*T\n -32.2831164*T*LN(T)-0.0114310436*T**2+1.75212671E-06*T**3;\n 1200.00 Y +565230.011+1453776.82*T**(-1)+139.106857*T\n -53.3225696*T*LN(T)+0.00393279264*T**2-2.42637831E-07*T**3;\n 2600.00 Y +583134.867-3023002.76*T**(-1)+39.6531838*T\n -40.3154759*T*LN(T)-1.64330156E-04*T**2-5.40281315E-09*T**3;\n 6000.00 N !\n$ Si3(g)\n FUNCTION F8245T 298.15 +616635.909+234142.916*T**(-1)+129.920395*T\n -58.7282976*T*LN(T)-0.00312912992*T**2+5.00836655E-07*T**3;\n 1000.00 Y +614516.828+384664.408*T**(-1)+160.460124*T\n -63.3670984*T*LN(T)+9.95168584E-04*T**2-1.50930827E-07*T**3;\n 2900.00 Y +630336.932-1798745.53*T**(-1)+58.7146891*T\n -49.9352032*T*LN(T)-0.00334104952*T**2+9.15842733E-08*T**3;\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Ti\n$\n$ BCT_A5 added in unary 3.0\n$\n PAR G(HCP_A3,TI:VA),, +GHSERTI; 4000 N 91Din !\n PAR G(BCC_A2,TI:VA),, +GBCCTI; 4000 N 91Din !\n PAR G(A2_BCC,TI:VA),, +GBCCTI; 4000 N 91Din !\n PAR G(FCC_A1,TI:VA),, +GHSERTI+6000-0.1*T; 4000 N 91Din !\n PAR G(A1_FCC,TI:VA),, +GHSERTI+6000-0.1*T; 4000 N 91Din !\n$PAR G(DIAMOND_A4,TI),, +GHSERTI+25000; 4000 N 91Din !\n$PAR G(BCT_A5,TI),, +GHSERTI+4602.2; 3000 N SGCOST !\n PAR G(CBCC_A12,TI:VA),, +GHSERTI+4602.2; 4000 N 91Din !\n PAR G(CUB_A13,TI:VA),, +GHSERTI+7531.2; 4000 N 91Din !\n PAR G(LIQUID,TI),, +GLIQTI; 4000 N 91Din !\n$\n PAR G(CU4TI1,TI:TI),, +5*GHSERTI+25000;,, N 96Har2 !\n PAR G(CUTI_B11,TI:TI),, +2*GHSERTI+10000;,, N 96Har2 !\n$PAR G(C14_LAVES,TI:TI),, +3*GFCCTI+57600;,, N 06Slu !\n$PAR G(C15_LAVES,TI:TI),, +3*GFCCTI+60900;,, N 06Slu !\n$PAR G(C36_LAVES,TI:TI),, +3*GFCCTI+59100;,, N 13Slu !\n PAR G(C14_LAVES,TI:TI),, +3*GHSERTI+45000;,, N 17Hal2 !\n PAR G(C15_LAVES,TI:TI),, +3*GHSERTI+48300;,, N 17Hal2 !\n PAR G(C36_LAVES,TI:TI),, +3*GHSERTI+46500;,, N 17Hal2 !\n PAR G(MC_ETA,TI:VA),, +GHSERTI+20000; 4000 N 96Shi !\n PAR G(NITI2,TI:TI),, +3*GHSERTI+15000;,, N 99Dup2 !\n$PAR G(OMEGA_C32,TI),, +GHSERTI+1886.7-0.1561*T;,, N 01Zha !\n PAR G(SI3TI5_D88,TI:TI:TI),, +8*GHSERTI+40000+20*T;,, N 96Sei !\n$\n FUNCTION GHSERTI 298.15 -8059.921+133.615208*T-23.9933*T*LN(T)\n -0.004777975*T**2+1.06716E-07*T**3+72636*T**(-1);\n 900.00 Y -7811.815+132.988068*T-23.9887*T*LN(T)\n -0.0042033*T**2-9.0876E-08*T**3+42680*T**(-1);\n 1155.00 Y +908.837+66.976538*T-14.9466*T*LN(T)\n -0.0081465*T**2+2.02715E-07*T**3-1477660*T**(-1);\n 1941.00 Y -124526.786+638.806871*T-87.2182461*T*LN(T)\n +0.008204849*T**2-3.04747E-07*T**3+36699805*T**(-1);\n 4000.00 N !\n FUNCTION GBCCTI 298.15 -1272.064+134.71418*T-25.5768*T*LN(T)\n -6.63845E-04*T**2-2.78803E-07*T**3+7208*T**(-1);\n 1155.00 Y +6667.385+105.366379*T-22.3771*T*LN(T)\n +0.00121707*T**2-8.4534E-07*T**3-2002750*T**(-1);\n 1941.00 Y +26483.26-182.426471*T+19.0900905*T*LN(T)\n -0.02200832*T**2+1.228863E-06*T**3+1400501*T**(-1);\n 4000.00 N !\n FUNCTION GLIQTI 298.15 +12194.415-6.980938*T+GHSERTI;\n 1300.00 Y +369519.198-2554.0225*T+342.059267*T*LN(T)\n -0.163409355*T**2+1.2457117E-05*T**3-67034516*T**(-1);\n 1941.00 Y -19887.066+298.7367*T-46.29*T*LN(T);\n 4000.00 N !\n FUNCTION GFCCTI 298.15 +GHSERTI+6000-0.1*T; 4000 N !\n$ ------------------------------------------------------------------------------\n$ V\n$\n PAR G(BCC_A2,V:VA),, +GHSERVV; 4000 N 91Din !\n PAR G(A2_BCC,V:VA),, +GHSERVV; 4000 N 91Din !\n PAR G(FCC_A1,V:VA),, +GHSERVV+7500+1.7*T; 4000 N 91Din !\n PAR G(A1_FCC,V:VA),, +GHSERVV+7500+1.7*T; 4000 N 91Din !\n PAR G(HCP_A3,V:VA),, +GHSERVV+4000+2.4*T; 4000 N 91Din !\n PAR G(CBCC_A12,V:VA),, +GHSERVV+9000; 4000 N 91Din !\n PAR G(CUB_A13,V:VA),, +GHSERVV+10000; 4000 N 91Din !\n PAR G(LIQUID,V),, +GLIQVV; 4000 N 91Din !\n$\n PAR G(C14_LAVES,V:V),, +3*GHSERVV+36983;,, N 13Khv2 !\n PAR G(MC_ETA,V:VA),, +GHSERVV+4000+2.4*T;,, N 02Bra !\n PAR G(SIGMA_D8B,V:V:V),, +30*GHSERVV+100000;,, N 02Sun !\n PAR G(SIV3_A15,V:V),, +4*GHSERVV+18000+10*T;,, N 98Ran !\n$\n FUNCTION GHSERVV 298.15 -7930.43+133.346053*T-24.134*T*LN(T)\n -0.003098*T**2+1.2175E-07*T**3+69460*T**(-1);\n 790.00 Y -7967.842+143.291093*T-25.9*T*LN(T)\n +6.25E-05*T**2-6.8E-07*T**3;\n 2183.00 Y -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9);\n 4000.00 N !\n FUNCTION GLIQVV 298.15 +20764.117-9.455552*T+GHSERVV-5.19136E-22*T**7;\n 2183.00 Y -19617.51+311.055983*T-47.43*T*LN(T);\n 4000.00 N !\n FUNCTION GFCCVV 298.15 +GHSERVV+7500+1.7*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Binary systems\n$ ------------------------------------------------------------------------------\n$ C-N\n$\n$ No parameters for this system.\n$\n$ ------------------------------------------------------------------------------\n$ Cr-C\n$\n$ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ The liquid interaction has been changed compared to 92Lee.\n$ There is still very nearly a stable miscibility gap on the C-rich side.\n$\n$ M7C3 and CR3C2 become stable again above 9000K. This is a result of the\n$ T**2 terms and is not important.\n$\n$ The enthalpies and Gibbs energies of formation compare well with recent\n$ data from Kleykamp (J. Alloys Compd., 321, 138-45(2001)) and\n$ Meschel and Kleppa on Cr7C3 (J. Alloys Compd., 257, 227-33(1997)).\n$ The standard entropies and cp at 298K are not quite as good as they\n$ could (or should) be, but it doesn't motivate a reassessment.\n$\n$ It would probably be desirable to use the G(FCC_A1,CR:C) parameter from 04Bra,\n$ but in order to do that it may be necessary to adjust L(FCC_A1,CR:C,VA) and\n$ ternary fcc parameters in the systems Cr-Fe-C, Cr-Mn-C, Cr-Ni-C and Co-Cr-C.\n$\n PAR L(LIQUID,C,CR;0),, -69245-35*T;,, N 12Khv1 !\n PAR L(LIQUID,C,CR;1),, +83242;,, N 12Khv1 !\n PAR L(LIQUID,C,CR;2),, +88000;,, N 12Khv1 !\n$\n PAR G(BCC_A2,CR:C),, +GHSERCR+3*GHSERCC+416000;,, N 87And2 !\n PAR TC(BCC_A2,CR:C),, -311.50;,, N 90Kaj !\n PAR BMAG(BCC_A2,CR:C),, -0.008;,, N 90Kaj !\n PAR L(BCC_A2,CR:C,VA;0),, -190*T;,, N 87And2 !\n$\n PAR G(A2_BCC,CR:C),, +GHSERCR+3*GHSERCC+416000;,, N 87And2 !\n PAR TC(A2_BCC,CR:C),, -311.50;,, N 90Kaj !\n PAR BMAG(A2_BCC,CR:C),, -0.008;,, N 90Kaj !\n PAR L(A2_BCC,CR:C,VA;0),, -190*T;,, N 87And2 !\n$\n PAR G(M23C6_D84,CR:CR:C),, +GCR23C6;,, N 87And2 !\n PAR G(CR3C2_D510,CR:C),, -100823.8+530.66989*T\n -89.6694*T*LN(T)-0.0301188*T**2;,, N 92Lee1 !\n PAR G(M7C3_D101,CR:C),, -201690+1103.128*T\n -190.177*T*LN(T)-0.0578207*T**2;,, N 92Lee1 !\n$\n$ metastable\n$\n PAR G(FCC_A1,CR:C),, +GHSERCR+GHSERCC\n +1200-1.94*T;,, N 92Lee1 !\n$ The parameter below gives a formation energy considerably more negative\n$ than the previous from 92Lee1 and is consistent with data in 92Fer.\n$PAR G(FCC_A1,CR:C),, -32690+248.42*T\n$ -41.678*T*LN(T)-0.00301955*T**2;,, N 04Bra !\n PAR L(FCC_A1,CR:C,VA;0),, -11977+6.8194*T;,, N 92Lee1 !\n$\n PAR G(A1_FCC,CR:C),, +GHSERCR+GHSERCC\n +1200-1.94*T;,, N 92Lee1 !\n PAR L(A1_FCC,CR:C,VA;0),, -11977+6.8194*T;,, N 92Lee1 !\n$\n PAR G(HCP_A3,CR:C),, +GHSERCR+0.5*GHSERCC\n -18504+9.4173*T-2.4997*T*LN(T)+0.001386*T**2;,, N 92Lee1 !\n PAR L(HCP_A3,CR:C,VA;0),, +4165;,, N 88Gus5 !\n$\n PAR G(CBCC_A12,CR:C),, +GHSERCR+GHSERCC+5000;,, N 93Lee2 !\n PAR G(CUB_A13,CR:C),, +GHSERCR+GHSERCC+5000;,, N 93Lee2 !\n$\n PAR G(CEMENTITE_D011,CR:C),, +3*GHSERCR+GHSERCC\n -48000-9.2888*T;,, N 92Fer !\n$\n PAR G(CR3SI_A15,CR:CR:C),, +4*GHSERCR+3*GHSERCC;,, N 00Du2 !\n$\n PAR G(FE4N_L1,CR:C),, +UN_ASS;,, N !\n$\n PAR G(KSI_CARBIDE,CR:C),, +3*GHSERCR+GHSERCC\n +114060-47.2519*T;,, N 92Qiu2 !\n$\n FUNCTION GCR23C6 298.15 -521983+3622.24*T-620.965*T*LN(T)-0.126431*T**2;\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Cr-Cu\n$\n$ M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen, O. Teppo,\n$ Calphad, 14, 125-37(1990).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ This version seems more reasonable than the later version from 98Zen2, which\n$ is included in LB Vol. 3.\n$\n PAR L(LIQUID,CR,CU;0),, +62797.75-18.95186*T;,, N 90Ham !\n PAR L(LIQUID,CR,CU;1),, -1183.91;,, N 90Ham !\n$\n PAR L(BCC_A2,CR,CU:VA;0),, +77107.48;,, N 90Ham !\n PAR L(A2_BCC,CR,CU:VA;0),, +77107.48;,, N 90Ham !\n$\n PAR L(FCC_A1,CR,CU:VA;0),, +53195.87-3.31182*T;,, N 90Ham !\n PAR L(A1_FCC,CR,CU:VA;0),, +53195.87-3.31182*T;,, N 90Ham !\n$\n$ metastable\n$\n PAR L(HCP_A3,CR,CU:VA;0),, +60000;,, N 98Zen2 !\n PAR L(CBCC_A12,CR,CU:VA;0),, +60000;,, N Same !\n PAR L(CUB_A13,CR,CU:VA;0),, +60000;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe\n$\n$ From J.-O. Andersson and B. Sundman 1987 (included in LB Vol. 2)\n$ Liquid changed by B.-J. Lee 1993\n$\n$ J.-O. Andersson, B. Sundman, Calphad, 11, 83-92(1987).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ Wrong sign for L(FCC_A1,CR,FE:VA;0) in the paper.\n$\n$ The SIGMA_D8B and SIGMA_OLD phase fields are very similar.\n$\n$PAR L(LIQUID,CR,FE;0),, -14550+6.65*T;,, N 87And1 !\n PAR L(LIQUID,CR,FE;0),, -17737+7.996546*T;,, N 93Lee1 !\n PAR L(LIQUID,CR,FE;1),, -1331;,, N 93Lee1 !\n$\n PAR L(BCC_A2,CR,FE:VA;0),, +20500-9.68*T;,, N 87And1 !\n PAR BMAG(BCC_A2,CR,FE:VA;0),, -0.85;,, N 87And1 !\n PAR TC(BCC_A2,CR,FE:VA;0),, +1650;,, N 87And1 !\n PAR TC(BCC_A2,CR,FE:VA;1),, +550;,, N 87And1 !\n$\n PAR L(A2_BCC,CR,FE:VA;0),, +20500-9.68*T;,, N 87And1 !\n PAR BMAG(A2_BCC,CR,FE:VA;0),, -0.85;,, N 87And1 !\n PAR TC(A2_BCC,CR,FE:VA;0),, +1650;,, N 87And1 !\n PAR TC(A2_BCC,CR,FE:VA;1),, +550;,, N 87And1 !\n$\n PAR G(B2_BCC,CR:FE:VA),, +3000;,, N 97Lin !\n PAR G(B2_BCC,FE:CR:VA),, +3000;,, N 97Lin !\n$\n PAR L(FCC_A1,CR,FE:VA;0),, +10833-7.477*T;,, N 87And1 !\n PAR L(FCC_A1,CR,FE:VA;1),, +1410;,, N 87And1 !\n$\n PAR L(A1_FCC,CR,FE:VA;0),, +10833-7.477*T;,, N 87And1 !\n PAR L(A1_FCC,CR,FE:VA;1),, +1410;,, N 87And1 !\n$\n PAR G(SIGMA_D8B,FE:CR:CR),, +10*GFCCFE+20*GHSERCR\n +83844-111.32*T;,, N 00Wes !\n PAR G(SIGMA_D8B,FE:CR:FE),, +10*GFCCFE+4*GHSERCR\n +16*GHSERFE+140515-111.32*T;,, N 00Wes !\n$\n$ metastable\n$\n PAR L(HCP_A3,CR,FE:VA;0),, +10833-7.477*T;,, N 90Fri1 !\n$\n PAR G(CHI_A12,CR:CR:FE),, +24*GFCCCR+10*GHSERCR\n +24*GFCCFE+500000;,, N 88Gus4 !\n PAR G(CHI_A12,FE:CR:CR),, +24*GFCCFE+10*GHSERCR\n +24*GFCCCR+18300-100*T;,, N 88And4 !\n PAR G(CHI_A12,FE:CR:FE),, +48*GFCCFE+10*GHSERCR\n +57300-100*T;,, N 88And4 !\n$\n PAR G(CR3SI_A15,FE:CR:VA),, +3*GHSERFE+GHSERCR+8000;,, N 97Lin !\n$\n PAR G(C14_LAVES,CR:FE),, +2*GHSERCR+GHSERFE+86733;,, N 16Jac1 !\n PAR G(C14_LAVES,FE:CR),, +2*GHSERFE+GHSERCR+66547;,, N 16Jac1 !\n$\n PAR G(C15_LAVES,CR:FE),, +2*GHSERCR+GHSERFE+80893;,, N 16Jac1 !\n PAR G(C15_LAVES,FE:CR),, +2*GHSERFE+GHSERCR+50467;,, N 16Jac1 !\n$\n$ Added 100 J to SIGMA_D8B\n PAR G(HIGH_SIGMA,FE:CR:CR),, +10*GFCCFE+20*GHSERCR\n +83944-111.32*T;,, N 00Wes !\n PAR G(HIGH_SIGMA,FE:CR:FE),, +10*GFCCFE+4*GHSERCR\n +16*GHSERFE+140615-111.32*T;,, N 00Wes !\n$ ------------------------------------------------------------------------------\n$ Cr-Mg\n$\n$ From I. Ansara 1998 (included in LB Vol. 2)\n$\n$ I. Ansara, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST.\n$\n PAR L(LIQUID,CR,MG;0),, +94500;,, N 98Ans !\n PAR L(LIQUID,CR,MG;1),, +12500;,, N 98Ans !\n$\n PAR L(BCC_A2,CR,MG:VA;0),, +80*T;,, N 98Ans !\n PAR L(A2_BCC,CR,MG:VA;0),, +80*T;,, N 98Ans !\n PAR L(HCP_A3,CR,MG:VA;0),, +80*T;,, N 98Ans !\n$\n$ metastable\n$\n PAR L(FCC_A1,CR,MG:VA;0),, +80*T;,, N Same !\n PAR L(A1_FCC,CR,MG:VA;0),, +80*T;,, N Same !\n PAR L(CBCC_A12,CR,MG:VA;0),, +80*T;,, N Same !\n PAR L(CUB_A13,CR,MG:VA;0),, +80*T;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn\n$\n$ From B.-J. Lee 1993 (Included in LB Vol. 2)\n$\n$ B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ HIGH-SIGMA with 10:4:16 model added by B. Hallstedt, 2016.\n$\n$ The phase field of HIGH_SIGMA with 10:4:16 is slightly more narrow.\n$ Invariant temperatures are very nearly unchanged.\n$\n$ The CBCC_A12 interaction referred to as 98Lee is an old parameter from 1991.\n$ It is used by mistake in COST and LB.\n$\n$ L(FCC_4SL,CR,MN:*:*:*:VA;0) added for the Cr-Fe-Mn system.\n$\n PAR L(LIQUID,CR,MN;0),, -15009+13.6587*T;,, N 93Lee3 !\n PAR L(LIQUID,CR,MN;1),, +504+0.9479*T;,, N 93Lee3 !\n$\n PAR L(FCC_A1,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Lee3 !\n PAR L(A1_FCC,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Lee3 !\n$\n PAR L(FCC_4SL,CR,MN:*:*:*:VA;0),, +2000;,, N 16Hal7 !\n$\n PAR L(BCC_A2,CR,MN:VA;0),, -20328+18.7339*T;,, N 93Lee3 !\n PAR L(BCC_A2,CR,MN:VA;1),, -9162+4.4183*T;,, N 93Lee3 !\n PAR TC(BCC_A2,CR,MN:VA;0),, -1325;,, N 93Lee3 !\n PAR TC(BCC_A2,CR,MN:VA;2),, -1133;,, N 93Lee3 !\n PAR TC(BCC_A2,CR,MN:VA;4),, -10294;,, N 93Lee3 !\n PAR TC(BCC_A2,CR,MN:VA;6),, +26706;,, N 93Lee3 !\n PAR TC(BCC_A2,CR,MN:VA;8),, -28117;,, N 93Lee3 !\n PAR BMAG(BCC_A2,CR,MN:VA;0),, +0.48643;,, N 93Lee3 !\n PAR BMAG(BCC_A2,CR,MN:VA;2),, -0.72035;,, N 93Lee3 !\n PAR BMAG(BCC_A2,CR,MN:VA;4),, -1.93265;,, N 93Lee3 !\n$\n PAR L(A2_BCC,CR,MN:VA;0),, -20328+18.7339*T;,, N 93Lee3 !\n PAR L(A2_BCC,CR,MN:VA;1),, -9162+4.4183*T;,, N 93Lee3 !\n PAR TC(A2_BCC,CR,MN:VA;0),, -1325;,, N 93Lee3 !\n PAR TC(A2_BCC,CR,MN:VA;2),, -1133;,, N 93Lee3 !\n PAR TC(A2_BCC,CR,MN:VA;4),, -10294;,, N 93Lee3 !\n PAR TC(A2_BCC,CR,MN:VA;6),, +26706;,, N 93Lee3 !\n PAR TC(A2_BCC,CR,MN:VA;8),, -28117;,, N 93Lee3 !\n PAR BMAG(A2_BCC,CR,MN:VA;0),, +0.48643;,, N 93Lee3 !\n PAR BMAG(A2_BCC,CR,MN:VA;2),, -0.72035;,, N 93Lee3 !\n PAR BMAG(A2_BCC,CR,MN:VA;4),, -1.93265;,, N 93Lee3 !\n$\n PAR L(CBCC_A12,CR,MN:VA;0),, -38349+22.6925*T;,, N 93Lee3 !\n$PAR L(CBCC_A12,CR,MN:VA;0),, -36796+20.385*T;,, N 98Lee !\n PAR L(CUB_A13,CR,MN:VA;0),, -31260+16.4919*T;,, N 93Lee3 !\n$\n PAR G(SIGMA_D8B,MN:CR:CR),, +10*GFCCMN+20*GHSERCR\n +10000;,, N 16Hal6 !\n PAR G(SIGMA_D8B,MN:CR:MN),, +10*GFCCMN+4*GHSERCR\n +16*GBCCMN-168613+65.6*T;,, N 16Hal6 !\n PAR L(SIGMA_D8B,MN:CR:CR,MN;0),, -947617+762.6*T;,, N 16Hal6 !\n$\n PAR G(HIGH_SIGMA,MN:CR:CR),, +10*GFCCMN+20*GHSERCR\n -105987+105*T;,, N 16Hal6 !\n PAR G(HIGH_SIGMA,MN:CR:MN),, +10*GFCCMN+4*GHSERCR\n +16*GBCCMN-73252-10*T;,, N 16Hal6 !\n$\n PAR G(CR3MN5,CR:MN),, +3*GHSERCR+5*GHSERMN\n -72550+21.1732*T;,, N 93Lee3 !\n$\n$ Metastable\n$\n$PAR L(HCP_A3,CR,MN:VA;0),, +60000;,, N 93Lee3 !\n PAR L(HCP_A3,CR,MN:VA;0),, -19088+17.5423*T;,, N 93Fri !\n$\n PAR G(C14_LAVES,CR:MN),, +2*GHSERCR+GHSERMN+61860;,, N Lin !\n PAR G(C14_LAVES,MN:CR),, +2*GHSERMN+GHSERCR+41280;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo\n$\n$ From K. Frisk and P. Gustafson 1988 (Included in LB Vol. 2)\n$\n$ K. Frisk, P. Gustafson, Calphad, 12, 247-254(1988).\n$\n$ Checked against LB and paper.\n$\n PAR L(LIQUID,CR,MO;0),, +15810-6.714*T;,, N 88Fri !\n PAR L(LIQUID,CR,MO;1),, -6220;,, N 88Fri !\n$\n PAR L(BCC_A2,CR,MO:VA;0),, +28890-7.962*T;,, N 88Fri !\n PAR L(BCC_A2,CR,MO:VA;1),, +5974-2.428*T;,, N 88Fri !\n$\n PAR L(A2_BCC,CR,MO:VA;0),, +28890-7.962*T;,, N 88Fri !\n PAR L(A2_BCC,CR,MO:VA;1),, +5974-2.428*T;,, N 88Fri !\n$\n$ Metastable\n$\n$ Same as bcc\n PAR L(FCC_A1,CR,MO:VA;0),, +28890-7.962*T;,, N 92Qiu1 !\n PAR L(FCC_A1,CR,MO:VA;1),, +5974-2.428*T;,, N 92Qiu1 !\n$\n PAR L(A1_FCC,CR,MO:VA;0),, +28890-7.962*T;,, N 92Qiu1 !\n PAR L(A1_FCC,CR,MO:VA;1),, +5974-2.428*T;,, N 92Qiu1 !\n$\n$ Same as bcc\n PAR L(HCP_A3,CR,MO:VA;0),, +28890-7.962*T;,, N NIST !\n PAR L(HCP_A3,CR,MO:VA;1),, +5974-2.428*T;,, N NIST !\n$\n$ Same as bcc\n PAR L(CBCC_A12,CR,MO:VA;0),, +28890-7.962*T;,, N 95Lee !\n PAR L(CBCC_A12,CR,MO:VA;1),, +5974-2.428*T;,, N 95Lee !\n$\n$ Same as bcc\n PAR L(CUB_A13,CR,MO:VA;0),, +28890-7.962*T;,, N 95Lee !\n PAR L(CUB_A13,CR,MO:VA;1),, +5974-2.428*T;,, N 95Lee !\n$\n PAR G(CHI_A12,CR:CR:MO),, +24*GFCCCR+10*GHSERCR+24*GFCCMO\n +500000;,, N 88Gus4 !\n PAR G(CHI_A12,CR:MO:MO),, +24*GFCCCR+10*GHSERMO+24*GFCCMO\n +500000;,, N 88Gus4 !\n PAR G(CHI_A12,CR:MO:CR),, +48*GFCCCR+10*GHSERMO\n +500000;,, N 88Gus4 !\n$ Parameter below from TCFE-99\n$PAR G(CHI_A12,CR:MO:CR),, +48*GFCCCR+10*GHSERMO\n$ -26000;,, N Null !\n$\n PAR G(CRNI2_C11B,CR:MO),, +ZERO;,, N 06Tur !\n$\n PAR G(C14_LAVES,CR:MO),, +2*GFCCCR+GHSERMO-8000-6*T;,, N 87Gus2 !\n PAR G(C14_LAVES,MO:CR),, +2*GHSERMO+GHSERCR+190000;,, N 17Hal5 !\n$PAR L(C14_LAVES,CR,MO:*;0),, +60000;,, N 99Lee !\n$PAR L(C14_LAVES,*:CR,MO;0),, +30000;,, N 99Lee !\n$\n PAR G(MU_D85,CR:MO:CR:CR),, +7*GFCCCR+2*GHSERCR\n +4*GHSERMO;,, N Lin !\n PAR G(MU_D85,CR:MO:CR:MO),, +3*GHSERCR+4*GHSERMO\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,CR:MO:MO:CR),, +7*GFCCCR+6*GHSERMO;,, N Lin !\n PAR G(MU_D85,CR:MO:MO:MO),, +GHSERCR+6*GHSERMO\n +6*GFCCMO;,, N Lin !\n$\n PAR G(MONI,CR:CR:MO),, +6*GFCCCR+5*GHSERCR+3*GHSERMO\n +12500;,, N 90Fri3 !\n PAR G(MONI,CR:MO:MO),, +6*GFCCCR+8*GHSERMO+25000;,, N 90Fri3 !\n$\n PAR G(P_PHASE,CR:CR:MO),, +24*GFCCCR+20*GHSERCR+12*GHSERMO\n +252300-100*T;,, N 90Fri3 !\n PAR G(P_PHASE,CR:MO:MO),, +24*GFCCCR+32*GHSERMO\n +265000-200*T;,, N 17Hal11 !\n$\n PAR G(R_PHASE,CR:MO:CR),, +27*GFCCCR+12*GHSERCR+14*GHSERMO\n -20000;,, N 88And4 !\n PAR G(R_PHASE,CR:MO:MO),, +27*GFCCCR+26*GHSERMO\n -20000;,, N 88And4 !\n$\n PAR G(SIGMA_D8B,MO:CR:CR),, +10*GFCCMO+20*GHSERCR\n +150000;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MO:CR:MO),, +10*GFCCMO+4*GHSERCR\n +16*GHSERMO;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MO:MO:CR),, +10*GFCCMO+4*GHSERMO\n +16*GHSERCR-150000;,, N 17Hal6 !\n$ ------------------------------------------------------------------------------\n$ Cr-N\n$\n$ From K. Frisk 1991 (included in LB Vol. 2)\n$\n$ K. Frisk, Calphad, 15, 79-106(1991).\n$\n$ Checked against LB and paper.\n$\n$ BCC_A2 has a gigantic stability region above 2500 K.\n$\n PAR L(LIQUID,CR,N;0),, -161800-16.11*T;,, N 91Fri1 !\n PAR L(LIQUID,CR,N;1),, +65508;,, N 91Fri1 !\n$\n PAR G(FCC_A1,CR:N),, +GHSERCR+GHSERNN\n -124460+142.16*T-8.5*T*LN(T);,, N 91Fri1 !\n PAR L(FCC_A1,CR:N,VA;0),, +20000;,, N 91Fri1 !\n$\n PAR G(A1_FCC,CR:N),, +GHSERCR+GHSERNN\n -124460+142.16*T-8.5*T*LN(T);,, N 91Fri1 !\n PAR L(A1_FCC,CR:N,VA;0),, +20000;,, N 91Fri1 !\n$\n PAR G(BCC_A2,CR:N),, +GHSERCR+3*GHSERNN\n +311870+29.12*T;,, N 91Fri1 !\n PAR TC(BCC_A2,CR:N),, -311.5;,, N 91Fri1 !\n PAR BMAG(BCC_A2,CR:N),, -0.008;,, N 91Fri1 !\n PAR L(BCC_A2,CR:N,VA;0),, -200000;,, N 91Fri1 !\n$\n PAR G(A2_BCC,CR:N),, +GHSERCR+3*GHSERNN\n +311870+29.12*T;,, N 91Fri1 !\n PAR TC(A2_BCC,CR:N),, -311.5;,, N 91Fri1 !\n PAR BMAG(A2_BCC,CR:N),, -0.008;,, N 91Fri1 !\n PAR L(A2_BCC,CR:N,VA;0),, -200000;,, N 91Fri1 !\n$\n PAR G(HCP_A3,CR:N),, +GHSERCR+0.5*GHSERNN\n -65760+64.69*T-3.93*T*LN(T);,, N 91Fri1 !\n PAR L(HCP_A3,CR:N,VA;0),, +21120-10.61*T;,, N 91Fri1 !\n PAR L(HCP_A3,CR:N,VA;1),, -6204;,, N 91Fri1 !\n$\n$ metastable\n$\n PAR G(CEMENTITE_D011,CR:N),, +3*GHSERCR+GHSERNN+40000;,, N Null !\n PAR G(FE4N_L1,CR:N),, -135240+717.87*T-127.18*T*LN(T)\n -0.002899*T**2-1.0968E-06*T**3+450231*T**(-1);,, N 93Fri !\n$ ------------------------------------------------------------------------------\n$ Cr-Nb\n$\n$ C. Schmetterer, A. Khvan, A. Jacob, B. Hallstedt, T. Markus\n$ J. Phase Equilib. Diffus., 35, 434-44(2014).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CR,NB;0),, -10856;,, N 14Sch !\n PAR L(LIQUID,CR,NB;1),, -5056;,, N 14Sch !\n PAR L(LIQUID,CR,NB;2),, -2520;,, N 14Sch !\n$\n PAR L(BCC_A2,CR,NB:VA;0),, +61904-23.12*T;,, N 14Sch !\n PAR L(BCC_A2,CR,NB:VA;1),, +37791-19.31*T;,, N 14Sch !\n$\n PAR L(A2_BCC,CR,NB:VA;0),, +61904-23.12*T;,, N 14Sch !\n PAR L(A2_BCC,CR,NB:VA;1),, +37791-19.31*T;,, N 14Sch !\n$\n PAR G(C15_LAVES,CR:NB),, +2*GHSERCR+GHSERNB\n -6976-10.46*T;,, N 14Sch !\n PAR G(C15_LAVES,NB:CR),, +GHSERCR+2*GHSERNB+222090;,, N 14Sch !\n PAR L(C15_LAVES,CR,NB:CR;0),, +35896;,, N 14Sch !\n PAR L(C15_LAVES,CR,NB:NB;0),, +35896;,, N 14Sch !\n PAR L(C15_LAVES,CR:CR,NB;0),, -55035;,, N 14Sch !\n PAR L(C15_LAVES,NB:CR,NB;0),, -55035;,, N 14Sch !\n$\n$ metastable\n$\n PAR L(FCC_A1,CR,NB:VA;0),, +61904-23.12*T;,, N Same !\n PAR L(FCC_A1,CR,NB:VA;1),, +37791-19.31*T;,, N Same !\n$\n PAR L(A1_FCC,CR,NB:VA;0),, +61904-23.12*T;,, N Same !\n PAR L(A1_FCC,CR,NB:VA;1),, +37791-19.31*T;,, N Same !\n$\n PAR L(HCP_A3,CR,NB:VA;0),, +61904-23.12*T;,, N Same !\n PAR L(HCP_A3,CR,NB:VA;1),, +37791-19.31*T;,, N Same !\n$\n PAR G(C14_LAVES,CR:NB),, +2*GHSERCR+GHSERNB\n -5600-10.46*T;,, N 16Jac1 !\n PAR G(C14_LAVES,NB:CR),, +GHSERCR+2*GHSERNB+227160;,, N 16Jac1 !\n PAR L(C14_LAVES,CR,NB:CR;0),, +35896;,, N 16Jac1 !\n PAR L(C14_LAVES,CR,NB:NB;0),, +35896;,, N 16Jac1 !\n PAR L(C14_LAVES,CR:CR,NB;0),, -55035;,, N 16Jac1 !\n PAR L(C14_LAVES,NB:CR,NB;0),, -55035;,, N 16Jac1 !\n$\n PAR G(MU_D85,CR:NB:CR:CR),, +9*GHSERCR+4*GHSERNB+47060;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:CR:NB),, +3*GHSERCR+10*GHSERNB\n +359580;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:NB:CR),, +7*GHSERCR+6*GHSERNB+10140;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:NB:NB),, +GHSERCR+12*GHSERNB+214240;,, N 16Jac1 ! \n PAR G(MU_D85,NB:NB:CR:CR),, +8*GHSERCR+5*GHSERNB\n +135200;,, N 16Jac1 ! \n PAR G(MU_D85,NB:NB:CR:NB),, +2*GHSERCR+11*GHSERNB\n +378690;,, N 16Jac1 ! \n PAR G(MU_D85,NB:NB:NB:CR),, +6*GHSERCR+7*GHSERNB+75660;,, N 16Jac1 ! \n$ ------------------------------------------------------------------------------\n$ Cr-Ni\n$\n$ F. Tang, B. Hallstedt, Calphad, 55, 260-69(2016).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ Metastable ordering in fcc and bcc from N. Dupin. Changed to a 4SL fcc\n$ model with option F. Adding a reciprocal term makes CrNi3 (the only\n$ ordered state) less stable; max T decreases from 450 K to 235 K.\n$\n$ The hcp interaction is set 2kJ more positive than the fcc interaction\n$ to avoid having hcp stable in Cr-Ni-C.\n$\n PAR L(LIQUID,CR,NI;0),, -13300+2.7*T;,, N 16Tan !\n PAR L(LIQUID,CR,NI;1),, +2900+1*T;,, N 16Tan !\n$\n PAR L(FCC_A1,CR,NI:VA;0),, +4300-8.9*T;,, N 16Tan !\n PAR L(FCC_A1,CR,NI:VA;1),, +27000-13.8*T;,, N 16Tan !\n PAR TC(FCC_A1,CR,NI:VA;0),, -3605;,, N 86Din !\n PAR BMAG(FCC_A1,CR,NI:VA;0),, -1.91;,, N 86Din !\n$\n PAR L(A1_FCC,CR,NI:VA;0),, +4300-8.9*T;,, N 16Tan !\n PAR L(A1_FCC,CR,NI:VA;1),, +27000-13.8*T;,, N 16Tan !\n PAR TC(A1_FCC,CR,NI:VA;0),, -3605;,, N 86Din !\n PAR BMAG(A1_FCC,CR,NI:VA;0),, -1.91;,, N 86Din !\n$\n PAR G(FCC_4SL,CR:CR:CR:NI:VA),, +GFCR3NI;,, N 01Dup !\n PAR G(FCC_4SL,CR:CR:NI:NI:VA),, +GFCR2NI2;,, N 01Dup !\n PAR G(FCC_4SL,CR:NI:NI:NI:VA),, +GFCRNI3;,, N 01Dup !\n$PAR L(FCC_4SL,CR,NI:CR,NI:*:*:VA),, +SFCRNI;,, N 16Hal3 !\n$\n PAR L(BCC_A2,CR,NI:VA;0),, +14500-9*T;,, N 16Tan !\n PAR L(BCC_A2,CR,NI:VA;1),, +27500-7.6*T;,, N 16Tan !\n PAR TC(BCC_A2,CR,NI:VA;0),, +2373;,, N 86Din !\n PAR TC(BCC_A2,CR,NI:VA;1),, +617;,, N 86Din !\n PAR BMAG(BCC_A2,CR,NI:VA;0),, +4;,, N 86Din !\n$\n PAR L(A2_BCC,CR,NI:VA;0),, +14500-9*T;,, N 16Tan !\n PAR L(A2_BCC,CR,NI:VA;1),, +27500-7.6*T;,, N 16Tan !\n PAR TC(A2_BCC,CR,NI:VA;0),, +2373;,, N 86Din !\n PAR TC(A2_BCC,CR,NI:VA;1),, +617;,, N 86Din !\n PAR BMAG(A2_BCC,CR,NI:VA;0),, +4;,, N 86Din !\n$\n PAR G(B2_BCC,CR:NI:VA),, +4000;,, N 01Dup !\n PAR G(B2_BCC,NI:CR:VA),, +4000;,, N 01Dup !\n$\n PAR G(CRNI2_C11B,CR:NI),, +GHSERCR+2*GHSERNI\n -6000-6.8*T;,, N 16Tan !\n$\n$ Metastable\n$\n PAR L(HCP_A3,CR,NI:VA;0),, +6300-8.9*T;,, N Same !\n PAR L(HCP_A3,CR,NI:VA;1),, +27000-13.8*T;,, N Same !\n$PAR L(HCP_A3,CR,NI:VA;0),, +50000;,, N 95Dup !\n PAR TC(HCP_A3,CR,NI:VA;0),, -3605;,, N Same !\n PAR BMAG(HCP_A3,CR,NI:VA;0),, -1.91;,, N Same !\n$\n PAR G(CHI_A12,CR:CR:NI),, +24*GFCCCR+10*GHSERCR\n +24*GHSERNI;,, N Lin !\n PAR G(CHI_A12,NI:CR:CR),, +24*GHSERNI+10*GHSERCR\n +24*GFCCCR;,, N Lin !\n PAR G(CHI_A12,NI:CR:NI),, +48*GHSERNI+10*GHSERCR;,, N Lin !\n$\n PAR G(CR3SI_A15,NI:CR:VA),, +3*GHSERNI+GHSERCR+20000;,, N 00Sch !\n$\n PAR G(C14_LAVES,CR:NI),, +2*GHSERCR+GHSERNI+15000;,, N REFLAV !\n PAR G(C14_LAVES,NI:CR),, +2*GHSERNI+GHSERCR+15000;,, N REFLAV !\n$\n$PAR G(SIGMA_D8B,NI:CR:CR),, +10*GHSERNI+20*GHSERCR\n$ +258130-254.715*T;,, N 93Lee4 !\n PAR G(SIGMA_D8B,NI:CR:CR),, +10*GHSERNI+20*GHSERCR\n +240000-254.715*T;,, N 16Hal4 !\n PAR G(SIGMA_D8B,NI:CR:NI),, +10*GHSERNI+4*GHSERCR+16*GBCCNI\n +175400;,, N 88Gus6 !\n$\n PAR G(HIGH_SIGMA,NI:CR:CR),, +10*GHSERNI+20*GHSERCR\n +240000-254.715*T;,, N 16Hal4 !\n PAR G(HIGH_SIGMA,NI:CR:NI),, +10*GHSERNI+4*GHSERCR+16*GBCCNI\n +175400;,, N 88Gus6 !\n$\n FUNCTION U1FCRNI 298.15 -1980; 6000 N !\n FUNCTION SFCRNI 298.15 +U1FCRNI; 6000 N !\n FUNCTION GFCRNI3 298.15 +3*U1FCRNI; 6000 N !\n FUNCTION GFCR2NI2 298.15 +4*U1FCRNI; 6000 N !\n FUNCTION GFCR3NI 298.15 +3*U1FCRNI; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Cr-Si\n$\n$ Y. Du, J.C. Schuster, J. Phase Equilib., 21, 281-86(2000).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ The parameter G(CR3SI_A15,SI:SI:VA) should probably be changed.\n$ Modified M5SI3_D88 to be stoichiometric for combination with e.g. Fe-Si.\n$ The temperature dependence of G(M4SI3,CR:SI) has the wrong sign in 00Sch.\n$\n$ Stoichiometric version of M5SI3_D88 is used here.\n$\n PAR L(LIQUID,CR,SI;0),, -126112.28+19.92557*T;,, N 00Du1 !\n PAR L(LIQUID,CR,SI;1),, -48048.45+11.38497*T;,, N 00Du1 !\n$\n PAR L(BCC_A2,CR,SI:VA;0),, -83007.82-1.35928*T;,, N 00Du1 !\n PAR L(BCC_A2,CR,SI:VA;1),, -48048.45+11.38497*T;,, N 00Du1 !\n$\n PAR L(A2_BCC,CR,SI:VA;0),, -83007.82-1.35928*T;,, N 00Du1 !\n PAR L(A2_BCC,CR,SI:VA;1),, -48048.45+11.38497*T;,, N 00Du1 !\n$\n PAR G(B2_BCC,CR:SI:VA),, -20000;,, N 97Lin !\n PAR G(B2_BCC,SI:CR:VA),, -20000;,, N 97Lin !\n$\n PAR G(CR3SI_A15,CR:SI:VA),, +3*GHSERCR+GHSERSI\n -115442.82-1.40036*T;,, N 00Du1 !\n PAR G(CR3SI_A15,SI:CR:VA),, +GHSERCR+3*GHSERSI\n +316999.96-68.59964*T;,, N 00Du1 !\n PAR L(CR3SI_A15,CR,SI:CR:VA;0),, -9661.46;,, N 00Du1 !\n PAR L(CR3SI_A15,CR,SI:SI:VA;0),, -9661.46;,, N 00Du1 !\n PAR L(CR3SI_A15,CR:CR,SI:VA;0),, -16781.4;,, N 00Du1 !\n PAR L(CR3SI_A15,SI:CR,SI:VA;0),, -16781.4;,, N 00Du1 !\n$\n PAR G(CR5SI3_D8M,CR:SI),, +GCR5SI3;,, N 00Du1 !\n$\n PAR G(M5SI3_D88,CR:SI:VA),, +GCR5SI3\n +19359-10.89*T;,, N 07Hal1 !\n$\n PAR G(MSI_B20,CR:SI),, -79273.09+312.40316*T\n -51.62865*T*LN(T)-0.00447355*T**2\n +391330*T**(-1);,, N 00Du1 !\n$\n PAR G(CRSI2_C40,CR:SI),, -100352.65+336.777*T\n -57.855747*T*LN(T)-0.0132277*T**2\n -4.3203E-07*T**3;,, N 00Du1 !\n PAR G(CRSI2_C40,SI:CR),, +2*GHSERCR+GHSERSI\n +174006-27.21105*T;,, N 00Du1 !\n PAR L(CRSI2_C40,CR,SI:CR;0),, +1435.7;,, N 00Du1 !\n PAR L(CRSI2_C40,CR,SI:SI;0),, +1435.7;,, N 00Du1 !\n PAR L(CRSI2_C40,CR:CR,SI;0),, +ZERO;,, N 00Du1 !\n PAR L(CRSI2_C40,SI:CR,SI;0),, +ZERO;,, N 00Du1 !\n$\n$ metastable\n$\n PAR L(FCC_A1,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same !\n PAR L(FCC_A1,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same !\n$\n PAR L(A1_FCC,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same !\n PAR L(A1_FCC,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same !\n$\n PAR L(HCP_A3,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same !\n PAR L(HCP_A3,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same !\n$\n PAR L(CBCC_A12,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same !\n PAR L(CBCC_A12,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same !\n$\n PAR L(CUB_A13,CR,SI:VA;0),, -83007.82-1.35928*T;,, N Same !\n PAR L(CUB_A13,CR,SI:VA;1),, -48048.45+11.38497*T;,, N Same !\n$\n PAR G(C14_LAVES,CR:SI),, +2*GHSERCR+GHSERSI+100000;,, N 17Hal10 !\n PAR G(C14_LAVES,SI:CR),, +2*GHSERSI+GHSERCR+100000;,, N 17Hal10 !\n$\n PAR G(M4SI3,CR:SI),, +4*GHSERCR+3*GHSERSI\n -213260.3-1.74503*T;,, N 00Sch !\n PAR G(NI5SI2,CR:SI),, +5*GHSERCR+2*GHSERSI\n -23370.86-78.25748*T;,, N 00Sch !\n PAR G(NI2SI_C37,CR:SI),, +2*GHSERCR+GHSERSI\n -40923.29-23.21742*T;,, N 00Sch !\n$\n FUNCTION GCR5SI3 298.15 -316886.2+1067.97713*T-182.578184*T*LN(T)\n -0.023919688*T**2-2.31728E-06*T**3;\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Cr-Ti\n$\n$ J. Pavlu, J. Vrestal, M. Sob, Calphad, 34, 215-21(2010).\n$\n$ Both 2-SL and 3-SL models are included for the C14_LAVES and C36_LAVES phases.\n$ This dataset includes the 2-SL models.\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ There are two models for Cr2Ti included. CR2TI_C14 etc are the original from\n$ 10Pav. C14_LAVES etc include new end-member values and refitted interactions.\n$ Incorrect values for G(C14_LAVES,TI:TI), G(C15_LAVES,TI:TI) and\n$ G(C36_LAVES,TI:TI) were used in a previous version.\n$ When using the correct value for C14_LAVES from 06Slu it was not possible to\n$ refit the Mn-Ti phase diagram without using excessive interaction parameters.\n$ Therefore a value for G(C14_LAVES,TI:TI) was selected that produces moderate\n$ interaction parameters.\n$ The Ti solubility in the Laves phases increases somewhat and invariant\n$ temperatures change by up to about 7 K.\n$\n PAR L(LIQUID,CR,TI;0),, -992;,, N 00Zhu !\n PAR L(LIQUID,CR,TI;1),, +1811;,, N 00Zhu !\n$\n PAR L(BCC_A2,CR,TI:VA;0),, +11824;,, N 00Zhu !\n PAR L(BCC_A2,CR,TI:VA;1),, +5012;,, N 00Zhu !\n$\n PAR L(A2_BCC,CR,TI:VA;0),, +11824;,, N 00Zhu !\n PAR L(A2_BCC,CR,TI:VA;1),, +5012;,, N 00Zhu !\n$\n PAR L(HCP_A3,CR,TI:VA;0),, +25500;,, N 00Zhu !\n$\n PAR G(C14_LAVES,CR:TI),, +2*GHSERCR+GHSERTI\n -25401-0.788*T+0.788*T*LN(T);,, N 10Pav !\n PAR G(C14_LAVES,TI:CR),, +2*GHSERTI+GHSERCR\n +154157;,, N 10Pav !\n PAR L(C14_LAVES,CR,TI:TI;0),, +10000;,, N 17Hal2 !\n$\n PAR G(C15_LAVES,CR:TI),, +2*GHSERCR+GHSERTI\n -30486-1.414*T+1.414*T*LN(T);,, N 10Pav !\n PAR G(C15_LAVES,TI:CR),, +2*GHSERTI+GHSERCR\n +171806;,, N 10Pav !\n PAR L(C15_LAVES,CR,TI:TI;0),, -7500;,, N 17Hal2 !\n$\n PAR G(C36_LAVES,CR:TI),, +2*GHSERCR+GHSERTI\n -28534-1.107*T+1.107*T*LN(T);,, N 10Pav !\n PAR G(C36_LAVES,TI:CR),, +2*GHSERTI+GHSERCR\n +160581;,, N 10Pav !\n PAR L(C36_LAVES,CR,TI:TI;0),, +8000;,, N 17Hal2 !\n$\n$ metastable\n$\n$PAR L(FCC_A1,CR,TI:VA;0),, +32000;,, N 95Dup !\n PAR L(FCC_A1,CR,TI:VA;0),, +15791.59;,, N Null !\n PAR L(A1_FCC,CR,TI:VA;0),, +15791.59;,, N Null !\n$\n PAR G(MU_D85,CR:TI:TI:CR),, +7*GFCCCR+6*GBCCTI;,, N Lin !\n PAR G(MU_D85,CR:TI:CR:CR),, +7*GFCCCR+4*GBCCTI\n +2*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-V\n$\n$ From B.-J. Lee 1992 (Included in LB Vol. 2)\n$\n$ B.-J. Lee, Z. Metallkd., 83, 292-99(1992).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CR,V;0),, -9874-2.6964*T;,, N 92Lee3 !\n PAR L(LIQUID,CR,V;1),, -1720-2.5237*T;,, N 92Lee3 !\n$\n PAR L(BCC_A2,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 !\n PAR L(BCC_A2,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 !\n$\n PAR L(A2_BCC,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 !\n PAR L(A2_BCC,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 !\n$\n$ Metastable\n$\n PAR L(FCC_A1,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 !\n PAR L(FCC_A1,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 !\n$\n PAR L(A1_FCC,CR,V:VA;0),, -9874-2.6964*T;,, N 92Lee3 !\n PAR L(A1_FCC,CR,V:VA;1),, -1720-2.5237*T;,, N 92Lee3 !\n$\n PAR L(HCP_A3,CR,V:VA;0),, -9874-2.6964*T;,, N Same !\n PAR L(HCP_A3,CR,V:VA;1),, -1720-2.5237*T;,, N Same !\n$\n PAR G(C14_LAVES,CR:V),, +2*GHSERCR+GHSERVV+67290;,, N Lin !\n PAR G(C14_LAVES,V:CR),, +2*GHSERVV+GHSERCR+52140;,, N Lin !\n$\n PAR G(SIGMA_D8B,V:CR:CR),, +10*GFCCVV+20*GHSERCR;,, N Lin !\n PAR G(SIGMA_D8B,V:CR:V),, +10*GFCCVV+4*GHSERCR\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,V:V:CR),, +10*GFCCVV+4*GHSERVV\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cu-C\n$\n$ From A.T. Dinsdale 2004 (included in LB Vol. 2)\n$\n$ A.T. Dinsdale, unpublished, 2004.\n$\n$ Checked against LB.\n$\n$ The calculated diagram using the fcc interaction from LBall-v7+fun.tdb\n$ is not in agreement with the text in LB. According to the text the max C\n$ C solubility in fcc-Cu is 0.04 at%. The calculated solubility is 3e-6 at%.\n$\n$ L(FCC_A1,CU:C,VA;0) was fitted to solubility data from R.B. McLellan,\n$ Scripta Metall., 3, 389-92(1989), which is roughly in agreement with the\n$ text in LB.\n$\n$ There are new data on the C solubility in fcc-Cu from Lopez and Mittemeijer\n$ (Scripta Mater., 51, 1-5(2004)). These indicate a much lower solubility\n$ of 7.4e-4 at.% at 1293 K. These data were used by 14Shu and their parameters\n$ are used here.\n$\n$ The liquid solubility is in agreement with data from L.L. Oden and\n$ N.A. Gokcen, Metall. Trans. B, 23B, 453-58(1992), which were also used\n$ by 14Shu.\n$\n$ The BCC_A2 parameters suggested by 14Shu are questionable, but it is not\n$ clear if the 87Cha parameters are any better. The BCC_A2 parameters were\n$ selected here for a G-curve approximately parallel to the FCC_A1 curve\n$ at 1373 K.\n$ \n$\n PAR L(LIQUID,C,CU;0),, +123650-24.5461*T;,, N 04Din !\n$\n$PAR G(FCC_A1,CU:C),, +GHSERCU+GHSERCC\n$ +138490-14.64*T;,, N 87Cha !\n PAR G(FCC_A1,CU:C),, +GHSERCU+GHSERCC+127000;,, N 14Shu !\n$PAR L(FCC_A1,CU:C,VA;0),, +75000;,, N 04Din !\n$PAR L(FCC_A1,CU:C,VA;0),, -91200+45.8*T;,, N 08Hal2 !\n PAR L(FCC_A1,CU:C,VA;0),, +ZERO;,, N 14Shu !\n$\n PAR G(A1_FCC,CU:C),, +GHSERCU+GHSERCC+127000;,, N 14Shu !\n PAR L(A1_FCC,CU:C,VA;0),, +ZERO;,, N 14Shu !\n$\n$ metastable\n$\n$PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC+127000;,, N 14Shu !\n$PAR L(BCC_A2,CU:C,VA;0),, +ZERO;,, N 14Shu !\n$PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC\n$ +146858-14.64*T;,, N 87Cha !\n$PAR L(BCC_A2,CU:C,VA;0),, +120000;,, N 87Cha !\n PAR G(BCC_A2,CU:C),, +GHSERCU+3*GHSERCC+440000;,, N 17Hal15 !\n PAR L(BCC_A2,CU:C,VA;0),, +ZERO;,, N 17Hal15 !\n$\n PAR G(A2_BCC,CU:C),, +GHSERCU+3*GHSERCC+440000;,, N 17Hal15 !\n PAR L(A2_BCC,CU:C,VA;0),, +ZERO;,, N 17Hal15 !\n$\n PAR G(HCP_A3,CU:C),, +UN_ASS;,, N !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe\n$\n$ Q. Chen, Z.P. Jin, Metall. Mater. Trans. A, 26A, 417-26(1995).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CU,FE;0),, +35625.8-2.19045*T;,, N 95Che !\n PAR L(LIQUID,CU,FE;1),, -1529.8+1.15291*T;,, N 95Che !\n PAR L(LIQUID,CU,FE;2),, +12714.4-5.18624*T;,, N 95Che !\n PAR L(LIQUID,CU,FE;3),, +1177.1;,, N 95Che !\n$\n PAR L(FCC_A1,CU,FE:VA;0),, +43319.6-6.94445*T;,, N 95Che !\n PAR L(FCC_A1,CU,FE:VA;1),, +6068.8-2.83662*T;,, N 95Che !\n PAR L(FCC_A1,CU,FE:VA;2),, +3629.4;,, N 95Che !\n$\n PAR L(A1_FCC,CU,FE:VA;0),, +43319.6-6.94445*T;,, N 95Che !\n PAR L(A1_FCC,CU,FE:VA;1),, +6068.8-2.83662*T;,, N 95Che !\n PAR L(A1_FCC,CU,FE:VA;2),, +3629.4;,, N 95Che !\n$\n PAR L(BCC_A2,CU,FE:VA;0),, +39676-4.73222*T;,, N 95Che !\n PAR TC(BCC_A2,CU,FE:VA;0),, -41.40;,, N 95Che !\n$\n PAR L(A2_BCC,CU,FE:VA;0),, +39676-4.73222*T;,, N 95Che !\n PAR TC(A2_BCC,CU,FE:VA;0),, -41.40;,, N 95Che !\n$\n$ metastable\n$\n PAR L(HCP_A3,CU,FE:VA;0),, +43319.6-6.94445*T;,, N Same !\n PAR L(HCP_A3,CU,FE:VA;1),, +6068.8-2.83662*T;,, N Same !\n PAR L(HCP_A3,CU,FE:VA;2),, +3629.4;,, N Same !\n$\n PAR L(CBCC_A12,CU,FE:VA;0),, +50000;,, N 03Mie3 !\n PAR L(CUB_A13,CU,FE:VA;0),, +50000;,, N 03Mie3 !\n$ ------------------------------------------------------------------------------\n$ Cu-Mg\n$\n$ B. Hallstedt, unpublished, 2016.\n$\n$ Checked at 6000 K.\n$\n$ Based on the assessment from P. Liang et al. 1998 with modified Gibbs\n$ energies from S.H. Zhou et al. 2007. This was necessary because the heat\n$ capacity of Cu2Mg (C15) from 98Lia2 increases too rapidly and makes Cu2Mg\n$ stable again above 2800 K.\n$\n$ The Gibbs energy functions from 07Zho for C15_LAVES and CUMG2_CB are\n$ discontinuous across the temperature interval limit. This was corrected by\n$ adjusting the functions for the upper temperature interval. The other Laves\n$ phase and CuMg2 parameters were reoptimised to reproduce the invariant\n$ equilibria from 98Lia (and to some extent 07Zho).\n$\n$ The hcp interaction is very different from the fcc interaction. The fcc \n$ interaction can be considered reasonably well determined since it is\n$ based on a relatively well determined solubility of Mg in Cu. The current\n$ hcp interaction gives a Cu solubility in Mg at the eutectic temperature\n$ of 0.049 at.% Cu. The measured solubility is smaller (0.01 to 0.02 at.% Cu).\n$ There are several measurements cited in Nayeb-Hashemi and Clark,\n$ BAPD, 5(1), 36-43(1984), but they are all very old; 1931 or earlier.\n$ Thus, the hcp interaction seems uncertain and the value from 98Lia seems a\n$ reasonable compromise. The hcp interaction from 07Zho results in an even\n$ lower solubility than measured and should not be used.\n$\n$ The parameters for the metastable C14 and C36 phases are modified to keep\n$ the same Delta-G relative to C15.\n$\n PAR L(LIQUID,CU,MG;0),, -36962.71+4.74394*T;,, N 98Lia2 !\n PAR L(LIQUID,CU,MG;1),, -8182.19;,, N 98Lia2 !\n$\n PAR L(FCC_A1,CU,MG:VA;0),, -22059.61+5.63232*T;,, N 98Lia2 !\n PAR L(A1_FCC,CU,MG:VA;0),, -22059.61+5.63232*T;,, N 98Lia2 !\n$\n PAR L(HCP_A3,CU,MG:VA;0),, +22500-3*T;,, N 98Lia2 !\n$\n PAR G(C15_LAVES,CU:MG),, +GC15CUMG;,, N 16Hal9 !\n PAR G(C15_LAVES,MG:CU),, +GHSERCU+2*GHSERMG\n +104970.96-16.46448*T;,, N 98Lia2 !\n PAR L(C15_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 !\n PAR L(C15_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 !\n PAR L(C15_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 !\n PAR L(C15_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 !\n$\n PAR G(CUMG2_CB,CU:MG),, +GCBCUMG;,, N 16Hal9 !\n$\n$ Metastable\n$\n PAR L(BCC_A2,CU,MG:VA;0),, -6500;,, N 98Lia2 !\n PAR L(A2_BCC,CU,MG:VA;0),, -6500;,, N 98Lia2 !\n$\n$PAR G(C14_LAVES,CU:MG),, +GC15CUMG+30000;,, N 98Lia2 !\n$PAR G(C14_LAVES,MG:CU),, +GHSERCU+2*GHSERMG\n$ +74970.96-16.46448*T;,, N 98Lia2 !\n$PAR L(C14_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 !\n$PAR L(C14_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 !\n$PAR L(C14_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 !\n$PAR L(C14_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 !\n$\n$PAR G(C36_LAVES,CU:MG),, +GC15CUMG+20000;,, N 98Lia2 !\n$PAR G(C36_LAVES,MG:CU),, +GHSERCU+2*GHSERMG\n$ +84970.96-16.46448*T;,, N 98Lia2 !\n$PAR L(C36_LAVES,CU,MG:CU;0),, +13011.35;,, N 98Lia2 !\n$PAR L(C36_LAVES,CU,MG:MG;0),, +13011.35;,, N 98Lia2 !\n$PAR L(C36_LAVES,CU:CU,MG;0),, +6599.45;,, N 98Lia2 !\n$PAR L(C36_LAVES,MG:CU,MG;0),, +6599.45;,, N 98Lia2 !\n$\n FUNCTION GC15CUMG 298.15 -54854+408.17*T-76.1*T*LN(T)\n -9.9E-04*T**2-1.35E-06*T**3+183906*T**(-1);\n 1070.00 Y -61915.6682+489.549872*T-87.17102875*T*LN(T);\n 6000.00 N !\n FUNCTION GCBCUMG 298.15 -50415+423.34*T-77.9913484*T*LN(T)\n +0.00231*T**2-2.72115E-06*T**3+190378*T**(-1);\n 850.00 Y -54534.6038+477.968452*T-85.33353573*T*LN(T);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Cu-Mn\n$\n$ From J. Miettinen 2003 (Included in LB Vol. 3)\n$\n$ J. Miettinen, Calphad, 27, 103-14(2003).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CU,MN;0),, +1800-2.28*T;,, N 96Vre !\n PAR L(LIQUID,CU,MN;1),, -6500-2.91*T;,, N 96Vre !\n$\n PAR L(BCC_A2,CU,MN:VA;0),, +11190-6*T;,, N 03Mie2 !\n PAR L(BCC_A2,CU,MN:VA;1),, -9865;,, N 03Mie2 !\n$\n PAR L(A2_BCC,CU,MN:VA;0),, +11190-6*T;,, N 03Mie2 !\n PAR L(A2_BCC,CU,MN:VA;1),, -9865;,, N 03Mie2 !\n$\n PAR L(FCC_A1,CU,MN:VA;0),, +11820-2.3*T;,, N 03Mie2 !\n PAR L(FCC_A1,CU,MN:VA;1),, -10600+3*T;,, N 03Mie2 !\n PAR L(FCC_A1,CU,MN:VA;2),, +ZERO;,, N 03Mie2 !\n PAR L(FCC_A1,CU,MN:VA;3),, -4850+3.5*T;,, N 03Mie2 !\n$\n PAR L(A1_FCC,CU,MN:VA;0),, +11820-2.3*T;,, N 03Mie2 !\n PAR L(A1_FCC,CU,MN:VA;1),, -10600+3*T;,, N 03Mie2 !\n PAR L(A1_FCC,CU,MN:VA;2),, +ZERO;,, N 03Mie2 !\n PAR L(A1_FCC,CU,MN:VA;3),, -4850+3.5*T;,, N 03Mie2 !\n$\n PAR L(CBCC_A12,CU,MN:VA;0),, +35000;,, N 03Mie2 !\n PAR L(CUB_A13,CU,MN:VA;0),, +35000;,, N 03Mie2 !\n$\n$ metastable\n$\n PAR L(HCP_A3,CU,MN:VA;0),, +11820-2.3*T;,, N Same !\n PAR L(HCP_A3,CU,MN:VA;1),, -10600+3*T;,, N Same !\n PAR L(HCP_A3,CU,MN:VA;2),, +ZERO;,, N Same !\n PAR L(HCP_A3,CU,MN:VA;3),, -4850+3.5*T;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cu-Mo\n$\n$ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida,\n$ J. Phase Equilib., 21, 54-62(2000).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CU,MO;0),, +57285.4+2*T;,, N 00Wan !\n PAR L(LIQUID,CU,MO;1),, -1200;,, N 00Wan !\n$\n PAR L(BCC_A2,CU,MO:VA;0),, +82313;,, N 80Bre !\n PAR L(A2_BCC,CU,MO:VA;0),, +82313;,, N 80Bre !\n$\n PAR L(FCC_A1,CU,MO:VA;0),, +83144;,, N 80Bre !\n PAR L(A1_FCC,CU,MO:VA;0),, +83144;,, N 80Bre !\n$\n$ metastable\n$\n PAR L(HCP_A3,CU,MO:VA;0),, +83144;,, N Same !\n PAR L(CBCC_A12,CU,MO:VA;0),, +83144;,, N Same !\n PAR L(CUB_A13,CU,MO:VA;0),, +83144;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cu-N\n$\n$ K. Frisk, Report IM-2929, 1991.\n$\n$ The solubility of N in fcc-Cu is extremely small. Results without the gas\n$ included are not reasonable; there is then a large bcc region in the center.\n$\n$ The bcc phase is far too stable.\n$\n PAR L(LIQUID,CU,N;0),, +33115;,, N 91Fri4 !\n$\n PAR G(FCC_A1,CU:N),, +GHSERCU+GHSERNN+374805;,, N 91Fri4 !\n PAR G(A1_FCC,CU:N),, +GHSERCU+GHSERNN+374805;,, N 91Fri4 !\n$\n$ metastable\n$\n PAR G(BCC_A2,CU:N),, +GHSERCU+3*GHSERNN\n +100000+200*T;,, N 91Fri4 !\n PAR G(A2_BCC,CU:N),, +GHSERCU+3*GHSERNN\n +100000+200*T;,, N 91Fri4 !\n PAR G(HCP_A3,CU:N),, +GHSERCU+0.5*GHSERNN\n +300000;,, N 91Fri4 !\n$ ------------------------------------------------------------------------------\n$ Cu-Nb\n$\n$ From Hämäläinen et al. 1990 (Included in LB Vol. 3)\n$\n$ M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen,\n$ O. Teppo, Calphad, 14, 125-37(1990).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ The temperature dependence of the liquid interaction is ridiculous.\n$\n PAR L(LIQUID,CU,NB;0),, +204361.19-89.93141*T;,, N 90Ham !\n PAR L(LIQUID,CU,NB;1),, -105148.17+57.81653*T;,, N 90Ham !\n$\n PAR L(FCC_A1,CU,NB:VA;0),, +45699.84-5.22785*T;,, N 90Ham !\n PAR L(A1_FCC,CU,NB:VA;0),, +45699.84-5.22785*T;,, N 90Ham !\n$\n PAR L(BCC_A2,CU,NB:VA;0),, +49480.18;,, N 90Ham !\n PAR L(A2_BCC,CU,NB:VA;0),, +49480.18;,, N 90Ham !\n$\n$ metastable\n$\n PAR L(HCP_A3,CU,NB:VA;0),, +45699.84-5.22785*T;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cu-Ni\n$\n$ From S. an Mey 1992 (Included in LB Vol. 3)\n$\n$ S. an Mey, Calphad 16, 255-60(1992).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ The COST 507 database has different parameters for BMAG(FCC_A1,CU,NI:VA).\n$ Probable error in the COST 507 database.\n$\n$ TCFE2000 uses L(BCC_A2,CU,NI:VA;0)=-20000 to stabilize BCC in 2% Cu steel.\n$\n PAR L(LIQUID,CU,NI;0),, +12048.61+1.29893*T;,, N 92Mey !\n PAR L(LIQUID,CU,NI;1),, -1861.61+0.94201*T;,, N 92Mey !\n$\n PAR L(FCC_A1,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey !\n PAR L(FCC_A1,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey !\n PAR TC(FCC_A1,CU,NI:VA;0),, -935.5;,, N 87Jan !\n PAR TC(FCC_A1,CU,NI:VA;1),, -594.9;,, N 87Jan !\n PAR BMAG(FCC_A1,CU,NI:VA;0),, -0.7316;,, N 87Jan !\n PAR BMAG(FCC_A1,CU,NI:VA;1),, -0.3174;,, N 87Jan !\n$\n PAR L(A1_FCC,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey !\n PAR L(A1_FCC,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey !\n PAR TC(A1_FCC,CU,NI:VA;0),, -935.5;,, N 87Jan !\n PAR TC(A1_FCC,CU,NI:VA;1),, -594.9;,, N 87Jan !\n PAR BMAG(A1_FCC,CU,NI:VA;0),, -0.7316;,, N 87Jan !\n PAR BMAG(A1_FCC,CU,NI:VA;1),, -0.3174;,, N 87Jan !\n$\n$ Metastable\n$\n PAR L(BCC_A2,CU,NI:VA;0),, +8366+2.802*T;,, N 87Jan !\n PAR L(BCC_A2,CU,NI:VA;1),, -4359.6+1.812*T;,, N 87Jan !\n$\n PAR L(A2_BCC,CU,NI:VA;0),, +8366+2.802*T;,, N 87Jan !\n PAR L(A2_BCC,CU,NI:VA;1),, -4359.6+1.812*T;,, N 87Jan !\n$\n PAR L(HCP_A3,CU,NI:VA;0),, +8047.72+3.42217*T;,, N 92Mey !\n PAR L(HCP_A3,CU,NI:VA;1),, -2041.3+0.99714*T;,, N 92Mey !\n$\n PAR L(CBCC_A12,CU,NI:VA;0),, +8047.72+3.42217*T;,, N Same !\n PAR L(CBCC_A12,CU,NI:VA;1),, -2041.3+0.99714*T;,, N Same !\n$\n PAR L(CUB_A13,CU,NI:VA;0),, +8047.72+3.42217*T;,, N Same !\n PAR L(CUB_A13,CU,NI:VA;1),, -2041.3+0.99714*T;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cu-Si\n$\n$ B. Hallstedt, J. Groebner, M. Hampl, R. Schmid-Fetzer,\n$ Calphad, 53, 25-38(2016).\n$\n$ BCC_A2 is stable as beta at about CU85SI15 and HCP_A3 is stable as\n$ kappa at about CU87SI13.\n$\n PAR L(LIQUID,CU,SI;0),, -37776+3.47*T;,, N 16Hal10 !\n PAR L(LIQUID,CU,SI;1),, -44866+14.53*T;,, N 16Hal10 !\n PAR L(LIQUID,CU,SI;2),, -40866+8.62*T;,, N 16Hal10 !\n PAR L(LIQUID,CU,SI;3),, -10060;,, N 16Hal10 !\n PAR L(LIQUID,CU,SI;4),, +17550;,, N 16Hal10 !\n$\n PAR L(FCC_A1,CU,SI:VA;0),, -32244+20*T;,, N 16Hal10 !\n PAR L(FCC_A1,CU,SI:VA;1),, -43581-28.5*T;,, N 16Hal10 !\n$\n PAR L(A1_FCC,CU,SI:VA;0),, -32244+20*T;,, N 16Hal10 !\n PAR L(A1_FCC,CU,SI:VA;1),, -43581-28.5*T;,, N 16Hal10 !\n$\n PAR L(HCP_A3,CU,SI:VA;0),, -26218+11*T;,, N 16Hal10 !\n PAR L(HCP_A3,CU,SI:VA;1),, -60756-15.4*T;,, N 16Hal10 !\n$\n PAR L(BCC_A2,CU,SI:VA;0),, -19744+11*T;,, N 16Hal10 !\n PAR L(BCC_A2,CU,SI:VA;1),, -88450-9*T;,, N 16Hal10 !\n$\n PAR L(A2_BCC,CU,SI:VA;0),, -19744+11*T;,, N 16Hal10 !\n PAR L(A2_BCC,CU,SI:VA;1),, -88450-9*T;,, N 16Hal10 !\n$\n$PAR G(DIAMOND_A4,SI:CU),, +GHSERSI+GHSERCU+100000;,, N 16Hal10 !\n$PAR L(DIAMOND_A4,SI:CU,VA;0),, +47230-30.23*T;,, N 16Hal10 !\n$\n PAR G(CU33SI7_A13,CU:SI),, +33*GHSERCU+7*GHSERSI\n -156240-163.2*T;,, N 16Hal10 !\n PAR G(CU33SI7_HT,CU:SI),, +33*GHSERCU+7*GHSERSI\n -90160-228.8*T;,, N 16Hal10 !\n PAR G(CU15SI4_D86,CU:SI),, +15*GHSERCU+4*GHSERSI\n -88065-77.9*T;,, N 16Hal10 !\n PAR G(CU3SI_LT,CU:SI),, +0.77*GHSERCU+0.23*GHSERSI\n -4770-4*T;,, N 16Hal10 !\n PAR G(CU3SI_MT,CU:SI),, +0.765*GHSERCU+0.235*GHSERSI\n -4060-4.88*T;,, N 16Hal10 !\n PAR G(CU3SI_HT,CU:SI),, +0.76*GHSERCU+0.24*GHSERSI\n -2885-6.23*T;,, N 16Hal10 !\n$\n$ metastable\n$\n PAR L(CBCC_A12,CU,SI:VA;0),, -32244+20*T;,, N Same !\n PAR L(CBCC_A12,CU,SI:VA;1),, -43581-28.5*T;,, N Same !\n$\n PAR L(CUB_A13,CU,SI:VA;0),, -32244+20*T;,, N Same !\n PAR L(CUB_A13,CU,SI:VA;1),, -43581-28.5*T;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cu-Ti\n$\n$ J. Wang, C. Liu, C. Leinenbach, U.E. Klotz, P.J. Uggowitzer, J.F. Loeffler,\n$ Calphad, 35, 82-94(2011).\n$\n$ Modified from Hari Kumar et al. 1996. Gibbs energy of CuTi2 was changed for\n$ use in the Cu-Sn-Ti system. It is also used in the Cu-Ni-Ti system.\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CU,TI;0),, -19330+7.651*T;,, N 96Har2 !\n PAR L(LIQUID,CU,TI;2),, +9382-5.448*T;,, N 96Har2 !\n$\n PAR L(FCC_A1,CU,TI:VA;0),, -9882;,, N 96Har2 !\n PAR L(FCC_A1,CU,TI:VA;1),, +15777;,, N 96Har2 !\n$\n PAR L(A1_FCC,CU,TI:VA;0),, -9882;,, N 96Har2 !\n PAR L(A1_FCC,CU,TI:VA;1),, +15777;,, N 96Har2 !\n$\n PAR L(BCC_A2,CU,TI:VA;0),, +3389;,, N 96Har2 !\n PAR L(A2_BCC,CU,TI:VA;0),, +3389;,, N 96Har2 !\n$\n PAR L(HCP_A3,CU,TI:VA;0),, +16334;,, N 96Har2 !\n$\n PAR G(CU4TI1,CU:TI),, +4*GHSERCU+GHSERTI\n -30055+11.695*T;,, N 96Har2 !\n PAR G(CU4TI1,TI:CU),, +4*GHSERTI+GHSERCU\n +80055-11.695*T;,, N 96Har2 !\n PAR L(CU4TI1,CU,TI:CU;0),, +17089;,, N 96Har2 !\n PAR L(CU4TI1,CU,TI:TI;0),, +17089;,, N 96Har2 !\n PAR L(CU4TI1,CU:CU,TI;0),, -15767;,, N 96Har2 !\n PAR L(CU4TI1,TI:CU,TI;0),, -15767;,, N 96Har2 !\n$\n PAR G(CU2TI,CU:TI),, +2*GHSERCU+GHSERTI-17628;,, N 96Har2 !\n PAR G(CU3TI2,CU:TI),, +3*GHSERCU+2*GHSERTI\n -46245+10.86*T;,, N 96Har2 !\n PAR G(CU4TI3,CU:TI),, +4*GHSERCU+3*GHSERTI\n -68236+15.946*T;,, N 96Har2 !\n$\n PAR G(CUTI_B11,CU:TI),, +GHSERCU+GHSERTI\n -22412+6.544*T;,, N 96Har2 !\n PAR G(CUTI_B11,TI:CU),, +GHSERTI+GHSERCU\n +42412-6.544*T;,, N 96Har2 !\n PAR L(CUTI_B11,CU,TI:CU;0),, +15419;,, N 96Har2 !\n PAR L(CUTI_B11,CU,TI:TI;0),, +15419;,, N 96Har2 !\n PAR L(CUTI_B11,CU:CU,TI;0),, +15578;,, N 96Har2 !\n PAR L(CUTI_B11,TI:CU,TI;0),, +15578;,, N 96Har2 !\n$\n$PAR G(CUTI2_C11B,CU:TI),, +GHSERCU+2*GHSERTI\n$ -36393+14.064*T;,, N 96Har2 !\n PAR G(CUTI2_C11B,CU:TI),, +GHSERCU+2*GHSERTI\n -27000+6.6*T;,, N 11Wan !\n$\n$ Metastable\n$\n$PAR L(BCT_A5,CU,TI;0),, +20000;,, N 11Wan !\n$ ------------------------------------------------------------------------------\n$ Cu-V\n$\n$ J. Zhao, Y. Du, L.Zhang, H. Xu, Calphad, 32, 252-55(2008).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,CU,V;0),, +37900;,, N 08Zha1 !\n PAR L(LIQUID,CU,V;1),, +18500;,, N 08Zha1 !\n$\n PAR L(FCC_A1,CU,V:VA;0),, +53650;,, N 08Zha1 !\n PAR L(A1_FCC,CU,V:VA;0),, +53650;,, N 08Zha1 !\n$\n PAR L(BCC_A2,CU,V:VA;0),, +42377.8;,, N 08Zha1 !\n PAR L(A2_BCC,CU,V:VA;0),, +42377.8;,, N 08Zha1 !\n$\n$ metastable\n$\n PAR L(HCP_A3,CU,V:VA;0),, +53650;,, N Same !\n PAR L(CBCC_A12,CU,V:VA;0),, +53650;,, N Same !\n PAR L(CUB_A13,CU,V:VA;0),, +53650;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Fe-C\n$\n$ From P. Gustafson 1985 (included in LB Vol. 3)\n$\n$ P. Gustafson, Scand. J. Metall., 14, 259-67(1985).\n$\n$ Checked against paper and LB. All numbers are exactly reproduced, except\n$ for a rounding error in the paper of the temperature of the FCC + LIQ + CEM\n$ equilibrium (1421 K in the paper, 1421.51 K calculated).\n$\n$ Cementite changed to 10Hal.\n$ The eutectoid (bcc+fcc+cem) temperature changed from 999.78 to 999.68 K.\n$ The eutectic (fcc+liq+cem) temperature changed from 1421.51 to 1421.31 K.\n$ The congruent melting point of cementite changed from 1497.8 to 1497.1 K.\n$\n$ BCC_A2 is stable above 4000 K around x(C)=0.33.\n$ There is an inverse miscibility gap in the liquid with a minimum at\n$ 5559 K and x(C)=0.53.\n$\n$ According to ab initio calculations by Joerg van Appen from 2008 is the\n$ energy of NM and AFM FeC (fcc) nearly the same. The AFM state has a BM of\n$ 0.9 per metal atom.\n$\n$ The value of TC(FCC_A1,FE:C,VA) was adjusted to match the measured influence\n$ of C on the Neel temperature in the Fe-Mn-C system. It could even be\n$ increased further to possibly 6000 or 7000.\n$\n PAR L(LIQUID,C,FE;0),, -124320+28.5*T;,, N 85Gus !\n PAR L(LIQUID,C,FE;1),, +19300;,, N 85Gus !\n PAR L(LIQUID,C,FE;2),, +49260-19*T;,, N 85Gus !\n$\n PAR G(BCC_A2,FE:C),, +GHSERFE+3*GHSERCC\n +322050+75.667*T;,, N 85Gus !\n PAR TC(BCC_A2,FE:C),, 1043.00;,, N 85Gus !\n PAR BMAG(BCC_A2,FE:C),, 2.22;,, N 85Gus !\n PAR L(BCC_A2,FE:C,VA;0),, -190*T;,, N 85Gus !\n$\n PAR G(A2_BCC,FE:C),, +GHSERFE+3*GHSERCC\n +322050+75.667*T;,, N 85Gus !\n PAR TC(A2_BCC,FE:C),, 1043.00;,, N 85Gus !\n PAR BMAG(A2_BCC,FE:C),, 2.22;,, N 85Gus !\n PAR L(A2_BCC,FE:C,VA;0),, -190*T;,, N 85Gus !\n$\n PAR G(FCC_A1,FE:C),, +GFCCFE+GHSERCC\n +77207-15.877*T;,, N 85Gus !\n$PAR TC(FCC_A1,FE:C),, -201.00;,, N 85Gus !\n$PAR BMAG(FCC_A1,FE:C),, -2.10;,, N 85Gus !\n PAR L(FCC_A1,FE:C,VA;0),, -34671;,, N 85Gus !\n PAR TC(FCC_A1,FE:C,VA),, +5000;,, N 12Hal !\n$\n PAR G(A1_FCC,FE:C),, +GFCCFE+GHSERCC\n +77207-15.877*T;,, N 85Gus !\n$PAR TC(A1_FCC,FE:C),, -201.00;,, N 85Gus !\n$PAR BMAG(A1_FCC,FE:C),, -2.10;,, N 85Gus !\n PAR L(A1_FCC,FE:C,VA;0),, -34671;,, N 85Gus !\n PAR TC(A1_FCC,FE:C,VA),, +5000;,, N 12Hal !\n$\n PAR G(CEMENTITE_D011,FE:C) 0.01 +GFECEM;,, N 10Hal !\n PAR TC(CEMENTITE_D011,FE:C) 0.01 485.00;,, N 10Hal !\n PAR BMAG(CEMENTITE_D011,FE:C) 0.01 1.008;,, N 10Hal !\n$\n$ metastable\n$\n PAR G(HCP_A3,FE:C),, +GFCCFE+0.5*GHSERCC\n +52905-11.9075*T;,, N 88And2 !\n PAR L(HCP_A3,FE:C,VA;0),, -17335;,, N 88And2 !\n$PAR L(HCP_A3,FE:C,VA;0),, -22126;,, N 93Du !\n$\n PAR G(CBCC_A12,FE:C),, +GHSERFE+GHSERCC+80000;,, N 90Hua2 !\n PAR L(CBCC_A12,FE:C,VA;0),, -34671;,, N 90Hua2 !\n$\n PAR G(CUB_A13,FE:C),, +GHSERFE+GHSERCC+90000;,, N 90Hua2 !\n PAR L(CUB_A13,FE:C,VA;0),, -34671;,, N 90Hua2 !\n$\n PAR G(M7C3_D101,FE:C),, +2.333333*GFECEM\n +0.666667*GHSERCC+13200;,, N 11Dju !\n PAR G(M23C6_D84,FE:FE:C),, +GFE23C6;,, N 11Dju !\n PAR G(M5C2,FE:C),, +1.666667*GFECEM\n +0.333333*GHSERCC+6200;,, N 11Dju !\n PAR G(FE4N_L1,FE:C),, +4*GHSERFE+GHSERCC+15965;,, N 93Du !\n PAR G(FECN_CHI,FE:C),, -11287.4+1013.78*T\n -176.412*T*LN(T)+810869*T**(-1);,, N 93Du !\n PAR G(KSI_CARBIDE,FE:C),, +3*GHSERFE+GHSERCC\n +14540+20*T;,, N 88And2 !\n PAR G(V3C2,FE:C),, +7250+741.566*T\n -125.833*T*LN(T)+779485*T**(-1);,, N 91Hua4 !\n$\n FUNCTION GFECEM 0.01 +11369.937746-5.641259263*T-8.333E-6*T**4;\n 43.00 Y +11622.647246-59.537709263*T+15.74232*T*LN(T)\n -0.27565*T**2;\n 163.00 Y -10195.860754+690.949887637*T-118.47637*T*LN(T)\n -0.0007*T**2+590527*T**(-1);\n 6000.00 N !\n FUNCTION GFE23C6 298.15 +7.666667*GFECEM-1.666667*GHSERCC+15000; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Fe-Mg\n$\n$ From J. Tibballs 1998 (included in LB Vol. 3)\n$\n$ J. Tibballs, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST. Checked at 6000 K.\n$\n PAR L(LIQUID,FE,MG;0),, +61343+1.5*T;,, N 98Tib !\n PAR L(LIQUID,FE,MG;1),, -2700;,, N 98Tib !\n$\n PAR L(FCC_A1,FE,MG:VA;0),, +65200;,, N 98Tib !\n PAR L(A1_FCC,FE,MG:VA;0),, +65200;,, N 98Tib !\n PAR L(BCC_A2,FE,MG:VA;0),, +65700;,, N 98Tib !\n PAR L(A2_BCC,FE,MG:VA;0),, +65700;,, N 98Tib !\n PAR L(HCP_A3,FE,MG:VA;0),, +92400;,, N 98Tib !\n$\n$ metastable\n$\n PAR L(CBCC_A12,FE,MG:VA;0),, +70000;,, N Same !\n PAR L(CUB_A13,FE,MG:VA;0),, +70000;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn\n$\n$ From W. Huang 1989 (included in LB Vol. 3)\n$\n$ W. Huang, Calphad, 13, 243-52(1989).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ HCP_A3 interaction slightly modified by 11Dju.\n$\n$ The Neel temperature (fcc) is well described, but there is an uncertainty\n$ concerning the magnetic moments. A value BMAG(CC_A1,FE,MN:VA;0)=1 seems to\n$ fit M_s data best.\n$\n$ Fcc ordering energies (approximately) from Alexey Dick 2008.\n$\n PAR L(LIQUID,FE,MN;0),, -3950+0.489*T;,, N 89Hua2 !\n PAR L(LIQUID,FE,MN;1),, +1145;,, N 89Hua2 !\n$\n PAR L(FCC_A1,FE,MN:VA;0),, -7762+3.865*T;,, N 89Hua2 !\n PAR L(FCC_A1,FE,MN:VA;1),, -259;,, N 89Hua2 !\n PAR TC(FCC_A1,FE,MN:VA;0),, -2282;,, N 89Hua2 !\n PAR TC(FCC_A1,FE,MN:VA;1),, -2068;,, N 89Hua2 !\n$ New value below (old value was zero)\n PAR BMAG(FCC_A1,FE,MN:VA;0),, +1;,, N 12Hal !\n$\n PAR L(A1_FCC,FE,MN:VA;0),, -7762+3.865*T;,, N 89Hua2 !\n PAR L(A1_FCC,FE,MN:VA;1),, -259;,, N 89Hua2 !\n PAR TC(A1_FCC,FE,MN:VA;0),, -2282;,, N 89Hua2 !\n PAR TC(A1_FCC,FE,MN:VA;1),, -2068;,, N 89Hua2 !\n PAR BMAG(A1_FCC,FE,MN:VA;0),, +1;,, N 12Hal !\n$\n PAR G(FCC_4SL,FE:FE:FE:MN:VA),, +GFFE3MN;,, N 08Hal3 !\n PAR G(FCC_4SL,FE:FE:MN:MN:VA),, +GFFE2MN2;,, N 08Hal3 !\n PAR G(FCC_4SL,FE:MN:MN:MN:VA),, +GFFEMN3;,, N 08Hal3 !\n PAR L(FCC_4SL,FE,MN:FE,MN:*:*:VA;0),, +SFFEMN;,, N 08Hal3 !\n$\n PAR L(BCC_A2,FE,MN:VA;0),, -2759+1.237*T;,, N 89Hua2 !\n PAR TC(BCC_A2,FE,MN:VA;0),, +123;,, N 89Hua2 !\n$\n PAR L(A2_BCC,FE,MN:VA;0),, -2759+1.237*T;,, N 89Hua2 !\n PAR TC(A2_BCC,FE,MN:VA;0),, +123;,, N 89Hua2 !\n$\n PAR L(HCP_A3,FE,MN:VA;0),, -5748+3.865*T;,, N 11Dju !\n PAR L(HCP_A3,FE,MN:VA;1),, +273;,, N 11Dju !\n$PAR L(HCP_A3,FE,MN:VA;0),, -5582+3.865*T;,, N 89Hua2 !\n$PAR L(HCP_A3,FE,MN:VA;1),, +273;,, N 89Hua2 !\n$\n PAR L(CBCC_A12,FE,MN:VA;0),, -10184;,, N 89Hua2 !\n PAR L(CUB_A13,FE,MN:VA;0),, -11518+2.819*T;,, N 89Hua2 !\n$\n$ Metastable\n$\n PAR G(C14_LAVES,FE:MN),, +2*GHSERFE+GHSERMN+36320;,, N 12Liu !\n PAR G(C14_LAVES,MN:FE),, +2*GHSERMN+GHSERFE+28510;,, N 12Liu !\n$\n FUNCTION U1FFEMN 298.15 -700; 6000 N !\n FUNCTION GFFE3MN 298.15 +3*U1FFEMN-90; 6000 N !\n FUNCTION GFFE2MN2 298.15 +4*U1FFEMN; 6000 N !\n FUNCTION GFFEMN3 298.15 +3*U1FFEMN+90; 6000 N !\n FUNCTION SFFEMN 298.15 +U1FFEMN; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo\n$\n$ From J.-O. Andersson 1988 (included in LB Vol. 3)\n$\n$ J.-O. Andersson, Calphad, 12, 9-23(1988).\n$ Completely revised from the original Fernandez Guillermet 1982 version.\n$\n$ Checked against LB (SIGMA_D8B) and paper (SIGMA_OLD). Checked at 6000 K.\n$\n$ There are small differences (up to 2K) for the invariant temperatures\n$ compared to the paper.\n$\n$ In LB FE2MO_C14 is described as a stoichiometric compound. The upper\n$ stability limit of FE2MO_C14 is 4K lower in LB.\n$\n$ The SIGMA_OLD and SIGMA_D8B phase fields are rather similar. They have\n$ somewhat different solubility limits, in particular on the Mo-rich side.\n$\n$ There are two models for Fe2Mo included. FE2MO_C14 is the original from 88And.\n$ C14_LAVES includes new end-member values and refitted interactions.\n$ The max temperature for C14_LAVES is 1192 K instead of 1177 K previously,\n$ which is closer to 82Gui where it is 1200 K.\n$\n$ The change of model for MU_D85 results in a somewhat wider phase field\n$ with preserved invariant temperatures.\n$\n$ Mo was added on the first sublattice of SIGMA_D8B. This was necessary in\n$ order to use the 10:4:16 model in the Cr-Fe-Mo system. Otherwise the\n$ experimentally determined Mo content in sigma cannot be reached. The previous\n$ SIGMA_D8B phase field is closely reproduced and invariant temperatures\n$ differ by less than 2-3 K.\n$\n PAR L(LIQUID,FE,MO;0),, -6973-0.37*T;,, N 88And2 !\n PAR L(LIQUID,FE,MO;1),, -9424+4.502*T;,, N 88And2 !\n$\n PAR L(FCC_A1,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 !\n PAR L(A1_FCC,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 !\n$\n PAR L(BCC_A2,FE,MO:VA;0),, +36818-9.141*T;,, N 88And2 !\n PAR L(BCC_A2,FE,MO:VA;1),, -362-5.724*T;,, N 88And2 !\n PAR TC(BCC_A2,FE,MO:VA;0),, +335;,, N 82Fer !\n PAR TC(BCC_A2,FE,MO:VA;1),, +526;,, N 82Fer !\n$\n PAR L(A2_BCC,FE,MO:VA;0),, +36818-9.141*T;,, N 88And2 !\n PAR L(A2_BCC,FE,MO:VA;1),, -362-5.724*T;,, N 88And2 !\n PAR TC(A2_BCC,FE,MO:VA;0),, +335;,, N 82Fer !\n PAR TC(A2_BCC,FE,MO:VA;1),, +526;,, N 82Fer !\n$\n PAR G(C14_LAVES,FE:MO),, +2*GFCCFE+GHSERMO\n -10798-0.132*T;,, N 88And2 !\n PAR G(C14_LAVES,MO:FE),, +2*GHSERMO+3*GHSERFE-2*GFCCFE\n +153330+10798+0.132*T;,, N !\n$\n PAR G(MU_D85,FE:MO:FE:FE),, +7*GFCCFE+4*GHSERMO+2*GHSERFE\n -14320-18.9*T;,, N 17Hal4 !\n PAR G(MU_D85,FE:MO:FE:MO),, +3*GHSERFE+10*GHSERMO\n +445950;,, N 14Raj !\n PAR G(MU_D85,FE:MO:MO:FE),, +7*GFCCFE+6*GHSERMO\n -46663-5.891*T;,, N 88And2 !\n PAR G(MU_D85,FE:MO:MO:MO),, +GHSERFE+12*GHSERMO\n +340960;,, N 14Raj !\n PAR L(MU_D85,FE:MO:FE,MO:FE;0),, +17780;,, N 17Hal4 !\n$\n PAR G(R_PHASE,FE:MO:FE),, +27*GFCCFE+14*GHSERMO\n +12*GHSERFE-77487-50.486*T;,, N 88And2 !\n PAR G(R_PHASE,FE:MO:MO),, +27*GFCCFE+26*GHSERMO\n +313474-289.472*T;,, N 88And2 !\n$\n PAR G(SIGMA_D8B,FE:MO:FE),, +10*GFCCFE+16*GHSERFE\n +4*GHSERMO+65550-62.2*T;,, N 17Hal6 !\n PAR G(SIGMA_D8B,FE:MO:MO),, +10*GFCCFE+20*GHSERMO\n +40000-62.2*T;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MO:MO:FE),, +10*GFCCMO+16*GHSERFE\n +4*GHSERMO+150000;,, N 17Hal6 !\n PAR L(SIGMA_D8B,FE:MO:FE,MO;0),, +220253;,, N 00Wes !\n$\n$ metastable\n$\n PAR L(HCP_A3,FE,MO:VA;0),, +28347-17.691*T;,, N 88And2 !\n$\n PAR G(CHI_A12,FE:MO:FE),, +48*GFCCFE+10*GHSERMO\n +305210-270*T;,, N 88And4 !\n$ Parameter below in TCFE-99\n$PAR G(CHI_A12,FE:MO:FE),, +48*GFCCFE+10*GHSERMO\n$ +156437-169*T;,, N 95Lee !\n PAR G(CHI_A12,FE:MO:MO),, +24*GFCCFE+10*GHSERMO\n +24*GFCCMO+97300-100*T;,, N 88And4 !\n$\n PAR G(MONI,FE:FE:MO),, +6*GFCCFE+5*GHSERFE\n +3*GHSERMO+25000;,, N 92Fri1 !\n PAR G(MONI,FE:MO:MO),, +6*GFCCFE+8*GHSERMO+25000;,, N 92Fri1 !\n$\n PAR G(P_PHASE,FE:FE:MO),, +24*GFCCFE+20*GHSERFE\n +12*GHSERMO+111361;,, N 92Fri1 !\n PAR G(P_PHASE,FE:MO:MO),, +24*GFCCFE+32*GHSERMO\n +362525-332.7*T;,, N 92Fri1 !\n$ ------------------------------------------------------------------------------\n$ Fe-N\n$\n$ H. Du, J. Phase Equilib., 14, 682-93(1993).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ FE4N_L1 modified to avoid Fe4N to become stable in e.g. Cr-Fe. The Fe4N\n$ phase field is slightly changed and the fcc+hcp+Fe4N equilibrium decreases\n$ from 923 to 920 K.\n$\n$ The FeN (FCC_A1) phase still seems somewhat too stable at low temperature.\n$\n PAR L(LIQUID,FE,N;0),, -19930-12.01*T;,, N 91Fri1 !\n$\n PAR G(FCC_A1,FE:N),, +GHSERFE+GHSERNN\n -20277+245.3931*T-21.2984*T*LN(T);,, N 93Du !\n PAR L(FCC_A1,FE:N,VA;0),, -26150;,, N 91Fri1 !\n$\n PAR G(A1_FCC,FE:N),, +GHSERFE+GHSERNN\n -20277+245.3931*T-21.2984*T*LN(T);,, N 93Du !\n PAR L(A1_FCC,FE:N,VA;0),, -26150;,, N 91Fri1 !\n$\n PAR G(BCC_A2,FE:N),, +GHSERFE+3*GHSERNN\n +93562+165.07*T;,, N 91Fri1 !\n PAR TC(BCC_A2,FE:N),, 1043;,, N 91Fri1 !\n PAR BMAG(BCC_A2,FE:N),, 2.22;,, N 91Fri1 !\n$\n PAR G(A2_BCC,FE:N),, +GHSERFE+3*GHSERNN\n +93562+165.07*T;,, N 91Fri1 !\n PAR TC(A2_BCC,FE:N),, 1043;,, N 91Fri1 !\n PAR BMAG(A2_BCC,FE:N),, 2.22;,, N 91Fri1 !\n$\n PAR G(HCP_A3,FE:N),, +GHSERFE+0.5*GHSERNN\n -13863+40.2123*T;,, N 93Du !\n PAR L(HCP_A3,FE:N,VA;0),, +10012-19.9853*T;,, N 93Du !\n PAR L(HCP_A3,FE:N,VA;1),, -9446+9.3472*T;,, N 93Du !\n$\n PAR G(FE4N_L1,FE:N),, +4*GHSERFE+GHSERNN\n -37514+72.6235*T;,, N 93Du !\n$PAR L(FE4N_L1,FE:N,VA;0),, +64679-21.9574*T;,, N 93Du !\n PAR L(FE4N_L1,FE:N,VA;0),, +44679-21.9574*T;,, N 17Hal12 !\n PAR L(FE4N_L1,FE:N,VA;1),, -27905-3.409*T;,, N 93Du !\n$\n$ metastable\n$\n PAR G(CBCC_A12,FE:N),, +GHSERFE+GHSERNN\n -30766+375.42*T-37.6*T*LN(T);,, N 93Qiu2 !\n PAR L(CBCC_A12,FE:N,VA;0),, -26150;,, N 93Qiu2 !\n$\n PAR G(CUB_A13,FE:N),, +GHSERFE+GHSERNN\n -32216+375.42*T-37.6*T*LN(T);,, N 93Qiu2 !\n PAR L(CUB_A13,FE:N,VA;0),, -26150;,, N 93Qiu2 !\n$\n PAR G(CEMENTITE_D011,FE:N),, -20060+538.7902*T\n -99.7371*T*LN(T)+226735*T**(-1);,, N 93Du !\n PAR G(FECN_CHI,FE:N),, -55838+952.0774*T\n -174.5248*T*LN(T)+438672*T**(-1);,, N 93Du !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb\n$\n$ A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov, B. Hallstedt,\n$ Calphad, 54, 1-15(2016).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ Modified from the description by A.V. Khvan and B. Hallstedt 2013.\n$ It was necessary to reduce the stability of the mu phase to model Cr-Fe-Nb.\n$\n$ B2 ordering added to have a reasonable extension of FeTi-B2 in Fe-Nb-Ti.\n$\n PAR L(LIQUID,FE,NB;0),, -74257+99.67*T-10*T*LN(T);,, N 13Khv1 !\n PAR L(LIQUID,FE,NB;1),, +17624-10.805*T;,, N 13Khv1 !\n$\n PAR L(FCC_A1,FE,NB:VA;0),, -6176-2.04*T;,, N 13Khv1 !\n PAR L(A1_FCC,FE,NB:VA;0),, -6176-2.04*T;,, N 13Khv1 !\n$\n PAR L(BCC_A2,FE,NB:VA;0),, -10893+10.288*T;,, N 13Khv1 !\n PAR L(BCC_A2,FE,NB:VA;1),, +4674-5.776*T;,, N 13Khv1 !\n$\n PAR L(A2_BCC,FE,NB:VA;0),, -10893+10.288*T;,, N 13Khv1 !\n PAR L(A2_BCC,FE,NB:VA;1),, +4674-5.776*T;,, N 13Khv1 !\n$\n PAR G(B2_BCC,FE:NB:VA),, -10000;,, N 17Hal17 !\n PAR G(B2_BCC,NB:FE:VA),, -10000;,, N 17Hal17 !\n$\n PAR G(C14_LAVES,FE:NB),, +2*GHSERFE+GHSERNB\n -67223+13.971*T;,, N 13Khv1 !\n PAR G(C14_LAVES,NB:FE),, +2*GHSERNB+GHSERFE+180030;,, N 12Liu !\n PAR L(C14_LAVES,FE,NB:FE;0),, +ZERO;,, N 12Liu !\n PAR L(C14_LAVES,FE,NB:NB;0),, +ZERO;,, N 12Liu !\n PAR L(C14_LAVES,FE:FE,NB;0),, -33816;,, N 13Khv1 !\n PAR L(C14_LAVES,NB:FE,NB;0),, -33816;,, N 13Khv1 !\n$\n PAR G(MU_D85,FE:NB:FE:FE),, +9*GHSERFE+4*GHSERNB\n -100230;,, N 12Liu !\n PAR G(MU_D85,FE:NB:FE:NB),, +3*GHSERFE+10*GHSERNB\n +426530;,, N 12Liu !\n PAR G(MU_D85,FE:NB:NB:FE),, +7*GHSERFE+6*GHSERNB\n -266116+56*T;,, N 16Jac1 !\n PAR G(MU_D85,FE:NB:NB:NB),, +GHSERFE+12*GHSERNB+176020;,, N 12Liu !\n PAR G(MU_D85,NB:NB:FE:FE),, +8*GHSERFE+5*GHSERNB-27430;,, N 12Liu !\n PAR G(MU_D85,NB:NB:FE:NB),, +2*GHSERFE+11*GHSERNB\n +499200;,, N 12Liu !\n PAR G(MU_D85,NB:NB:NB:FE),, +6*GHSERFE+7*GHSERNB\n -131400;,, N 12Liu !\n$\n$ Metastable\n$\n PAR L(HCP_A3,FE,NB:VA;0),, -6176-2.04*T;,, N Same !\n$\n PAR G(C15_LAVES,FE:NB),, +2*GHSERFE+GHSERNB\n -50000+13.971*T;,, N 16Jac1 !\n PAR G(C15_LAVES,NB:FE),, +2*GHSERNB+GHSERFE+178263;,, N 16Jac1 !\n PAR L(C15_LAVES,FE,NB:FE;0),, +ZERO;,, N 16Jac1 !\n PAR L(C15_LAVES,FE,NB:NB;0),, +ZERO;,, N 16Jac1 !\n PAR L(C15_LAVES,FE:FE,NB;0),, -33816;,, N 16Jac1 !\n PAR L(C15_LAVES,NB:FE,NB;0),, -33816;,, N 16Jac1 !\n$\n PAR G(SIGMA_D8B,FE:NB:FE),, +26*GHSERFE+4*GHSERNB\n +57084;,, N 13Khv2 !\n PAR G(SIGMA_D8B,FE:NB:NB),, +10*GHSERFE+20*GHSERNB\n +497885;,, N 13Khv2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni\n$\n$ N. Dupin, B. Sundman, March 2003 at JEEP.\n$\n$ Checked against LB. Checked at 6000 K.\n$\n$ This dataset is modified from the LB dataset by changing the ordering\n$ parameter to have a much weaker temperature dependence. A strongly positive\n$ ordering contribution causes ordering at high temperature (in this case)\n$ in the Cr-Fe-Ni and Fe-Mn-Ni systems. Compared to the LB dataset the critical\n$ temperature for ordering (FeNi3) is the same, but the FeNi3 phase field\n$ becomes wider at lower temperature and the bcc+fcc+FeNi3 equilibrium\n$ temperature decreases.\n$\n$ There are several different descriptions of the fcc ordering floating around.\n$ All are referred to I. Ansara. This one is taken from LBall-v7+fun.tdb and\n$ cited there as I. Ansara 1995. However, the description in FeNi-95Ans-CK.tdb\n$ is different. Therefore I assume that the complete present description\n$ (and not just the SRO contribution) is from N. Dupin 2003.\n$\n$ Bcc ordering added by B. Sundman 2003\n$ Liquid changed by B.-J. Lee 1993\n$ U1FFENI changed by B. Hallstedt 2016\n$\n$ I have not seen the original 85Xin report, but it is consistently cited\n$ by both AFG and B.-J. Lee, so I believe it is correctly cited.\n$\n$ The diagram in LB is calculated using the original 85Xin parameters for\n$ the liquid.\n$\n$PAR L(LIQUID,FE,NI;0),, -18378.86+6.03912*T;,, N 85Xin !\n$PAR L(LIQUID,FE,NI;1),, +9228.1-3.54642*T;,, N 85Xin !\n PAR L(LIQUID,FE,NI;0),, -16911+5.1622*T;,, N 93Lee1 !\n PAR L(LIQUID,FE,NI;1),, +10180-4.146656*T;,, N 93Lee1 !\n$\n PAR L(FCC_A1,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin !\n PAR L(FCC_A1,FE,NI:VA;1),, +11082.1315-4.45077*T;,, N 85Xin !\n PAR L(FCC_A1,FE,NI:VA;2),, -725.805174;,, N 85Xin !\n PAR TC(FCC_A1,FE,NI:VA;0),, +2133;,, N 85Xin !\n PAR TC(FCC_A1,FE,NI:VA;1),, -682;,, N 85Xin !\n PAR BMAG(FCC_A1,FE,NI:VA;0),, +9.55;,, N 85Xin !\n PAR BMAG(FCC_A1,FE,NI:VA;1),, +7.23;,, N 85Xin !\n PAR BMAG(FCC_A1,FE,NI:VA;2),, +5.93;,, N 85Xin !\n PAR BMAG(FCC_A1,FE,NI:VA;3),, +6.18;,, N 85Xin !\n$\n PAR L(A1_FCC,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin !\n PAR L(A1_FCC,FE,NI:VA;1),, +11082.1315-4.45077*T;,, N 85Xin !\n PAR L(A1_FCC,FE,NI:VA;2),, -725.805174;,, N 85Xin !\n PAR TC(A1_FCC,FE,NI:VA;0),, +2133;,, N 85Xin !\n PAR TC(A1_FCC,FE,NI:VA;1),, -682;,, N 85Xin !\n PAR BMAG(A1_FCC,FE,NI:VA;0),, +9.55;,, N 85Xin !\n PAR BMAG(A1_FCC,FE,NI:VA;1),, +7.23;,, N 85Xin !\n PAR BMAG(A1_FCC,FE,NI:VA;2),, +5.93;,, N 85Xin !\n PAR BMAG(A1_FCC,FE,NI:VA;3),, +6.18;,, N 85Xin !\n$\n PAR G(FCC_4SL,FE:FE:FE:NI:VA),, +GFFE3NI;,, N 16Hal5 !\n PAR G(FCC_4SL,FE:FE:NI:NI:VA),, +GFFE2NI2;,, N 16Hal5 !\n PAR G(FCC_4SL,FE:NI:NI:NI:VA),, +GFFENI3;,, N 16Hal5 !\n PAR L(FCC_4SL,FE,NI:*:*:*:VA;0),, +U3FFENI;,, N 03Dup !\n PAR L(FCC_4SL,FE,NI:FE,NI:*:*:VA;0),, +SFFENI;,, N 16Hal5 !\n$\n PAR L(BCC_A2,FE,NI:VA;0),, -956.63-1.28726*T;,, N 85Xin !\n PAR L(BCC_A2,FE,NI:VA;1),, +1789.03-1.92912*T;,, N 85Xin !\n$\n PAR L(A2_BCC,FE,NI:VA;0),, -956.63-1.28726*T;,, N 85Xin !\n PAR L(A2_BCC,FE,NI:VA;1),, +1789.03-1.92912*T;,, N 85Xin !\n$\n PAR G(B2_BCC,FE:NI:VA),, -2000;,, N 07Zha !\n PAR G(B2_BCC,NI:FE:VA),, -2000;,, N 07Zha !\n$\n$ metastable\n$\n PAR L(HCP_A3,FE,NI:VA;0),, -12054.355+3.27413*T;,, N 85Xin !\n PAR L(HCP_A3,FE,NI:VA;1),, +11082-4.45077*T;,, N 85Xin !\n PAR L(HCP_A3,FE,NI:VA;2),, -725.8;,, N 85Xin !\n$\n PAR L(CBCC_A12,FE,NI:VA;0),, +ZERO;,, N 09Zha !\n PAR L(CUB_A13,FE,NI:VA;0),, -7000;,, N 09Zha ! \n$\n PAR G(C14_LAVES,FE:NI),, +2*GHSERFE+GHSERNI+48320;,, N 17Hal8 !\n PAR G(C14_LAVES,NI:FE),, +2*GHSERNI+GHSERFE+52510;,, N 17Hal8 !\n$\n$ Function below from 03Dup\n$FUNCTION U1FFENI 298.15 -7500+13.7*T; 6000 N !\n$ Half T dependence (below) is not sufficient.\n$FUNCTION U1FFENI 298.15 -1906+6.5*T; 6000 N !\n FUNCTION U1FFENI 298.15 +814+3*T; 6000 N !\n FUNCTION SFFENI 298.15 +U1FFENI; 6000 N !\n FUNCTION U3FFENI 298.15 +1200; 6000 N !\n FUNCTION GFFENI3 298.15 +3*U1FFENI-6315; 6000 N !\n FUNCTION GFFE3NI 298.15 +3*U1FFENI+6000; 6000 N !\n FUNCTION GFFE2NI2 298.15 +4*U1FFENI; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Fe-Si\n$\n$ From J. Lacaze and B. Sundman 1991 (included in LB Vol. 3)\n$\n$ J. Lacaze, B. Sundman, Metall. Mater. Trans. A, 22A, 2211-23(1991).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ tcfe99 has a different liquid interaction (from Miettinen 1998)\n$ 91Lac: Inverse miscibility gap with min at 2170K, x(Si)=0.87\n$ 98Mie: Inverse miscibility gap with min at 2740K, x(Si)=0.76\n$\n$ The modification of the liquid changes invariant temperatures less than 1 K.\n$\n PAR L(LIQUID,FE,SI;0),, -164435+41.977*T;,, N 91Lac !\n PAR L(LIQUID,FE,SI;1),, -21.523*T;,, N 91Lac !\n$PAR L(LIQUID,FE,SI;2),, -18821+22.07*T;,, N 91Lac !\n$PAR L(LIQUID,FE,SI;3),, +9696;,, N 91Lac !\n PAR L(LIQUID,FE,SI;2),, +5220+5.726*T;,, N 98Mie !\n PAR L(LIQUID,FE,SI;3),, -28955+26.275*T;,, N 98Mie !\n$\n PAR L(FCC_A1,FE,SI:VA;0),, -125248+41.116*T;,, N 91Lac !\n PAR L(FCC_A1,FE,SI:VA;1),, -142708;,, N 91Lac !\n PAR L(FCC_A1,FE,SI:VA;2),, +89907;,, N 91Lac !\n$\n PAR L(A1_FCC,FE,SI:VA;0),, -125248+41.116*T;,, N 91Lac !\n PAR L(A1_FCC,FE,SI:VA;1),, -142708;,, N 91Lac !\n PAR L(A1_FCC,FE,SI:VA;2),, +89907;,, N 91Lac !\n$\n PAR L(BCC_A2,FE,SI:VA;0),, +4*L0BCC-4*FESIW1;,, N 91Lac !\n PAR L(BCC_A2,FE,SI:VA;1),, +8*L1BCC;,, N 91Lac !\n PAR L(BCC_A2,FE,SI:VA;2),, +16*L2BCC;,, N 91Lac !\n PAR TC(BCC_A2,FE,SI:VA;1),, +8*ETCFESI;,, N 91Lac !\n$\n PAR L(A2_BCC,FE,SI:VA;0),, +4*L0BCC-4*FESIW1;,, N 91Lac !\n PAR L(A2_BCC,FE,SI:VA;1),, +8*L1BCC;,, N 91Lac !\n PAR L(A2_BCC,FE,SI:VA;2),, +16*L2BCC;,, N 91Lac !\n PAR TC(A2_BCC,FE,SI:VA;1),, +8*ETCFESI;,, N 91Lac !\n$\n PAR G(B2_BCC,SI:FE:VA),, -2*FESIW1;,, N 91Lac !\n PAR G(B2_BCC,FE:SI:VA),, -2*FESIW1;,, N 91Lac !\n$\n PAR G(FE2SI,FE:SI),, +2*GHSERFE+GHSERSI\n -71256-10.62*T;,, N 91Lac !\n PAR G(FESI2_H,FE:SI),, +0.3*GHSERFE+0.7*GHSERSI\n -19649-0.92*T;,, N 91Lac !\n PAR G(FESI2_L,FE:SI),, +GHSERFE+2*GHSERSI\n -82149+10.44*T;,, N 91Lac !\n PAR G(MSI_B20,FE:SI),, +GHSERFE+GHSERSI\n -72762+4.44*T;,, N 91Lac !\n PAR G(M5SI3_D88,FE:SI:VA),, +5*GHSERFE+3*GHSERSI\n -241144+2.16*T;,, N 91Lac !\n$\n$ Metastable\n$\n PAR L(HCP_A3,FE,SI:VA;0),, -123468+41.116*T;,, N 93For !\n PAR L(HCP_A3,FE,SI:VA;1),, -142708;,, N 93For !\n PAR L(HCP_A3,FE,SI:VA;2),, +89907;,, N 93For !\n$\n PAR L(CBCC_A12,FE,SI:VA;0),, -153141+46.48*T;,, N 93For !\n PAR L(CBCC_A12,FE,SI:VA;1),, -92352;,, N 93For !\n PAR L(CBCC_A12,FE,SI:VA;2),, +62240;,, N 93For !\n$\n PAR L(CUB_A13,FE,SI:VA;0),, -153141+46.48*T;,, N 93For !\n PAR L(CUB_A13,FE,SI:VA;1),, -92352;,, N 93For !\n PAR L(CUB_A13,FE,SI:VA;2),, +62240;,, N 93For !\n$\n PAR G(CR3SI_A15,FE:SI:VA),, +3*GHSERFE+GHSERSI\n -75000+8*T;,, N 97Lin !\n$PAR G(CR5SI3_D8M,FE:SI),, +5*GHSERFE+3*GHSERSI\n$ -180000;,, N 97Lin !\n PAR G(CR5SI3_D8M,FE:SI),, +5*GHSERFE+3*GHSERSI\n -140000;,, N 97Lin !\n$\n PAR G(MN3SI,FE:SI),, +3*GHSERFE+GHSERSI\n -94274-3.56*T;,, N 93For !\n$\n PAR G(C14_LAVES,FE:SI),, +2*GHSERFE+GHSERSI+25770;,, N 16Jac2 !\n PAR G(C14_LAVES,SI:FE),, +2*GHSERSI+GHSERFE+80090;,, N 16Jac2 !\n PAR L(C14_LAVES,FE,SI:FE;0),, -380000;,, N 16Jac2 !\n$\n FUNCTION FESIW1 298.15 +1260*R; 6000 N !\n FUNCTION L0BCC 298.15 -27809+11.62*T; 6000 N !\n FUNCTION L1BCC 298.15 -11544; 6000 N !\n FUNCTION L2BCC 298.15 +3890; 6000 N !\n FUNCTION ETCFESI 298.15 +63; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Fe-Ti\n$\n$ H. Bo, J. Wang, L. Duarte, C. Leinenbach, L. Liu, H. Liu, Z. Jin,\n$ Trans. Nonferrous Met. Soc. China, 22, 2204-11(2012).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ The hcp phase is not sufficiently stable.\n$\n$ There are two models for Fe2Ti included. FE2TI_C14 is the original from 12Bo.\n$ C14_LAVES includes new end-member values and refitted interactions.\n$ An incorrect value for G(C14_LAVES,TI:TI) was used in a previous version.\n$ When using the correct value from 06Slu it was not possible to refit the\n$ Mn-Ti phase diagram without using excessive interaction parameters. Therefore\n$ a value for G(C14_LAVES,TI:TI) was selected that produces moderate interaction\n$ parameters.\n$ The invariant temperatures are preserved, but the C14_LAVES phase shows lower\n$ Fe solubility.\n$\n PAR L(LIQUID,FE,TI;0),, -74300+17.839*T;,, N 12Bo !\n PAR L(LIQUID,FE,TI;1),, +8299.849-6.101*T;,, N 12Bo !\n$\n PAR L(FCC_A1,FE,TI:VA;0),, -52149.856+9.265*T;,, N 12Bo !\n PAR L(FCC_A1,FE,TI:VA;1),, +4755.9-4.982*T;,, N 12Bo !\n PAR L(FCC_A1,FE,TI:VA;2),, +29205.228-11.046*T;,, N 12Bo !\n$\n PAR L(A1_FCC,FE,TI:VA;0),, -52149.856+9.265*T;,, N 12Bo !\n PAR L(A1_FCC,FE,TI:VA;1),, +4755.9-4.982*T;,, N 12Bo !\n PAR L(A1_FCC,FE,TI:VA;2),, +29205.228-11.046*T;,, N 12Bo !\n$\n PAR L(BCC_A2,FE,TI:VA;0),, -69241.924+25.246*T\n +1E-04*T**2+120000*T**(-1);,, N 12Bo !\n PAR L(BCC_A2,FE,TI:VA;1),, +5018.986-4.992*T;,, N 12Bo !\n PAR L(BCC_A2,FE,TI:VA;2),, +23028.241-13.11*T;,, N 12Bo !\n PAR TC(BCC_A2,FE,TI:VA;0),, -2000.00;,, N 12Bo !\n$\n PAR L(A2_BCC,FE,TI:VA;0),, -69241.924+25.246*T\n +1E-04*T**2+120000*T**(-1);,, N 12Bo !\n PAR L(A2_BCC,FE,TI:VA;1),, +5018.986-4.992*T;,, N 12Bo !\n PAR L(A2_BCC,FE,TI:VA;2),, +23028.241-13.11*T;,, N 12Bo !\n PAR TC(A2_BCC,FE,TI:VA;0),, -2000.00;,, N 12Bo !\n$\n PAR G(B2_BCC,FE:TI:VA),, -30028.003+4.495*T;,, N 12Bo !\n PAR G(B2_BCC,TI:FE:VA),, -30028.003+4.495*T;,, N 12Bo !\n PAR L(B2_BCC,FE,TI:FE:VA;1),, -5001.5;,, N 12Bo !\n PAR L(B2_BCC,FE:FE,TI:VA;1),, -5001.5;,, N 12Bo !\n PAR L(B2_BCC,FE,TI:TI:VA;1),, +11000;,, N 12Bo !\n PAR L(B2_BCC,TI:FE,TI:VA;1),, +11000;,, N 12Bo !\n$\n PAR L(HCP_A3,FE,TI:VA;0),, -25000+35.004*T;,, N 12Bo !\n$\n PAR G(C14_LAVES,FE:TI),, +GFE2TI;,, N 12Bo !\n PAR G(C14_LAVES,TI:FE),, +3*GHSERFE+3*GHSERTI+89130\n -GFE2TI;,, N 17Hal2 !\n PAR L(C14_LAVES,FE,TI:FE;0),, -35000;,, N 17Hal2 !\n PAR L(C14_LAVES,FE,TI:TI;0),, -35000;,, N 17Hal2 !\n PAR L(C14_LAVES,FE:FE,TI;0),, -35000;,, N 17Hal2 !\n PAR L(C14_LAVES,TI:FE,TI;0),, -35000;,, N 17Hal2 !\n$\n$ Metastable\n$\n PAR G(MU_D85,FE:TI:FE:FE),, +7*GFCCFE+4*GBCCTI\n +2*GHSERFE;,, N Lin !\n PAR G(MU_D85,FE:TI:TI:FE),, +7*GFCCFE+6*GBCCTI-200000;,, N 17Hal17 !\n$\n PAR G(SIGMA_D8B,FE:TI:FE),, +10*GFCCFE+4*GBCCTI\n +16*GHSERFE;,, N Lin !\n PAR G(SIGMA_D8B,FE:TI:TI),, +10*GFCCFE+20*GBCCTI;,, N Lin !\n$\n FUNCTION GFE2TI 298.15 -85500+410.041*T-73.553*T*LN(T)\n -0.01017*T**2+124212.42*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Fe-V\n$\n$ From W. Huang 1991 (Included in LB Vol. 3)\n$\n$ W. Huang, Z. Metallkd., 82, 391-401(1991).\n$\n$ Checked against LB and paper. Checked at 6000K.\n$\n$ W. Huang used the 8:4:18 model for the sigma phase (SIGMA_OLD). This was\n$ changed to 10:4:16 (SIGMA_D8B) for LB. The change of model shifts\n$ the maximum to higher V content. Max at x(V)=0.485 for SIGMA_OLD\n$ and x(V)=0.517 for SIGMA_D8B.\n$\n PAR L(LIQUID,FE,V;0),, -34679+1.895*T;,, N 91Hua2 !\n PAR L(LIQUID,FE,V;1),, +10209;,, N 91Hua2 !\n$\n PAR L(FCC_A1,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 !\n PAR L(A1_FCC,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 !\n$\n PAR L(BCC_A2,FE,V:VA;0),, -23674+0.465*T;,, N 91Hua2 !\n PAR L(BCC_A2,FE,V:VA;1),, +8283;,, N 91Hua2 !\n PAR TC(BCC_A2,FE,V:VA;0),, -110;,, N 83And !\n PAR TC(BCC_A2,FE,V:VA;1),, +3075;,, N 83And !\n PAR TC(BCC_A2,FE,V:VA;2),, +808;,, N 83And !\n PAR TC(BCC_A2,FE,V:VA;3),, -2169;,, N 83And !\n PAR BMAG(BCC_A2,FE,V:VA;0),, -2.26;,, N 83And !\n$\n PAR L(A2_BCC,FE,V:VA;0),, -23674+0.465*T;,, N 91Hua2 !\n PAR L(A2_BCC,FE,V:VA;1),, +8283;,, N 91Hua2 !\n PAR TC(A2_BCC,FE,V:VA;0),, -110;,, N 83And !\n PAR TC(A2_BCC,FE,V:VA;1),, +3075;,, N 83And !\n PAR TC(A2_BCC,FE,V:VA;2),, +808;,, N 83And !\n PAR TC(A2_BCC,FE,V:VA;3),, -2169;,, N 83And !\n PAR BMAG(A2_BCC,FE,V:VA;0),, -2.26;,, N 83And !\n$\n PAR G(SIGMA_D8B,FE:V:FE),, +10*GFCCFE+4*GHSERVV\n +16*GHSERFE-174619+78.27*T;,, N 00Wes !\n PAR G(SIGMA_D8B,FE:V:V),, +10*GFCCFE+20*GHSERVV\n -249118-68.64*T;,, N 00Wes !\n PAR G(SIGMA_D8B,V:V:FE),, +14*GHSERVV+16*GHSERFE\n +100000;,, N 02Sun !\n PAR L(SIGMA_D8B,FE:V:FE,V;0),, -200000;,, N 02Sun !\n$\n$ Metastable\n$\n PAR L(HCP_A3,FE,V:VA;0),, -15291-4.138*T;,, N 91Hua2 !\n$\n PAR L(CBCC_A12,FE,V:VA;0),, -10000;,, N 91Hua3 !\n PAR L(CUB_A13,FE,V:VA;0),, -10000;,, N 91Hua3 !\n$\n PAR G(C14_LAVES,FE:V),, +2*GHSERFE+GHSERVV+75611;,, N 13Khv2 !\n PAR G(C14_LAVES,V:FE),, +2*GHSERVV+GHSERFE+124858;,, N 13Khv2 !\n$ ------------------------------------------------------------------------------\n$ Mg-C\n$\n$ From B. Hallstedt 2006\n$\n$ This is a very preliminary description based on the limited information\n$ from A.A. Nayeb-Hashemi and J.B. Clark in ASM Handbook of binary phase\n$ diagrams 1996. Gas phase and carbides are taken from SGSUB 1997.\n$\n$ G(HCP_A3,MG:C) set to give approximately the same C solubility in hcp as\n$ in the liquid, which is treated as ideal, at the melting temperature of Mg.\n$\n$ The carbides Mg2C3 and MgC2 do not appear to be stable.\n$ The only important gas species is Mg1.\n$\n PAR G(HCP_A3,MG:C),, +GHSERMG+0.5*GHSERCC+45000;,, N 06Hal4 !\n$\n PAR G(MG2C3,MG:C),, +31041.1756+712.136068*T\n -118.7419*T*LN(T)-0.00535552*T**2+1251016*T**(-1);,, N 97SUB !\n PAR G(MGC2,MG:C),, +61324.7987+432.693209*T\n -71.17821*T*LN(T)-0.003231094*T**2+6.56084E-10*T**3\n +749881.5*T**(-1);,, N 97SUB !\n$\n$ Metastable\n$\n PAR G(BCC_A2,MG:C),, +GHSERMG+3*GHSERCC+320000;,, N 15Hal2 !\n PAR G(A2_BCC,MG:C),, +GHSERMG+3*GHSERCC+320000;,, N 15Hal2 !\n$ ------------------------------------------------------------------------------\n$ Mg-Mn\n$\n$ J. Groebner, D. Mirkovic, M. Ohno, R. Schmid-Fetzer,\n$ J. Phase Equilib. Diffus., 26, 234-39(2005).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ The shape of the liquid miscibility gap is more reasonable than in 98Tib.\n$\n$ Solid interactions except HCP_A3 should probably be changed.\n$\n PAR L(LIQUID,MG,MN;0),, +25922.4+9.0357*T;,, N 05Gro !\n PAR L(LIQUID,MG,MN;1),, -3470.8;,, N 05Gro !\n$\n PAR L(FCC_A1,MG,MN:VA;0),, +85000;,, N 05Gro !\n PAR L(A1_FCC,MG,MN:VA;0),, +85000;,, N 05Gro !\n PAR L(BCC_A2,MG,MN:VA;0),, +85000;,, N 05Gro !\n PAR L(A2_BCC,MG,MN:VA;0),, +85000;,, N 05Gro !\n PAR L(HCP_A3,MG,MN:VA;0),, +37148.1-1.8103*T;,, N 05Gro !\n PAR L(CBCC_A12,MG,MN:VA;0),, +85000;,, N 05Gro !\n PAR L(CUB_A13,MG,MN:VA;0),, +85000;,, N 05Gro !\n$ ------------------------------------------------------------------------------\n$ Mg-Mo\n$ ------------------------------------------------------------------------------\n$ Mg-N\n$\n$ B. Hallstedt, unpublished, 2015.\n$\n$ Checked at 6000K.\n$\n$ This is just a dummy until reasonable interactions have been determined.\n$ Interactions should be determined from a suitable ternary system.\n$\n$ There is a stable nitride, Mg3N2. Its enthalpy of formation is taken from\n$ LB IV/5 (Predel). No further parameters are included.\n$\n PAR L(LIQUID,MG,N;0),, +ZERO;,, N 15Hal3 !\n$\n PAR L(HCP_A3,MG:N;0),, +ZERO;,, N 15Hal3 !\n$\n PAR G(MG3N2_D53,MG:N),, +3*GHSERMG+2*GHSERNN\n -461000;,, N 15Hal3 !\n$ ------------------------------------------------------------------------------\n$ Mg-Nb\n$\n$ B. Hallstedt, unpublished, 2015.\n$\n$ Checked at 6000K.\n$\n$ This is just a dummy until reasonable interactions have been determined.\n$ Interactions should be determined from a suitable ternary system and/or\n$ SQS calculations.\n$\n$ There are no intermetallic compounds and the terminal solubilities are small\n$ (LB IV/5; Predel).\n$\n PAR L(LIQUID,MG,NB;0),, +100000;,, N 15Hal4 !\n$\n PAR L(BCC_A2,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n PAR L(A2_BCC,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n$\n PAR L(HCP_A3,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n PAR L(A1_FCC,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n PAR L(CBCC_A12,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n PAR L(CUB_A13,MG,NB:VA;0),, +100000;,, N 15Hal4 !\n$ ------------------------------------------------------------------------------\n$ Mg-Ni\n$\n$ From M.H.G. Jacobs and P.J. Spencer 1998 (Included in LB Vol. 3)\n$\n$ M.H.G. Jacobs, P.J. Spencer, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST. Checked at 6000 K.\n$\n$ This version is quite different from the version published in Calphad,\n$ which seems quite reasonable with the exception of an inverse liquid\n$ miscibility gap and probably too positive solid interactions.\n$\n$ Solid interactions should be changed. Ni endpoint of C36_LAVES should be\n$ changed. Mg2Ni has a constant heat capacity.\n$\n PAR L(LIQUID,MG,NI;0),, -42304.49+7.45704*T;,, N 98Jac2 !\n PAR L(LIQUID,MG,NI;1),, -15611.66+9.11885*T;,, N 98Jac2 !\n$\n PAR L(FCC_A1,MG,NI:VA;0),, +80*T;,, N 98Jac2 !\n PAR L(A1_FCC,MG,NI:VA;0),, +80*T;,, N 98Jac2 !\n PAR L(HCP_A3,MG,NI:VA;0),, +80*T;,, N 98Jac2 !\n$\n PAR G(C36_LAVES,MG:NI),, +104136-293.9216*T\n +54.35385*T*LN(T)+0.0333*T**2+99*T**(-1)\n -5.14203E-06*T**3;,, N 98Jac2 !\n PAR G(C36_LAVES,NI:MG),, -74136+293.9216*T\n -54.35385*T*LN(T)-0.0333*T**2-99*T**(-1)\n +5.14203E-06*T**3;,, N 98Jac2 !\n PAR L(C36_LAVES,MG,NI:MG;0),, +50000;,, N 98Jac2 !\n PAR L(C36_LAVES,MG,NI:NI;0),, +50000;,, N 98Jac2 !\n PAR L(C36_LAVES,MG:MG,NI;0),, +50000;,, N 98Jac2 !\n PAR L(C36_LAVES,NI:MG,NI;0),, +50000;,, N 98Jac2 !\n$\n PAR G(MG2NI,MG:NI),, -82211.2+571.0183*T\n -95.992*T*LN(T);,, N 98Jac2 !\n$\n$ Metastable\n$\n PAR L(BCC_A2,MG,NI:VA;0),, +80*T;,, N 98Jac2 !\n PAR L(A2_BCC,MG,NI:VA;0),, +80*T;,, N 98Jac2 !\n$ ------------------------------------------------------------------------------\n$ Mg-Si\n$\n$ S.-M. Liang, P. Wang, R. Schmid-Fetzer, Calphad, 54, 82-96(2016).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ Includes new model for the T-dependence of the liquid interaction.\n$\n PAR L(LIQUID,MG,SI;0),, -59907.1*FET+10*T*FET;,, N 16Lia !\n PAR L(LIQUID,MG,SI;1),, -20810.1*FET+12.2428*T*FET;,, N 16Lia !\n PAR L(LIQUID,MG,SI;2),, +26078.6*FET-14*T*FET;,, N 16Lia !\n$\n PAR L(HCP_A3,MG,SI:VA;0),, -5330;,, N 16Lia !\n PAR L(DIAMOND_A4,MG,SI;0),, +40618-38*T;,, N 16Lia !\n$\n PAR G(MG2SI_C1,MG:SI),, +GMG2SI;,, N 16Lia !\n$\n$ metastable\n$\n PAR L(FCC_A1,MG,SI:VA;0),, -5330;,, N Same !\n PAR L(A1_FCC,MG,SI:VA;0),, -5330;,, N Same !\n PAR L(BCC_A2,MG,SI:VA;0),, -5330;,, N Same !\n PAR L(A2_BCC,MG,SI:VA;0),, -5330;,, N Same !\n PAR L(CBCC_A12,MG,SI:VA;0),, -5330;,, N Same !\n PAR L(CUB_A13,MG,SI:VA;0),, -5330;,, N Same !\n$\n PAR G(C15_LAVES,MG:SI),, +2*GHSERMG+GHSERSI\n +104970.96-16.46448*T;,, N 98Luk !\n PAR G(C15_LAVES,SI:MG),, +2*GHSERSI+GHSERMG\n +41039+6.25*T;,, N 98Luk !\n PAR L(C15_LAVES,SI,MG:SI;0),, +15000;,, N 98Luk !\n PAR L(C15_LAVES,SI:SI,MG;0),, +8000;,, N 98Luk !\n PAR L(C15_LAVES,MG:MG,SI;0),, +8000;,, N 98Luk !\n PAR L(C15_LAVES,MG,SI:MG;0),, +15000;,, N 98Luk ! \n$\n FUNCTION EXP1 298.15 +EXP(-1.25E-07*T**2); 6000 N !\n FUNCTION EXP2 298.15 +EXP(1.25E-04*T); 6000 N !\n FUNCTION FET 298.15 +0.96923*EXP1*EXP2; 6000 N !\n FUNCTION GMG2SI 1.00 -75335.76-5.205E-03*T**2+1.25E-07*T**4;\n 17.00 Y -75321.86-0.4894*T-0.40121*T*LN(T)\n +0.074176*T**2-1.04634E-03*T**3-68.8*T**(-1);\n 50.00 Y -73998.13-160.5303*T+40.92023*T*LN(T)\n -0.498235*T**2+4.38333E-04*T**3-8007*T**(-1);\n 120.00 Y -79151.48+145.3746*T-22.83914*T*LN(T)\n -0.1476684*T**2+7.69627E-05*T**3+70083*T**(-1);\n 250.00 Y -86546.8+410.4926*T-71.661*T*LN(T)\n -0.00561*T**2+278010*T**(-1);\n 1400.00 Y -96748.07+521.8042*T-87.0853*T*LN(T);\n 3600.00 N !\n$ ------------------------------------------------------------------------------\n$ Mg-Ti\n$\n$ J.L. Murray, Bull. Alloy Phase Diagrams, 7, 245-48(1986).\n$\n$ Checked against paper. Checked at 6000K.\n$\n$ The match is reasonable considering that pre-SGTE lattice stabilities were\n$ used in 86Mur.\n$\n PAR L(LIQUID,MG,TI;0),, +77020;,, N 86Mur !\n$\n PAR L(BCC_A2,MG,TI:VA;0),, +33608;,, N 86Mur !\n PAR L(A2_BCC,MG,TI:VA;0),, +33608;,, N 86Mur !\n$\n PAR L(HCP_A3,MG,TI:VA;0),, +21779+22.165*T;,, N 86Mur !\n PAR L(HCP_A3,MG,TI:VA;1),, +9467;,, N 86Mur !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MG,TI:VA;0),, +21779+22.165*T;,, N Same !\n PAR L(FCC_A1,MG,TI:VA;1),, +9467;,, N Same !\n$\n PAR L(A1_FCC,MG,TI:VA;0),, +21779+22.165*T;,, N Same !\n PAR L(A1_FCC,MG,TI:VA;1),, +9467;,, N Same !\n$\n PAR L(CBCC_A12,MG,TI:VA;0),, +21779+22.165*T;,, N Same !\n PAR L(CBCC_A12,MG,TI:VA;1),, +9467;,, N Same !\n$\n PAR L(CUB_A13,MG,TI:VA;0),, +21779+22.165*T;,, N Same !\n PAR L(CUB_A13,MG,TI:VA;1),, +9467;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Mg-V\n$\n$ B. Hallstedt, unpublished, 2015.\n$\n$ Checked at 6000K.\n$\n$ This is just a dummy until reasonable interactions have been determined.\n$ Interactions should be determined from a suitable ternary system and/or\n$ SQS calculations.\n$\n$ There are no intermetallic compounds and the terminal solubilities are small\n$ (LB IV/5; Predel).\n$\n$ There is also a dataset from 08GTT. In contrast to 08GTT I do not assume\n$ ideal mixing in the liquid. The interactions are also larger here than in\n$ 08GTT.\n$\n PAR L(LIQUID,MG,V;0),, +100000;,, N 15Hal5 !\n$\n PAR L(BCC_A2,MG,V:VA;0),, +100000;,, N 15Hal5 !\n PAR L(A2_BCC,MG,V:VA;0),, +100000;,, N 15Hal5 !\n$\n PAR L(HCP_A3,MG,V:VA;0),, +100000;,, N 15Hal5 !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MG,V:VA;0),, +100000;,, N 15Hal5 !\n PAR L(A1_FCC,MG,V:VA;0),, +100000;,, N 15Hal5 !\n$\n PAR L(CBCC_A12,MG,V:VA;0),, +100000;,, N Same !\n PAR L(CUB_A13,MG,V:VA;0),, +100000;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Mn-C\n$\n$ D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski,\n$ Calphad, 34, 279-85(2010).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,C,MN;0),, -179183+43.8449*T;,, N 10Dju !\n PAR L(LIQUID,C,MN;1),, +6313;,, N 10Dju !\n PAR L(LIQUID,C,MN;2),, +23281;,, N 10Dju !\n$\n PAR G(FCC_A1,MN:C),, +GHSERMN+GHSERCC+13.659*T;,, N 10Dju !\n PAR L(FCC_A1,MN:C,VA;0),, -41333;,, N 10Dju !\n$\n PAR G(A1_FCC,MN:C),, +GHSERMN+GHSERCC+13.659*T;,, N 10Dju !\n PAR L(A1_FCC,MN:C,VA;0),, -41333;,, N 10Dju !\n$\n PAR G(BCC_A2,MN:C),, +GHSERMN+3*GHSERCC\n +10000+30*T;,, N 90Hua1 !\n PAR G(A2_BCC,MN:C),, +GHSERMN+3*GHSERCC\n +10000+30*T;,, N 90Hua1 !\n$\n PAR G(HCP_A3,MN:C),, +GHSERMN+0.5*GHSERCC\n -9000-1.0651*T;,, N 10Dju !\n PAR L(HCP_A3,MN:C,VA;0),, -5006;,, N 10Dju !\n$\n PAR G(CBCC_A12,MN:C),, +GHSERMN+GHSERCC\n +27.46525*T;,, N 10Dju !\n PAR L(CBCC_A12,MN:C,VA;0),, -52204;,, N 10Dju !\n$\n PAR G(CUB_A13,MN:C),, +GHSERMN+GHSERCC+2607;,, N 10Dju !\n PAR L(CUB_A13,MN:C,VA;0),, -10175;,, N 10Dju !\n$\n PAR G(M23C6_D84,MN:MN:C),, +GMN23C6;,, N 10Dju !\n PAR G(CEMENTITE_D011,MN:C),, +GMN3C;,, N 10Dju !\n PAR G(M5C2,MN:C),, +GMN5C2;,, N 10Dju !\n PAR G(M7C3_D101,MN:C),, +GMN7C3;,, N 10Dju !\n$\n$ metastable\n$\n PAR G(V3C2,MN:C),, -76135+750.415*T\n -125.589*T*LN(T)+922711*T**(-1);,, N 91Fer2 !\n$\n FUNCTION GMN23C6 298.15 +23*GHSERMN+6*GHSERCC-310473+53.86*T; 6000 N !\n FUNCTION GMN3C 298.15 +3*GHSERMN+GHSERCC-39644+3.04*T; 6000 N !\n FUNCTION GMN5C2 298.15 +5*GHSERMN+2*GHSERCC-73954+6.36*T; 6000 N !\n FUNCTION GMN7C3 298.15 +7*GHSERMN+3*GHSERCC-106695+9.36*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Mn-Mo\n$\n$ From from B.-J. Lee 1995 (Included in LB Vol. 4)\n$\n$ B.-J. Lee, unpublished research, 1995.\n$\n$ Checked against previous datasets. Checked at 6000 K.\n$\n$ Modified from the dataset by 95Lee.\n$\n$ Model for MU_D85 changed from 7:2:4 to 1:4:2:6 and extended.\n$ Mo added on the 1st SL in SIGMA_D8B. This was necessary in the Cr-Fe-Mo\n$ system.\n$\n$ MU_D85 becomes unstable below 445 K.\n$\n$ New model for MU_D85: The MU_D85 phase has a narrow homogeneity range and\n$ is shifted somewhat towards Mo at high temperature. The SIGMA_D8B parameters\n$ were changed to approximately keep the composition and invarient temperatures\n$ of the original version.\n$\n PAR L(LIQUID,MN,MO;0),, -22275+13.6587*T;,, N 95Lee !\n PAR L(LIQUID,MN,MO;1),, +23500-10.7493*T;,, N 95Lee !\n$\n PAR L(FCC_A1,MN,MO:VA;0),, +11174;,, N 95Lee !\n PAR L(A1_FCC,MN,MO:VA;0),, +11174;,, N 95Lee !\n$\n PAR L(BCC_A2,MN,MO:VA;0),, +49770-14.2564*T;,, N 95Lee !\n PAR L(BCC_A2,MN,MO:VA;1),, -7260;,, N 95Lee !\n$\n PAR L(A2_BCC,MN,MO:VA;0),, +49770-14.2564*T;,, N 95Lee !\n PAR L(A2_BCC,MN,MO:VA;1),, -7260;,, N 95Lee !\n$\n PAR L(CBCC_A12,MN,MO:VA;0),, +646;,, N 95Lee !\n$\n PAR L(CUB_A13,MN,MO:VA;0),, +5626;,, N 95Lee !\n$\n PAR G(MU_D85,MN:MO:MO:MN),, +7*GFCCMN+6*GHSERMO\n -7638-27*T;,, N 17Hal4 !\n PAR G(MU_D85,MN:MO:MO:MO),, +GFCCMN+6*GHSERMO\n +6*GFCCMO+100000;,, N 17Hal4 !\n$\n PAR G(SIGMA_D8B,MN:MO:MN),, +10*GFCCMN+4*GHSERMO\n +16*GBCCMN+30000;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MN:MO:MO),, +10*GFCCMN+20*GHSERMO\n +83000-30*T;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MO:MO:MN),, +10*GFCCMO+4*GHSERMO\n +16*GBCCMN+300000;,, N 17Hal6 !\n$\n$ Metastable\n$\n PAR L(HCP_A3,MN,MO:VA;0),, +11174;,, N Same !\n$\n PAR G(C14_LAVES,MN:MO),, +2*GHSERMN+GHSERMO;,, N Lin !\n PAR G(C14_LAVES,MO:MN),, +2*GHSERMO+GHSERMN+79700;,, N Lin !\n$\n PAR G(R_PHASE,MN:MO:MN),, +27*GFCCMN+14*GHSERMO\n +12*GBCCMN;,, N 95Lee !\n PAR G(R_PHASE,MN:MO:MO),, +27*GFCCMN+26*GHSERMO;,, N 95Lee !\n$ ------------------------------------------------------------------------------\n$ Mn-N\n$\n$ From C. Qiu and AFG (Included in LB Vol. 4)\n$\n$ C. Qiu, A. Fernandez Guillermet, Z. Metallkd., 84, 11-22(1993).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ There are no strange features when the gas is not included.\n$\n$ MN6N5 appears to have a distorted NaCl structure. It should possibly be\n$ modelled as FCC_A1.\n$\n$ Va added on the second sublattice of FE4N_L1 to be compatible with\n$ Fe-N from 93Du. This adds a narrow solubility range for FE4N_L1 and\n$ invariant equilibria on the Mn-rich side of FE4N_L1 increase by about 10 K.\n$\n PAR L(LIQUID,MN,N;0),, -142308+6.0759*T;,, N 93Qiu1 !\n PAR L(LIQUID,MN,N;1),, +32906;,, N 93Qiu1 !\n$\n PAR G(BCC_A2,MN:N),, -55600+606.648*T\n -100.41*T*LN(T)+844897*T**(-1);,, N 93Qiu1 !\n PAR L(BCC_A2,MN:N,VA;0),, -185000;,, N 93Qiu1 !\n$\n PAR G(A2_BCC,MN:N),, -55600+606.648*T\n -100.41*T*LN(T)+844897*T**(-1);,, N 93Qiu1 !\n PAR L(A2_BCC,MN:N,VA;0),, -185000;,, N 93Qiu1 !\n$\n PAR G(FCC_A1,MN:N),, -75940+292.226*T\n -50.294*T*LN(T)+265051*T**(-1);,, N 93Qiu1 !\n PAR L(FCC_A1,MN:N,VA;0),, -69698+11.5845*T;,, N 93Qiu1 !\n$\n PAR G(A1_FCC,MN:N),, -75940+292.226*T\n -50.294*T*LN(T)+265051*T**(-1);,, N 93Qiu1 !\n PAR L(A1_FCC,MN:N,VA;0),, -69698+11.5845*T;,, N 93Qiu1 !\n$\n PAR G(HCP_A3,MN:N),, -60607+211.1804*T\n -37.7331*T*LN(T)+129442*T**(-1);,, N 93Qiu1 !\n PAR L(HCP_A3,MN:N,VA;0),, -7194-5.2075*T;,, N 93Qiu1 !\n PAR L(HCP_A3,MN:N,VA;1),, -11810+6.9538*T;,, N 93Qiu1 !\n$\n PAR G(CBCC_A12,MN:N),, -53114+299.266*T\n -50.216*T*LN(T)+358309*T**(-1);,, N 93Qiu1 !\n PAR L(CBCC_A12,MN:N,VA;0),, -58869;,, N 93Qiu1 !\n$\n PAR G(CUB_A13,MN:N),, -67484+299.266*T\n -50.216*T*LN(T)+358309*T**(-1);,, N 93Qiu1 !\n PAR L(CUB_A13,MN:N,VA;0),, -58869;,, N 93Qiu1 !\n$\n PAR G(FE4N_L1,MN:N),, -155790+691.0638*T\n -126.9328*T*LN(T)+307417*T**(-1);,, N 93Qiu1 !\n PAR G(MN3N2,MN:N),, -232807+714.166*T\n -125.6685*T*LN(T)+513949*T**(-1);,, N 93Qiu1 !\n PAR G(MN6N5,MN:N),, -546880+1591.607*T\n -276.668*T*LN(T)+1297983*T**(-1);,, N 93Qiu1 !\n$\n$ Metastable\n$\n PAR G(CEMENTITE_D011,MN:N),, +3*GHSERMN+GHSERNN+40000;,, N 99Lee !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb\n$\n$ S. Liu, B. Hallstedt, D. Music, Y. Du, Calphad, 38, 43-58(2012).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n PAR L(LIQUID,MN,NB;0),, -15322.786;,, N 12Liu !\n PAR L(LIQUID,MN,NB;1),, +12376.04;,, N 12Liu !\n$\n PAR L(FCC_A1,MN,NB:VA;0),, +6305.5;,, N 12Liu !\n PAR L(A1_FCC,MN,NB:VA;0),, +6305.5;,, N 12Liu !\n$\n PAR L(BCC_A2,MN,NB:VA;0),, +16895.03;,, N 12Liu !\n PAR L(A2_BCC,MN,NB:VA;0),, +16895.03;,, N 12Liu !\n$\n PAR L(CBCC_A12,MN,NB:VA;0),, -10485.26;,, N 12Liu !\n PAR L(CUB_A13,MN,NB:VA;0),, -10485.26;,, N 12Liu !\n$\n PAR G(C14_LAVES,MN:NB),, +2*GHSERMN+GHSERNB\n -32983.815;,, N 12Liu !\n PAR G(C14_LAVES,NB:MN),, +2*GHSERNB+GHSERMN+160800;,, N 12Liu !\n PAR G(C14_LAVES,MN,NB:MN;0),, +5249.5;,, N 12Liu !\n PAR G(C14_LAVES,MN,NB:NB;0),, +5249.5;,, N 12Liu !\n PAR G(C14_LAVES,MN:MN,NB;0),, +ZERO;,, N 12Liu !\n PAR G(C14_LAVES,NB:MN,NB;0),, +ZERO;,, N 12Liu !\n$\n PAR G(MU_D85,MN:NB:NB:MN),, +7*GHSERMN+6*GHSERNB\n -119340;,, N 12Liu !\n PAR G(MU_D85,MN:NB:NB:NB),, +GHSERMN+12*GHSERNB\n +181220;,, N 12Liu !\n PAR G(MU_D85,NB:NB:NB:MN),, +6*GHSERMN+7*GHSERNB\n -47450;,, N 12Liu !\n$\n$ Metastable\n$\n PAR L(HCP_A3,MN,NB:VA;0),, +6305.5;,, N Same !\n$\n PAR G(SIGMA_D8B,MN:NB:MN),, +10*GFCCMN+4*GHSERNB\n +16*GHSERMN;,, N Lin !\n PAR G(SIGMA_D8B,MN:NB:NB),, +10*GFCCMN+20*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Ni\n$\n$ P. Franke, Int. J. Mater. Res., 98, 954-60(2007).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ 4SL model for fcc using option F.\n$\n$ The parameters for the disordered phases (except bcc) are kept from \n$ Guo and Du 2005.\n$\n$ There seems to be a magnetic miscibility gap (with Nishizawa horn) in the\n$ fcc phase on the Ni-rich side below about 500 K. For some reason it\n$ continues as a very thin miscibility gap up to the solidus.\n$\n PAR L(LIQUID,MN,NI;0),, -45032.1+2.7764*T;,, N 05Guo !\n PAR L(LIQUID,MN,NI;1),, +11665.5-7.6061*T;,, N 05Guo !\n$\n PAR L(FCC_A1,MN,NI:VA;0),, -27996.5-1.2275*T;,, N 05Guo !\n PAR L(FCC_A1,MN,NI:VA;1),, +19266.4-12.2853*T;,, N 05Guo !\n PAR TC(FCC_A1,MN,NI:VA;0),, -3171.20;,, N 05Guo !\n PAR TC(FCC_A1,MN,NI:VA;1),, -4317.73;,, N 05Guo !\n PAR BMAG(FCC_A1,MN,NI:VA;0),, -1.3947;,, N 05Guo !\n PAR BMAG(FCC_A1,MN,NI:VA;1),, +3.9050;,, N 05Guo !\n$\n PAR L(A1_FCC,MN,NI:VA;0),, -27996.5-1.2275*T;,, N 05Guo !\n PAR L(A1_FCC,MN,NI:VA;1),, +19266.4-12.2853*T;,, N 05Guo !\n PAR TC(A1_FCC,MN,NI:VA;0),, -3171.20;,, N 05Guo !\n PAR TC(A1_FCC,MN,NI:VA;1),, -4317.73;,, N 05Guo !\n PAR BMAG(A1_FCC,MN,NI:VA;0),, -1.3947;,, N 05Guo !\n PAR BMAG(A1_FCC,MN,NI:VA;1),, +3.9050;,, N 05Guo !\n$\n PAR G(FCC_4SL,MN:MN:MN:NI:VA),, +GFMN3NI;,, N 07Fra !\n PAR G(FCC_4SL,MN:MN:NI:NI:VA),, +GFMN2NI2;,, N 07Fra !\n PAR G(FCC_4SL,MN:NI:NI:NI:VA),, +GFMNNI3;,, N 07Fra !\n PAR G(FCC_4SL,MN,NI:MN,NI:*:*:VA;0),, +SFMNNI;,, N 07Fra !\n$\n PAR L(BCC_A2,MN,NI:VA;0),, -11466-14*T;,, N 07Fra !\n PAR L(A2_BCC,MN,NI:VA;0),, -11466-14*T;,, N 07Fra !\n$\n PAR G(B2_BCC,MN:NI:VA),, -23774+4.5*T;,, N 07Fra !\n PAR G(B2_BCC,NI:MN:VA),, -23774+4.5*T;,, N 07Fra !\n$\n PAR L(CBCC_A12,MN,NI:VA;0),, -27797.3-0.4267*T;,, N 05Guo !\n PAR L(CBCC_A12,MN,NI:VA;1),, +36529.6-30.5162*T;,, N 05Guo !\n$\n PAR L(CUB_A13,MN,NI:VA;0),, -28815.2+0.1795*T;,, N 05Guo !\n PAR L(CUB_A13,MN,NI:VA;1),, +24317.8-16.8271*T;,, N 05Guo !\n$\n$ metastable\n$\n PAR L(HCP_A3,MN,NI:VA;0),, -27996.5-1.2275*T;,, N Same !\n PAR L(HCP_A3,MN,NI:VA;1),, +19266.4-12.2853*T;,, N Same !\n$\n PAR G(C14_LAVES,MN:NI),, +2*GHSERMN+GHSERNI+32700;,, N Lin !\n PAR G(C14_LAVES,NI:MN),, +2*GHSERNI+GHSERMN+44700;,, N Lin !\n$\n FUNCTION U1FMNNI 298.15 -7050; 6000 N !\n FUNCTION SFMNNI 298.15 -5500; 6000 N !\n FUNCTION GFMN3NI 298.15 +3*U1FMNNI+2200; 6000 N !\n FUNCTION GFMN2NI2 298.15 +4*U1FMNNI; 6000 N !\n FUNCTION GFMNNI3 298.15 +3*U1FMNNI+1550; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Mn-Si\n$\n$ From J.E. Tibballs 1991 (included in LB Vol. 4)\n$\n$ J.E. Tibballs, SI-report 890221-5, 1991 (also COST 507 report, 1998).\n$\n$ Checked against LB and COST report. Checked at 6000 K.\n$\n$ There are some differences in the invariant equilibria between LB and the\n$ COST report, possibly because of rounding errors. This dataset reproduces\n$ the LB version correctly.\n$\n$ Mn6Si is stable above 5500 K and there is an inverse miscibility gap with\n$ a minimum at 5800 K and x(Si)=0.58.\n$\n PAR L(LIQUID,MN,SI;0),, -139817.4+29.86137*T;,, N 91Tib !\n PAR L(LIQUID,MN,SI;1),, -34917.2+3.20488*T;,, N 91Tib !\n PAR L(LIQUID,MN,SI;2),, +46782.4-18.18969*T;,, N 91Tib !\n PAR L(LIQUID,MN,SI;3),, +16168.2;,, N 91Tib !\n$\n PAR L(FCC_A1,MN,SI:VA;0),, -95600+2.94097*T;,, N 91Tib !\n PAR L(FCC_A1,MN,SI:VA;1),, -7500;,, N 91Tib !\n$\n PAR L(A1_FCC,MN,SI:VA;0),, -95600+2.94097*T;,, N 91Tib !\n PAR L(A1_FCC,MN,SI:VA;1),, -7500;,, N 91Tib !\n$\n PAR L(BCC_A2,MN,SI:VA;0),, -89620.7+2.94097*T;,, N 91Tib !\n PAR L(BCC_A2,MN,SI:VA;1),, -7500;,, N 91Tib !\n$\n PAR L(A2_BCC,MN,SI:VA;0),, -89620.7+2.94097*T;,, N 91Tib !\n PAR L(A2_BCC,MN,SI:VA;1),, -7500;,, N 91Tib !\n$\n PAR L(CBCC_A12,MN,SI:VA;0),, -142743.62+22.3961*T;,, N 91Tib !\n PAR L(CBCC_A12,MN,SI:VA;1),, +16440.608-3.5300332*T;,, N 91Tib !\n$\n PAR L(CUB_A13,MN,SI:VA;0),, -142343.62+21.89261*T;,, N 91Tib !\n PAR L(CUB_A13,MN,SI:VA;1),, +16440.608-3.5300332*T;,, N 91Tib !\n$\n PAR G(MN6SI,MN:SI),, +20*GMN17SI3;,, N 91Tib !\n PAR G(MN9SI2,MN:SI),, +40*GMN33SI7;,, N 91Tib !\n PAR G(MN3SI,MN:SI),, +4*GMN3SI;,, N 91Tib !\n PAR G(M5SI3_D88,MN:SI:VA),, +GMN5SI3;,, N 91Tib !\n PAR G(MSI_B20,MN:SI),, +2*GMNSI;,, N 91Tib !\n PAR G(MN11SI19,MN:SI),, +GMN11SI1;,, N 91Tib !\n$\n$ metastable\n$\n PAR L(HCP_A3,MN,SI:VA;0),, -86775+2.94*T;,, N 93For !\n PAR L(HCP_A3,MN,SI:VA;1),, -7500;,, N 93For !\n$\n PAR G(C14_LAVES,MN:SI),, +2*GHSERMN+GHSERSI+61260;,, N Lin !\n PAR G(C14_LAVES,SI:MN),, +2*GHSERSI+GHSERMN+101820;,, N Lin !\n$\n FUNCTION GMN17SI3 298.15 +0.85*GHSERMN+0.15*GHSERSI-12509.03+4.24222*T\n -0.6038776*T*LN(T)-0.001652606*T**2+375.7*T**(-1);\n 1519.00 Y +0.85*GHSERMN+0.15*GHSERSI-14100.43-1.629152*T\n +0.6033774*T*LN(T)-0.0029395827*T**2+1.964114E+30*T**(-9);\n 6000.00 N !\n FUNCTION GMN33SI7 298.15 +0.825*GHSERMN+0.175*GHSERSI-14455.21+9.53235*T\n -1.421747*T*LN(T)-0.001250875*T**2+364.65*T**(-1);\n 1519.00 Y +0.825*GHSERMN+0.175*GHSERSI-15999.8+3.833662*T\n -0.25*T*LN(T)-0.0025*T**2+1.906346E+30*T**(-9);\n 6000.00 N !\n FUNCTION GMN3SI 298.15 -31047.468+195.60933*T-32.920521*T*LN(T)\n -0.0019425154*T**2+414300.232*T**(-1);\n 950.00 Y -29935.151+194.43847*T-32.920521*T*LN(T)\n -0.0019425154*T**2+414300.232*T**(-1);\n 6000.00 N !\n FUNCTION GMN5SI3 298.15 -261930.32+1170.7779*T-211.15016*T*LN(T)\n -0.01529344*T**2-149263.11*T**(-1);\n 6000.00 N !\n FUNCTION GMNSI 298.15 -39067.572+154.1244*T-26.210608*T*LN(T)\n -0.0034516778*T**2+438221.48*T**(-1);\n 6000.00 N !\n FUNCTION GMN11SI1 298.15 -636300.49+1624.9288*T-378.69397*T*LN(T)\n -0.16391259*T**2-15432618*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Mn-Ti\n$\n$ From N. Saunders 1998 (included in LB Vol. 4)\n$\n$ N. Saunders, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST report. Checked at 6000 K.\n$\n$ REFLAV not used for G(MN2TI_C14,MN:MN).\n$ -4*T term missing for G(MNTI_ALPHA,MN:TI)in the COST report.\n$\n$ There are two models for Mn2Ti included. MN2TI_C14 is the original from 98Sau.\n$ C14_LAVES includes new end-member values and refitted interactions.\n$ An incorrect value for G(C14_LAVES,TI:TI) was used in a previous version.\n$ When using the correct value from 06Slu it was not possible to refit the\n$ phase diagram without using excessive interaction parameters. Therefore\n$ a value for G(C14_LAVES,TI:TI) was selected that produces moderate interaction\n$ parameters. The interaction parameters were selected so that the invariant\n$ temperatures involving the liquid change minimally. The C14_LAVES phase field\n$ is more narrow and the invariant temperatures involving C14_LAVES change\n$ somewhat. The minimum temperature of beta-MnTi increases by 10 K. Other\n$ equilibria change less.\n$\n PAR L(LIQUID,MN,TI;0),, -34000+21.5*T;,, N 98Sau2 !\n PAR L(LIQUID,MN,TI;1),, +1400;,, N 98Sau2 !\n$\n PAR L(FCC_A1,MN,TI:VA;0),, -26200+20*T;,, N 98Sau2 !\n PAR L(A1_FCC,MN,TI:VA;0),, -26200+20*T;,, N 98Sau2 !\n$\n PAR L(BCC_A2,MN,TI:VA;0),, -23200+20*T;,, N 98Sau2 !\n PAR L(BCC_A2,MN,TI:VA;1),, -1000;,, N 98Sau2 !\n$\n PAR L(A2_BCC,MN,TI:VA;0),, -23200+20*T;,, N 98Sau2 !\n PAR L(A2_BCC,MN,TI:VA;1),, -1000;,, N 98Sau2 !\n$\n PAR L(HCP_A3,MN,TI:VA;0),, +22100;,, N 98Sau2 !\n$\n PAR L(CBCC_A12,MN,TI:VA;0),, -29500+20*T;,, N 98Sau2 !\n PAR L(CBCC_A12,MN,TI:VA;1),, -3635-5*T;,, N 98Sau2 !\n$\n PAR L(CUB_A13,MN,TI:VA;0),, -34000+20*T;,, N 98Sau2 !\n$\n PAR G(C14_LAVES,MN:TI),, +2*GHSERMN+GHSERTI-26400;,, N 98Sau2 !\n PAR G(C14_LAVES,TI:MN),, +GHSERMN+2*GHSERTI+92100;,, N 17Hal2 !\n PAR L(C14_LAVES,MN,TI:MN;0),, -6500;,, N 17Hal2 !\n PAR L(C14_LAVES,MN,TI:TI;0),, -6500;,, N 17Hal2 !\n PAR L(C14_LAVES,MN:MN,TI;0),, -5500;,, N 17Hal2 !\n PAR L(C14_LAVES,TI:MN,TI;0),, -5500;,, N 17Hal2 !\n$\n PAR G(MN3TI,MN:TI),, +3*GHSERMN+GHSERTI\n -18552-9.12*T;,, N 98Sau2 !\n PAR G(MN4TI,MN:TI),, +0.815*GHSERMN+0.185*GHSERTI\n -2445-2.9*T;,, N 98Sau2 !\n PAR G(MNTI_ALPHA,MN:TI),, +GHSERMN+GHSERTI\n -11478-4*T;,, N 98Sau2 !\n PAR G(MNTI_BETA,MN:TI),, +0.515*GHSERMN+0.485*GHSERTI\n -5540-2.29*T;,, N 98Sau2 !\n$\n$ metastable\n$\n PAR G(MU_D85,MN:TI:TI:MN),, +7*GFCCMN+6*GBCCTI;,, N Lin !\n$\n PAR G(SIGMA_D8B,MN:TI:MN),, +10*GFCCMN+4*GBCCTI\n +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,MN:TI:TI),, +10*GFCCMN+20*GBCCTI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-V\n$\n$ From W. Huang 1991 (Included in LB Vol. 4)\n$\n$ W. Huang, Calphad, 15, 195-208(1991).\n$\n$ Checked against LB and paper. Checked at 6000K.\n$\n$ W. Huang used the 8:4:18 model for the sigma phase (SIGMA_OLD). This was\n$ changed to 10:4:16 (SIGMA_D8B) for LB. The change of model only slightly\n$ changes the V-rich side of the sigma phase field.\n$\n PAR L(LIQUID,MN,V;0),, -11399;,, N 91Hua3 !\n$\n PAR L(FCC_A1,MN,V:VA;0),, -11820;,, N 91Hua3 !\n PAR L(A1_FCC,MN,V:VA;0),, -11820;,, N 91Hua3 !\n PAR L(BCC_A2,MN,V:VA;0),, -10000;,, N 91Hua3 !\n PAR L(A2_BCC,MN,V:VA;0),, -10000;,, N 91Hua3 !\n PAR L(CBCC_A12,MN,V:VA;0),, -22225;,, N 91Hua3 !\n PAR L(CUB_A13,MN,V:VA;0),, -17724;,, N 91Hua3 !\n$\n PAR G(SIGMA_D8B,MN:V:MN),, +10*GFCCMN+4*GHSERVV\n +16*GBCCMN-225273+57.82*T;,, N 00Wes !\n PAR G(SIGMA_D8B,MN:V:V),, +10*GFCCMN+20*GHSERVV\n -52083-60.39*T;,, N 00Wes !\n PAR G(SIGMA_D8B,V:V:MN),, +14*GHSERVV+16*GBCCMN\n +100000;,, N 02Sun !\n$\n$ Metastable\n$\n PAR L(HCP_A3,MN,V:VA;0),, -11820;,, N 91Hua4 !\n$\n PAR G(C14_LAVES,MN:V),, +2*GHSERMN+GHSERVV+26130;,, N Lin !\n PAR G(C14_LAVES,V:MN),, +2*GHSERVV+GHSERMN+31560;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-C\n$\n$ From J.-O. Andersson 1988 (included in LB Vol. 2)\n$\n$ J.-O. Andersson, Calphad, 12, 1-8(1988).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ BCC_A2 is stable above 5400 K at x(C) about 0.55. There is no inverse\n$ miscibility gap in the liquid.\n$\n$ Shim et al. 1996 claim that a negative L(BCC_A2,MO:C,VA;0) is necessary\n$ in order to describe Mo-Ti-C, but this brings the C-solubility in bcc-Mo\n$ far beyond all experimental data. This parameter is in TCFE, but not in LB.\n$\n$ CEMENTITE_D011 is stable above 3100K.\n$\n PAR L(LIQUID,C,MO;0),, -217800+38.41*T;,, N 88And1 !\n PAR L(LIQUID,C,MO;1),, +30000;,, N 88And1 !\n PAR L(LIQUID,C,MO;2),, +47000;,, N 88And1 !\n$\n PAR G(BCC_A2,MO:C),, +GHSERMO+3*GHSERCC\n +331000-75*T;,, N 88And1 !\n PAR L(BCC_A2,MO:C,VA;0),, -20000;,, N 15Hal1 !\n PAR G(A2_BCC,MO:C),, +GHSERMO+3*GHSERCC\n +331000-75*T;,, N 88And1 !\n PAR L(A2_BCC,MO:C,VA;0),, -20000;,, N 15Hal1 !\n$PAR L(BCC_A2,MO:C,VA;0),, -50000;,, N 96Shi !\n$\n PAR G(FCC_A1,MO:C),, +GHSERMO+GHSERCC\n -7500-8.3*T-750000*T**(-1);,, N 88And1 !\n PAR L(FCC_A1,MO:C,VA;0),, -41300;,, N 88And1 !\n$\n PAR G(A1_FCC,MO:C),, +GHSERMO+GHSERCC\n -7500-8.3*T-750000*T**(-1);,, N 88And1 !\n PAR L(A1_FCC,MO:C,VA;0),, -41300;,, N 88And1 !\n$\n PAR G(HCP_A3,MO:C),, +GHSERMO+0.5*GHSERCC\n -24150-3.625*T-163000*T**(-1);,, N 88And1 !\n PAR L(HCP_A3,MO:C,VA;0),, +4150;,, N 88And1 !\n$\n PAR G(MC_ETA,MO:C),, +GHSERMO+GHSERCC\n -9100-5.35*T-750000*T**(-1);,, N 88And1 !\n PAR L(MC_ETA,MO:C,VA;0),, -59500;,, N 88And1 !\n$\n PAR G(MC_SHP,MO:C),, +GHSERMO+GHSERCC\n -32983+2.5*T;,, N 88And1 !\n$\n$ metastable\n$\n PAR G(CBCC_A12,MO:C),, +UN_ASS;,, N !\n PAR G(CUB_A13,MO:C),, +UN_ASS;,, N !\n PAR G(CEMENTITE_D011,MO:C),, +3*GHSERMO+GHSERCC\n +77000-57.4*T;,, N 88And2 !\n PAR G(M7C3_D101,MO:C),, +7*GHSERMO+3*GHSERCC\n -140415+24.24*T;,, N 92Qiu2 !\n PAR G(CR3C2_D510,MO:C),, +3*GHSERMO+2*GHSERCC+27183;,, N 92Qiu2 !\n PAR G(KSI_CARBIDE,MO:C),, +3*GHSERMO+GHSERCC\n +167009-33*T;,, N 88And2 !\n$ ------------------------------------------------------------------------------\n$ Mo-N\n$\n$ From K. Frisk 1991 (included in LB Vol. 4)\n$\n$ K. Frisk, Calphad, 15, 79-106(1991).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ BCC_A2 has a gigantic stability region above 3000 K.\n$ There is no inverse miscibility gap below 6000 K in the liquid.\n$\n PAR L(LIQUID,MO,N;0),, -198280+37.49*T;,, N 91Fri1 !\n$\n PAR G(FCC_A1,MO:N),, +GHSERMO+GHSERNN\n -65344+149.7*T-9.78*T*LN(T);,, N 91Fri1 !\n PAR L(FCC_A1,MO:N,VA;0),, -52565;,, N 91Fri1 !\n$\n PAR G(A1_FCC,MO:N),, +GHSERMO+GHSERNN\n -65344+149.7*T-9.78*T*LN(T);,, N 91Fri1 !\n PAR L(A1_FCC,MO:N,VA;0),, -52565;,, N 91Fri1 !\n$\n PAR G(BCC_A2,MO:N),, +GHSERMO+3*GHSERNN\n +299700+79.73*T;,, N 91Fri1 !\n PAR G(A2_BCC,MO:N),, +GHSERMO+3*GHSERNN\n +299700+79.73*T;,, N 91Fri1 !\n$\n PAR G(HCP_A3,MO:N),, +GHSERMO+0.5*GHSERNN\n -29450+28.7*T;,, N 91Fri1 !\n$\n$ metastable\n$\n PAR G(CEMENTITE_D011,MO:N),, +UN_ASS;,, N !\n$\n PAR G(MC_SHP,MO:N),, -65897+276.75741*T\n -45.6523426*T*LN(T)-0.00302837129*T**2\n +450481*T**(-1);,, N 96Fri !\n$ ------------------------------------------------------------------------------\n$ Mo-Nb\n$\n$ W. Xiong, Y. Du, Y. Liu, B.Y. Huang, H.H. Xu, H.L. Chen, Z. Pan,\n$ Calphad, 28, 133-40(2004).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ The very large negative enthalpy of mixing for the bcc phase seems very\n$ improbable. The 80Che version also has a large negative enthalpy of mixing,\n$ but not as large by far as here. This casts some doubt on the experimental\n$ chemical potential data in Fig. 5 in 04Xio. Both solid and liquid should be\n$ expected to be nearly ideal.\n$\n PAR L(LIQUID,MO,NB;0),, +15253.7;,, N 04Xio !\n PAR L(LIQUID,MO,NB;1),, +10594.2;,, N 04Xio !\n$\n PAR L(BCC_A2,MO,NB:VA;0),, -68202.6+29.85596*T;,, N 04Xio !\n PAR L(BCC_A2,MO,NB:VA;1),, +8201.3;,, N 04Xio !\n$\n PAR L(A2_BCC,MO,NB:VA;0),, -68202.6+29.85596*T;,, N 04Xio !\n PAR L(A2_BCC,MO,NB:VA;1),, +8201.3;,, N 04Xio !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MO,NB:VA;0),, +ZERO;,, N 15Zha1 !\n PAR L(A1_FCC,MO,NB:VA;0),, +ZERO;,, N 15Zha1 !\n$\n PAR L(HCP_A3,MO,NB:VA;0),, +ZERO;,, N 15Zha1 !\n$\n PAR G(C14_LAVES,MO:NB),, +2*GHSERMO+GHSERNB+89340;,, N Lin !\n PAR G(C14_LAVES,NB:MO),, +2*GHSERNB+GHSERMO+69480;,, N Lin !\n$\n PAR G(MU_D85,NB:MO:MO:MO),, +GFCCNB+6*GHSERMO+6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NB:MO:MO:NB),, +7*GFCCNB+6*GHSERMO;,, N Lin !\n PAR G(MU_D85,NB:MO:NB:MO),, +GFCCNB+4*GHSERMO+2*GHSERNB\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NB:MO:NB:NB),, +7*GFCCNB+4*GHSERMO\n +2*GHSERNB;,, N Lin !\n PAR G(MU_D85,NB:NB:MO:MO),, +GFCCNB+4*GHSERNB+2*GHSERMO\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NB:NB:MO:NB),, +7*GFCCNB+4*GHSERNB\n +2*GHSERMO;,, N Lin !\n PAR G(MU_D85,NB:NB:NB:MO),, +GFCCNB+6*GHSERNB+6*GFCCMO;,, N Lin !\n$\n PAR G(SIGMA_D8B,MO:MO:NB),, +10*GFCCMO+4*GHSERMO\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,MO:NB:MO),, +10*GFCCMO+4*GHSERNB\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:NB:NB),, +10*GFCCMO+20*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Ni\n$\n$ K. Frisk, Calphad, 14, 371-380(1990).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ Presently calculated invariant equilibria are up to 3 K higher than in\n$ the paper.\n$\n$ Included in NIST superalloys database 23-Sep-2002 and SSOL V4.\n$\n$ D1A_NI4X is not stable below 317 K.\n$\n$ MONI changes to Mo-rich at low T without any apparent reason.\n$ The parameters for MONI seem strange.\n$\n PAR L(LIQUID,MO,NI;0),, -46540+19.53*T;,, N 90Fri2 !\n PAR L(LIQUID,MO,NI;1),, +2915;,, N 90Fri2 !\n$\n PAR L(FCC_A1,MO,NI:VA;0),, +4803.7-5.96*T;,, N 90Fri2 !\n PAR L(FCC_A1,MO,NI:VA;1),, +10880;,, N 90Fri2 !\n$\n PAR L(A1_FCC,MO,NI:VA;0),, +4803.7-5.96*T;,, N 90Fri2 !\n PAR L(A1_FCC,MO,NI:VA;1),, +10880;,, N 90Fri2 !\n$\n PAR L(BCC_A2,MO,NI:VA;0),, +46422;,, N 90Fri2 !\n PAR L(A2_BCC,MO,NI:VA;0),, +46422;,, N 90Fri2 !\n$\n PAR G(NI3X_D0A,NI:MO),, +GHSERMO+3*GHSERNI\n -4199-7.00*T;,, N 90Fri2 !\n$\n PAR G(NI4X_D1A,NI:MO),, +GHSERMO+4*GHSERNI\n -4330-9.21*T;,, N 90Fri2 !\n$\n PAR G(MONI,NI:NI:MO),, +6*GHSERNI+5*GBCCNI+3*GHSERMO\n -257.5-23.375*T+3.375*T*LN(T);,, N 90Fri2 !\n PAR G(MONI,NI:MO:MO),, +6*GHSERNI+8*GHSERMO\n -53025+272.25*T-35.5*T*LN(T);,, N 90Fri2 !\n$\n$ Metastable\n$\n$ Same as fcc (zero in TCFE 1999)\n PAR L(HCP_A3,MO,NI:VA;0),, +4803.7-5.96*T;,, N NIST !\n PAR L(HCP_A3,MO,NI:VA;1),, +10880;,, N NIST !\n$\n PAR G(CHI_A12,NI:MO:MO),, +24*GHSERNI+10*GHSERMO\n +24*GFCCMO;,, N Lin !\n PAR G(CHI_A12,NI:MO:NI),, +48*GHSERNI+10*GHSERMO;,, N Lin !\n$\n PAR G(CRNI2_C11B,MO:NI),, +GHSERMO+2*GHSERNI\n +1000;,, N 06Tur !\n$\n PAR G(C14_LAVES,MO:NI),, +2*GHSERMO+GHSERNI+91700;,, N 17Hal8 !\n PAR G(C14_LAVES,NI:MO),, +2*GHSERNI+GHSERMO;,, N Lin !\n$\n PAR G(MU_D85,NI:MO:NI:NI),, +7*GHSERNI+4*GHSERMO\n +2*GBCCNI;,, N Lin !\n PAR G(MU_D85,NI:MO:NI:MO),, +3*GBCCNI+10*GHSERMO\n +200000;,, N 17Hal8 !\n PAR G(MU_D85,NI:MO:MO:NI),, +7*GHSERNI+6*GHSERMO\n -20000;,, N 17Hal8 !\n PAR G(MU_D85,NI:MO:MO:MO),, +GBCCNI+12*GHSERMO\n +200000;,, N 17Hal8 !\n$\n PAR G(SIGMA_D8B,NI:MO:MO),, +10*GHSERNI+20*GHSERMO\n +64295-65*T;,, N 17Hal8 !\n PAR G(SIGMA_D8B,NI:MO:NI),, +10*GHSERNI+4*GHSERMO\n +16*GBCCNI+150000;,, N 17Hal8 !\n PAR G(SIGMA_D8B,MO:MO:NI),, +10*GFCCMO+4*GHSERMO\n +16*GBCCNI+150000;,, N 17Hal8 !\n$\n PAR G(P_PHASE,NI:NI:MO;0),, +24*GHSERNI+20*GBCCNI+12*GHSERMO\n +208845-100*T;,, N 92Fri1 !\n PAR G(P_PHASE,NI:MO:MO;0),, +24*GHSERNI+32*GHSERMO\n +26739-100*T;,, N 92Fri1 !\n$\n PAR G(R_PHASE,NI:MO:NI),, +27*GHSERNI+12*GBCCNI\n +14*GHSERMO+100000;,, N 92Fri1 !\n PAR G(R_PHASE,NI:MO:MO),, +27*GHSERNI+26*GHSERMO\n -18000;,, N 92Fri1 !\n$ ------------------------------------------------------------------------------\n$ Mo-Si\n$\n$ From from P.-Y. Chevalier and E. Fischer 2003 (Included in LB Vol. 4)\n$\n$ P.-Y. Chevalier, E. Fischer, unpublished research, 2003.\n$\n$ Checked against LB. Checked at 6000 K.\n$\n$PAR L(LIQUID,MO,SI;0),, -135276.2+1.772195*T;,, N 89Vah !\n$PAR L(LIQUID,MO,SI;1),, -47107.9+33.71028*T;,, N 89Vah !\n$PAR L(LIQUID,MO,SI;2),, +75846.6-30.9*T;,, N 89Vah !\n PAR L(LIQUID,MO,SI;0),, -137903.34+8.40536*T;,, N 03Che !\n PAR L(LIQUID,MO,SI;1),, -42528.38;,, N 03Che !\n PAR L(LIQUID,MO,SI;2),, +49284.19;,, N 03Che !\n PAR L(LIQUID,MO,SI;3),, +48395.52;,, N 03Che !\n$\n$PAR L(BCC_A2,MO,SI:VA;0),, -70899.6;,, N 89Vah !\n PAR L(BCC_A2,MO,SI:VA;0),, -75688.45;,, N 03Che !\n PAR L(A2_BCC,MO,SI:VA;0),, -75688.45;,, N 03Che !\n$\n PAR G(MO3SI_A15,MO:SI),, +4*GMO3SI;,, N 03Che !\n PAR G(MOSI2_C11B,MO:SI),, +3*GMOSI2;,, N 03Che !\n PAR G(M5SI3_D8M,MO:SI),, +8*GMO5SI3;,, N 03Che !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MO,SI:VA;0),, -75688.45;,, N Same !\n PAR L(A1_FCC,MO,SI:VA;0),, -75688.45;,, N Same !\n PAR L(HCP_A3,MO,SI:VA;0),, -75688.45;,, N Same !\n PAR L(CBCC_A12,MO,SI:VA;0),, -75688.45;,, N Same !\n PAR L(CUB_A13,MO,SI:VA;0),, -75688.45;,, N Same !\n$\n PAR G(C14_LAVES,MO:SI),, +2*GHSERMO+GHSERSI+120260;,, N Lin !\n PAR G(C14_LAVES,SI:MO),, +2*GHSERSI+GHSERMO;,, N Lin !\n$\n PAR G(MU_D85,SI:MO:MO:MO),, +GFCCSI+6*GHSERMO+6*GFCCMO;,, N Lin !\n PAR G(MU_D85,SI:MO:MO:SI),, +7*GFCCSI+6*GHSERMO;,, N Lin !\n PAR G(MU_D85,SI:MO:SI:MO),, +GFCCSI+4*GHSERMO+2*GBCCSI\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,SI:MO:SI:SI),, +7*GFCCSI+4*GHSERMO\n +2*GBCCSI;,, N Lin !\n$\n PAR G(SIGMA_D8B,MO:MO:SI),, +10*GFCCMO+4*GHSERMO\n +16*GBCCSI;,, N Lin !\n$\n FUNCTION GMO3SI 298.15 -39940.78+150.83071*T-26.260529*T*LN(T)\n +0.5380211E-3*T**2-0.457131E-6*T**3+159265*T**(-1);\n 6000.00 N !\n FUNCTION GMO5SI3 298.15 -48230.28+148.34434*T-26.078027*T*LN(T)\n +0.3235301E-3*T**2-0.396771E-6*T**3+174382*T**(-1);\n 6000.00 N !\n FUNCTION GMOSI2 298.15 -52358.28+146.62405*T-24.788623*T*LN(T)\n -0.6491781E-3*T**2-0.216351E-6*T**3+180226*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Mo-Ti\n$\n$ From N. Saunders 1998 (included in LB Vol. 4)\n$\n$ N. Saunders, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST. Checked at 6000 K.\n$\n PAR L(LIQUID,MO,TI;0),, -9000+2*T;,, N 98Sau3 !\n$\n PAR L(BCC_A2,MO,TI:VA;0),, +2000;,, N 98Sau3 !\n PAR L(BCC_A2,MO,TI:VA;1),, -2000;,, N 98Sau3 !\n$\n PAR L(A2_BCC,MO,TI:VA;0),, +2000;,, N 98Sau3 !\n PAR L(A2_BCC,MO,TI:VA;1),, -2000;,, N 98Sau3 !\n$\n PAR L(HCP_A3,MO,TI:VA;0),, +22760-6*T;,, N 98Sau3 !\n$\n$ Metastable\n$\n PAR L(FCC_A1,MO,TI:VA;0),, +16500;,, N 98Sau3 !\n PAR L(A1_FCC,MO,TI:VA;0),, +16500;,, N 98Sau3 !\n$\n PAR G(C14_LAVES,MO:TI),, +2*GHSERMO+GHSERTI+87800;,, N Lin !\n PAR G(C14_LAVES,TI:MO),, +2*GHSERTI+GHSERMO+66400;,, N Lin !\n$\n PAR G(SIGMA_D8B,MO:MO:TI),, +10*GFCCMO+4*GHSERMO\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:MO),, +10*GFCCMO+4*GBCCTI\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:TI),, +10*GFCCMO+20*GBCCTI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-V\n$\n$ From J. Bratberg and K. Frisk 2002 (included in LB Vol. 5)\n$\n$ J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ There is a miscibility gap in bcc below 1158 K, which is not experimentally\n$ verified.\n$\n PAR L(LIQUID,MO,V;0),, +17784;,, N 02Bra !\n$\n PAR L(BCC_A2,MO,V:VA;0),, +19245;,, N 02Bra !\n PAR L(A2_BCC,MO,V:VA;0),, +19245;,, N 02Bra !\n$\n$ metastable\n$\n PAR L(FCC_A1,MO,V:VA;0),, +ZERO;,, N 02Bra !\n PAR L(A1_FCC,MO,V:VA;0),, +ZERO;,, N 02Bra !\n PAR L(HCP_A3,MO,V:VA;0),, +ZERO;,, N 02Bra !\n PAR L(MC_ETA,MO,V:VA;0),, +ZERO;,, N 02Bra !\n$\n PAR G(C14_LAVES,MO:V),, +2*GHSERMO+GHSERVV+85130;,, N Lin !\n PAR G(C14_LAVES,V:MO),, +2*GHSERVV+GHSERMO;,, N Lin !\n$\n PAR G(MU_D85,V:MO:MO:MO),, +GFCCVV+6*GHSERMO+6*GFCCMO;,, N Lin !\n PAR G(MU_D85,V:MO:MO:V),, +7*GFCCVV+6*GHSERMO;,, N Lin !\n PAR G(MU_D85,V:MO:V:MO),, +GFCCVV+4*GHSERMO+2*GHSERVV\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,V:MO:V:V),, +7*GFCCVV+4*GHSERMO\n +2*GHSERVV;,, N Lin !\n$\n PAR G(SIGMA_D8B,MO:MO:V),, +10*GFCCMO+4*GHSERMO\n +16*GHSERVV+100000;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:MO),, +10*GFCCMO+4*GHSERVV\n +16*GHSERMO+100000;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:V),, +10*GFCCMO+20*GHSERVV\n +100000;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:MO),, +10*GFCCVV+20*GHSERMO\n +100000;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:V),, +10*GFCCVV+4*GHSERMO\n +16*GHSERVV+100000;,, N Lin !\n PAR G(SIGMA_D8B,V:V:MO),, +10*GFCCVV+4*GHSERVV\n +16*GHSERMO+100000;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-C\n$\n$ From B.-J. Lee 2001 (Included in TCFE 1999)\n$\n$ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001).\n$\n$ Checked against paper. Checked at 6000K.\n$\n$ The congruent melting temperature of NbC is 2 K lower than in the paper.\n$\n$ The BCC_A2 phase was modified by A.V. Khvan and B. Hallstedt to avoid an\n$ an inverse stability range for this phase.\n$\n PAR L(LIQUID,C,NB;0),, -292831+31.2967*T;,, N 01Lee !\n PAR L(LIQUID,C,NB;1),, +6091;,, N 01Lee !\n PAR L(LIQUID,C,NB;2),, +41021;,, N 01Lee !\n$\n PAR G(FCC_A1,NB:C),, -156735+284.1689*T\n -46.34274*T*LN(T)-0.0029287*T**2+563374*T**(-1)\n -1.02788144E+09*T**(-3);,, N 01Lee !\n PAR L(FCC_A1,NB:C,VA;0),, -94050+22.6993*T;,, N 01Lee !\n PAR L(FCC_A1,NB:C,VA;2),, -65000+17.4391*T;,, N 01Lee !\n$\n PAR G(A1_FCC,NB:C),, -156735+284.1689*T\n -46.34274*T*LN(T)-0.0029287*T**2+563374*T**(-1)\n -1.02788144E+09*T**(-3);,, N 01Lee !\n PAR L(A1_FCC,NB:C,VA;0),, -94050+22.6993*T;,, N 01Lee !\n PAR L(A1_FCC,NB:C,VA;2),, -65000+17.4391*T;,, N 01Lee !\n$\n PAR G(BCC_A2,NB:C),, +GHSERNB+3*GHSERCC\n +446349;,, N 13Khv1 !\n PAR L(BCC_A2,NB:C,VA;0),, -510296-70*T;,, N 13Khv1 !\n$PAR G(BCC_A2,NB:C),, +GHSERNB+3*GHSERCC\n$ +446349-70*T;,, N 01Lee !\n$PAR L(BCC_A2,NB:C,VA;0),, -510296;,, N 01Lee !\n$\n PAR G(A2_BCC,NB:C),, +GHSERNB+3*GHSERCC\n +446349;,, N 13Khv1 !\n PAR L(A2_BCC,NB:C,VA;0),, -510296-70*T;,, N 13Khv1 !\n$\n PAR G(HCP_A3,NB:C),, -103175+206.3004*T\n -34.986618*T*LN(T)-0.002897*T**2+252376*T**(-1)\n -58298590*T**(-3);,, N 01Lee !\n PAR L(HCP_A3,NB:C,VA;0),, +4735;,, N 01Lee !\n$\n$ Metastable\n$\n$PAR G(CEMENTITE_D011,NB:C),, +3*GHSERNB+GHSERCC-86000;,, N 90Hua3 !\n PAR G(CEMENTITE_D011,NB:C),, +3*GHSERNB+GHSERCC+137491;,, N 12Khv1!\n PAR G(M7C3_D101,NB:C),, +7*GHSERNB+3*GHSERCC\n +151964;,, N 12Khv1!\n PAR G(M5C2,NB:C),, +5*GHSERNB+2*GHSERCC\n -110958;,, N 12Khv1!\n$PAR G(M23C6_D84,NB:NB:C),, +UN_ASS;,, N !\n PAR G(MC_ETA,NB:C),, +GHSERNB+GHSERCC+15000;,, N 15Zha1 !\n$ ------------------------------------------------------------------------------\n$ Nb-N\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ Modified from W. Huang 1996. The bcc stability problem was solved by using\n$ ugly parameters. However, the bcc phase is still stable above 4000 K around\n$ x(N)=0.5 (when gas is not included).\n$\n PAR L(LIQUID,N,NB;0),, -292101;,, N 96Hua !\n PAR L(LIQUID,N,NB;1),, -105406;,, N 96Hua !\n$\n PAR G(FCC_A1,NB:N),, +GHSERNB+GHSERNN\n -227779+120.567*T-4*T*LN(T);,, N 96Hua !\n PAR L(FCC_A1,NB:N,VA;0),, -65218;,, N 96Hua !\n$\n PAR G(A1_FCC,NB:N),, +GHSERNB+GHSERNN\n -227779+120.567*T-4*T*LN(T);,, N 96Hua !\n PAR L(A1_FCC,NB:N,VA;0),, -65218;,, N 96Hua !\n$\n PAR G(BCC_A2,NB:N),, +GHSERNB+3*GHSERNN\n +4273902-324.302*T;,, N 13Khv1 !\n PAR L(BCC_A2,NB:N,VA;0),, -6778349+577.778*T;,, N 13Khv1 !\n PAR L(BCC_A2,NB:N,VA;1),, -1917408;,, N 13Khv1 !\n$\n PAR G(A2_BCC,NB:N),, +GHSERNB+3*GHSERNN\n +4273902-324.302*T;,, N 13Khv1 !\n PAR L(A2_BCC,NB:N,VA;0),, -6778349+577.778*T;,, N 13Khv1 !\n PAR L(A2_BCC,NB:N,VA;1),, -1917408;,, N 13Khv1 !\n$\n PAR G(HCP_A3,NB:N),, +GHSERNB+0.5*GHSERNN\n -135568+59.295*T-2*T*LN(T);,, N 96Hua !\n PAR L(HCP_A3,NB:N,VA;0),, +ZERO;,, N 96Hua !\n$ ------------------------------------------------------------------------------\n$ Nb-Ni\n$\n$ H. Chen, Y. Du, Calphad, 30, 308-15(2006).\n$\n$ Checked against paper. Checked at 6000K.\n$\n$ Changed lattice stability G(MU_D85,NB:NB:NB:NB).\n$ There is a slight change in the shape of the MU_D85 phase field\n$ on the Nb-rich side and a slightly higher peritectic temperature (1572 K\n$ instead of 1564 K).\n$\n PAR L(LIQUID,NB,NI;0),, -74555-12.00495*T;,, N 06Che !\n PAR L(LIQUID,NB,NI;1),, +31039+19*T;,, N 06Che !\n PAR L(LIQUID,NB,NI;2),, +42510-28.68081*T;,, N 06Che !\n$\n PAR L(FCC_A1,NB,NI:VA;0),, -36499-15.24689*T;,, N 06Che !\n PAR L(FCC_A1,NB,NI:VA;1),, +94812;,, N 06Che !\n PAR TC(FCC_A1,NB,NI:VA;0),, -1200;,, N 96Bol !\n PAR TC(FCC_A1,NB,NI:VA;1),, +760;,, N 96Bol !\n$\n PAR L(A1_FCC,NB,NI:VA;0),, -36499-15.24689*T;,, N 06Che !\n PAR L(A1_FCC,NB,NI:VA;1),, +94812;,, N 06Che !\n PAR TC(A1_FCC,NB,NI:VA;0),, -1200;,, N 96Bol !\n PAR TC(A1_FCC,NB,NI:VA;1),, +760;,, N 96Bol !\n$\n PAR L(BCC_A2,NB,NI:VA;0),, -22463+4.89296*T;,, N 06Che !\n PAR L(A2_BCC,NB,NI:VA;0),, -22463+4.89296*T;,, N 06Che !\n$\n PAR G(MU_D85,NB:NB:NB:NI),, +7*GHSERNB+6*GHSERNI\n -285506;,, N 06Che !\n PAR G(MU_D85,NB:NB:NI:NB),, +11*GHSERNB+2*GHSERNI\n +517348;,, N 06Che !\n PAR G(MU_D85,NB:NB:NI:NI),, +5*GHSERNB+8*GHSERNI\n +166842;,, N 06Che !\n PAR G(MU_D85,NI:NB:NB:NB),, +12*GHSERNB+GHSERNI+269698;,, N 06Che !\n PAR G(MU_D85,NI:NB:NB:NI),, +6*GHSERNB+7*GHSERNI\n -80808;,, N 06Che !\n PAR G(MU_D85,NI:NB:NI:NB),, +10*GHSERNB+3*GHSERNI\n +722046;,, N 06Che !\n PAR G(MU_D85,NI:NB:NI:NI),, +4*GHSERNB+9*GHSERNI\n +371540;,, N 06Che !\n PAR L(MU_D85,NB,NI:NB:NB:NB;0),, -286806;,, N 06Che !\n PAR L(MU_D85,NB,NI:NB:NB:NI;0),, -286806;,, N 06Che !\n PAR L(MU_D85,NB,NI:NB:NI:NB;0),, -286806;,, N 06Che !\n PAR L(MU_D85,NB,NI:NB:NI:NI;0),, -286806;,, N 06Che !\n PAR L(MU_D85,NB:NB:NB,NI:NB;0),, -545207;,, N 06Che !\n PAR L(MU_D85,NB:NB:NB,NI:NI;0),, -545207;,, N 06Che !\n PAR L(MU_D85,NI:NB:NB,NI:NB;0),, -545207;,, N 06Che !\n PAR L(MU_D85,NI:NB:NB,NI:NI;0),, -545207;,, N 06Che !\n PAR L(MU_D85,NB:NB:NB:NB,NI;0),, -50000;,, N 17Hal7 !\n PAR L(MU_D85,NB:NB:NI:NB,NI;0),, -50000;,, N 17Hal7 !\n PAR L(MU_D85,NI:NB:NB:NB,NI;0),, -50000;,, N 17Hal7 !\n PAR L(MU_D85,NI:NB:NI:NB,NI;0),, -50000;,, N 17Hal7 !\n$\n PAR G(NBNI3_D0A,NB:NI),, +GHSERNB+3*GHSERNI\n -123184+5.8664*T;,, N 06Che !\n PAR G(NBNI3_D0A,NI:NB),, +GHSERNI+3*GHSERNB\n +163184-5.8664*T;,, N 06Che !\n PAR L(NBNI3_D0A,NB,NI:NB;0),, -2480;,, N 06Che !\n PAR L(NBNI3_D0A,NB,NI:NI;0),, -2480;,, N 06Che !\n PAR L(NBNI3_D0A,NB:NB,NI;0),, +64712;,, N 06Che !\n PAR L(NBNI3_D0A,NI:NB,NI;0),, +64712;,, N 06Che !\n$\n PAR G(NBNI8,NB:NI),, +GHSERNB+8*GHSERNI\n -128556+4.54104*T;,, N 06Che !\n$\n$ Metastable\n$\n PAR L(HCP_A3,NB,NI:VA;0),, -36499-15.24689*T;,, N Same !\n PAR L(HCP_A3,NB,NI:VA;1),, +94812;,, N Same !\n$\n PAR G(C14_LAVES,NB:NI),, +2*GHSERNB+GHSERNI+51980;,, N Lin !\n PAR G(C14_LAVES,NI:NB),, +2*GHSERNI+GHSERNB;,, N Lin !\n$\n PAR G(SIGMA_D8B,NI:NB:NB),, +10*GHSERNI+20*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,NI:NB:NI),, +10*GHSERNI+4*GHSERNB\n +16*GBCCNI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-Si\n$\n$ T. Geng, C. Li, J. Bao, X. Zhao, Z. Du, C. Guo,\n$ Intermetallics, 17, 343-57(2009).\n$\n$ Checked against paper. Checked at 6000K.\n$\n$ Parameters are very similar to those of 02Fer.\n$\n PAR L(LIQUID,NB,SI;0),, -199000;,, N 09Gen !\n PAR L(LIQUID,NB,SI;1),, -18800;,, N 09Gen !\n PAR L(LIQUID,NB,SI;2),, +50000;,, N 09Gen !\n$\n PAR L(BCC_A2,NB,SI:VA;0),, -151178;,, N 09Gen !\n PAR L(BCC_A2,NB,SI:VA;1),, -15915;,, N 09Gen !\n PAR L(BCC_A2,NB,SI:VA;2),, +40000;,, N 09Gen !\n$\n PAR L(A2_BCC,NB,SI:VA;0),, -151178;,, N 09Gen !\n PAR L(A2_BCC,NB,SI:VA;1),, -15915;,, N 09Gen !\n PAR L(A2_BCC,NB,SI:VA;2),, +40000;,, N 09Gen !\n$\n PAR G(NB3SI,NB:SI),, +3*GHSERNB+GHSERSI\n -133428-25.8*T;,, N 09Gen !\n$\n PAR G(NB5SI3_D8L,NB:SI),, +5*GHSERNB+3*GHSERSI\n -504010.8-23.2*T;,, N 09Gen !\n PAR L(NB5SI3_D8L,NB,SI:SI;0),, -97808;,, N 09Gen !\n$\n PAR G(NB5SI3_D8M,NB:NB:SI),, +5*GHSERNB+3*GHSERSI\n -405092-68*T;,, N 09Gen !\n PAR G(NB5SI3_D8M,NB:SI:SI),, +4*GHSERNB+4*GHSERSI\n -146496-122.2688*T;,, N 09Gen !\n PAR L(NB5SI3_D8M,NB:NB,SI:SI;0),, -194544;,, N 09Gen !\n$\n PAR G(NBSI2_C40,NB:SI),, +GHSERNB+2*GHSERSI\n -153600-15*T;,, N 09Gen !\n PAR L(NBSI2_C40,NB,SI:SI;0),, +38757+12.7986*T;,, N 09Gen !\n$\n$ Metastable\n$\n PAR L(FCC_A1,NB,SI:VA;0),, -151178;,, N Same !\n PAR L(FCC_A1,NB,SI:VA;1),, -15915;,, N Same !\n PAR L(FCC_A1,NB,SI:VA;2),, +40000;,, N Same !\n$\n PAR L(A1_FCC,NB,SI:VA;0),, -151178;,, N Same !\n PAR L(A1_FCC,NB,SI:VA;1),, -15915;,, N Same !\n PAR L(A1_FCC,NB,SI:VA;2),, +40000;,, N Same !\n$\n PAR L(HCP_A3,NB,SI:VA;0),, -151178;,, N Same !\n PAR L(HCP_A3,NB,SI:VA;1),, -15915;,, N Same !\n PAR L(HCP_A3,NB,SI:VA;2),, +40000;,, N Same !\n$\n PAR G(C14_LAVES,NB:SI),, +2*GHSERNB+GHSERSI+121144;,, N 17Jac !\n$PAR G(C14_LAVES,SI:NB),, +2*GHSERSI+GHSERNB\n$ +3400+35*T;,, N 17Jac !\n PAR G(C14_LAVES,SI:NB),, +2*GHSERSI+GHSERNB-18510;,, N 16Jac2 !\n$\n PAR G(MU_D85,NB:NB:NB:SI),, +7*GHSERNB+6*GHSERSI\n -424026;,, N 16Jac2 !\n PAR G(MU_D85,NB:NB:SI:NB),, +11*GHSERNB+2*GHSERSI\n +112710;,, N 16Jac2 !\n PAR G(MU_D85,NB:NB:SI:SI),, +5*GHSERNB+8*GHSERSI\n -214240;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:NB:NB),, +12*GHSERNB+GHSERSI\n +61326;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:NB:SI),, +6*GHSERNB+7*GHSERSI\n -290703;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:SI:NB),, +10*GHSERNB+3*GHSERSI\n -16640;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:SI:SI),, +4*GHSERNB+9*GHSERSI\n -27040;,, N 16Jac2 !\n$ ------------------------------------------------------------------------------\n$ Nb-Ti\n$\n$ From Y. Zhang et al. 2001 (Included in LB Vol. 4)\n$\n$ Y. Zhang, H. Liu, Z. Jin, Calphad, 25, 305-17(2001).\n$\n$ Checked against LB. Checked at 6000K.\n$\n$ Original dataset includes the metastable (at normal pressure) omega phase.\n$\n PAR L(LIQUID,NB,TI;0),, +7406.1;,, N 01Zha !\n$\n PAR L(BCC_A2,NB,TI:VA;0),, +13045.3;,, N 01Zha !\n PAR L(A2_BCC,NB,TI:VA;0),, +13045.3;,, N 01Zha !\n$\n PAR L(HCP_A3,NB,TI:VA;0),, +11742.4;,, N 01Zha !\n$\n$PAR L(OMEGA_C32,NB,TI;0),, -3775.9;,, N 01Zha !\n$\n$ Metastable\n$\n PAR L(FCC_A1,NB,TI:VA;0),, +11742.4;,, N Same !\n PAR L(A1_FCC,NB,TI:VA;0),, +11742.4;,, N Same !\n$\n PAR G(C14_LAVES,NB:TI),, +2*GHSERNB+GHSERTI+48080;,, N Lin !\n PAR G(C14_LAVES,TI:NB),, +2*GHSERTI+GHSERNB+46540;,, N Lin !\n$\n PAR G(MU_D85,NB:NB:TI:NB),, +7*GFCCNB+4*GHSERNB\n +2*GBCCTI;,, N Lin !\n PAR G(MU_D85,NB:TI:NB:NB),, +7*GFCCNB+4*GBCCTI\n +2*GHSERNB;,, N Lin !\n PAR G(MU_D85,NB:TI:TI:NB),, +7*GFCCNB+6*GBCCTI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-V\n$\n$ From K.C. Hari Kumar et al. 1994 (Included in LB Vol. 4)\n$\n$ K.C. Hari Kumar, P. Wollants, L. Delaey, Calphad, 18, 71-79(1994).\n$\n$ Checked against paper and LB. Checked at 6000K.\n$\n PAR L(LIQUID,NB,V;0),, -1875;,, N 94Har !\n$\n PAR L(BCC_A2,NB,V:VA;0),, +9080;,, N 94Har !\n PAR L(A2_BCC,NB,V:VA;0),, +9080;,, N 94Har !\n$\n$ Metastable\n$\n PAR L(FCC_A1,NB,V:VA;0),, +9080;,, N Same !\n PAR L(A1_FCC,NB,V:VA;0),, +9080;,, N Same !\n$\n PAR L(HCP_A3,NB,V:VA;0),, +9080;,, N 94Har !\n$\n PAR G(C14_LAVES,NB:V),, +2*GHSERNB+GHSERVV+147190;,, N 13Khv2 !\n PAR G(C14_LAVES,V:NB),, +2*GHSERVV+GHSERNB\n +29427-17.627*T;,, N 13Khv2 !\n$\n PAR G(MU_D85,NB:NB:NB:V),, +7*GHSERNB+6*GHSERVV\n +103339;,, N 13Khv2 !\n PAR G(MU_D85,NB:NB:V:NB),, +11*GHSERNB+2*GHSERVV\n +438296;,, N 13Khv2 !\n PAR G(MU_D85,NB:NB:V:V),, +5*GHSERNB+8*GHSERVV\n +157578;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:NB:NB),, +12*GHSERNB+GHSERVV\n +395871;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:NB:V),, +6*GHSERNB+7*GHSERVV\n +834518;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:V:NB),, +10*GHSERNB+3*GHSERVV\n +502985;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:V:V),, +4*GHSERNB+9*GHSERVV\n +154133;,, N 13Khv2 !\n$\n PAR G(SIGMA_D8B,V:NB:NB),, +20*GHSERNB+10*GHSERVV\n +830734;,, N 13Khv2 !\n PAR G(SIGMA_D8B,V:NB:V),, +4*GHSERNB+26*GHSERVV\n +313770;,, N 13Khv2 !\n PAR G(SIGMA_D8B,V:V:NB),, +14*GHSERVV+16*GHSERNB\n +812161;,, N 13Khv2 !\n$ ------------------------------------------------------------------------------\n$ Ni-C\n$\n$ B. Hallstedt, unpublished, 2006\n$\n$ Checked at 6000 K.\n$\n$ Liquid interaction adjusted to exp. data from Oden and Gokcen 1997.\n$\n$ The parameter G(BCC_A2,NI:C) was set temperature independent to\n$ avoid inverse stability of bcc (equal to 87Gab at about 1273K).\n$\n PAR L(LIQUID,C,NI;0),, -93450+24*T;,, N 06Hal2 !\n$\n PAR G(FCC_A1,NI:C),, +GHSERNI+GHSERCC\n +62000-7.6*T;,, N 92Fer !\n PAR TC(FCC_A1,NI:C),, 633.00;,, N 87Gab !\n PAR BMAG(FCC_A1,NI:C),, 0.52;,, N 87Gab !\n PAR L(FCC_A1,NI:C,VA;0),, -14902+7.5*T;,, N 92Lee1 !\n$\n PAR G(A1_FCC,NI:C),, +GHSERNI+GHSERCC\n +62000-7.6*T;,, N 92Fer !\n PAR TC(A1_FCC,NI:C),, 633.00;,, N 87Gab !\n PAR BMAG(A1_FCC,NI:C),, 0.52;,, N 87Gab !\n PAR L(A1_FCC,NI:C,VA;0),, -14902+7.5*T;,, N 92Lee1 !\n$\n$ Metastable\n$\n PAR G(BCC_A2,NI:C),, +GHSERNI+3*GHSERCC\n +270000;,, N 06Hal2 !\n PAR TC(BCC_A2,NI:C),, 575.00;,, N 87Gab !\n PAR BMAG(BCC_A2,NI:C),, 0.85;,, N 87Gab !\n$\n PAR G(A2_BCC,NI:C),, +GHSERNI+3*GHSERCC\n +270000;,, N 06Hal2 !\n PAR TC(A2_BCC,NI:C),, 575.00;,, N 87Gab !\n PAR BMAG(A2_BCC,NI:C),, 0.85;,, N 87Gab !\n$\n PAR G(HCP_A3,NI:C),, +GHSERNI+0.5*GHSERCC\n +34796+2.665*T;,, N 88Fer3 !\n PAR TC(HCP_A3,NI:C),, 633.00;,, N 88Fer3 !\n PAR BMAG(HCP_A3,NI:C),, 0.52;,, N 88Fer3 !\n$\n PAR G(CEMENTITE_D011,NI:C),, +3*GHSERNI+GHSERCC\n +34700-20*T;,, N 87Gab !\n PAR G(M7C3_D101,NI:C),, +7*GHSERNI+3*GHSERCC\n +198000-37*T;,, N 06Hal3 !\n PAR G(M23C6_D84,NI:NI:C),, +GNI23C6;,, N 06Hal3 !\n$\n FUNCTION GNI23C6 298.15 +23*GHSERNI+6*GHSERCC+350000-85*T; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Ni-N\n$\n$ From A. Fernandez Guillermet and K. Frisk 1991 (included in LB Vol. 4)\n$\n$ A. Fernandez Guillermet, K. Frisk, Int. J. Thermophys., 12, 417-31(1991).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ In LB this dataset is incorrectly attributed to 91Fri2.\n$\n PAR L(LIQUID,N,NI;0),, +14981;,, N 91Fer1 !\n$\n PAR G(FCC_A1,NI:N),, +GHSERNI+GHSERNN\n +38680+143.09*T-10.9*T*LN(T)+0.00438*T**2;,, N 91Fer1 !\n$\n PAR G(A1_FCC,NI:N),, +GHSERNI+GHSERNN\n +38680+143.09*T-10.9*T*LN(T)+0.00438*T**2;,, N 91Fer1 !\n$\n PAR G(HCP_A3,NI:N),, +GHSERNI+0.5*GHSERNN\n -4409.6+72.93*T-7.36*T*LN(T)+0.00614*T**2;,, N 91Fer1 !\n$\n$ metastable\n$\n PAR G(BCC_A2,NI:N),, +GHSERNI+3*GHSERNN\n +200000+200*T;,, N 91Fri2 !\n PAR TC(BCC_A2,NI:N),, +575;,, N 91Fri2 !\n PAR BMAG(BCC_A2,NI:N),, +0.85;,, N 91Fri2 !\n$\n PAR G(A2_BCC,NI:N),, +GHSERNI+3*GHSERNN\n +200000+200*T;,, N 91Fri2 !\n PAR TC(A2_BCC,NI:N),, +575;,, N 91Fri2 !\n PAR BMAG(A2_BCC,NI:N),, +0.85;,, N 91Fri2 !\n$\n PAR G(FE4N_L1,NI:N),, +4*GHSERNI+GHSERNN\n -5393+142.97*T-15.65*T*LN(T)+0.0154*T**2;,, N 91Fer1 !\n$ ------------------------------------------------------------------------------\n$ Ni-Si\n$\n$ Y. Du, J.C. Schuster, Metall. Mater. Trans. A, 30A, 2409-18(1999).\n$\n$ Checked against paper, checked at 6000 K.\n$\n$ There two! inverse miscibility gaps; one at x(Si)=0.35, T>5600 K,\n$ another at x(Si)=0.92, T>2900\n$\n$ Misprint in paper: their L(LIQUID,NI,SI;2) is L(LIQUID,NI,SI;3)\n$\n$ There are up to 3 K differences in invariant equilibria involving\n$ Ni2Si-theta.\n$\n$ The L12_FCC model cannot be converted to FCC_4SL without changing parameter\n$ values. With the current parameters L10 becomes a stable phase. If the\n$ parameters from 12Yua for NiSi_L10 and NiSi3_L12 are used Ni3Si_L12 is far\n$ too stable. The 99Du parameters were adjusted. There is then a slight change\n$ in the Ni3Si_L12 phase field.\n$\n PAR L(LIQUID,NI,SI;0),, -205176.85+33.40446*T;,, N 99Du !\n PAR L(LIQUID,NI,SI;1),, -114240.82+20.34156*T;,, N 99Du !\n PAR L(LIQUID,NI,SI;2),, +ZERO;,, N 99Du !\n PAR L(LIQUID,NI,SI;3),, +116695.857-53.88609*T;,, N 99Du !\n$\n PAR L(FCC_A1,NI,SI:VA;0),, -204564.5+38.99204*T;,, N 99Du !\n PAR L(FCC_A1,NI,SI:VA;1),, -82289.61;,, N 99Du !\n$\n PAR L(A1_FCC,NI,SI:VA;0),, -204564.5+38.99204*T;,, N 99Du !\n PAR L(A1_FCC,NI,SI:VA;1),, -82289.61;,, N 99Du !\n$\n$PAR G(FCC_4SL,NI:NI:NI:SI:VA),, -35712+11.07*T;,, N 12Yua !\n PAR G(FCC_4SL,NI:NI:NI:SI:VA),, -28245+6*T;,, N 17Hal13 !\n PAR G(FCC_4SL,NI:NI:SI:SI:VA),, +7649.4;,, N 12Yua !\n PAR G(FCC_4SL,NI:SI:SI:SI:VA),, +37790.1;,, N 12Yua !\n PAR L(FCC_4SL,NI,SI:*:*:*:VA;1),, -8886.4+3.6585*T;,, N 12Yua !\n PAR L(FCC_4SL,NI,SI:NI,SI:*:*:VA;0),, -25458.8;,, N 12Yua !\n$\n PAR G(NI3SI_M,NI:SI),, +3*GHSERNI+GHSERSI\n -144506.1-9.63044*T;,, N 99Du !\n PAR G(NI3SI_H,NI:SI),, +3*GHSERNI+GHSERSI\n -143815.8-10.12344*T;,, N 99Du !\n PAR G(NI5SI2,NI:SI),, +5*GHSERNI+2*GHSERSI\n -303488.9+2.32414*T;,, N 99Du !\n PAR G(NI2SI_C37,NI:SI),, +2*GHSERNI+GHSERSI\n -128241.1-5.47659*T;,, N 99Du !\n$\n PAR G(NI2SI_THETA,NI:NI:SI),, +2*GHSERNI+GHSERSI\n -124473.6-7.83186*T;,, N 99Du !\n PAR G(NI2SI_THETA,NI:VA:SI),, +GHSERNI+GHSERSI\n -77347.09+1.49818*T;,, N 99Du !\n PAR L(NI2SI_THETA,NI:NI,VA:SI;0),, +17973.42;,, N 99Du !\n$\n PAR G(NI3SI2,NI:SI),, +3*GHSERNI+2*GHSERSI\n -217858.8+3.90115*T;,, N 99Du !\n PAR G(NISI_B31,NI:SI),, +GHSERNI+GHSERSI\n -76423.44-1.84188*T;,, N 99Du !\n PAR G(NISI2_C1,NI:SI),, +GHSERNI+2*GHSERSI\n -94542.19+11.29221*T;,, N 99Du !\n$\n$ metastable\n$\n PAR L(BCC_A2,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same !\n PAR L(BCC_A2,NI,SI:VA;1),, -82289.61;,, N Same !\n$\n PAR L(A2_BCC,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same !\n PAR L(A2_BCC,NI,SI:VA;1),, -82289.61;,, N Same !\n$\n PAR L(HCP_A3,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same !\n PAR L(HCP_A3,NI,SI:VA;1),, -82289.61;,, N Same !\n$\n PAR L(CBCC_A12,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same !\n PAR L(CBCC_A12,NI,SI:VA;1),, -82289.61;,, N Same !\n$\n PAR L(CUB_A13,NI,SI:VA;0),, -204564.5+38.99204*T;,, N Same !\n PAR L(CUB_A13,NI,SI:VA;1),, -82289.61;,, N Same !\n$\n PAR G(C14_LAVES,NI:SI),, +2*GHSERNI+GHSERSI+85260;,, N Lin !\n PAR G(C14_LAVES,SI:NI),, +2*GHSERSI+GHSERNI+113820;,, N Lin !\n$\n PAR G(CR3SI_A15,NI:SI:VA),, +3*GHSERNI+GHSERSI-30000;,, N 00Sch !\n PAR G(M4SI3,NI:SI),, +4*GHSERNI+3*GHSERSI\n -285000+9.93391*T;,, N 00Sch !\n PAR G(MSI_B20,NI:SI),, +GHSERNI+GHSERSI\n -74500+1.2949*T;,, N 00Sch !\n$ ------------------------------------------------------------------------------\n$ Ni-Ti\n$\n$ From P. Bellen et al. 1996 (included in LB Vol. 4)\n$\n$ P. Bellen, K.C. Hari Kumar, P. Wollants, Z. Metallkd., 87, 972-78(1996).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ Fcc and NiTi2 modified by N. Dupin (00Dup and 99Dup2).\n$ Ti removed from the first sublattice of NI3TI_D024.\n$\n$ NI3TI_D024 reappears above 1916 K at x(Ti)=0.097. This covers an inverse\n$ miscibility gap in the liquid with a minimum at 4981 K and x(Ti)=0.41.\n$\n$ The LB/00Dup version of the fcc-Ni solvus is quite different from the paper\n$ at low temperature with a much lower Ti solubility. At high temperature\n$ the differences are minimal. In the LB/00Dup version there is a metastable\n$ miscibility gap in fcc close to Ni with a maximum just below 600 K.\n$ The original fcc is considerably more well behaved.\n$\n PAR L(LIQUID,NI,TI;0),, -153707+34.8594*T;,, N 96Bel !\n PAR L(LIQUID,NI,TI;1),, -81824.8+25.8099*T;,, N 96Bel !\n PAR L(LIQUID,NI,TI;2),, -10.0779*T;,, N 96Bel !\n$\n PAR L(FCC_A1,NI,TI:VA;0),, -125000+22.62*T;,, N 00Dup !\n PAR L(FCC_A1,NI,TI:VA;1),, -84260+5.77*T;,, N 00Dup !\n PAR L(FCC_A1,NI,TI:VA;2),, +95730-46.45*T;,, N 00Dup !\n PAR TC(FCC_A1,NI,TI:VA;0),, -4670;,, N 96Bel !\n$ Original fcc parameters from Bellen below\n$PAR L(FCC_A1,NI,TI:VA;0),, -99290.4+6.21142*T;,, N 96Bel !\n$PAR L(FCC_A1,NI,TI:VA;1),, -59449.5;,, N 96Bel !\n$\n PAR L(A1_FCC,NI,TI:VA;0),, -125000+22.62*T;,, N 00Dup !\n PAR L(A1_FCC,NI,TI:VA;1),, -84260+5.77*T;,, N 00Dup !\n PAR L(A1_FCC,NI,TI:VA;2),, +95730-46.45*T;,, N 00Dup !\n PAR TC(A1_FCC,NI,TI:VA;0),, -4670;,, N 96Bel !\n$\n PAR L(BCC_A2,NI,TI:VA;0),, -97427.4+12.112*T;,, N 96Bel !\n PAR L(BCC_A2,NI,TI:VA;1),, -32315.3;,, N 96Bel !\n$\n PAR L(A2_BCC,NI,TI:VA;0),, -97427.4+12.112*T;,, N 96Bel !\n PAR L(A2_BCC,NI,TI:VA;1),, -32315.3;,, N 96Bel !\n$\n PAR G(B2_BCC,NI:TI:VA;0),, -33193.7+10.284*T;,, N 96Bel !\n PAR G(B2_BCC,TI:NI:VA;0),, -33193.7+10.284*T;,, N 96Bel !\n PAR L(B2_BCC,NI,TI:NI:VA;0),, -55288.8+25.4416*T;,, N 96Bel !\n PAR L(B2_BCC,NI,TI:NI:VA;2),, +6010.11+3.95974*T;,, N 96Bel !\n PAR L(B2_BCC,NI:NI,TI:VA;0),, -55288.8+25.4416*T;,, N 96Bel !\n PAR L(B2_BCC,NI:NI,TI:VA;2),, +6010.11+3.95974*T;,, N 96Bel !\n PAR L(B2_BCC,TI:NI,TI:VA;0),, +60723.7-15.4024*T;,, N 96Bel !\n PAR L(B2_BCC,NI,TI:TI:VA;0),, +60723.7-15.4024*T;,, N 96Bel !\n$\n PAR L(HCP_A3,NI,TI:VA;0),, -20000;,, N 96Bel !\n$\n PAR G(NI3TI_D024,NI:TI),, +0.75*GHCPNI+0.25*GHSERTI\n -39435.7+4.66357*T;,, N 96Bel !\n PAR L(NI3TI_D024,NI:NI,TI;0),, +56040.9-41.6971*T;,, N 96Bel !\n PAR L(NI3TI_D024,NI:NI,TI;1),, +56197.1-38.2252*T;,, N 96Bel !\n$\n PAR G(NITI2,NI:TI),, +3*GNITI2;,, N 96Bel !\n PAR G(NITI2,TI:NI),, +3*GHSERNI+3*GHSERTI+30000\n -3*GNITI2;,, N 99Dup2 !\n PAR L(NITI2,NI,TI:NI;0),, +60000;,, N 99Dup2 !\n PAR L(NITI2,NI,TI:TI;0),, +60000;,, N 99Dup2 !\n PAR L(NITI2,NI:NI,TI;0),, +60000;,, N 99Dup2 !\n PAR L(NITI2,TI:NI,TI;0),, +60000;,, N 99Dup2 !\n$\n$ metastable\n$\n PAR G(C14_LAVES,NI:TI),, +2*GHSERNI+GHSERTI;,, N Lin !\n PAR G(C14_LAVES,TI:NI),, +2*GHSERTI+GHSERNI+48900;,, N Lin !\n$\n PAR G(MU_D85,NI:TI:NI:NI),, +7*GHSERNI+4*GBCCTI\n +2*GBCCNI;,, N Lin !\n PAR G(MU_D85,NI:TI:TI:NI),, +7*GHSERNI+6*GBCCTI;,, N Lin !\n$\n PAR G(SIGMA_D8B,NI:TI:NI),, +10*GHSERNI+4*GBCCTI\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:TI),, +10*GHSERNI+20*GBCCTI;,, N Lin !\n$\n FUNCTION GNITI2 298.15 +0.333333*GHSERNI+0.666667*GHSERTI\n -27514.2+2.85345*T;\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Ni-V\n$\n$ From J. Korb and K. Hack 1998 (included in LB Vol. 4)\n$\n$ J. Korb, K. Hack, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST. Checked at 6000 K.\n$\n$ The model change for the sigma phase in LB leads to quite large shifts of\n$ the phase boundaries, in particular on the V-rich side.\n$ Invariant equilibria listed in COST are reproduced when SIGMA_OLD is used.\n$\n$ NI3V_D022 is not stable below 386 K.\n$\n PAR L(LIQUID,NI,V;0),, -51927+14.99*T;,, N 98Kor !\n$\n PAR L(BCC_A2,NI,V:VA;0),, -30513.8+12.6138*T;,, N 98Kor !\n PAR L(A2_BCC,NI,V:VA;0),, -30513.8+12.6138*T;,, N 98Kor !\n$\n PAR L(FCC_A1,NI,V:VA;0),, -36365.6+3.75677*T;,, N 98Kor !\n PAR L(FCC_A1,NI,V:VA;1),, +11860.7-9.0302*T;,, N 98Kor !\n PAR L(FCC_A1,NI,V:VA;2),, -10647.5+7.00954*T;,, N 98Kor !\n$\n PAR L(A1_FCC,NI,V:VA;0),, -36365.6+3.75677*T;,, N 98Kor !\n PAR L(A1_FCC,NI,V:VA;1),, +11860.7-9.0302*T;,, N 98Kor !\n PAR L(A1_FCC,NI,V:VA;2),, -10647.5+7.00954*T;,, N 98Kor !\n$\n PAR G(NI3V_D022,NI:V),, -45524.96+529.01852*T\n -99.74166*T*LOG(T)-0.00824*T**2-13753.332*T**(-1);,, N 98Kor !\n PAR G(NI2V1,NI:V),, -38032.065+337.2614*T\n -64.6973*T*LOG(T)-0.01512*T**2-13.75326*T**(-1);,, N 98Kor !\n PAR G(NI2V7_A15,NI:V),, -190634.14+1333.90548*T\n -233.55668*T*LOG(T)-0.00482*T**2-5.196308E-06*T**3\n +844557.21*T**(-1);,, N 98Kor !\n$\n PAR G(SIGMA_D8B,NI:V:NI),, +26*GHSERNI+4*GHSERVV\n +79717-127.17*T;,, N 02Sun !\n PAR G(SIGMA_D8B,NI:V:V),, +10*GHSERNI+20*GHSERVV\n -450217+137.12*T;,, N 02Sun !\n PAR G(SIGMA_D8B,V:V:NI),, +16*GHSERNI+14*GHSERVV\n +100000;,, N 02Sun !\n$\n$ metastable\n$\n PAR L(HCP_A3,NI,V:VA;0),, -36365.6+3.75677*T;,, N Same !\n PAR L(HCP_A3,NI,V:VA;1),, +11860.7-9.0302*T;,, N Same !\n PAR L(HCP_A3,NI,V:VA;2),, -10647.5+7.00954*T;,, N Same !\n$\n PAR G(C14_LAVES,NI:V),, +2*GHSERNI+GHSERVV+50130;,, N Lin !\n PAR G(C14_LAVES,V:NI),, +2*GHSERVV+GHSERNI+43560;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Si-C\n$\n$ From J. Lacaze and B. Sundman 1991 (included in SGSOL V4.3)\n$\n$ J. Lacaze, B. Sundman, Metall. Mater. Trans. A, 22A, 2211-23(1991).\n$\n$ Checked against paper. Checked at 6000 K.\n$\n$ In the paper reference is given to unpublished work by I. Ansara, 1989.\n$\n$ If BCC_A2 is included, it is stable above 3900 K at about SiC composition.\n$\n$ No phase diagram is shown in the paper.\n$\n$ CBCC_A12 and CUB_A13 parameters should probably be removed.\n$\n PAR L(LIQUID,C,SI;0),, -133000+30.97*T;,, N 91Lac !\n$\n PAR L(DIAMOND_A4,C,SI;0),, +ZERO;,, N 91Lac !\n$\n PAR G(SIC_B3,SI:C),, +GSIC;,, N 91Lac !\n$\n$ Metastable\n$\n PAR G(FCC_A1,SI:C),, +GHSERSI+GHSERCC\n -20510+38.7*T;,, N 91Lac !\n PAR L(FCC_A1,SI:C,VA;0),, +ZERO;,, N 91Lac !\n$\n PAR G(A1_FCC,SI:C),, +GHSERSI+GHSERCC\n -20510+38.7*T;,, N 91Lac !\n PAR L(A1_FCC,SI:C,VA;0),, +ZERO;,, N 91Lac !\n$\n PAR G(BCC_A2,SI:C),, +GBCCSI+3*GHSERCC\n +322050-75.667*T;,, N 91Lac !\n PAR L(BCC_A2,SI:C,VA;0),, +ZERO;,, N 91Lac !\n$\n PAR G(A2_BCC,SI:C),, +GBCCSI+3*GHSERCC\n +322050-75.667*T;,, N 91Lac !\n PAR L(A2_BCC,SI:C,VA;0),, +ZERO;,, N 91Lac !\n$\n PAR G(HCP_A3,SI:C),, +GHSERSI+0.5*GHSERCC\n +UN_ASS;,, N !\n PAR G(CBCC_A12,SI:C),, +1000000+566.0326*T\n -85.955678*T*LN(T)-0.007814909*T**2+3.7239E-07*T**3\n +1688653*T**(-1);,, N 89NPL !\n PAR G(CUB_A13,SI:C),, +1000000+566.0326*T\n -85.955678*T*LN(T)-0.007814909*T**2+3.7239E-07*T**3\n +1688653*T**(-1);,, N 89NPL !\n PAR G(CR3SI_A15,SI:SI:C),, +4*GHSERSI+3*GHSERCC;,, N 00Du2 !\n$\n FUNCTION GSIC 298.15 -85572.264+173.2005*T-25.856*T*LN(T)\n -0.02107*T**2+3.2153E-06*T**3+438415*T**(-1); \n 700.00 Y -95145.902+300.346*T-45.093*T*LN(T)\n -0.00367*T**2+2.2E-07*T**3+1341065*T**(-1);\n 2100.00 Y -105007.971+360.309*T-53.073*T*LN(T)\n -7.4525E-04*T**2+1.73167E-08*T**3+3693345*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Si-N\n$\n$ From X. Ma et al. 2003 (included in LB Vol. 5)\n$\n$ X. Ma, C. Li, F. Wang, W. Zhang, Calphad, 27, 383-88(2003).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ Alpha- and beta-Si3N4 are assumed to have the same Gibbs energy.\n$\n PAR L(LIQUID,N,SI;0),, -87631.311+22.359*T;,, N 03Ma !\n$\n PAR G(SI3N4,SI:N),, -788513.009+733.225*T\n -121.79*T*LN(T)-0.02065*T**2+6.9938E-07*T**3\n +1666886.4*T**(-1);,, N 03Ma !\n$\n PAR G(GAS,SIN),, +F12915T+RTLNP;,, N 00SUB !\n PAR G(GAS,SI2N),, +F12921T+RTLNP;,, N 00SUB !\n$\n$ SiN(g)\n FUNCTION F12915T 298.15 +373690.147-126.773849*T-11.48813*T*LN(T)\n -0.02760032*T**2+4.14460833E-06*T**3-201121*T**(-1);\n 900.00 Y +345651.105+184.200439*T-57.02462*T*LN(T)\n +0.005212695*T**2-2.80815333E-07*T**3+3030993*T**(-1);\n 3000.00 Y +401766.122-30.0990737*T-30.3733*T*LN(T)\n -6.13755E-04*T**2-3.30314167E-08*T**3-19797170*T**(-1);\n 5800.00 Y +397720.711-70.2315921*T-24.95975*T*LN(T)\n -0.0020519915*T**2+1.71382167E-08*T**3-543722*T**(-1);\n 6000.00 N !\n$ Si2N(g)\n FUNCTION F12921T 298.15 +367551.162+68.9613567*T-47.11477*T*LN(T)\n -0.01410916*T**2+2.51869833E-06*T**3+190945.2*T**(-1);\n 800.00 Y +360363.442+166.768467*T-61.99726*T*LN(T)\n -8.395595E-05*T**2+2.98128167E-09*T**3+863651*T**(-1);\n 3400.00 Y +358195.746+179.731995*T-63.68676*T*LN(T)\n +4.0735635E-04*T**2-2.15632833E-08*T**3+1158715*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Si-Ti\n$\n$ From H.J. Seifert et al. 1996 (Included in LB Vol. 4)\n$\n$ H.J. Seifert, H.L. Lukas, G. Petzow, Z. Metallkd., 87, 2-13(1996).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ In the paper there is also a version with stoichiometric Si3Ti5 and\n$ another with ionic liquid. The ionic liquid seems to yield a good\n$ description, but I could not interpret the parameters presented in the paper.\n$\n PAR L(LIQUID,SI,TI;0),, -255852.17+21.87411*T;,, N 96Sei !\n PAR L(LIQUID,SI,TI;1),, +25025.35-2.00203*T;,, N 96Sei !\n PAR L(LIQUID,SI,TI;2),, +83940.65-6.71526*T;,, N 96Sei !\n$\n PAR L(BCC_A2,SI,TI:VA;0),, -275629.1+42.5094*T;,, N 96Sei !\n PAR L(BCC_A2,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei !\n PAR L(BCC_A2,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei !\n$\n PAR L(A2_BCC,SI,TI:VA;0),, -275629.1+42.5094*T;,, N 96Sei !\n PAR L(A2_BCC,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei !\n PAR L(A2_BCC,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei !\n$\n PAR L(HCP_A3,SI,TI:VA;0),, -302731.04+69.08469*T;,, N 96Sei !\n PAR L(HCP_A3,SI,TI:VA;1),, +25025.35-2.00203*T;,, N 96Sei !\n PAR L(HCP_A3,SI,TI:VA;2),, +83940.65-6.71526*T;,, N 96Sei !\n$\n PAR G(SI2TI_C54,SI:TI),, +GHSERTI+2*GHSERSI\n -175038.5+4.54797*T;,, N 96Sei !\n PAR G(SITI_B27,SI:TI),, +GHSERSI+GHSERTI\n -155061.7+7.6345*T;,, N 96Sei !\n PAR G(SI4TI5,SI:TI),, +4*GHSERSI+5*GHSERTI\n -711000+22.37355*T;,, N 96Sei !\n$\n PAR G(SI3TI5_D88,SI:SI:TI),, +5*GHSERSI+3*GHSERTI\n -206191.45+16.49531*T;,, N 96Sei !\n PAR G(SI3TI5_D88,SI:TI:TI),, +2*GHSERSI+6*GHSERTI\n +417372.85+33.81017*T;,, N 96Sei !\n PAR G(SI3TI5_D88,TI:SI:TI),, +5*GHSERTI+3*GHSERSI\n -583564.31+2.68514*T;,, N 96Sei !\n PAR L(SI3TI5_D88,SI,TI:SI:TI;0),, -500000+40*T;,, N 96Sei !\n PAR L(SI3TI5_D88,SI,TI:TI:TI;0),, -500000+40*T;,, N 96Sei !\n PAR L(SI3TI5_D88,SI:SI,TI:TI;0),, +43024.29-3.44194*T;,, N 96Sei !\n PAR L(SI3TI5_D88,TI:SI,TI:TI;0),, +43024.29-3.44194*T;,, N 96Sei !\n$\n PAR G(SITI3,SI:TI),, +GHSERSI+3*GHSERTI\n -200000+3.19924*T;,, N 96Sei !\n$\n$ Metastable\n$\n PAR L(FCC_A1,SI,TI:VA;0),, -302731.04+69.08469*T;,, N Same !\n PAR L(FCC_A1,SI,TI:VA;1),, +25025.35-2.00203*T;,, N Same !\n PAR L(FCC_A1,SI,TI:VA;2),, +83940.65-6.71526*T;,, N Same !\n$\n PAR L(A1_FCC,SI,TI:VA;0),, -302731.04+69.08469*T;,, N Same !\n PAR L(A1_FCC,SI,TI:VA;1),, +25025.35-2.00203*T;,, N Same !\n PAR L(A1_FCC,SI,TI:VA;2),, +83940.65-6.71526*T;,, N Same !\n$\n PAR G(C14_LAVES,SI:TI),, +2*GHSERSI+GHSERTI;,, N Lin !\n PAR G(C14_LAVES,TI:SI),, +2*GHSERTI+GHSERSI+77460;,, N Lin !\n$\n PAR G(MU_D85,SI:TI:SI:SI),, +7*GFCCSI+4*GBCCTI\n +2*GBCCSI;,, N Lin !\n PAR G(MU_D85,SI:TI:TI:SI),, +7*GFCCSI+6*GBCCTI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Si-V\n$\n$ From M.H. Rand and N. Saunders 1998 (Included in LB Vol. 4)\n$\n$ M.H. Rand, N. Saunders, COST 507, Final report round 2, 1998.\n$\n$ Checked against LB and COST. Checked at 6000K.\n$\n PAR L(LIQUID,SI,V;0),, -180900+40*T;,, N 98Ran !\n PAR L(LIQUID,SI,V;1),, +37000;,, N 98Ran !\n PAR L(LIQUID,SI,V;2),, +20000;,, N 98Ran !\n$\n PAR L(BCC_A2,SI,V:VA;0),, -164505+30.1*T;,, N 98Ran !\n PAR L(BCC_A2,SI,V:VA;1),, +37000;,, N 98Ran !\n PAR L(BCC_A2,SI,V:VA;2),, +20000;,, N 98Ran !\n$\n PAR L(A2_BCC,SI,V:VA;0),, -164505+30.1*T;,, N 98Ran !\n PAR L(A2_BCC,SI,V:VA;1),, +37000;,, N 98Ran !\n PAR L(A2_BCC,SI,V:VA;2),, +20000;,, N 98Ran !\n$\n PAR G(SI2V_C40,SI:V),, -143160+401.98*T-67.8*T*LN(T)\n -0.0075*T**2+330000*T**(-1);,, N 98Ran !\n PAR G(SI3V5_D8M,SI:V),, -504000+1259.03*T\n -211.04*T*LN(T)-0.00748*T**2+1680000*T**(-1);,, N 98Ran !\n PAR G(SI5V6,SI:V),, -641675+1665.98*T\n -280.28*T*LN(T)-0.013915*T**2+2310000*T**(-1);,, N 98Ran !\n$\n PAR G(SIV3_A15,V:SI),, +3*GHSERSI+GHSERVV\n +166000-60*T;,, N 98Ran !\n PAR G(SIV3_A15,SI:V),, -216397+516.532*T\n -90.44*T*LN(T)-0.008346*T**2+358000*T**(-1);,, N 98Ran !\n PAR L(SIV3_A15,SI,V:SI;0),, +9794.5-21.8*T;,, N 98Ran !\n PAR L(SIV3_A15,SI,V:V;0),, +9794.5-21.8*T;,, N 98Ran !\n PAR L(SIV3_A15,SI:SI,V;0),, -150000;,, N 98Ran !\n PAR L(SIV3_A15,V:SI,V;0),, +ZERO;,, N 98Ran !\n$\n$ Metastable\n$\n PAR L(FCC_A1,SI,V:VA;0),, -164505+30.1*T;,, N Same !\n PAR L(FCC_A1,SI,V:VA;1),, +37000;,, N Same !\n PAR L(FCC_A1,SI,V:VA;2),, +20000;,, N Same !\n$\n PAR L(A1_FCC,SI,V:VA;0),, -164505+30.1*T;,, N Same !\n PAR L(A1_FCC,SI,V:VA;1),, +37000;,, N Same !\n PAR L(A1_FCC,SI,V:VA;2),, +20000;,, N Same !\n$\n PAR L(HCP_A3,SI,V:VA;0),, -164505+30.1*T;,, N Same !\n PAR L(HCP_A3,SI,V:VA;1),, +37000;,, N Same !\n PAR L(HCP_A3,SI,V:VA;2),, +20000;,, N Same !\n$\n PAR G(C14_LAVES,SI:V),, +2*GHSERSI+GHSERVV+107250;,, N Lin !\n PAR G(C14_LAVES,V:SI),, +2*GHSERVV+GHSERSI+72120;,, N Lin !\n$\n PAR G(SIGMA_D8B,V:V:SI),, +10*GFCCVV+4*GHSERVV\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Ti-C\n$\n$ From L.F.S. Dumitrescu et al. 1999 (Included in LB Vol. 2)\n$\n$ L.F.S. Dumitrescu, M. Hillert, B. Sundman, Z. Metallkd., 90, 534-41(1999).\n$\n$ Checked against LB and paper. Checked at 6000K.\n$\n PAR L(LIQUID,C,TI;0),, -125409-44.4*T;,, N 99Dum1 !\n$\n PAR G(FCC_A1,TI:C),, +GTIC;,, N 99Dum1 !\n PAR L(FCC_A1,TI:C,VA;0),, -52702-4.6*T;,, N 99Dum1 !\n PAR L(FCC_A1,TI:C,VA;1),, -121367+31.5*T;,, N 99Dum1 !\n$\n PAR G(A1_FCC,TI:C),, +GTIC;,, N 99Dum1 !\n PAR L(A1_FCC,TI:C,VA;0),, -52702-4.6*T;,, N 99Dum1 !\n PAR L(A1_FCC,TI:C,VA;1),, -121367+31.5*T;,, N 99Dum1 !\n$\n PAR G(BCC_A2,TI:C),, +GTIC+2*GHSERCC+600000;,, N 99Dum1 !\n PAR L(BCC_A2,TI:C,VA;0),, -881180+45.5*T;,, N 99Dum1 !\n$\n PAR G(A2_BCC,TI:C),, +GTIC+2*GHSERCC+600000;,, N 99Dum1 !\n PAR L(A2_BCC,TI:C,VA;0),, -881180+45.5*T;,, N 99Dum1 !\n$\n PAR G(HCP_A3,TI:C),, +GHSERTI+0.5*GHSERCC\n -67577-8.6*T;,, N 99Dum1 !\n PAR L(HCP_A3,TI:C,VA;0),, +ZERO;,, N 99Dum1 !\n$\n$ Metastable\n$\n PAR G(MC_ETA,TI:C),, +GHSERTI+GHSERCC-110000;,, N 96Shi !\n PAR G(TI2N_C4,TI:C),, +GHSERTI+GTIC-17349;,, N 99Dum1 !\n$\n FUNCTION GTIC 298.15 -168261.31+293.73187*T-48.0195*T*LN(T)\n -0.00272*T**2+819000*T**(-1)-2.03E+09*T**(-3);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Ti-N\n$\n$ K. Zeng, R. Schmid-Fetzer, Z. Metallkd., 87, 540-54(1996).\n$\n$ Checked against paper. Checked at 6000K.\n$\n PAR L(LIQUID,N,TI;0),, -376354.145;,, N 96Zen !\n PAR L(LIQUID,N,TI;1),, -98242.2945;,, N 96Zen !\n$\n PAR G(FCC_A1,TI:N),, +GTIN;,, N 96Zen !\n PAR L(FCC_A1,TI:N,VA;0),, -42704.41;,, N 96Zen !\n PAR L(FCC_A1,TI:N,VA;1),, -13989.34;,, N 96Zen !\n$\n PAR G(A1_FCC,TI:N),, +GTIN;,, N 96Zen !\n PAR L(A1_FCC,TI:N,VA;0),, -42704.41;,, N 96Zen !\n PAR L(A1_FCC,TI:N,VA;1),, -13989.34;,, N 96Zen !\n$\n PAR G(BCC_A2,TI:N),, +GTIN+2*GHSERNN\n +2604201.62+118.04*T;,, N 96Zen !\n PAR L(BCC_A2,TI:N,VA;0),, -3215338.17;,, N 96Zen !\n$\n PAR G(A2_BCC,TI:N),, +GTIN+2*GHSERNN\n +2604201.62+118.04*T;,, N 96Zen !\n PAR L(A2_BCC,TI:N,VA;0),, -3215338.17;,, N 96Zen !\n$\n PAR G(HCP_A3,TI:N),, +0.5*GHSERTI+0.5*GTIN\n -6046.53-2.653*T;,, N 96Zen !\n PAR L(HCP_A3,TI:N,VA;0),, -13501;,, N 96Zen !\n$\n PAR G(TI2N_C4,TI:N),, +GHSERTI+GTIN\n -67116+26.5395534*T;,, N 96Zen !\n$\n PAR G(TI3N2,TI:N),, +0.42*GHSERTI+0.29*GTIN\n -8190.33982-1.54816366*T;,, N 96Zen !\n$\n PAR G(TI4N3,TI:N),, +0.37*GHSERTI+0.315*GTIN\n -5956.86333-3.27489717*T;,, N 96Zen !\n$\n FUNCTION GTIN 298.15 -357905+330.498*T-52.4587*T*LN(T)\n -9.28E-04*T**2+1.48976561E-08*T**3+871000*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ Ti-V\n$\n$ From G. Ghosh 2002 (Included in LB Vol. 4)\n$\n$ G. Ghosh, J. Phase Equilib., 23, 310-28(2002).\n$\n$ Checked against paper and LB. Checked at 6000K.\n$\n PAR L(LIQUID,TI,V;0),, +368.55;,, N 02Gho !\n PAR L(LIQUID,TI,V;1),, +2838.63;,, N 02Gho !\n$\n PAR L(BCC_A2,TI,V:VA;0),, +6523.17;,, N 02Gho !\n PAR L(BCC_A2,TI,V:VA;1),, +2025.39;,, N 02Gho !\n$\n PAR L(A2_BCC,TI,V:VA;0),, +6523.17;,, N 02Gho !\n PAR L(A2_BCC,TI,V:VA;1),, +2025.39;,, N 02Gho !\n$\n PAR L(HCP_A3,TI,V:VA;0),, +13233;,, N 02Gho !\n$\n$ Metastable\n$\n PAR L(FCC_A1,TI,V:VA;0),, +13233;,, N Same !\n PAR L(A1_FCC,TI,V:VA;0),, +13233;,, N Same !\n$\n PAR G(C14_LAVES,TI:V),, +2*GFCCTI+GHSERVV+42328;,, N Lin !\n PAR G(C14_LAVES,V:TI),, +2*GHSERVV+GHSERTI;,, N Lin !\n$\n PAR G(MU_D85,V:TI:TI:V),, +7*GFCCVV+6*GBCCTI;,, N Lin !\n PAR G(MU_D85,V:TI:V:V),, +7*GFCCVV+4*GBCCTI\n +2*GHSERVV;,, N Lin !\n$\n PAR G(SIGMA_D8B,V:TI:TI),, +10*GFCCVV+20*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:V),, +10*GFCCVV+4*GBCCTI\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,V:V:TI),, +10*GFCCVV+4*GHSERVV\n +16*GBCCTI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ V-C\n$\n$ From W. Huang 1991 (included in LB Vol. 2)\n$\n$ W. Huang, Z. Metallkd., 82, 174-81(1991).\n$\n$ Slight modification of the liquid interaction by A.V. Khvan 2011 to\n$ remove a small miscibility gap.\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ Wrong sign for L(FCC_A1,V:C,VA;1) in the paper.\n$\n$ There is a very small (stable) liquid miscibility gap close to C at 4716\n$ to 4748 K.\n$\n PAR L(LIQUID,C,V;0),, -284196+38.952*T;,, N 91Hua1 !\n PAR L(LIQUID,C,V;1),, +96335-17.775*T;,, N 91Hua1 !\n$PAR L(LIQUID,C,V;2),, +102050;,, N 91Hua1 !\n PAR L(LIQUID,C,V;2),, +101050;,, N 11Khv !\n$\n PAR G(BCC_A2,V:C),, +GHSERVV+3*GHSERCC+108449;,, N 91Hua1 !\n PAR L(BCC_A2,V:C,VA;0),, -297868;,, N 91Hua1 !\n$\n PAR G(A2_BCC,V:C),, +GHSERVV+3*GHSERCC+108449;,, N 91Hua1 !\n PAR L(A2_BCC,V:C,VA;0),, -297868;,, N 91Hua1 !\n$\n PAR G(FCC_A1,V:C),, -117302+262.57*T\n -41.756*T*LN(T)-0.00557101*T**2+590546*T**(-1);,, N 91Hua1 !\n PAR L(FCC_A1,V:C,VA;0),, -74811+10.201*T;,, N 91Hua1 !\n PAR L(FCC_A1,V:C,VA;1),, -30394;,, N 91Hua1 !\n$\n PAR G(A1_FCC,V:C),, -117302+262.57*T\n -41.756*T*LN(T)-0.00557101*T**2+590546*T**(-1);,, N 91Hua1 !\n PAR L(A1_FCC,V:C,VA;0),, -74811+10.201*T;,, N 91Hua1 !\n PAR L(A1_FCC,V:C,VA;1),, -30394;,, N 91Hua1 !\n$\n PAR G(HCP_A3,V:C),, -85473+182.441*T\n -30.551*T*LN(T)-0.00538998*T**2+229029*T**(-1);,, N 91Hua1 !\n PAR L(HCP_A3,V:C,VA;0),, +12430-3.986*T;,, N 91Hua1 !\n$\n PAR G(V3C2,V:C),, +3*GHSERVV+2*GHSERCC\n -260341+16.897*T;,, N 91Hua1 !\n$\n$ metastable\n$\n PAR G(CBCC_A12,V:C),, +GHSERVV+GHSERCC+10000;,, N 91Fer2 !\n PAR G(CUB_A13,V:C),, +GHSERVV+GHSERCC+10000;,, N 91Fer2 !\n PAR G(CEMENTITE_D011,V:C),, -156971+601.922*T\n -100.438*T*LN(T)+765557*T**(-1);,, N 91Fer2 !\n$PAR G(CEMENTITE_D011,V:C),, +3*GHSERVV+GHSERCC-96000;,, N 91Hua4 !\n PAR G(MC_ETA,V:C),, -115426.29+299.799*T\n -47.012*T*LN(T)+210127.634*T**(-1);,, N 02Bra !\n PAR G(M7C3_D101,V:C),, -454245+1518.48*T\n -250.981*T*LN(T)+2148692*T**(-1);,, N 91Fer2 !\n PAR G(CR3C2_D510,V:C),, +3*GHSERVV+2*GHSERCC\n -222500+16.6545*T;,, N 92Lee2 !\n PAR G(M23C6_D84,V:V:C),, +GV23C6;,, N 91Fer2 !\n PAR G(M5C2,V:C),, -307123.3+1059.7*T\n -175.66*T*LN(T)+1453274*T**(-1);,, N 91Fer2 !\n$\n FUNCTION GV23C6 298.15 -990367+4330.63*T-728.829*T*LN(T)\n +5003425*T**(-1);\n 6000.00 N !\n$ ------------------------------------------------------------------------------\n$ V-N\n$\n$ From H. Ohtani and M. Hillert 1991 (Included in LB Vol. 4)\n$\n$ H. Ohtani, M. Hillert, Calphad, 15, 11-24(1991).\n$\n$ Checked against LB and paper. Checked at 6000 K.\n$\n$ Misprint in the bcc interaction in the paper; one zero missing.\n$\n$ The bcc-field shown in the phase diagram in the paper is not in agreement\n$ with the parameters given. The calculated N solubility is somewhat lower.\n$\n$ TI2N_C4 becomes stable above 2200 K. This requires changes in Ti-V-N from\n$ 98Zen.\n$\n$ In order to use V-N from 97Du it is necessary to remodel Fe-V-N.\n$\n PAR L(LIQUID,N,V;0),, -239000;,, N 91Oht1 !\n PAR L(LIQUID,N,V;1),, -8380;,, N 91Oht1 !\n$\n PAR G(FCC_A1,V:N),, +GHSERVV+GHSERNN\n -215000+101*T-2.22*T*LN(T)+0.00073*T**2;,, N 91Oht1 !\n PAR L(FCC_A1,V:N,VA;0),, -131000+47.1*T;,, N 91Oht1 !\n$\n PAR G(A1_FCC,V:N),, +GHSERVV+GHSERNN\n -215000+101*T-2.22*T*LN(T)+0.00073*T**2;,, N 91Oht1 !\n PAR L(A1_FCC,V:N,VA;0),, -131000+47.1*T;,, N 91Oht1 !\n$\n PAR G(BCC_A2,V:N),, +GHSERVV+3*GHSERNN+843000;,, N 91Oht1 !\n PAR L(BCC_A2,V:N,VA;0),, -1680000+325*T;,, N 91Oht1 !\n$\n PAR G(A2_BCC,V:N),, +GHSERVV+3*GHSERNN+843000;,, N 91Oht1 !\n PAR L(A2_BCC,V:N,VA;0),, -1680000+325*T;,, N 91Oht1 !\n$\n PAR G(HCP_A3,V:N),, +GHSERVV+0.5*GHSERNN\n -139000+50.4*T;,, N 91Oht1 !\n PAR L(HCP_A3,V:N,VA;0),, -18400+4.84*T;,, N 91Oht1 !\n PAR L(HCP_A3,V:N,VA;1),, -19700+2.13*T;,, N 91Oht1 !\n$\n$ Metastable\n$\n PAR G(TI2N_C4,V:N),, +2*GHSERVV+GHSERNN\n -100000+20*T;,, N 98Zen1 ! \n$ ------------------------------------------------------------------------------\n$ Ternary systems\n$ ------------------------------------------------------------------------------\n$ Cr-C-N\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-C\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Fe\n$\n$ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida,\n$ J. Phase Equilib., 23, 236-45(2002).\n$\n$ Checked against paper.\n$\n PAR L(LIQUID,CR,CU,FE;0),, +ZERO;,, N 97Oht !\n$\n PAR L(FCC_A1,CR,CU,FE:VA;0),, +35007.5-27.5*T;,, N 02Wan !\n PAR L(A1_FCC,CR,CU,FE:VA;0),, +35007.5-27.5*T;,, N 02Wan !\n$\n PAR L(BCC_A2,CR,CU,FE:VA;0),, +38650-50*T;,, N 97Oht !\n PAR L(A2_BCC,CR,CU,FE:VA;0),, +38650-50*T;,, N 97Oht !\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Mg\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Mn\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Mo\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-N\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Nb\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Ni\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Si\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-Ti\n$ ------------------------------------------------------------------------------\n$ Cr-Cu-V\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-C\n$\n$ A.V. Khvan, B. Hallstedt, C. Broeckmann, Calphad, 46, 24-33(2014).\n$\n PAR L(LIQUID,C,CR,FE;0),, -528500;,, N 14Khv !\n PAR L(LIQUID,C,CR,FE;1),, +57150;,, N 14Khv !\n PAR L(LIQUID,C,CR,FE;2),, +62630;,, N 14Khv !\n$\n PAR L(BCC_A2,CR,FE:C;0),, -1320000+667.7*T;,, N 14Khv !\n PAR BMAG(BCC_A2,CR,FE:C;0),, -0.85;,, N 88And3 !\n PAR TC(BCC_A2,CR,FE:C;0),, +1650;,, N 88And3 !\n PAR TC(BCC_A2,CR,FE:C;1),, +550;,, N 88And3 !\n$\n PAR L(A2_BCC,CR,FE:C;0),, -1320000+667.7*T;,, N 14Khv !\n PAR BMAG(A2_BCC,CR,FE:C;0),, -0.85;,, N 88And3 !\n PAR TC(A2_BCC,CR,FE:C;0),, +1650;,, N 88And3 !\n PAR TC(A2_BCC,CR,FE:C;1),, +550;,, N 88And3 !\n$\n PAR L(FCC_A1,CR,FE:C;0),, -69534+3.2353*T;,, N 14Khv !\n PAR L(A1_FCC,CR,FE:C;0),, -69534+3.2353*T;,, N 14Khv !\n$\n PAR L(CEMENTITE_D011,CR,FE:C;0),, +14586-9.18*T;,, N 14Khv !\n$\n PAR G(M23C6_D84,FE:CR:C),, +0.130435*GCR23C6\n +0.869565*GFE23C6;,, N 14Khv !\n PAR G(M23C6_D84,CR:FE:C),, +0.869565*GCR23C6\n +0.130435*GFE23C6;,, N 14Khv !\n PAR L(M23C6_D84,CR,FE:CR:C;0),, +6609;,, N 14Khv !\n PAR L(M23C6_D84,CR,FE:FE:C;0),, +6609;,, N 14Khv !\n PAR L(M23C6_D84,CR:CR,FE:C;0),, +991;,, N 14Khv !\n PAR L(M23C6_D84,FE:CR,FE:C;0),, +991;,, N 14Khv !\n PAR L(M23C6_D84,CR,FE:CR:C;1),, -43600;,, N 14Khv !\n PAR L(M23C6_D84,CR,FE:FE:C;1),, -43600;,, N 14Khv !\n PAR L(M23C6_D84,CR:CR,FE:C;1),, -6540;,, N 14Khv !\n PAR L(M23C6_D84,FE:CR,FE:C;1),, -6540;,, N 14Khv !\n$\n PAR L(M7C3_D101,CR,FE:C;0),, +81940-61.86*T;,, N 14Khv !\n PAR L(M7C3_D101,CR,FE:C;1),, -7310;,, N 14Khv !\n PAR L(M7C3_D101,CR,FE:C;2),, +27050;,, N 14Khv !\n$\n$ metastable\n$\n PAR L(KSI_CARBIDE,CR,FE:C;0),, -139900;,, N 92Qiu2 !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Mg\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Mn\n$\n$ B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993).\n$\n$ Checked against paper.\n$\n$ Changed model for sigma and high-sigma from 8:4:18 to 10:4:16.\n$ Ternary parameters were recalculated using the scheme in 93Lee3 with a\n$ modified correction term; -135000 J for sigma and -140000 J for high-sigma\n$ instead of -123570 J for both.\n$ B. Hallstedt, Nov. 2016.\n$\n$ The sigma phase field is very close to that in 93Lee3, but the high-sigma\n$ field extends less far into the ternary. There are no experimental data\n$ to support one version or the other.\n$\n PAR L(LIQUID,CR,FE,MN;0),, +2378;,, N 93Lee3 !\n$\n PAR L(FCC_A1,CR,FE,MN:VA;0),, +6715-10.3933*T;,, N 93Lee3 !\n PAR L(A1_FCC,CR,FE,MN:VA;0),, +6715-10.3933*T;,, N 93Lee3 !\n$\n PAR L(BCC_A2,CR,FE,MN:VA;0),, -5996;,, N 93Lee3 !\n PAR L(A2_BCC,CR,FE,MN:VA;0),, -5996;,, N 93Lee3 !\n$\n PAR G(SIGMA_D8B,FE:CR:MN),, +10*GFCCFE+4*GHSERCR\n +16*GBCCMN-49718-2.446*T;,, N 16Hal6 !\n PAR G(SIGMA_D8B,MN:CR:FE),, +10*GFCCMN+4*GHSERCR\n +16*GHSERFE-113380-43.274*T;,, N 16Hal6 !\n PAR L(SIGMA_D8B,FE:CR:CR,MN;0),, -947617+762.6*T;,, N 16Hal6 !\n$\n PAR G(HIGH_SIGMA,FE:CR:MN),, +10*GFCCFE+4*GHSERCR\n +16*GBCCMN+9350-48.969*T;,, N 16Hal6 !\n PAR G(HIGH_SIGMA,MN:CR:FE),, +10*GFCCMN+4*GHSERCR\n +16*GHSERFE-81088-72.351*T;,, N 16Hal6 !\n$\n$ metastable\n$\n PAR L(HCP_A3,CR,FE,MN:VA;0),, +34600;,, N 93Qiu3 !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Mo\n$\n$ J.-O. Andersson, N. Lange, Metall. Trans. A, 19A, 1385-94(1988).\n$\n$ Extended model for C14_LAVES (99Lee).\n$ Cr added on the first sublattice of CHI_A12 (88Gus4).\n$ Modified Fe:Mo:Cr parameter for CHI_A12 (88Gus4).\n$ Cr-Mo interaction added for fcc and hcp.\n$ Cr-Fe liquid interaction modified (93Lee1).\n$\n$ New lattice stabilities for C14_LAVES.\n$ Model for SIGMA changed from 8:4:18 to 10:4:16 and for MU_D85 from 7:2:4\n$ to 1:4:2:6. The change of SIGMA model made it necessary to introduce Mo\n$ on the first sublattice. For this the Fe-Mo binary was modified with\n$ minimal changes. In spite of this it was very difficult to reasonably\n$ reproduce previous results in the Cr-Fe-Mo system and a (probably too) large\n$ number of parameters was used.\n$\n$ 1273, 1373 K isothermal sections are very close to original. Largest change\n$ is for fcc-bcc equilibria, now in agreement with 92Qiu1. There is a\n$ considerable change in bcc-liquid equilibria in the Cr-Fe binary. Equilibria\n$ between liquid and sigma or R-phase do not change much. (This concerns\n$ canges before the change of SIGMA and MU models.)\n$\n$ Cr was introduced on the first sublattice of CHI_A12 by P. Gustafson 1988\n$ and some of the parameters modified.\n$\n$ The parameters G(CHI_A12,CR:MO:CR), L(SIGMA_OLD,FE:CR:FE,MO;0) and\n$ L(SIGMA_OLD,FE:MO:CR,FE;0) have been further modified in TCFE-99,\n$ but the isothermal section at 1273 K is not well reproduced with the new\n$ parameters. The reason for doing them is also not clear.\n$\n$ TCFE99: CHI_A12 phase field is larger and R_PHASE is not stable at 1273 K.\n$ TCFE8: Further changes of sigma, mu and chi phase fields. R-phase not stable\n$ at 1273 K. There is a very large shift of the liquidus (bcc, sigma, R)\n$ towards the Fe corner at 1873 K. TCFE8 = TCFE7.\n$\n PAR G(CHI_A12,CR:MO:FE),, +24*GFCCCR+10*GHSERMO\n +24*GFCCFE+500000;,, N 88Gus4 !\n PAR G(CHI_A12,FE:CR:MO),, +24*GFCCFE+10*GHSERCR\n +24*GFCCMO+100000;,, N 88And4 !\n$PAR G(CHI_A12,FE:MO:CR),, +24*GFCCFE+10*GHSERMO\n$ +24*GFCCCR+20855-385*T;,, N 88And4 !\n PAR G(CHI_A12,FE:MO:CR),, +24*GFCCFE+10*GHSERMO\n +24*GFCCCR+32555-385*T;,, N 88Gus4 !\n$\n PAR L(C14_LAVES,CR,FE:MO;0),, +40000;,, N 99Lee !\n$\n PAR G(MU_D85,CR:MO:CR:FE),, +3*GHSERCR+4*GHSERMO\n +6*GFCCFE;,, N Lin !\n PAR G(MU_D85,CR:MO:FE:CR),, +7*GHSERCR+4*GHSERMO\n +2*GHSERFE;,, N Lin !\n PAR G(MU_D85,CR:MO:FE:FE),, +GHSERCR+4*GHSERMO+2*GHSERFE\n +6*GFCCFE;,, N Lin !\n PAR G(MU_D85,CR:MO:FE:MO),, +GHSERCR+4*GHSERMO+2*GHSERFE\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,CR:MO:MO:FE),, +GHSERCR+6*GHSERMO\n +6*GFCCFE;,, N Lin !\n PAR G(MU_D85,FE:MO:CR:CR),, +GFCCFE+4*GHSERMO\n +8*GHSERCR;,, N Lin !\n PAR G(MU_D85,FE:MO:CR:FE),, +7*GFCCFE+4*GHSERMO\n +2*GHSERCR+88740-110*T;,, N 17Hal4 !\n PAR G(MU_D85,FE:MO:CR:MO),, +GFCCFE+4*GHSERMO+2*GHSERCR\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,FE:MO:FE:CR),, +GFCCFE+4*GHSERMO+2*GHSERFE\n +6*GHSERCR;,, N Lin !\n PAR G(MU_D85,FE:MO:MO:CR),, +GFCCFE+6*GHSERMO\n +6*GHSERCR+128710-90*T;,, N 17Hal4 !\n$\n PAR G(R_PHASE,CR:MO:FE),, +27*GFCCCR+14*GHSERMO\n +12*GHSERFE+645260-620*T;,, N 88And4 !\n PAR G(R_PHASE,FE:MO:CR),, +27*GFCCFE+14*GHSERMO\n +12*GHSERCR+600260-620*T;,, N 88And4 !\n$\n PAR G(SIGMA_D8B,FE:CR:MO),, +10*GFCCFE+4*GHSERCR\n +16*GHSERMO+550000-400*T;,, N 17Hal6 !\n PAR G(SIGMA_D8B,FE:MO:CR),, +10*GFCCFE+4*GHSERMO\n +16*GHSERCR+184100-100*T;,, N 17Hal6 !\n PAR G(SIGMA_D8B,MO:CR:FE),, +10*GFCCMO+4*GHSERCR\n +16*GHSERFE+150000;,, N 17Hal6 !\n PAR L(SIGMA_D8B,FE:CR:CR,MO;0),, -438780+100*T;,, N 17Hal6 !\n PAR L(SIGMA_D8B,FE:MO:CR,MO;0),, +70260;,, N 17Hal6 !\n PAR L(SIGMA_D8B,FE:CR:FE,MO;0),, +570000;,, N 88And4 !\n PAR L(SIGMA_D8B,FE:CR,MO:FE;0),, +274600-200*T;,, N 17Hal6 !\n PAR L(SIGMA_D8B,FE:MO:CR,FE;0),, -36790-100*T;,, N 17Hal6 !\n$\n$ metastable\n$\n PAR G(MONI,CR:FE:MO),, +UN_ASS;,, N !\n PAR G(MONI,FE:CR:MO),, +UN_ASS;,, N !\n$\n PAR G(P_PHASE,CR:FE:MO),, +24*GFCCCR+20*GHSERFE\n +12*GHSERMO+100000+UN_ASS;,, N 99Lee !\n PAR G(P_PHASE,FE:CR:MO),, +24*GFCCFE+20*GHSERCR\n +12*GHSERMO+100000+UN_ASS;,, N 99Lee !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-N\n$\n$ K. Frisk, Metall. Trans. A, 21A, 2477-88(1990).\n$\n$ Checked against paper.\n$\n$ Cr-Fe modified liquid from 93Lee1\n$ Fe-N from 93Du instead of 91Fri\n$\n$ At 1273 the N-solubility in bcc is about twice as high as shown in the paper.\n$ This seems to be a mistake in the paper. At higher temperature the N\n$ solubility in bcc is close to that shown in the paper.\n$\n$ The liquidus temperatures are lower than in the original 90Fri assessment,\n$ but data are lacking. The fcc+fcc (fcc-Fe+CrN) miscibility gap is rather\n$ different from 90Fri (at 1673 K).\n$\n$ First parameter is from TCFE99, second from 90Fri1.\n$PAR L(LIQUID,CR,FE,N;0),, -127121+68.6*T;,, N Null !\n PAR L(LIQUID,CR,FE,N;0),, -340750+187.4*T;,, N 90Fri1 !\n$\n PAR L(FCC_A1,CR,FE:N;0),, -128930+86.49*T;,, N 90Fri1 !\n PAR L(FCC_A1,CR,FE:N;1),, +24330;,, N 90Fri1 !\n PAR L(FCC_A1,CR,FE:N,VA;0),, -162516;,, N 90Fri1 !\n$\n PAR L(A1_FCC,CR,FE:N;0),, -128930+86.49*T;,, N 90Fri1 !\n PAR L(A1_FCC,CR,FE:N;1),, +24330;,, N 90Fri1 !\n PAR L(A1_FCC,CR,FE:N,VA;0),, -162516;,, N 90Fri1 !\n$\n PAR L(BCC_A2,CR,FE:N;0),, -799379+293*T;,, N 90Fri1 !\n PAR TC(BCC_A2,CR,FE:N;0),, +1650;,, N 90Fri1 !\n PAR TC(BCC_A2,CR,FE:N;1),, +550;,, N 90Fri1 !\n PAR BMAG(BCC_A2,CR,FE:N;0),, -0.85;,, N 90Fri1 !\n$\n PAR L(A2_BCC,CR,FE:N;0),, -799379+293*T;,, N 90Fri1 !\n PAR TC(A2_BCC,CR,FE:N;0),, +1650;,, N 90Fri1 !\n PAR TC(A2_BCC,CR,FE:N;1),, +550;,, N 90Fri1 !\n PAR BMAG(A2_BCC,CR,FE:N;0),, -0.85;,, N 90Fri1 !\n$\n PAR L(HCP_A3,CR,FE:N;0),, +12826-19.48*T;,, N 90Fri1 !\n$\n$ metastable\n$\n PAR G(PI_CRFENIN,CR:FE:N),, +12.8*GHSERCR+7.2*GHSERFE\n +4*GHSERNN-160994;,, N 91Fri3 !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Nb\n$\n$ A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov, B. Hallstedt,\n$ Calphad, 54, 1-15(2016).\n$\n$ Checked against paper.\n$\n PAR L(LIQUID,CR,FE,NB;0),, +35000;,, N 16Jac1 !\n PAR L(LIQUID,CR,FE,NB;1),, +25000;,, N 16Jac1 !\n PAR L(LIQUID,CR,FE,NB;2),, -30000;,, N 16Jac1 !\n$\n PAR L(C14_LAVES,FE:CR,NB;0),, -100000;,, N 16Jac1 !\n$\n PAR L(C15_LAVES,FE:CR,NB;0),, -100000;,, N 16Jac1 !\n$\n PAR G(MU_D85,CR:NB:CR:FE),, +3*GHSERCR+6*GHSERFE+4*GHSERNB\n -51272;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:FE:CR),, +7*GHSERCR+2*GHSERFE+4*GHSERNB\n +86129;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:FE:FE),, +GHSERCR+8*GHSERFE+4*GHSERNB\n +32907;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:FE:NB),, +GHSERCR+2*GHSERFE+10*GHSERNB\n +434399;,, N 16Jac1 ! \n PAR G(MU_D85,CR:NB:NB:FE),, +GHSERCR+6*GHSERFE+6*GHSERNB\n -158000-19*T;,, N 16Jac1 ! \n PAR G(MU_D85,FE:NB:CR:CR),, +8*GHSERCR+GHSERFE+4*GHSERNB\n +30559;,, N 16Jac1 ! \n PAR G(MU_D85,FE:NB:CR:FE),, +2*GHSERCR+7*GHSERFE+4*GHSERNB\n -45258;,, N 16Jac1 ! \n PAR G(MU_D85,FE:NB:CR:NB),, +2*GHSERCR+GHSERFE+10*GHSERNB\n +338945;,, N 16Jac1 ! \n PAR G(MU_D85,FE:NB:FE:CR),, +6*GHSERCR+3*GHSERFE+4*GHSERNB\n +97604;,, N 16Jac1 ! \n PAR G(MU_D85,FE:NB:NB:CR),, +6*GHSERCR+GHSERFE+6*GHSERNB\n -9919;,, N 16Jac1 ! \n PAR G(MU_D85,NB:NB:CR:FE),, +2*GHSERCR+6*GHSERFE+5*GHSERNB\n +13767;,, N 16Jac1 ! \n PAR G(MU_D85,NB:NB:FE:CR),, +6*GHSERCR+2*GHSERFE+5*GHSERNB\n +192989;,, N 16Jac1 ! \n PAR L(MU_D85,CR,FE:NB:NB:CR,FE;0),, -120000;,, N 16Jac1 ! \n$\n PAR G(SIGMA_D8B,FE:CR:NB),, +10*GHSERFE+4*GHSERCR\n +16*GHSERNB+323133;,, N 16Jac1 ! \n PAR G(SIGMA_D8B,FE:NB:CR),, +10*GHSERFE+4*GHSERNB\n +16*GHSERCR+93933;,, N 16Jac1 ! \n$PAR G(SIGMA_D8B,NB:CR:FE),, +10*GHSERNB+4*GHSERCR\n$ +16*GHSERFE+806333;,, N 16Jac1 ! \n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Ni\n$\n$ B.-J. Lee, J. Korean Inst. Met. Mater., 31, 480-89(1993).\n$\n$ Checked against paper (93Lee4 and 90Hil).\n$\n$ Cr-Ni is changed from 92Lee to 16Tan.\n$\n$ Sigma phase model is changed from 8:4:18 to 10:4:16.\n$ Ni:Cr:Cr parameter adjusted for better fit in Cr-Fe-Ni.\n$\n$ Results are very similar to those of 93Lee4, including the 74 wt.% Fe\n$ isopleth. There are small shifts in fcc, bcc, liquid and sigma phase\n$ boundaries.\n$\n$ Fcc and bcc ordering is added; 4SL fcc and 2SL bcc with Va.\n$ Fcc ordering was also added by P. Franke 2011 (based on Fe-Ni from 03Dup).\n$\n$ Ordering did not behave well at high temperature (similar to the\n$ Fe-Mn-Ni system). At 1673 K L1_2 is stable as (Fe,Ni)3Cr, from around\n$ Fe2NiCr to FeNi2Cr. The 823 K isothermal section is correctly reproduced\n$ with no ordered phases. Results at 773 and 673 K are similar to the\n$ the results P. Franke 2011. The high temperature problem was solved by\n$ changing the UFFENI parameter in the Fe-Ni system.\n$\n PAR L(LIQUID,CR,FE,NI;0),, +36583;,, N 93Lee1 !\n PAR L(LIQUID,CR,FE,NI;1),, +13254;,, N 93Lee1 !\n PAR L(LIQUID,CR,FE,NI;2),, -10018;,, N 93Lee1 !\n$\n PAR L(FCC_A1,CR,FE,NI:VA;0),, +16580-9.7835*T;,, N 93Lee1 !\n PAR L(A1_FCC,CR,FE,NI:VA;0),, +16580-9.7835*T;,, N 93Lee1 !\n$\n PAR L(BCC_A2,CR,FE,NI:VA;0),, -2673+2.04145*T;,, N 93Lee1 !\n PAR L(A2_BCC,CR,FE,NI:VA;0),, -2673+2.04145*T;,, N 93Lee1 !\n$\n PAR G(SIGMA_D8B,FE:CR:NI),, +10*GFCCFE+4*GHSERCR\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:CR:FE),, +10*GHSERNI+4*GHSERCR\n +16*GHSERFE;,, N Lin !\n$\n$ metastable\n$\n PAR G(CHI_A12,FE:CR:NI),, +24*GFCCFE+10*GHSERCR\n +24*GHSERNI;,, N Lin !\n PAR G(CHI_A12,NI:CR:FE),, +24*GHSERNI+10*GHSERCR\n +24*GFCCFE;,, N Lin !\n PAR L(CHI_A12,CR,FE:CR:NI;0),, -174000;,, N 99Lee !\n$\n PAR G(HIGH_SIGMA,FE:CR:NI),, +10*GFCCFE+4*GHSERCR\n +16*GBCCNI;,, N Lin !\n PAR G(HIGH_SIGMA,NI:CR:FE),, +10*GHSERNI+4*GHSERCR\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Si\n$\n$ From B. Hallstedt 2008 (based on the assessment from M. Lindholm 1997)\n$\n$ Cr-Si was changed from 94Cou to 00Du, but the simple model for \n$ M5SI3_D88 kept. M5SI3_D88 also appears as a high-temperature phase in Cr-Si.\n$ This changes the M5SI3_D88 phase field compared to 97Lin. Experimentally not\n$ much is known in this system. It was tried to stay close to the assessment\n$ by Lindholm.\n$\n$ Liquid interaction modified to reproduce the melting temperatures in the\n$ Cr0.6Fe0.4-Si section from 97Lin.\n$ New (but rough) M5Si3 interaction to produce a reasonable M5Si3 phase field.\n$ The stability of the sigma phase was slightly decreased.\n$\n PAR L(LIQUID,CR,FE,SI;0),, -40000;,, N 08Hal4 !\n$\n PAR L(BCC_A2,CR,FE,SI:VA;0),, -54000;,, N 97Lin !\n PAR L(A2_BCC,CR,FE,SI:VA;0),, -54000;,, N 97Lin !\n$\n PAR L(CR3SI_A15,CR,FE:SI:VA;0),, +10000;,, N 97Lin !\n$\n PAR L(CR5SI3_D8M,CR,FE:SI;0),, +12000;,, N 97Lin !\n$\n PAR L(M5SI3_D88,CR,FE:SI:VA;0),, +60000+20*T;,, N 08Hal4 !\n PAR L(M5SI3_D88,CR,FE:SI:VA;1),, +40000;,, N 08Hal4 !\n$\n PAR L(MSI_B20,CR,FE:SI;0),, +15000;,, N 97Lin !\n$\n PAR G(SIGMA_D8B,FE:CR:SI),, +10*GFCCFE+4*GHSERCR\n +16*GBCCSI-900000+275*T;,, N 17Hal10 !\n PAR L(SIGMA_D8B,FE:CR:CR,SI;0),, -2115000+155*T;,, N 97Lin !\n PAR L(SIGMA_D8B,FE:CR:FE,SI;0),, -2015000+155*T;,, N 97Lin !\n$\n$ metastable\n$\n$ Skip these parameters. There is no real support for them.\n$ Restored in version 4b.\n$ The fcc interaction was estimated to give reasonable Cr distribution\n$ during solidification of high Si cast iron.\n$\n PAR L(FCC_A1,CR,FE,SI:VA;0),, -100000;,, N 17Hal20 !\n PAR L(A1_FCC,CR,FE,SI:VA;0),, -100000;,, N 17Hal20 !\n PAR L(HCP_A3,CR,FE,SI:VA;0),, -54000;,, N Same !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Ti\n$\n PAR G(SIGMA_D8B,FE:CR:TI),, +10*GFCCFE+4*GHSERCR\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,FE:TI:CR),, +10*GFCCFE+4*GBCCTI\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-V\n$\n$ B.-J. Lee, Z. Metallkd., 83, 292-299(1992).\n$\n$ Checked against paper.\n$\n$ Changing SIGMA_OLD to SIGMA_D8B leads to moderate changes of the sigma phase\n$ field. The fit to data remains about equally good, but ternary parameters\n$ and Cr-V parameters should probably be refitted.\n$\n PAR L(LIQUID,CR,FE,V;0),, +14881;,, N 92Lee3 !\n PAR L(LIQUID,CR,FE,V;1),, +17968;,, N 92Lee3 !\n PAR L(LIQUID,CR,FE,V;2),, -7692;,, N 92Lee3 !\n$\n PAR L(BCC_A2,CR,FE,V:VA;0),, +14881;,, N 92Lee3 !\n PAR L(BCC_A2,CR,FE,V:VA;1),, +17968;,, N 92Lee3 !\n PAR L(BCC_A2,CR,FE,V:VA;2),, -7692;,, N 92Lee3 !\n$\n PAR L(A2_BCC,CR,FE,V:VA;0),, +14881;,, N 92Lee3 !\n PAR L(A2_BCC,CR,FE,V:VA;1),, +17968;,, N 92Lee3 !\n PAR L(A2_BCC,CR,FE,V:VA;2),, -7692;,, N 92Lee3 !\n$\n PAR G(SIGMA_D8B,FE:CR:V),, +10*GFCCFE+4*GHSERCR\n +16*GHSERVV-245761-67.3294*T;,, N 92Lee3 !\n PAR G(SIGMA_D8B,FE:V:CR),, +10*GFCCFE+4*GHSERVV\n +16*GHSERCR+155735-89.5976*T;,, N 92Lee3 !\n PAR G(SIGMA_D8B,V:CR:FE),, +10*GFCCVV+4*GHSERCR\n +16*GHSERFE;,, N Lin !\n PAR L(SIGMA_D8B,FE:CR:FE,V;0),, -235158;,, N 92Lee3 !\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-C\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Mn\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Mo\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-N\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Nb\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Ni\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Si\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-Ti\n$ ------------------------------------------------------------------------------\n$ Cr-Mg-V\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-C\n$\n$ B.-J. Lee, Metall. Trans. A, 24A, 1017-25 (1993).\n$\n$ Checked against paper.\n$\n$ Cr-C modified by 12Khv.\n$ Sigma and high-sigma changed from 8:4:18 to 10:4:16 in Cr-Mn.\n$ New Mn-C from 10Dju.\n$\n$ The BCC_A2 interaction is the same as without C. This is either without\n$ influence on anything or wrong. The same applies for FCC_A1, HCP_A3,\n$ CBCC_A12 and CUB_A13.\n$\n$ The HCP_A3 interaction is necessary, but is now different from the one\n$ without C.\n$\n PAR L(BCC_A2,CR,MN:C;0),, -20328+18.7339*T;,, N 93Lee2 !\n PAR L(BCC_A2,CR,MN:C;1),, -9162+4.4183*T;,, N 93Lee2 !\n$\n PAR L(A2_BCC,CR,MN:C;0),, -20328+18.7339*T;,, N 93Lee2 !\n PAR L(A2_BCC,CR,MN:C;1),, -9162+4.4183*T;,, N 93Lee2 !\n$\n PAR L(FCC_A1,CR,MN:C;0),, -19088+17.5423*T;,, N 93Lee2 !\n PAR L(A1_FCC,CR,MN:C;0),, -19088+17.5423*T;,, N 93Lee2 !\n$\n PAR L(HCP_A3,CR,MN:C;0),, +60000;,, N 93Lee2 !\n$\n PAR L(CBCC_A12,CR,MN:C;0),, -38349+22.6925*T;,, N 93Lee2 !\n$PAR L(CBCC_A12,CR,MN:C;0),, -36796+20.385*T;,, N 98Lee !\n$\n PAR L(CUB_A13,CR,MN:C;0),, -31260+16.4919*T;,, N 93Lee2 !\n$\n PAR L(CEMENTITE_D011,CR,MN:C),, +9000;,, N 93Lee2 !\n$\n PAR G(M23C6_D84,CR:MN:C),, +0.869565*GCR23C6\n +0.130435*GMN23C6;,, N 93Lee2 !\n PAR G(M23C6_D84,MN:CR:C),, +0.869565*GMN23C6\n +0.130435*GCR23C6;,, N 93Lee2 !\n PAR L(M23C6_D84,CR,MN:CR:C;0),, -173680+160*T;,, N 93Lee2 !\n PAR L(M23C6_D84,CR,MN:CR:C;1),, -286614;,, N 93Lee2 !\n PAR L(M23C6_D84,CR,MN:MN:C;0),, -173680+160*T;,, N 93Lee2 !\n PAR L(M23C6_D84,CR,MN:MN:C;1),, -286614;,, N 93Lee2 !\n$\n PAR L(M7C3_D101,CR,MN:C),, +72737-56.4964*T;,, N 93Lee2 !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-Mo\n$\n PAR G(R_PHASE,CR:MO:MN),, +27*GFCCCR+14*GHSERMO\n +12*GBCCMN;,, N Lin !\n PAR G(R_PHASE,MN:MO:CR),, +27*GFCCMN+14*GHSERMO\n +12*GHSERCR;,, N Lin !\n$\n PAR G(SIGMA_D8B,MN:CR:MO),, +10*GFCCMN+4*GHSERCR\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MN:MO:CR),, +10*GFCCMN+4*GHSERMO\n +16*GHSERCR;,, N Lin !\n PAR G(SIGMA_D8B,MO:CR:MN),, +10*GFCCMO+4*GHSERCR\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-N\n$ -----------------------------------------------------------------------------\n$ Cr-Mn-Nb\n$\n PAR G(SIGMA_D8B,MN:CR:NB),, +10*GFCCMN+4*GHSERCR\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,MN:NB:CR),, +10*GFCCMN+4*GHSERNB\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-Ni\n$\n$ B. Hallstedt, unpublished, 2016.\n$\n$ Added ternary parameters to, very roughly, reproduce isothermal sections\n$ at 1223 K from E.M. Slyusarenko et al., J. Alloys Compd. 1997 and at 923 K\n$ from M. Majdic and K. Fritscher, Z. Werkstofftechnik, 1987.\n$\n$ The parameter L(FCC_4SL,CR,MN:*:*:*:VA) was given a positive value to\n$ partially suppress an L1_2 field ((Cr,Mn)Ni3) in the Ni corner at 923 K.\n$\n PAR L(LIQUID,CR,MN,NI;0),, +30000;,, N 16Hal7 !\n$\n PAR L(FCC_A1,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 !\n PAR L(A1_FCC,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 !\n$\n PAR L(BCC_A2,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 !\n PAR L(A2_BCC,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 !\n$\n PAR L(CBCC_A12,CR,MN,NI:VA;0),, +60000;,, N 16Hal7 !\n PAR L(CUB_A13,CR,MN,NI:VA;0),, +40000;,, N 16Hal7 !\n$\n PAR G(SIGMA_D8B,MN:CR:NI),, +10*GFCCMN+4*GHSERCR\n +16*GBCCNI;,, N 16Hal7 !\n PAR G(SIGMA_D8B,NI:CR:MN),, +10*GHSERNI+4*GHSERCR\n +16*GBCCMN-190000;,, N 16Hal7 !\n$\n PAR G(HIGH_SIGMA,MN:CR:NI),, +10*GFCCMN+4*GHSERCR\n +16*GBCCNI;,, N 16Hal7 !\n PAR G(HIGH_SIGMA,NI:CR:MN),, +10*GHSERNI+4*GHSERCR\n +16*GBCCMN-190000;,, N 16Hal7 !\n$\n$ metastable\n$\n PAR L(HCP_A3,CR,MN,NI:VA;0),, +30000;,, N 16Hal7 !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-Si\n$\n PAR G(SIGMA_D8B,MN:CR:SI),, +10*GFCCMN+4*GHSERCR\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-Ti\n$\n PAR G(SIGMA_D8B,MN:CR:TI),, +10*GFCCMN+4*GHSERCR\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MN:TI:CR),, +10*GFCCMN+4*GBCCTI\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mn-V\n$\n PAR G(SIGMA_D8B,MN:CR:V),, +10*GFCCMN+4*GHSERCR\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MN:V:CR),, +10*GFCCMN+4*GHSERVV\n +16*GHSERCR;,, N Lin !\n PAR G(SIGMA_D8B,V:CR:MN),, +10*GFCCVV+4*GHSERCR\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-C\n$\n$ C. Qiu, ISIJ Int., 32, 1117-27(1992).\n$\n$ Checked against paper.\n$\n PAR L(HCP_A3,CR,MO:C;0),, -3905+18.5304*T;,, N 92Qiu2 !\n PAR G(M23C6_D84,CR:MO:C),, +20*GHSERCR+3*GHSERMO\n +6*GHSERCC-439117-50.0535*T;,, N 92Qiu2 !\n PAR L(CR3C2_D510,CR,MO:C;0),, +40000;,, N 92Qiu2 !\n PAR L(M7C3_D101,CR,MO:C;0),, +165280;,, N 92Qiu2 !\n$\n$ metastable\n$\n PAR L(FCC_A1,CR,MO:C;0),, -10240+17.65*T;,, N Null !\n PAR L(A1_FCC,CR,MO:C;0),, -10240+17.65*T;,, N Null !\n PAR L(CEMENTITE_D011,CR,MO:C;0),, +40000;,, N 92Qiu2 !\n PAR L(KSI_CARBIDE,CR,MO:C;0),, -348033;,, N 92Qiu2 !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-N\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-Nb\n$\n PAR G(SIGMA_D8B,MO:CR:NB),, +10*GFCCMO+4*GHSERCR\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,MO:NB:CR),, +10*GFCCMO+4*GHSERNB\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-Ni\n$\n$ K. Frisk, TRITA-MAC 429, Stockholm 1990.\n$\n$ Cr-Ni from 16Tan\n$ Added fcc interaction in Cr-Mo\n$ CrNi2 from 06Tur added\n$ Changed sigma model from 8:4:18 to 10:4:16 with Mo on first SL\n$\n$ The ternary interaction parameter for FCC_A1 is present in TCFE99 and\n$ SSOL V2, but not in V3 or V4. It is included to balance the effect of the\n$ Cr-Mo interaction, which was not present in the original work by K. Frisk.\n$ The experimental data on the fcc-boundary are better fitted with the\n$ binary interaction included, without any ternary interaction.\n$\n$PAR L(FCC_A1,CR,MO,NI:VA;0),, -30000;,, N Null !\n$\n PAR G(CRNI2_C11B,CR:MO,NI;0),, -80000;,, N 06Tur !\n PAR G(CRNI2_C11B,CR,MO:NI;0),, -11000;,, N 06Tur !\n$\n PAR G(SIGMA_D8B,NI:MO:CR),, +10*GHSERNI+4*GHSERMO+16*GHSERCR\n -50000;,, N 17Hal11 !\n PAR G(SIGMA_D8B,NI:CR:MO),, +10*GHSERNI+4*GHSERCR+16*GHSERMO\n -260000+125*T;,, N 17Hal11 !\n PAR G(SIGMA_D8B,MO:CR:NI),, +10*GFCCMO+4*GHSERCR\n +16*GBCCNI+300000;,, N 17Hal11 !\n$\n PAR G(P_PHASE,CR:NI:MO),, +24*GFCCCR+20*GBCCNI+12*GHSERMO\n -434085;,, N 90Fri3 !\n PAR G(P_PHASE,NI:CR:MO),, +24*GHSERNI+20*GHSERCR+12*GHSERMO\n -341858;,, N 90Fri3 !\n$\n PAR G(MONI,NI:CR:MO),, +6*GHSERNI+5*GHSERCR+3*GHSERMO\n -50000;,, N 90Fri3 !\n PAR G(MONI,CR:NI:MO),, +6*GFCCCR+6*GBCCNI+3*GHSERMO\n -50000;,, N 90Fri3 !\n$\n$ Metastable\n$\n PAR G(CHI_A12,CR:MO:NI),, +24*GFCCCR+10*GHSERMO\n +24*GHSERNI;,, N Lin !\n PAR G(CHI_A12,NI:CR:MO),, +24*GHSERNI+10*GHSERCR\n +24*GFCCMO;,, N Lin !\n PAR G(CHI_A12,NI:MO:CR),, +24*GHSERNI+10*GHSERMO\n +24*GFCCCR;,, N Lin !\n$\n PAR G(MU_D85,CR:MO:CR:NI),, +GFCCCR+4*GHSERMO+2*GHSERCR\n +6*GHSERNI;,, N Lin !\n PAR G(MU_D85,CR:MO:MO:NI),, +GFCCCR+6*GHSERMO\n +6*GHSERNI;,, N Lin !\n PAR G(MU_D85,CR:MO:NI:CR),, +7*GFCCCR+4*GHSERMO\n +2*GBCCNI;,, N Lin !\n PAR G(MU_D85,CR:MO:NI:MO),, +GFCCCR+4*GHSERMO+2*GBCCNI\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,CR:MO:NI:NI),, +GFCCCR+4*GHSERMO+2*GBCCNI\n +6*GHSERNI;,, N Lin !\n PAR G(MU_D85,NI:MO:CR:CR),, +GHSERNI+4*GHSERMO+2*GHSERCR\n +6*GFCCCR;,, N Lin !\n PAR G(MU_D85,NI:MO:CR:MO),, +GHSERNI+4*GHSERMO+2*GHSERCR\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NI:MO:CR:NI),, +7*GHSERNI+4*GHSERMO\n +2*GHSERCR;,, N Lin !\n PAR G(MU_D85,NI:MO:MO:CR),, +GHSERNI+6*GHSERMO\n +6*GFCCCR;,, N Lin !\n PAR G(MU_D85,NI:MO:NI:CR),, +GHSERNI+4*GHSERMO+2*GBCCNI\n +6*GFCCCR;,, N Lin !\n$\n PAR G(R_PHASE,CR:MO:NI),, +27*GFCCCR+12*GBCCNI\n +14*GHSERMO;,, N Lin !\n PAR G(R_PHASE,NI:MO:CR),, +27*GHSERNI+12*GHSERCR\n +14*GHSERMO;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-Si\n$\n PAR G(SIGMA_D8B,MO:CR:SI),, +10*GFCCMO+4*GHSERCR\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-Ti\n$\n PAR G(SIGMA_D8B,MO:CR:TI),, +10*GFCCMO+4*GHSERCR\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:CR),, +10*GFCCMO+4*GBCCTI\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Mo-V\n$\n PAR G(SIGMA_D8B,MO:CR:V),, +10*GFCCMO+4*GHSERCR\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:CR),, +10*GFCCMO+4*GHSERVV\n +16*GHSERCR;,, N Lin !\n PAR G(SIGMA_D8B,V:CR:MO),, +10*GFCCVV+4*GHSERCR\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:CR),, +10*GFCCVV+4*GHSERMO\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-C\n$\n$ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012).\n$\n PAR L(LIQUID,C,CR,NB;0),, +100000;,, N 12Khv1 !\n$\n PAR L(FCC_A1,CR,NB:C;0),, -23000;,, N 12Khv1 !\n PAR L(A1_FCC,CR,NB:C;0),, -23000;,, N 12Khv1 !\n PAR L(HCP_A3,CR,NB:C;0),, +18500;,, N 12Khv1 !\n$\n PAR G(M23C6_D84,CR:NB:C),, +0.8695652*GCR23C6\n +3*GHSERNB+0.7826087*GHSERCC-130000;,, N 12Khv1 !\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-N\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-Ni\n$\n PAR G(SIGMA_D8B,NI:CR:NB),, +10*GHSERNI+4*GHSERCR\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,NI:NB:CR),, +10*GHSERNI+4*GHSERNB\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-Si\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-Ti\n$ ------------------------------------------------------------------------------\n$ Cr-Nb-V\n$\n PAR G(SIGMA_D8B,V:CR:NB),, +10*GFCCVV+4*GHSERCR\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,V:NB:CR),, +10*GFCCVV+4*GHSERNB\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Ni-C\n$\n$ B.-J. Lee, Calphad, 16, 121-49(1992).\n$\n$ Cr-C modified by 12Khv.\n$ New Cr-Ni from 16Tan.\n$ Ni-C modified by 06Hal1.\n$ Cr-Ni-C modified by 06Hal2.\n$\n PAR L(FCC_A1,CR,NI:C;0),, +ZERO;,, N 06Hal3 !\n PAR TC(FCC_A1,CR,NI:C;0),, -3605;,, N Null !\n PAR BMAG(FCC_A1,CR,NI:C;0),, -1.91;,, N Null !\n$\n PAR L(A1_FCC,CR,NI:C;0),, +ZERO;,, N 06Hal3 !\n PAR TC(A1_FCC,CR,NI:C;0),, -3605;,, N Null !\n PAR BMAG(A1_FCC,CR,NI:C;0),, -1.91;,, N Null !\n$\n PAR TC(BCC_A2,CR,NI:C;0),, +2373;,, N Null !\n PAR TC(BCC_A2,CR,NI:C;1),, +617;,, N Null !\n PAR BMAG(BCC_A2,CR,NI:C;0),, +4;,, N Null !\n$\n PAR TC(A2_BCC,CR,NI:C;0),, +2373;,, N Null !\n PAR TC(A2_BCC,CR,NI:C;1),, +617;,, N Null !\n PAR BMAG(A2_BCC,CR,NI:C;0),, +4;,, N Null !\n$\n PAR G(M23C6_D84,CR:NI:C),, +0.8695652*GCR23C6\n +0.1304348*GNI23C6;,, N 92Lee1 !\n PAR G(M23C6_D84,NI:CR:C),, +0.8695652*GNI23C6\n +0.1304348*GCR23C6;,, N 92Lee1 !\n PAR L(M23C6_D84,CR,NI:CR:C;0),, +ZERO;,, N 06Hal3 !\n PAR L(M23C6_D84,CR,NI:NI:C;0),, +ZERO;,, N 06Hal3 !\n$\n PAR L(M7C3_D101,CR,NI:C;0),, +ZERO;,, N 06Hal3 !\n$\n$ Metastable\n$\n PAR L(CEMENTITE_D011,CR,NI:C;0),, +27898;,, N Null !\n$ ------------------------------------------------------------------------------\n$ Cr-Ni-N\n$ ------------------------------------------------------------------------------\n$ Cr-Ni-Si\n$\n$ J.C. Schuster, Y. Du, Metall. Mater. Trans. A, 31A, 1795-1803(2000).\n$\n$ Checked against paper.\n$\n$ Cr-Ni from 16Tan instead of 92Lee.\n$ FCC_4SL instead of L12_FCC (modified parameters from 12Yua).\n$ M5SI3_D88 (Cr5Si3) modelled as stoichiometric.\n$ Cr removed from 1st sl and Ni added on 3rd sl of SIGMA_D8B.\n$\n$ Ni3Si (L12) has a stability range towards CrNi3, which was previously not\n$ present. The extension does not seem excessive. The sigma phase field is\n$ more narrow with essentially fixed Cr to Ni ratio. It is also stable closer\n$ to Cr-Ni at high temperature. This should require some adjustments.\n$ NI2SI_C37 is slightly more stable. Other changes are minor. The Ni-Si binary\n$ from 12Yua should be used instead of 99Du, but this requires complete\n$ reoptimisation of the ternary.\n$\n PAR L(LIQUID,CR,NI,SI;0),, +2632.97;,, N 00Sch !\n PAR L(LIQUID,CR,NI,SI;1),, -31200.06;,, N 00Sch !\n PAR L(LIQUID,CR,NI,SI;2),, -195772.95;,, N 00Sch !\n$\n PAR L(FCC_A1,CR,NI,SI:VA;0),, -103437.71;,, N 00Sch !\n PAR L(A1_FCC,CR,NI,SI:VA;0),, -103437.71;,, N 00Sch !\n$\n PAR G(CR3NI5SI2,CR:NI:SI),, +3*GHSERCR+5*GHSERNI+2*GHSERSI\n -257244.2-57.6017*T;,, N 00Sch !\n PAR G(CR5NI5SI3,CR:NI:SI),, +5*GHSERCR+5*GHSERNI+3*GHSERSI\n -394722.4-41.94047*T;,, N 00Sch !\n$\n PAR L(NI2SI_C37,CR,NI:SI;0),, +65656.96-41.65881*T;,, N 00Sch !\n PAR L(NI2SI_C37,CR,NI:SI;1),, -14620.24;,, N 00Sch !\n$\n PAR G(SIGMA_D8B,NI:CR:SI),, +10*GHSERNI+4*GHSERCR\n +16*GHSERSI+150000;,, N 00Sch !\n$PAR L(SIGMA_D8B,CR,NI:CR:SI;0),, +75848.4+87.9975*T;,, N 00Sch !\n PAR L(SIGMA_D8B,NI:CR:CR,SI;0),, -3512346+321.015*T;,, N 00Sch !\n$ ------------------------------------------------------------------------------\n$ Cr-Ni-Ti\n$\n PAR G(SIGMA_D8B,NI:CR:TI),, +10*GHSERNI+4*GHSERCR\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:CR),, +10*GHSERNI+4*GBCCTI\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Ni-V\n$\n PAR G(SIGMA_D8B,NI:CR:V),, +10*GHSERNI+4*GHSERCR\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:CR),, +10*GHSERNI+4*GHSERVV\n +16*GHSERCR;,, N Lin !\n PAR G(SIGMA_D8B,V:CR:NI),, +10*GFCCVV+4*GHSERCR\n +16*GBCCNI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Si-C\n$\n$ Y. Du, J.C. Schuster, L. Perring, J. Am. Ceram. Soc., 83, 2067-73(2000).\n$\n$ Checked against paper.\n$\n$ Cr-C from 12Khv instead of 92Lee.\n$ Si-C from 91Lac instead of 96Gro (for compatibility with Fe-Si-C from 98Mie).\n$ Simplified model for M5SI3_D88 (fixed Cr/Si ratio).\n$\n$ There is a small change for M5SI3_D88. The liquid (with Si-C from 91Lac) is\n$ much more stable and there is quite a bit of liquid at 1673 K. At this\n$ temperature there should only be liquid close to the Cr-Si binary.\n$\n PAR L(LIQUID,C,CR,SI;0),, -248421;,, N 00Du2 !\n PAR L(LIQUID,C,CR,SI;1),, +40606;,, N 00Du2 !\n PAR L(LIQUID,C,CR,SI;2),, -30000;,, N 00Du2 !\n$\n PAR G(CR3SI_A15,CR:SI:C),, +3*GHSERCR+GHSERSI+3*GHSERCC\n -40000;,, N 00Du2 !\n PAR G(CR3SI_A15,SI:CR:C),, +GHSERCR+3*GHSERSI+3*GHSERCC\n +40000;,, N 00Du2 !\n$\n PAR G(M5SI3_D88,CR:SI:C),, +5*GHSERCR+3*GHSERSI+GHSERCC\n -295220-3.25085*T;,, N 00Du2 !\n$ ------------------------------------------------------------------------------\n$ Cr-Si-N\n$ ------------------------------------------------------------------------------\n$ Cr-Si-Ti\n$ ------------------------------------------------------------------------------\n$ Cr-Si-V\n$\n PAR G(SIGMA_D8B,V:CR:SI),, +10*GFCCVV+4*GHSERCR\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-Ti-C\n$ ------------------------------------------------------------------------------\n$ Cr-Ti-N\n$ ------------------------------------------------------------------------------\n$ Cr-Ti-V\n$\n PAR G(SIGMA_D8B,V:CR:TI),, +10*GFCCVV+4*GHSERCR\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:CR),, +10*GFCCVV+4*GBCCTI\n +16*GHSERCR;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Cr-V-C\n$\n$ B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-364(1992).\n$\n$ Checked against paper.\n$\n$ Cr-C from 12Khv instead of 92Lee.\n$\n$ Liquid interaction modified to approximately reproduce ternary invariant\n$ temperatures. The largest difference is now 11 K.\n$\n PAR L(LIQUID,C,CR,V;0),, -769497;,, N 92Lee2 !\n$PAR L(LIQUID,C,CR,V;1),, +263981;,, N 92Lee2 !\n PAR L(LIQUID,C,CR,V;1),, +230000;,, N 17Hal14 !\n PAR L(LIQUID,C,CR,V;2),, +3599;,, N 92Lee2 !\n$\n PAR L(FCC_A1,CR,V:C;0),, +35698-50.0981*T;,, N 92Lee2 !\n PAR L(A1_FCC,CR,V:C;0),, +35698-50.0981*T;,, N 92Lee2 !\n$\n PAR L(HCP_A3,CR,V:C;0),, +17165-9.9072*T;,, N 92Lee2 !\n$\n PAR G(M23C6_D84,CR:V:C),, +0.8695652*GCR23C6\n +0.1304348*GV23C6;,, N 92Lee2 !\n PAR G(M23C6_D84,V:CR:C),, +0.8695652*GV23C6\n +0.1304348*GCR23C6;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,V:CR:C;0),, -382069;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,V:V:C;0),, -382069;,, N 92Lee2 !\n$\n PAR L(M7C3_D101,CR,V:C;0),, -110271;,, N 92Lee2 !\n PAR L(CR3C2_D510,CR,V:C;0),, +21072;,, N 92Lee2 !\n$\n PAR G(CR2VC2,CR:V:C),, +2*GHSERCR+GHSERVV+2*GHSERCC\n -105987-38.2069*T;,, N 92Lee2 !\n$\n$ metastable\n$\n PAR L(CEMENTITE_D011,CR,V:C;0),, -29622-8.0892*T;,, N 92Lee2 !\n PAR L(CEMENTITE_D011,CR,V:C;1),, -5160-7.5711*T;,, N 92Lee2 !\n$ ------------------------------------------------------------------------------\n$ Cr-V-N\n$ ------------------------------------------------------------------------------\n$ Cu-C-N\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-C\n$\n$ B. Hallstedt, unpublished, 2017.\n$\n$ This dataset is essentially an extrapolation from the three binaries.\n$ Comparison was made with the assessment from K. Shubhank and Y.-B. Kang,\n$ Calphad, 45, 127-37(2014). A ternary liquid interaction is necessary to\n$ reproduce data.\n$\n$ Shubhank and Kang used the MQM liquid model and their own assessments\n$ for the three binaries, which do not differ much from the binaries used here.\n$\n PAR L(LIQUID,C,CU,FE;0),, -90000;,, N 17Hal16 !\n$\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Mg\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Mn\n$\n$ J. Miettinen, Calphad, 27, 141-45(2003).\n$\n$ Checked against paper.\n$\n$ Cu-Fe from 95Che instead of 93Ans (or87Jan).\n$\n$ The fcc miscibility gap is more narrow, especially for relatively high\n$ Cu and Mn contents.\n$\n PAR L(LIQUID,CU,FE,MN;0),, +115000-60*T;,, N 03Mie3 !\n PAR L(LIQUID,CU,FE,MN;1),, +13000;,, N 03Mie3 !\n PAR L(LIQUID,CU,FE,MN;2),, +10000;,, N 03Mie3 !\n$\n PAR L(FCC_A1,CU,FE,MN:VA;0),, -68000+50*T;,, N 03Mie3 !\n PAR L(A1_FCC,CU,FE,MN:VA;0),, -68000+50*T;,, N 03Mie3 !\n$\n PAR L(BCC_A2,CU,FE,MN:VA;0),, +30000;,, N 03Mie3 !\n PAR L(A2_BCC,CU,FE,MN:VA;0),, +30000;,, N 03Mie3 !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Mo\n$\n$ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida,\n$ J. Phase Equilib., 21, 54-62(2000).\n$\n$ Checked against paper.\n$\n$ In the isoplethal section at 5 wt% Mo there should be two fcc phases, but\n$ no lambda. Wang et al. seem to have labeled the diagram incorrectly.\n$\n PAR L(LIQUID,CU,FE,MO;0),, +ZERO;,, N 00Wan !\n$\n PAR L(FCC_A1,CU,FE,MO:VA;0),, -3000;,, N 00Wan !\n PAR L(A1_FCC,CU,FE,MO:VA;0),, -3000;,, N 00Wan !\n$\n PAR L(BCC_A2,CU,FE,MO:VA;0),, +40000-48*T;,, N 00Wan !\n PAR L(A2_BCC,CU,FE,MO:VA;0),, +40000-48*T;,, N 00Wan !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-N\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Nb\n$\n$ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida,\n$ J. Phase Equilib., 21, 54-62(2000).\n$\n$ Checked against paper.\n$\n$ Fe-Nb from 16Jac instead of 90Hua.\n$\n$ Changes along the Fe-Nb edge are considerable, but the ternary does not\n$ change much.\n$\n PAR L(LIQUID,CU,FE,NB;0),, +ZERO;,, N 00Wan !\n$\n PAR L(FCC_A1,CU,FE,NB:VA;0),, -33000;,, N 00Wan !\n PAR L(BCC_A2,CU,FE,NB:VA;0),, +30000-19.6*T;,, N 00Wan !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Ni\n$\n$ A. Jansson, TRITA-MAC 340, KTH, Stockholm 1987.\n$\n$ Cu-Fe from 95Che instead of 87Jan.\n$ Cu-Ni from 92Mey instead of 87Jan.\n$ Fe-Ni modified by 93Lee and ordering from 03Dup/16Hal.\n$ Cu-Fe-Ni ordering from 01Ser. \n$\n$ Parameters taken from H. Ohtani et al., ISIJ Int., 37, 207-16(1997).\n$ Parameters are also in C. Servant et al., Calphad, 25, 79-95(2001).\n$\n$ 97Oht used Cu-Fe from 93Swa rather than 87Jan.\n$\n$ Checked against 97Oht, 01Ser (and 14Dre).\n$\n$ In contrast to 01Ser there is no equilibrium between FeNi3 and fcc-Cu at\n$ 723 or 773 K. FeNi3 does nor extend quite far enough from the binary.\n$\n PAR L(LIQUID,CU,FE,NI;0),, -68786+30.9*T;,, N 87Jan !\n$\n PAR L(FCC_A1,CU,FE,NI:VA;0),, -73272+30.9*T;,, N 87Jan !\n PAR TC(FCC_A1,CU,FE,NI:VA;0),, +7000;,, N 87Jan !\n PAR BMAG(FCC_A1,CU,FE,NI:VA;0),, +20;,, N 87Jan !\n$\n PAR L(A1_FCC,CU,FE,NI:VA;0),, -73272+30.9*T;,, N 87Jan !\n PAR TC(A1_FCC,CU,FE,NI:VA;0),, +7000;,, N 87Jan !\n PAR BMAG(A1_FCC,CU,FE,NI:VA;0),, +20;,, N 87Jan !\n$\n PAR L(FCC_4SL,CU,FE:*:*:*:VA;0),, -7600;,, N 01Ser !\n$\n PAR L(BCC_A2,CU,FE,NI:VA;0),, +ZERO;,, N 87Jan !\n PAR L(A2_BCC,CU,FE,NI:VA;0),, +ZERO;,, N 87Jan !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Si\n$\n$ C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida,\n$ J. Phase Equilib., 23, 236-45(2002).\n$\n$ Checked against paper.\n$\n$ Ordering in bcc included (B2_BCC)\n$ CuSi from 16Hal instead of 98Jac\n$\n$ There are some changes compared to the original assessment, in particular\n$ the liquid miscibility gap and towards the Cu-Si edge.\n$\n PAR L(LIQUID,CU,FE,SI;0),, +23000-19.5*T;,, N 02Wan !\n PAR L(LIQUID,CU,FE,SI;1),, +50000-19.5*T;,, N 02Wan !\n PAR L(LIQUID,CU,FE,SI;2),, +23000-19.5*T;,, N 02Wan !\n$\n PAR L(FCC_A1,CU,FE,SI:VA;0),, -231494.5+130*T;,, N 02Wan !\n PAR L(A1_FCC,CU,FE,SI:VA;0),, -231494.5+130*T;,, N 02Wan !\n$\n PAR L(BCC_A2,CU,FE,SI:VA;0),, -158642.5+50*T;,, N 02Wan !\n PAR L(BCC_A2,CU,FE,SI:VA;1),, -182105.5+70*T;,, N 02Wan !\n PAR L(BCC_A2,CU,FE,SI:VA;2),, -158642.5+50*T;,, N 02Wan !\n$\n PAR L(A2_BCC,CU,FE,SI:VA;0),, -158642.5+50*T;,, N 02Wan !\n PAR L(A2_BCC,CU,FE,SI:VA;1),, -182105.5+70*T;,, N 02Wan !\n PAR L(A2_BCC,CU,FE,SI:VA;2),, -158642.5+50*T;,, N 02Wan !\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Fe-V\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-C\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Mn\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Mo\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-N\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Nb\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Ni\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Si\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Mg-V\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-C\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-Mo\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-N\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-Nb\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-Ni\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-Si\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Mn-V\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-C\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-N\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-Nb\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-Ni\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-Si\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Mo-V\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-C\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-N\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-Ni\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-Si\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Nb-V\n$ ------------------------------------------------------------------------------\n$ Cu-Ni-C\n$ ------------------------------------------------------------------------------\n$ Cu-Ni-N\n$ ------------------------------------------------------------------------------\n$ Cu-Ni-Si\n$ ------------------------------------------------------------------------------\n$ Cu-Ni-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Ni-V\n$ ------------------------------------------------------------------------------\n$ Cu-Si-C\n$ ------------------------------------------------------------------------------\n$ Cu-Si-N\n$ ------------------------------------------------------------------------------\n$ Cu-Si-Ti\n$ ------------------------------------------------------------------------------\n$ Cu-Si-V\n$ ------------------------------------------------------------------------------\n$ Cu-Ti-C\n$ ------------------------------------------------------------------------------\n$ Cu-Ti-N\n$ ------------------------------------------------------------------------------\n$ Cu-Ti-V\n$ ------------------------------------------------------------------------------\n$ Cu-V-C\n$ ------------------------------------------------------------------------------\n$ Cu-V-N\n$ ------------------------------------------------------------------------------\n$ Fe-C-N\n$\n$ H. Du, J. Phase Equilib., 14, 682-93(1993).\n$\n$ Checked against paper.\n$\n$ There are small differences compared to the paper visible at 863 K.\n$ Fcc is slightly too stable and hcp is slightly shifted.\n$\n$ For more carbon rich compositions than cementite, M5C2 and M7C3 are more\n$ stable than FECN_CHI (when using Fe-Mn-C from 11Dju). This is probably quite\n$ reasonable (in particular M5C2) and N solubility should be modelled.\n$\n$ FECN_CHI should be replaced by M5C2 with N solubility.\n$\n$ The value from 88And2 was kept for L(HCP_A3,FE:C,VA) instead of the new\n$ value from 93Du. This makes the hcp phase somewhat less stable in Fe-C-N.\n$\n PAR L(LIQUID,C,FE,N;0),, +490996-109.135*T;,, N 91Du !\n PAR L(LIQUID,C,FE,N;1),, +192167-109.135*T;,, N 91Du !\n PAR L(LIQUID,C,FE,N;2),, +490996-109.135*T;,, N 91Du !\n$\n PAR L(FCC_A1,FE:C,N;0),, -21893;,, N 93Du !\n PAR L(A1_FCC,FE:C,N;0),, -21893;,, N 93Du !\n$\n PAR L(HCP_A3,FE:C,N;0),, -62984;,, N 93Du !\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-C\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Mn\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Mo\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-N\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Nb\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Ni\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Si\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-Ti\n$ ------------------------------------------------------------------------------\n$ Fe-Mg-V\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-C\n$\n$ D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski,\n$ Calphad, 35, 479-91(2011).\n$\n PAR L(LIQUID,C,FE,MN;0),, -71514-11.3063*T;,, N 11Dju !\n PAR L(LIQUID,C,FE,MN;1),, +19817;,, N 11Dju !\n PAR L(LIQUID,C,FE,MN;2),, +27885;,, N 11Dju !\n$\n PAR L(FCC_A1,FE,MN:C;0),, +20082-11.6312*T;,, N 11Dju !\n PAR L(A1_FCC,FE,MN:C;0),, +20082-11.6312*T;,, N 11Dju !\n$\n PAR L(HCP_A3,FE,MN:C;0),, +21742-50.2703*T;,, N 11Dju !\n PAR L(HCP_A3,FE,MN:C;1),, -32608;,, N 11Dju !\n$\n PAR L(CBCC_A12,FE,MN:C;0),, -36732;,, N 11Dju !\n PAR L(CUB_A13,FE,MN:C;0),, -36732;,, N 11Dju !\n$\n PAR L(CEMENTITE_D011,FE,MN:C;0),, -7715+1.3687*T;,, N 11Dju !\n PAR L(M5C2,FE,MN:C;0),, +8743-15.1917*T;,, N 11Dju !\n PAR L(M7C3_D101,FE,MN:C;0),, +20157-24.7104*T;,, N 11Dju !\n$\n PAR G(M23C6_D84,FE:MN:C),, +0.869565*GFE23C6\n +0.130435*GMN23C6;,, N 11Dju !\n PAR G(M23C6_D84,MN:FE:C),, +0.130435*GFE23C6\n +0.869565*GMN23C6;,, N 11Dju !\n PAR L(M23C6_D84,FE,MN:FE,MN:C;0),, -95000;,, N 11Dju !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Mo\n$\n PAR G(R_PHASE,FE:MO:MN),, +27*GFCCFE+14*GHSERMO\n +12*GBCCMN;,, N Lin !\n PAR G(R_PHASE,MN:MO:FE),, +27*GFCCMN+14*GHSERMO\n +12*GHSERFE;,, N Lin !\n$\n PAR G(SIGMA_D8B,FE:MO:MN),, +10*GFCCFE+4*GHSERMO\n +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,MN:MO:FE),, +10*GFCCMN+4*GHSERMO\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-N\n$\n$ C. Qiu, Metall. Trans. A, 24A, 629-45(1993).\n$\n$ Checked against paper.\n$\n$ Fe-N from 93Du instead of 91Fri.\n$\n$ The isothermal section at 973 K changes very slightly.\n$\n PAR L(LIQUID,FE,MN,N;0),, -15211+18.43*T;,, N 93Qiu2 !\n$\n PAR L(FCC_A1,FE,MN:N;0),, +53968-38.102*T;,, N 93Qiu2 !\n PAR L(FCC_A1,FE,MN:N;1),, -27787;,, N 93Qiu2 !\n$\n PAR L(A1_FCC,FE,MN:N;0),, +53968-38.102*T;,, N 93Qiu2 !\n PAR L(A1_FCC,FE,MN:N;1),, -27787;,, N 93Qiu2 !\n$\n PAR L(FE4N_L1,FE,MN:N;0),, +36297-28.8876*T;,, N 93Qiu2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Nb\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ Checked against paper.\n$\n$ Same as the description from S.H. Liu 2012, but with a modified Fe-Nb and\n$ slightly modified MU_D85.\n$\n PAR G(MU_D85,FE:NB:FE:MN),, +3*GHSERFE+6*GHSERMN+4*GHSERNB\n -61620;,, N 12Liu !\n PAR G(MU_D85,FE:NB:NB:MN),, +GHSERFE+6*GHSERMN+6*GHSERNB\n -151320;,, N 13Khv1 !\n PAR G(MU_D85,MN:NB:FE:FE),, +8*GHSERFE+GHSERMN+4*GHSERNB\n -86710;,, N 12Liu !\n PAR G(MU_D85,MN:NB:FE:MN),, +2*GHSERFE+7*GHSERMN+4*GHSERNB\n -64610;,, N 12Liu !\n PAR G(MU_D85,MN:NB:NB:FE),, +6*GHSERFE+GHSERMN+6*GHSERNB\n -187070;,, N 13Khv1 !\n PAR G(MU_D85,MN:NB:FE:NB),, +2*GHSERFE+GHSERMN+10*GHSERNB\n +331760;,, N 12Liu !\n PAR G(MU_D85,NB:NB:FE:MN),, +2*GHSERFE+6*GHSERMN+5*GHSERNB\n +31720;,, N 12Liu !\n$\n$ Metastable\n$\n PAR G(SIGMA_D8B,FE:NB:MN),, +10*GFCCFE+4*GHSERNB\n +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,MN:NB:FE),, +10*GFCCMN+4*GHSERNB\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Ni\n$\n$ L. Zhang, Y. Du, H. Xu, S. Liu, Y. Liu, F. Zheng, N. Dupin, H. Zhou, C. Tang,\n$ Int. J. Mater. Res., 100, 160-75(2009).\n$\n$ The only parameter coming from 09Zha is L(CUB_A13,FE,NI:VA;0). We refer to\n$ 09Zha for comparison with their calculations. They used separate 2SL models\n$ for L1_2 (MnNi3 and FeNi3) and L1_0 (MnNi). Here a 4SL fcc model is used.\n$\n$ This dataset nicely reproduces phase diagrams and experimental data shown in\n$ 09Zha (as long as ordered fcc is excluded at high temperature), which\n$ is not quite the case with TCFE8 or steel11h (SGTE).\n$\n$ Using option F for FCC_4SL.\n$\n$ The high temperature problem with FCC_4SL was solved by\n$ changing the UFFENI parameter in the Fe-Ni system. It was then necessary\n$ to add a ternary order parameter to avoid an L1_2 field at 873 K in the\n$ Mn-rich corner.\n$\n$ Using ternary ordering energies reults in L1_0 and L1_2 extending\n$ far into the ternary. When not using option F the extension is considerably\n$ larger.\n$\n$ The problems described below have been solved (by changing UFFENI).\n$\n$ At high temperature (from below solidus up to quite far above liquidus)\n$ L1_2 becomes stable as (Fe,Ni)3Mn from about Fe2.5Ni0.5Mn to FeNi2Mn.\n$ This could be prevented by making FE:FE:MN:NI and NI:NI:FE:MN positive.\n$ The same thing happens when no wildcards are used.\n$\n$ By adding positive values to the ternary compounds the L1_0 and L1_2 phases\n$ near the Mn-Ni edge and, in particular at the Mn corner are stabilised at\n$ low temperature.\n$\n$PAR G(FCC_4SL,FE:FE:MN:NI:VA),, +FFE2MNNI;,, N 16Hal1 !\n$PAR G(FCC_4SL,MN:MN:FE:NI:VA),, +FFEMN2NI;,, N 16Hal1 !\n$PAR G(FCC_4SL,NI:NI:FE:MN:VA),, +FFEMNNI2;,, N 16Hal1 !\n$PAR G(FCC_4SL,FE:FE:MN:NI:VA),, +10*T;,, N 16Hal1 !\n$PAR G(FCC_4SL,MN:MN:FE:NI:VA),, +ZERO;,, N 16Hal1 !\n$PAR G(FCC_4SL,NI:NI:FE:MN:VA),, +10*T;,, N 16Hal1 !\n PAR G(FCC_4SL,MN:MN:FE:NI:VA),, -3000;,, N 16Hal1 !\n$\n FUNCTION FFE2MNNI 298.15 +2*U1FFEMN+2*U1FFENI+U1FMNNI; 6000 N !\n FUNCTION FFEMN2NI 298.15 +2*U1FFEMN+U1FFENI+2*U1FMNNI; 6000 N !\n FUNCTION FFEMNNI2 298.15 +U1FFEMN+2*U1FFENI+2*U1FMNNI; 6000 N !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Si\n$\n$ A. Forsberg, J. Agren, J. Phase Equilib., 14, 354-63(1993).\n$\n$ Checked against paper.\n$\n$ In the paper the ordering of the bcc phase was not\n$ considered. The diagrams were calculated for the disordered phase only.\n$ Ordering increases the size of the bcc/B2 phase field as compared with the\n$ paper. I.e. the system should be reoptimised.\n$\n PAR L(LIQUID,FE,MN,SI;0),, -180473;,, N 93For !\n PAR L(LIQUID,FE,MN,SI;1),, -95027;,, N 93For !\n PAR L(LIQUID,FE,MN,SI;2),, +154386;,, N 93For !\n$\n PAR L(FCC_A1,FE,MN,SI:VA;0),, -56655-55.613*T;,, N 93For !\n PAR TC(FCC_A1,FE,MN,SI:VA;0),, +13854;,, N 93For !\n$\n PAR L(A1_FCC,FE,MN,SI:VA;0),, -56655-55.613*T;,, N 93For !\n PAR TC(A1_FCC,FE,MN,SI:VA;0),, +13854;,, N 93For !\n$\n PAR L(BCC_A2,FE,MN,SI:VA;0),, -97474;,, N 93For !\n PAR L(A2_BCC,FE,MN,SI:VA;0),, -97474;,, N 93For !\n$\n PAR L(HCP_A3,FE,MN,SI:VA;0),, -24892-154.98*T;,, N 93For !\n$\n PAR L(CBCC_A12,FE,MN,SI:VA;0),, -91507;,, N 93For !\n PAR L(CUB_A13,FE,MN,SI:VA;0),, -91507;,, N 93For !\n$\n PAR L(MSI_B20,FE,MN:SI),, -10780+22.14*T;,, N 93For !\n PAR L(M5SI3_D88,FE,MN:SI:VA),, +24568;,, N 93For !\n PAR G(MN3SI,FE,MN:SI),, -16552;,, N 93For !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Ti\n$\n PAR G(SIGMA_D8B,FE:TI:MN),, +10*GFCCFE+4*GBCCTI\n +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,MN:TI:FE),, +10*GFCCMN+4*GBCCTI\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-V\n$\n$ W. Huang, Calphad, 15, 195-208(1991).\n$\n$ Checked against paper.\n$\n$ Old sigma parameters kept for SIGMA_D8B. These give very similar results\n$ in the ternary.\n$\n PAR G(SIGMA_D8B,FE:V:MN),, +10*GFCCFE+4*GHSERVV\n +16*GBCCMN-200000;,, N 91Hua3 !\n PAR G(SIGMA_D8B,MN:V:FE),, +10*GFCCMN+4*GHSERVV\n +16*GHSERFE-150000;,, N 91Hua3 !\n PAR L(SIGMA_D8B,FE:V:MN,V;0),, -100000;,, N 91Hua3 !\n PAR L(SIGMA_D8B,MN:V:FE,V;0),, -300000;,, N 91Hua3 !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-C\n$\n$ J.-O. Andersson, Calphad, 12, 9-23(1988).\n$\n$ Checked against paper.\n$\n$ New models for C14_LAVES, SIGMA_D8B and MU_D85 in Fe-Mo.\n$\n$ Modified bcc interaction. The bcc interaction is based on activity\n$ measurements from Wada and similar to that in the Cr-Fe-C system.\n$\n PAR L(LIQUID,C,FE,MO;0),, -37800;,, N 88And2 !\n$\n$PAR L(BCC_A2,FE,MO:C;0),, -1750000+940*T;,, N 88And2 !\n PAR L(BCC_A2,FE,MO:C;0),, -1250000+667.7*T;,, N 91Lee !\n PAR TC(BCC_A2,FE,MO:C;0),, +335;,, N 88And2 !\n PAR TC(BCC_A2,FE,MO:C;1),, +526;,, N 88And2 !\n$\n PAR L(A2_BCC,FE,MO:C;0),, -1250000+667.7*T;,, N 91Lee !\n PAR TC(A2_BCC,FE,MO:C;0),, +335;,, N 88And2 !\n PAR TC(A2_BCC,FE,MO:C;1),, +526;,, N 88And2 !\n$\n PAR L(FCC_A1,FE,MO:C;0),, +6000;,, N 88And2 !\n PAR L(A1_FCC,FE,MO:C;0),, +6000;,, N 88And2 !\n$\n PAR L(HCP_A3,FE,MO:C;0),, +13030-33.8*T;,, N 88And2 !\n$\n PAR G(KSI_CARBIDE,FE,MO:C),, -380000;,, N 88And2 !\n$\n PAR G(M6C_E93,FE:MO:FE:C),, +4*GHSERFE+2*GHSERMO+GHSERCC\n +77705-101.5*T;,, N 88And2 !\n PAR G(M6C_E93,FE:MO:MO:C),, +2*GHSERFE+4*GHSERMO+GHSERCC\n -122410+30.25*T;,, N 88And2 !\n PAR L(M6C_E93,FE:MO:FE,MO:C;0),, -37700;,, N 88And2 !\n$\n$ metastable\n$\n PAR G(M23C6_D84,FE:MO:C;0),, +20*GHSERFE+3*GHSERMO\n +6*GHSERCC-76351-5.0949*T;,, N 92Qiu2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-N\n$\n$ K. Frisk, Metall. Trans. A, 23A, 1271-78(1992).\n$\n$ Fe-N from 93Du instead of 91Fri.\n$\n$ There is not much to check against, but the N solubility in L is correct.\n$ The phase diagram is complex (above atmospheric pressure) and\n$ the calculation most certainly incorrect.\n$ There are only some N solubility data in the Fe-rich corner.\n$\n PAR L(LIQUID,FE,MO,N;0),, +ZERO;,, N 92Fri2 !\n PAR L(FCC_A1,FE,MO:N;0),, +ZERO;,, N 92Fri2 !\n PAR L(A1_FCC,FE,MO:N;0),, +ZERO;,, N 92Fri2 !\n PAR L(BCC_A2,FE,MO:N;0),, -151200;,, N 92Fri2 !\n PAR L(A2_BCC,FE,MO:N;0),, -151200;,, N 92Fri2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-Nb\n$\n PAR G(SIGMA_D8B,FE:MO:NB),, +10*GFCCFE+4*GHSERMO\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,FE:NB:MO),, +10*GFCCFE+4*GHSERNB\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:NB:FE),, +10*GFCCMO+4*GHSERNB\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-Ni\n$\n$ K. Frisk, Metall. Trans. A, 23A, 639-49(1992).\n$\n$ Checked against paper.\n$\n$ Model for SIGMA changed from 8:4:18 to 10:4:16 and Mo included on first SL.\n$ The SIGMA phase field is more narrow and extends further towards Mo-Ni\n$ at high temperature.\n$\n$ Model for MU changed from 7:2:4 to 1:4:2:6. The MU phase field is slightly\n$ wider, more stable towards low temperature and less stable towards high\n$ temperature (liquidus field almost disappeared).\n$\n$ New end member values for C14_LAVES.\n$\n PAR L(LIQUID,FE,MO,NI;0),, +50000;,, N 92Fri1 !\n$\n PAR L(BCC_A2,FE,MO,NI:VA;0),, -35743;,, N 92Fri1 !\n PAR L(A2_BCC,FE,MO,NI:VA;0),, -35743;,, N 92Fri1 !\n$\n PAR L(FCC_A1,FE,MO,NI:VA;0),, -204791+163.93*T;,, N 92Fri1 !\n PAR L(FCC_A1,FE,MO,NI:VA;1),, +11555-55.81*T;,, N 92Fri1 !\n PAR L(FCC_A1,FE,MO,NI:VA;2),, +77975;,, N 92Fri1 !\n$\n PAR L(A1_FCC,FE,MO,NI:VA;0),, -204791+163.93*T;,, N 92Fri1 !\n PAR L(A1_FCC,FE,MO,NI:VA;1),, +11555-55.81*T;,, N 92Fri1 !\n PAR L(A1_FCC,FE,MO,NI:VA;2),, +77975;,, N 92Fri1 !\n$\n PAR G(MONI,FE:NI:MO),, +6*GFCCFE+5*GHSERNI\n +3*GHSERMO;,, N 92Fri1 !\n PAR G(MONI,NI:FE:MO),, +6*GHSERNI+5*GHSERFE\n +3*GHSERMO;,, N 92Fri1 !\n$\n PAR G(MU_D85,FE:MO:FE:NI),, +GFCCFE+4*GHSERMO+2*GHSERFE\n +6*GHSERNI;,, N Lin !\n PAR G(MU_D85,FE:MO:MO:NI),, +GFCCFE+6*GHSERMO\n +6*GHSERNI+9285-45*T;,, N 17Hal8 !\n PAR G(MU_D85,FE:MO:NI:NI),, +GFCCFE+4*GHSERMO+2*GBCCNI\n +6*GHSERNI;,, N Lin !\n PAR G(MU_D85,FE:MO:NI:FE),, +GFCCFE+4*GHSERMO+2*GBCCNI\n +6*GFCCFE;,, N Lin !\n PAR G(MU_D85,FE:MO:NI:MO),, +GFCCFE+4*GHSERMO+2*GBCCNI\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NI:MO:FE:FE),, +GHSERNI+4*GHSERMO+2*GHSERFE\n +6*GFCCFE;,, N Lin !\n PAR G(MU_D85,NI:MO:FE:MO),, +GHSERNI+4*GHSERMO+2*GHSERFE\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,NI:MO:FE:NI),, +7*GHSERNI+4*GHSERMO\n +2*GHSERFE;,, N Lin !\n PAR G(MU_D85,NI:MO:MO:FE),, +GHSERNI+6*GHSERMO\n +6*GFCCFE-30000;,, N 17Hal8 !\n PAR G(MU_D85,NI:MO:NI:FE),, +GHSERNI+4*GHSERMO+2*GBCCNI\n +6*GFCCFE;,, N Lin !\n$\n PAR G(P_PHASE,FE:NI:MO),, +24*GFCCFE+20*GBCCNI\n +12*GHSERMO;,, N 92Fri1 !\n PAR G(P_PHASE,NI:FE:MO),, +24*GHSERNI+20*GHSERFE\n +12*GHSERMO-170245+100*T;,, N 92Fri1 !\n$\n PAR G(R_PHASE,FE:MO:NI),, +27*GFCCFE+14*GHSERMO\n +12*GBCCNI;,, N 92Fri1 !\n PAR G(R_PHASE,NI:MO:FE),, +27*GHSERNI+14*GHSERMO\n +12*GHSERFE;,, N 92Fri1 !\n$\n PAR G(SIGMA_D8B,FE:MO:NI),, +10*GFCCFE+4*GHSERMO\n +16*GBCCNI+150000;,, N 17Hal8 !\n PAR G(SIGMA_D8B,NI:MO:FE),, +10*GHSERNI+4*GHSERMO\n +16*GHSERFE+150000;,, N 17Hal8 !\n$\n$ Metastable\n$\n PAR G(CHI_A12,FE:MO:NI),, +24*GFCCFE+10*GHSERMO\n +24*GHSERNI;,, N Lin !\n PAR G(CHI_A12,NI:MO:FE),, +24*GHSERNI+10*GHSERMO\n +24*GFCCFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-Si\n$\n PAR G(SIGMA_D8B,FE:MO:SI),, +10*GFCCFE+4*GHSERMO\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-Ti\n$\n$ Modified from Z.-P. Jin and C. Qiu 1993\n$\n$ Z.-P. Jin, C. Qiu, Metall. Trans. A, 24A, 2137-44(1993).\n$\n$ This dataset includes Fe-Ti from 12Bo instead of 89Bal (or 98Dum) and Mo-Ti\n$ from 98Sau instead of 93Jin.\n$\n$ Checked against paper.\n$\n$ Model for MU_D85 changed from 7:2:4 to 1:2:4:6.\n$\n$ Nonstoichiometry added and end member values for C14_LAVES changed.\n$\n$ FeTi is now described as B2_BCC.\n$\n$ Ti added to the sigma model. The Ti solubility in sigma remains small.\n$\n$ There are quite substantial changes of the Laves, mu and FeTi phase fields.\n$\n$ The MU_D85 phase is possibly too stable at high temperature.\n$\n$ The parameter G(MU_D85,FE:TI:TI:FE) was modified to improve the fit in the\n$ Fe-Nb-Ti system. This increases the Ti content in the mu phase.\n$\n$ TCFE8 does not reproduce this system correctly.\n$\n PAR L(C14_LAVES,FE:MO,TI;0),, +10000;,, N 17Hal9 !\n$\n PAR G(MU_D85,FE:MO:TI:FE),, +7*GFCCFE+4*GHSERMO+2*GBCCTI\n -160000;,, N 17Hal9 !\n PAR G(MU_D85,FE:MO:TI:MO),, +GFCCFE+4*GHSERMO+2*GBCCTI\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,FE:TI:FE:MO),, +GFCCFE+4*GBCCTI+2*GHSERFE\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,FE:TI:MO:FE),, +7*GFCCFE+4*GBCCTI+2*GHSERMO\n ;,, N Lin !\n PAR G(MU_D85,FE:TI:MO:MO),, +GFCCFE+4*GBCCTI+2*GHSERMO\n +6*GFCCMO;,, N Lin !\n PAR G(MU_D85,FE:TI:TI:MO),, +GFCCFE+6*GBCCTI\n +6*GFCCMO;,, N Lin !\n$\n PAR G(SIGMA_D8B,FE:MO:TI),, +10*GFCCFE+4*GHSERMO\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,FE:TI:MO),, +10*GFCCFE+4*GBCCTI\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:FE),, +10*GFCCMO+4*GBCCTI\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-V\n$\n PAR G(SIGMA_D8B,FE:MO:V),, +10*GFCCFE+4*GHSERMO\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,FE:V:MO),, +10*GFCCFE+4*GHSERVV\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:FE),, +10*GFCCMO+4*GHSERVV\n +16*GHSERFE;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:FE),, +10*GFCCVV+4*GHSERMO\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-C\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ See also 12Khv2.\n$\n$ Checked against paper.\n$\n$ NbC solubilities in fcc are very similar to 90Hua and somewhat lower than\n$ 01Lee.\n$\n PAR L(FCC_A1,FE,NB:C;0),, -67500+29*T;,, N 05Can !\n PAR L(FCC_A1,FE,NB:C,VA;0),, -40000;,, N 05Can !\n$\n PAR L(A1_FCC,FE,NB:C;0),, -67500+29*T;,, N 05Can !\n PAR L(A1_FCC,FE,NB:C,VA;0),, -40000;,, N 05Can !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-N\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ Same as 01Lee, but with changed Fe-N, Fe-Nb and Nb-N.\n$\n$ Checked against paper.\n$\n PAR L(LIQUID,FE,N,NB;0),, -160000;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-Ni\n$\n PAR G(SIGMA_D8B,FE:NB:NI),, +10*GFCCFE+4*GHSERNB\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:NB:FE),, +10*GHSERNI+4*GHSERNB\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-Si\n$\n$ A. Jacob, unpublished, 2016.\n$\n$ Checked against the dataset from A. Jacob and FeNbSi-16Jac-orig.tdb.\n$\n$ This is a preliminary description of the system, based on the description\n$ presented in the PhD Thesis of A. Jacob.\n$\n$ The parameters for Nb-Si are claimed to be from 09Gen, but the parameters\n$ used by 16Jac are different. Their origin is unclear. Here the published\n$ parameters from 09Gen are used.\n$\n$ Ternary phases and C14 are possibly too stable at high temperature.\n$\n$ Very similar to the original dataset at 1273 and 1473 K. At 1273 the\n$ equilibrium Nb5Si3_D8L + FeNbSi shifts to C14 + FeNb2Si2. At 1473 the\n$ equilibrium Fe4Nb4Si7 + FeNb2Si2 shifts to NbSi2 + Fe3Nb4Si5.\n$ At 2073 K the extension of the liquid in the Si-rich part and the bcc phase\n$ in the Nb-rich part are different, but otherwise differences are very small.\n$\n PAR L(C14_LAVES,FE,SI:NB;0),, -490000;,, N 16Jac2 !\n$\n PAR G(MU_D85,FE:NB:FE:SI),, +3*GHSERFE+4*GHSERNB\n +6*GHSERSI-423669;,, N 16Jac2 !\n PAR G(MU_D85,FE:NB:NB:SI),, +GHSERFE+6*GHSERNB\n +6*GHSERSI-563997;,, N 16Jac2 !\n PAR G(MU_D85,FE:NB:SI:FE),, +7*GHSERFE+4*GHSERNB\n +2*GHSERSI-269490;,, N 16Jac2 !\n PAR G(MU_D85,FE:NB:SI:NB),, +GHSERFE+10*GHSERNB\n +2*GHSERSI+104260;,, N 16Jac2 !\n PAR G(MU_D85,FE:NB:SI:SI),, +GHSERFE+4*GHSERNB\n +8*GHSERSI-324870;,, N 16Jac2 !\n PAR G(MU_D85,NB:NB:FE:SI),, +2*GHSERFE+5*GHSERNB\n +6*GHSERSI-257275;,, N 16Jac2 !\n PAR G(MU_D85,NB:NB:SI:FE),, +6*GHSERFE+5*GHSERNB\n +2*GHSERSI-184730;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:FE:FE),, +8*GHSERFE+4*GHSERNB\n +GHSERSI-211120;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:FE:NB),, +2*GHSERFE+10*GHSERNB\n +GHSERSI+272997;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:FE:SI),, +2*GHSERFE+4*GHSERNB\n +7*GHSERSI-101010;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:NB:FE),, +6*GHSERFE+6*GHSERNB\n +GHSERSI-327728;,, N 16Jac2 !\n PAR G(MU_D85,SI:NB:SI:FE),, +6*GHSERFE+4*GHSERNB\n +3*GHSERSI-489060;,, N 16Jac2 !\n PAR L(MU_D85,FE:NB:NB:FE,SI;0),, -900000;,, N 16Jac2 !\n PAR L(MU_D85,FE:NB:NB:NB,SI;0),, -1000000;,, N 16Jac2 !\n$\n PAR G(FENBSI2,FE:NB:SI),, +GHSERFE+2*GHSERSI+GHSERNB\n -232160+7*T;,, N 16Jac2 !\n PAR G(FE4NB4SI7,FE:NB:SI),, +4*GHSERFE+4*GHSERSI+7*GHSERNB\n -896000+80*T;,, N 16Jac2 !\n PAR G(FENBSI1,FE:NB:SI),, +GHSERFE+GHSERSI+GHSERNB\n -173680-6*T;,, N 16Jac2 !\n PAR G(FENB2SI2,FE:NB:SI),, +GHSERFE+2*GHSERSI+2*GHSERNB\n -327000;,, N 16Jac2 !\n PAR G(FE3NB4SI5,FE:NB:SI),, +3*GHSERFE+5*GHSERSI+4*GHSERNB\n -741000;,, N 16Jac2 !\n PAR G(FENB4SI,FE:NB:SI),, +GHSERFE+GHSERSI+4*GHSERNB\n -174020-45*T;,, N 16Jac2 !\n$\n$ Metastable\n$\n PAR G(SIGMA_D8B,FE:NB:SI),, +10*GFCCFE+4*GHSERNB\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-Ti\n$\n$ B. Hallstedt, unpublished, 2017.\n$\n$ The experimental data from H. Xu et al. (J. Alloys Compd., 396, 151-55(2005))\n$ are roughly reproduced without introducing too many parameters.\n$ The exp. data from C.P. Wang et al. 2011 are considered unreliable, but are\n$ also roughly reproduced.\n$\n$ The liquid is clearly more stable than in the assessment by 11Wan and the\n$ bcc field on the Nb-Ti side is wider.\n$\n PAR G(MU_D85,FE:NB:TI:FE),, +7*GFCCFE+4*GHSERNB\n +2*GBCCTI-200000;,, N 17Hal17 !\n PAR G(MU_D85,FE:NB:TI:NB),, +GFCCFE+4*GHSERNB\n +2*GBCCTI+6*GFCCNB;,, N Lin !\n PAR G(MU_D85,FE:TI:FE:NB),, +GFCCFE+4*GHSERTI\n +2*GHSERFE+6*GFCCNB;,, N Lin !\n PAR G(MU_D85,FE:TI:NB:FE),, +7*GFCCFE+4*GHSERTI\n +2*GHSERNB-200000;,, N 17Hal17 !\n PAR G(MU_D85,FE:TI:NB:NB),, +GFCCFE+4*GHSERTI\n +2*GHSERNB+6*GFCCNB;,, N Lin !\n PAR G(MU_D85,FE:TI:TI:NB),, +GFCCFE+6*GHSERTI+6*GFCCNB;,, N Lin !\n PAR G(MU_D85,NB:NB:TI:FE),, +GFCCNB+4*GHSERNB\n +2*GHSERTI+6*GFCCFE;,, N Lin !\n PAR G(MU_D85,NB:TI:FE:FE),, +GFCCNB+4*GHSERTI\n +2*GHSERFE+6*GFCCFE;,, N Lin !\n PAR G(MU_D85,NB:TI:FE:NB),, +7*GFCCNB+4*GHSERTI\n +2*GHSERFE;,, N Lin !\n PAR G(MU_D85,NB:TI:NB:FE),, +GFCCNB+4*GHSERTI\n +2*GHSERNB+6*GFCCFE;,, N Lin !\n PAR G(MU_D85,NB:TI:TI:FE),, +GFCCNB+6*GHSERTI+6*GFCCFE;,, N Lin !\n$\n$ Metastable\n$\n PAR G(SIGMA_D8B,FE:NB:TI),, +10*GFCCFE+4*GHSERNB\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,FE:TI:NB),, +10*GFCCFE+4*GBCCTI\n +16*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-V\n$\n$ A.V. Khvan, K. Chang, B. Hallstedt, Calphad, 43, 143-48(2013).\n$\n$ Using Fe-Nb with modified MU_D85 from 16Jac1.\n$\n$ Checked against paper.\n$\n$ The ternary MU_D85 parameters were modified to match the change in Fe-Nb.\n$ The Laves phase field is somewhat wider and the Laves+mu+bcc three-phase\n$ triangle is more narrow.\n$\n PAR L(BCC_A2,FE,NB,V:VA;0),, +74752;,, N 13Khv2 !\n PAR L(A2_BCC,FE,NB,V:VA;0),, +74752;,, N 13Khv2 !\n$\n PAR L(C14_LAVES,FE,V:NB;0),, -48522;,, N 13Khv2 !\n$\n PAR G(MU_D85,FE:NB:FE:V),, +3*GHSERFE+4*GHSERNB+6*GHSERVV\n +47813;,, N 13Khv2 !\n PAR G(MU_D85,FE:NB:NB:V),, +GHSERFE+6*GHSERNB+6*GHSERVV\n +25031-67.91*T;,, N 17Hal19 !\n PAR G(MU_D85,FE:NB:V:FE),, +7*GHSERFE+4*GHSERNB+2*GHSERVV\n -178727;,, N 13Khv2 !\n PAR G(MU_D85,FE:NB:V:NB),, +GHSERFE+10*GHSERNB+2*GHSERVV\n +485717;,, N 13Khv2 !\n PAR G(MU_D85,FE:NB:V:V),, +GHSERFE+4*GHSERNB+8*GHSERVV\n -2242;,, N 13Khv2 !\n PAR G(MU_D85,NB:NB:FE:V),, +2*GHSERFE+5*GHSERNB+6*GHSERVV\n +193815;,, N 13Khv2 !\n PAR G(MU_D85,NB:NB:V:FE),, +6*GHSERFE+5*GHSERNB+2*GHSERVV\n -96693;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:FE:FE),, +8*GHSERFE+4*GHSERNB+GHSERVV\n -101302;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:FE:NB),, +2*GHSERFE+10*GHSERNB+GHSERVV\n +476515;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:FE:V),, +2*GHSERFE+4*GHSERNB+7*GHSERVV\n +106683;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:NB:FE),, +6*GHSERFE+6*GHSERNB+GHSERVV\n -152878;,, N 13Khv2 !\n PAR G(MU_D85,V:NB:V:FE),, +6*GHSERFE+4*GHSERNB+3*GHSERVV\n -185453;,, N 13Khv2 !\n PAR L(MU_D85,FE:NB:NB:FE,V;0),, -55000;,, N 17Hal19 !\n$\n PAR G(SIGMA_D8B,FE:NB:V),, +10*GHSERFE+4*GHSERNB\n +16*GHSERVV-368205;,, N 13Khv2 !\n PAR G(SIGMA_D8B,FE:V:NB),, +10*GHSERFE+4*GHSERVV\n +16*GHSERNB+463349;,, N 13Khv2 !\n$PAR G(SIGMA_D8B,NB:V:FE),, +10*GFCCNB+4*GHSERVV\n$ +16*GHSERFE;,, N 13Khv2 !\n PAR G(SIGMA_D8B,V:NB:FE),, +10*GHSERVV+4*GHSERNB\n +16*GHSERFE+81731;,, N 13Khv2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni-C\n$\n$ A. Gabriel, P. Gustafson, I. Ansara, Calphad, 11, 203-18(1987).\n$\n$ Checked against paper. Wrong sign for L(BCC_A2,FE,NI:C;0) in paper.\n$\n$ The hcp interaction should probably not be the same as the fcc interaction.\n$\n$ New cementite in Fe-C from 10Hal.\n$ Fe-Ni liquid modified by 93Lee1 and fcc ordering added by 03Dup.\n$ Ni-C modified by 06Hal2.\n$\n PAR L(LIQUID,C,FE,NI;0),, +122200-58.8*T;,, N 87Gab !\n PAR L(LIQUID,C,FE,NI;1),, +92200-58.8*T;,, N 87Gab !\n PAR L(LIQUID,C,FE,NI;2),, +152200-58.8*T;,, N 87Gab !\n$\n PAR L(FCC_A1,FE,NI:C;0),, +49074-7.32*T;,, N 87Gab !\n PAR L(FCC_A1,FE,NI:C;1),, -25800;,, N 87Gab !\n$\n PAR L(A1_FCC,FE,NI:C;0),, +49074-7.32*T;,, N 87Gab !\n PAR L(A1_FCC,FE,NI:C;1),, -25800;,, N 87Gab !\n$\n PAR L(BCC_A2,FE,NI:C;0),, -956.63-1.28726*T;,, N 87Gab !\n PAR L(BCC_A2,FE,NI:C;1),, +1789.03-1.92912*T;,, N 87Gab !\n$\n PAR L(A2_BCC,FE,NI:C;0),, -956.63-1.28726*T;,, N 87Gab !\n PAR L(A2_BCC,FE,NI:C;1),, +1789.03-1.92912*T;,, N 87Gab !\n$\n PAR L(CEMENTITE_D011,FE,NI:C;0),, +29400;,, N 87Gab !\n$\n$ Metastable\n$\n$PAR L(HCP_A3,FE,NI:C;0),, +49074-7.32*T;,, N Same !\n$PAR L(HCP_A3,FE,NI:C;1),, -25800;,, N Same !\n$\n PAR G(M23C6_D84,FE:NI:C),, +0.869565*GFE23C6\n +0.130435*GNI23C6;,, N 91Lee !\n PAR G(M23C6_D84,NI:FE:C),, +0.869565*GNI23C6\n +0.130435*GFE23C6;,, N 91Lee !\n PAR L(M23C6_D84,FE,NI:FE:C;0),, +196000;,, N 91Lee !\n PAR L(M23C6_D84,FE,NI:NI:C;0),, +196000;,, N 91Lee !\n$\n PAR L(M7C3_D101,FE,NI:C;0),, +68600;,, N 91Lee !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni-N\n$\n$ K. Frisk, Z. Metallkd., 82, 59-66(1991).\n$\n$ Checked against paper.\n$\n$ Using Fe-N from 93Du instead of 91Fri.\n$\n$ The fcc+Fe4N+hcp equilibrium is located at lower Ni content at 773K, but this\n$ is at high P(N2) and there are no exp. data.\n$\n PAR L(FCC_A1,FE,NI:N;0),, -22710+5.19*T;,, N 91Fri2 !\n PAR L(FCC_A1,FE,NI:N;1),, +3334;,, N 91Fri2 !\n$\n PAR L(A1_FCC,FE,NI:N;0),, -22710+5.19*T;,, N 91Fri2 !\n PAR L(A1_FCC,FE,NI:N;1),, +3334;,, N 91Fri2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni-Si\n$\n$ B. Hallstedt, unpublished, 2008.\n$\n$ Reoptimised against fcc, bcc and liquid data.\n$\n$ The fcc+bcc+Liq equilibrium at 1373 K is at higher Ni content and a bit\n$ rotated compared to 99Mie.\n$\n$ This evaluation only contains the liquid, fcc and bcc interactions. Fcc and\n$ bcc ordering and ternary solubilities in the silicides and possible\n$ ternary silicides remains to be done.\n$\n$ The extension of the Ni3Si (FCC_4SL) phase field seems reasonable.\n$\n$ FE2SI and NI2SI_THETA might have the same structure.\n$\n PAR L(LIQUID,FE,NI,SI;0),, -101000;,, N 08Hal1 !\n PAR L(LIQUID,FE,NI,SI;1),, +31000;,, N 08Hal1 !\n PAR L(LIQUID,FE,NI,SI;2),, +ZERO;,, N 08Hal1 !\n$\n PAR L(FCC_A1,FE,NI,SI:VA;0),, -112000-22*T;,, N 08Hal1 !\n PAR L(FCC_A1,FE,NI,SI:VA;1),, -15000-22*T;,, N 08Hal1 !\n PAR L(FCC_A1,FE,NI,SI:VA;2),, -22*T;,, N 08Hal1 !\n$\n PAR L(A1_FCC,FE,NI,SI:VA;0),, -112000-22*T;,, N 08Hal1 !\n PAR L(A1_FCC,FE,NI,SI:VA;1),, -15000-22*T;,, N 08Hal1 !\n PAR L(A1_FCC,FE,NI,SI:VA;2),, -22*T;,, N 08Hal1 !\n$\n PAR L(BCC_A2,FE,NI,SI:VA;0),, -158000;,, N 08Hal1 !\n PAR L(BCC_A2,FE,NI,SI:VA;1),, -72000;,, N 08Hal1 !\n PAR L(BCC_A2,FE,NI,SI:VA;2),, +ZERO;,, N 08Hal1 !\n$\n PAR L(A2_BCC,FE,NI,SI:VA;0),, -158000;,, N 08Hal1 !\n PAR L(A2_BCC,FE,NI,SI:VA;1),, -72000;,, N 08Hal1 !\n PAR L(A2_BCC,FE,NI,SI:VA;2),, +ZERO;,, N 08Hal1 !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni-Ti\n$\n PAR G(SIGMA_D8B,FE:TI:NI),, +10*GFCCFE+4*GBCCTI\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:FE),, +10*GHSERNI+4*GBCCTI\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Ni-V\n$\n PAR G(SIGMA_D8B,FE:V:NI),, +10*GFCCFE+4*GHSERVV\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:FE),, +10*GHSERNI+4*GHSERVV\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Si-C\n$\n$ J. Miettinen, Calphad 22, 231-56(1998).\n$\n PAR L(LIQUID,C,FE,SI;0),, +400000;,, N 98Mie !\n PAR L(LIQUID,C,FE,SI;1),, -55000;,, N 98Mie !\n PAR L(LIQUID,C,FE,SI;2),, +450000;,, N 98Mie !\n$\n PAR L(FCC_A1,FE,SI:C;0),, +226100-34.25*T;,, N 98Mie !\n PAR L(FCC_A1,FE,SI:C;1),, -202400;,, N 98Mie !\n$\n PAR L(A1_FCC,FE,SI:C;0),, +226100-34.25*T;,, N 98Mie !\n PAR L(A1_FCC,FE,SI:C;1),, -202400;,, N 98Mie !\n$\n PAR L(BCC_A2,FE,SI:C;0),, +1000000-100*T;,, N 98Mie !\n PAR L(BCC_A2,FE,SI:C;1),, -900000;,, N 98Mie !\n$\n PAR L(A2_BCC,FE,SI:C;0),, +1000000-100*T;,, N 98Mie !\n PAR L(A2_BCC,FE,SI:C;1),, -900000;,, N 98Mie !\n$\n PAR G(FE8SI2C,FE:SI:C),, +8*GHSERFE+2*GHSERSI+GHSERCC\n -231047+5.566*T;,, N 91Lac !\n$ ------------------------------------------------------------------------------\n$ Fe-Si-N\n$\n$ No assessment\n$\n$ ------------------------------------------------------------------------------\n$ Fe-Si-Ti\n$\n PAR G(SIGMA_D8B,FE:TI:SI),, +10*GFCCFE+4*GBCCTI\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Si-V\n$\n$ No assessment\n$\n PAR G(SIGMA_D8B,FE:V:SI),, +10*GFCCFE+4*GHSERVV\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-Ti-C\n$\n$ L.F.S. Dumitrescu, M. Hillert, ISIJ Int., 39, 84-90(1999).\n$\n$ Using Fe-Ti from 12Bo instead of 98Dum.\n$\n$ Checked against paper.\n$\n$ Isothermal sections are ok. The Fe-TiC vertical section in the paper is\n$ incorrect (fcc#1 is missing). The liquidus is ok though.\n$\n$ The TiC solubility in fcc-Fe is lower than 99Dum (orig) and even slightly\n$ lower than with 01Lee (orig).\n$\n$ The liquid interaction was adjusted to match data on the TiC liquidus.\n$\n$PAR L(LIQUID,C,FE,TI;0),, -123670;,, N 99Dum2 !\n PAR L(LIQUID,C,FE,TI;0),, -146600;,, N 17Hal3 !\n$\n PAR L(FCC_A1,FE,TI:C,VA;0),, +ZERO;,, N 99Dum2 !\n PAR L(FCC_A1,FE,TI:C,VA;1),, +258879;,, N 99Dum2 !\n PAR L(FCC_A1,FE,TI:C,VA;2),, -258879;,, N 99Dum2 !\n$\n PAR L(A1_FCC,FE,TI:C,VA;0),, +ZERO;,, N 99Dum2 !\n PAR L(A1_FCC,FE,TI:C,VA;1),, +258879;,, N 99Dum2 !\n PAR L(A1_FCC,FE,TI:C,VA;2),, -258879;,, N 99Dum2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Ti-N\n$\n$ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001).\n$\n$ Using Fe-Ti from 12Bo instead of 98Dum and Fe-N from 93Du instead of 91Fri.\n$\n$ Checked against paper.\n$\n$ The TiN solubility in fcc-Fe is somewhat lower than the original 01Lee.\n$\n$ The TiN solubility in fcc-Fe in TCFE8 is the same as in 99Dum and\n$ 01Lee (orig).\n$\n$ Ternary liquid interaction removed. It has a very small influence in the\n$ Fe corner, but causes a large N-solubility in the Fe-Ti liquid. This\n$ does not seem probable.\n$\n$PAR L(LIQUID,FE,N,TI;0),, -300000;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Fe-Ti-V\n$\n PAR G(SIGMA_D8B,FE:TI:V),, +10*GFCCFE+4*GBCCTI\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,FE:V:TI),, +10*GFCCFE+4*GHSERVV\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:FE),, +10*GFCCVV+4*GBCCTI\n +16*GHSERFE;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Fe-V-C\n$\n$ W. Huang, Z. Metallkd., 82, 391-401(1991).\n$\n$ Checked against paper.\n$\n$ In the original assessment V3C2 is modelled without Fe solubility.\n$ Cementite (V3C) was modified in 91Fer and used in 91Hua4.\n$\n PAR L(LIQUID,C,FE,V;0),, -60000;,, N 91Hua2 !\n PAR L(LIQUID,C,FE,V;1),, -60000;,, N 91Hua2 !\n PAR L(LIQUID,C,FE,V;2),, +100000;,, N 91Hua2 !\n$\n PAR L(FCC_A1,FE,V:C;0),, -7645.5-2.069*T;,, N 91Hua2 !\n PAR L(FCC_A1,FE,V:C;1),, -7645.5-2.069*T;,, N 91Hua2 !\n PAR L(FCC_A1,FE,V:C,VA;0),, -40000;,, N 91Hua2 !\n$\n PAR L(A1_FCC,FE,V:C;0),, -7645.5-2.069*T;,, N 91Hua2 !\n PAR L(A1_FCC,FE,V:C;1),, -7645.5-2.069*T;,, N 91Hua2 !\n PAR L(A1_FCC,FE,V:C,VA;0),, -40000;,, N 91Hua2 !\n$\n PAR L(BCC_A2,FE,V:C;0),, -23674+0.465*T;,, N 91Hua2 !\n PAR L(BCC_A2,FE,V:C;1),, +8283;,, N 91Hua2 !\n$\n PAR L(A2_BCC,FE,V:C;0),, -23674+0.465*T;,, N 91Hua2 !\n PAR L(A2_BCC,FE,V:C;1),, +8283;,, N 91Hua2 !\n$\n PAR L(HCP_A3,FE,V:C;0),, -15291-4.138*T;,, N 91Hua2 !\n$\n$PAR L(CEMENTITE_D011,FE,V:C;0),, -45657-12.414*T;,, N 91Hua2 !\n PAR L(CEMENTITE_D011,FE,V:C;0),, -45873-12.414*T;,, N 91Hua4 !\n$\n$ Metastable\n$\n PAR G(M23C6_D84,FE:V:C),, +0.869565*GFE23C6\n +0.130435*GV23C6;,, N 91Hua4 !\n PAR G(M23C6_D84,V:FE:C),, +0.869565*GV23C6\n +0.130435*GFE23C6;,, N 91Hua4 !\n$ ------------------------------------------------------------------------------\n$ Fe-V-N\n$\n$ H. Ohtani, M. Hillert, Calphad, 15, 25-39(1991).\n$\n$ Checked against paper.\n$\n$ Using Fe-N from 93Du instead of 91Fri.\n$\n$ No visible difference except Fe-solubility in VN at very high temperature,\n$ which is now lower.\n$\n PAR L(LIQUID,FE,N,V;0),, -228000;,, N 91Oht2 !\n PAR L(LIQUID,FE,N,V;1),, +3600000;,, N 91Oht2 !\n PAR L(LIQUID,FE,N,V;2),, +104000;,, N 91Oht2 !\n$\n PAR L(FCC_A1,FE,V:N;0),, -60000;,, N 91Oht2 !\n PAR L(FCC_A1,FE,V:N,VA;0),, -120000;,, N 91Oht2 !\n$\n PAR L(A1_FCC,FE,V:N;0),, -60000;,, N 91Oht2 !\n PAR L(A1_FCC,FE,V:N,VA;0),, -120000;,, N 91Oht2 !\n$ ------------------------------------------------------------------------------\n$ Mg-C-N\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-C\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-Mo\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-N\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-Nb\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-Ni\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-Si\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-Ti\n$ ------------------------------------------------------------------------------\n$ Mg-Mn-V\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-C\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-N\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-Nb\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-Ni\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-Si\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-Ti\n$ ------------------------------------------------------------------------------\n$ Mg-Mo-V\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-C\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-N\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-Ni\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-Si\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-Ti\n$ ------------------------------------------------------------------------------\n$ Mg-Nb-V\n$ ------------------------------------------------------------------------------\n$ Mg-Ni-C\n$ ------------------------------------------------------------------------------\n$ Mg-Ni-N\n$ ------------------------------------------------------------------------------\n$ Mg-Ni-Si\n$ ------------------------------------------------------------------------------\n$ Mg-Ni-Ti\n$ ------------------------------------------------------------------------------\n$ Mg-Ni-V\n$ ------------------------------------------------------------------------------\n$ Mg-Si-C\n$ ------------------------------------------------------------------------------\n$ Mg-Si-N\n$ ------------------------------------------------------------------------------\n$ Mg-Si-Ti\n$ ------------------------------------------------------------------------------\n$ Mg-Si-V\n$ ------------------------------------------------------------------------------\n$ Mg-Ti-C\n$ ------------------------------------------------------------------------------\n$ Mg-Ti-N\n$ ------------------------------------------------------------------------------\n$ Mg-Ti-V\n$ ------------------------------------------------------------------------------\n$ Mg-V-C\n$ ------------------------------------------------------------------------------\n$ Mg-V-N\n$ ------------------------------------------------------------------------------\n$ Mn-C-N\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-C\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-N\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-Nb\n$\n PAR G(SIGMA_D8B,MN:MO:NB),, +10*GFCCMN+4*GHSERMO\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,MN:NB:MO),, +10*GFCCMN+4*GHSERNB\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:NB:MN),, +10*GFCCMO+4*GHSERNB\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-Ni\n$\n PAR G(R_PHASE,NI:MO:MN),, +27*GHSERNI+14*GHSERMO\n +12*GBCCMN;,, N Lin !\n PAR G(R_PHASE,MN:MO:NI),, +27*GFCCMN+14*GHSERMO\n +12*GBCCNI;,, N Lin !\n$\n PAR G(SIGMA_D8B,MN:MO:NI),, +10*GFCCMN+4*GHSERMO\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:MO:MN),, +10*GHSERNI+4*GHSERMO\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-Si\n$\n PAR G(SIGMA_D8B,MN:MO:SI),, +10*GFCCMN+4*GHSERMO\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-Ti\n$\n PAR G(SIGMA_D8B,MN:MO:TI),, +10*GFCCMN+4*GHSERMO\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MN:TI:MO),, +10*GFCCMN+4*GBCCTI\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:MN),, +10*GFCCMO+4*GBCCTI\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Mo-V\n$\n PAR G(SIGMA_D8B,MN:MO:V),, +10*GFCCMN+4*GHSERMO\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MN:V:MO),, +10*GFCCMN+4*GHSERVV\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:MN),, +10*GFCCMO+4*GHSERVV\n +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:MN),, +10*GFCCVV+4*GHSERMO\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-C\n$\n$ A.V. Khvan, B. Hallstedt, K. Chang, Calphad, 39, 54-61(2012).\n$\n$ Checked against paper.\n$\n PAR G(M23C6_D84,MN:NB:C),, +0.8695652*GMN23C6\n +3*GHSERNB+0.7826087*GHSERCC-130000;,, N 12Khv1 !\n$PAR G(M23C6_D84,NB:MN:C),, +UN_ASS;,, N !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-N\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ No parameters for this system. Checked against paper.\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-Ni\n$\n PAR G(SIGMA_D8B,MN:NB:NI),, +10*GFCCMN+4*GHSERNB\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:NB:MN),, +10*GHSERNI+4*GHSERNB\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-Si\n$\n PAR G(SIGMA_D8B,MN:NB:SI),, +10*GFCCMN+4*GHSERNB\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-Ti\n$\n PAR G(SIGMA_D8B,MN:NB:TI),, +10*GFCCMN+4*GHSERNB\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MN:TI:NB),, +10*GFCCMN+4*GBCCTI\n +16*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Nb-V\n$\n$ Metastable\n$\n PAR G(SIGMA_D8B,MN:NB:V),, +10*GFCCMN+4*GHSERNB\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MN:V:NB),, +10*GFCCMN+4*GHSERVV\n +16*GHSERNB;,, N Lin !\n$PAR G(SIGMA_D8B,NB:V:MN),, +10*GFCCNB+4*GHSERVV\n$ +16*GBCCMN;,, N Lin !\n PAR G(SIGMA_D8B,V:NB:MN),, +10*GFCCVV+4*GHSERNB\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Ni-C\n$\n$ Not yet modelled.\n$\n$ ------------------------------------------------------------------------------\n$ Mn-Ni-N\n$ ------------------------------------------------------------------------------\n$ Mn-Ni-Si\n$ ------------------------------------------------------------------------------\n$ Mn-Ni-Ti\n$\n PAR G(SIGMA_D8B,MN:TI:NI),, +10*GFCCMN+4*GBCCTI\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:MN),, +10*GHSERNI+4*GBCCTI\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Ni-V\n$\n PAR G(SIGMA_D8B,MN:V:NI),, +10*GFCCMN+4*GHSERVV\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:MN),, +10*GHSERNI+4*GHSERVV\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Si-C\n$ ------------------------------------------------------------------------------\n$ Mn-Si-N\n$ ------------------------------------------------------------------------------\n$ Mn-Si-Ti\n$\n PAR G(SIGMA_D8B,MN:TI:SI),, +10*GFCCMN+4*GBCCTI\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Si-V\n$\n PAR G(SIGMA_D8B,MN:V:SI),, +10*GFCCMN+4*GHSERVV\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-Ti-C\n$ ------------------------------------------------------------------------------\n$ Mn-Ti-N\n$ ------------------------------------------------------------------------------\n$ Mn-Ti-V\n$\n PAR G(SIGMA_D8B,MN:TI:V),, +10*GFCCMN+4*GBCCTI\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MN:V:TI),, +10*GFCCMN+4*GHSERVV\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:MN),, +10*GFCCVV+4*GBCCTI\n +16*GBCCMN;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mn-V-C\n$\n$ A. Fernandez Guillermet, W. Huang, Int. J. Thermophys., 12, 1077-1102(1991).\n$\n$ Checked against paper.\n$\n$ Using Mn-C from 10Dju instead of 90Hua.\n$\n$ The Mn solubility in VC is slightly higher and the Mn solubility in V3C2 is\n$ slightly lower than in the original 91Fer dataset. Liquidus temperatures\n$ are somewhat lower (at least in the Mn-rich corner). There are no\n$ experimental to support one or the other.\n$\n PAR L(BCC_A2,MN,V:C;0),, -10000;,, N 91Fer2 !\n PAR L(A2_BCC,MN,V:C;0),, -10000;,, N 91Fer2 !\n PAR L(CBCC_A12,MN,V:C;0),, -22225.2;,, N 91Hua4 !\n PAR L(CUB_A13,MN,V:C;0),, -17724;,, N 91Hua4 !\n$\n PAR G(M23C6_D84,MN:V:C),, +0.869565*GMN23C6\n +0.130435*GV23C6;,, N 91Fer2 !\n PAR G(M23C6_D84,V:MN:C),, +0.869565*GV23C6\n +0.130435*GMN23C6;,, N 91Fer2 !\n$ ------------------------------------------------------------------------------\n$ Mn-V-N\n$ ------------------------------------------------------------------------------\n$ Mo-C-N\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-C\n$\n$ C. Zhang, Y. Peng, P. Zhou, W. Zhang, Y. Du, Calphad, 51, 104-10(2015).\n$\n$ Checked against paper and author's tdb.\n$\n$ Using Nb-C from 01Lee instead of 97Hua.\n$\n$ Some interactions (in particular liquid) have very large temperature\n$ dependencies. The bcc interaction seems questionable.\n$\n$ With the new Nb-C the bcc+Nb2C+NbC triangle is shifted towards lower Mo\n$ content. The change in Nb2C and MC composition is small. The mutual\n$ solubilities in Mo2C and Nb2C are somewhat lower. The C-content of the low-C\n$ phase boundary of Nb-rich MC is higher. Mo2C is not more present at 2640°C.\n$ There are changes in the 32.15 at.%C vertical section.\n$\n$ This system should be remodelled. A pop-file is provided by 15Zha1.\n$\n PAR L(LIQUID,C,MO,NB;0),, -904983.51+150*T;,, N 15Zha1 !\n PAR L(LIQUID,C,MO,NB;1),, -554680.05+150*T;,, N 15Zha1 !\n PAR L(LIQUID,C,MO,NB;2),, +228894.03+41.142*T;,, N 15Zha1 !\n$\n PAR L(FCC_A1,MO,NB:C;0),, -84005.09+29.061*T;,, N 15Zha1 !\n PAR L(FCC_A1,MO,NB:C;1),, +153432.08-39.012*T;,, N 15Zha1 !\n PAR L(FCC_A1,MO,NB:C;2),, -6461.64;,, N 15Zha1 !\n PAR L(FCC_A1,MO,NB:C,VA;0),, +ZERO;,, N 15Zha1 !\n PAR L(FCC_A1,MO,NB:C,VA;1),, -200000;,, N 15Zha1 !\n PAR L(FCC_A1,MO,NB:C,VA;2),, -200000;,, N 15Zha1 !\n$\n PAR L(BCC_A2,MO,NB:C;0),, +500000+200*T;,, N 15Zha1 !\n$\n PAR L(HCP_A3,MO,NB:C;0),, -3348;,, N 15Zha1 !\n PAR L(HCP_A3,MO,NB:C;1),, -15187.77-8.966*T;,, N 15Zha1 !\n PAR L(HCP_A3,MO,NB:C;2),, -104585.7+42.823*T;,, N 15Zha1 !\n PAR L(HCP_A3,MO,NB:C,VA;0),, +20000;,, N 15Zha1 !\n$\n PAR L(MC_ETA,MO,NB:C;0),, -204000;,, N 15Zha1 !\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-N\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-Ni\n$\n PAR G(SIGMA_D8B,MO:NB:NI),, +10*GFCCMO+4*GHSERNB\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:MO:NB),, +10*GHSERNI+4*GHSERMO\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,NI:NB:MO),, +10*GHSERNI+4*GHSERNB\n +16*GHSERMO;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-Si\n$\n PAR G(SIGMA_D8B,MO:NB:SI),, +10*GFCCMO+4*GHSERNB\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-Ti\n$\n PAR G(SIGMA_D8B,MO:NB:TI),, +10*GFCCMO+4*GHSERNB\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,MO:TI:NB),, +10*GFCCMO+4*GBCCTI\n +16*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Nb-V\n$\n PAR G(SIGMA_D8B,MO:NB:V),, +10*GFCCMO+4*GHSERNB\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:NB),, +10*GFCCMO+4*GHSERVV\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:NB),, +10*GFCCVV+4*GHSERMO\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,V:NB:MO),, +10*GFCCVV+4*GHSERNB\n +16*GHSERMO;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Ni-C\n$ ------------------------------------------------------------------------------\n$ Mo-Ni-N\n$ ------------------------------------------------------------------------------\n$ Mo-Ni-Si\n$\n PAR G(SIGMA_D8B,NI:MO:SI),, +10*GHSERNI+4*GHSERMO\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Ni-Ti\n$\n PAR G(SIGMA_D8B,MO:TI:NI),, +10*GFCCMO+4*GBCCTI\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:MO:TI),, +10*GHSERNI+4*GHSERMO\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:MO),, +10*GHSERNI+4*GBCCTI\n +16*GHSERMO;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Ni-V\n$\n PAR G(SIGMA_D8B,MO:V:NI),, +10*GFCCMO+4*GHSERVV\n +16*GBCCNI;,, N Lin !\n PAR G(SIGMA_D8B,NI:MO:V),, +10*GHSERNI+4*GHSERMO\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:MO),, +10*GHSERNI+4*GHSERVV\n +16*GHSERMO;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:NI),, +10*GFCCVV+4*GHSERMO\n +16*GBCCNI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Si-C\n$ ------------------------------------------------------------------------------\n$ Mo-Si-N\n$ ------------------------------------------------------------------------------\n$ Mo-Si-Ti\n$\n PAR G(SIGMA_D8B,MO:TI:SI),, +10*GFCCMO+4*GBCCTI\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Si-V\n$\n PAR G(SIGMA_D8B,MO:V:SI),, +10*GFCCMO+4*GHSERVV\n +16*GBCCSI;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:SI),, +10*GFCCVV+4*GHSERMO\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-Ti-C\n$\n$ Modified from J.-H. Shim et al. 1996\n$\n$ J.-H. Shim, C.-S. Oh, D.N. Lee, Metall. Mater. Trans. B, 27B, 955-66(1996).\n$\n$ This dataset includes Ti-C from 98Dum instead of 96Jon and Mo-Ti from\n$ 98Sau instead of 96Shi. The negative L(BCC_A2,MO:C,VA;0) introduced by 96Shi\n$ is partly removed.\n$\n$ Checked against paper.\n$\n$ There are changes compared to 96Shi, but not too drastic. The C solubility\n$ in bcc is somewhat lower to be more compatible with data from Mo-C.\n$\n PAR L(LIQUID,C,MO,TI;0),, -379405;,, N 96Shi !\n PAR L(LIQUID,C,MO,TI;1),, -15909;,, N 96Shi !\n PAR L(LIQUID,C,MO,TI;2),, -111135;,, N 96Shi !\n$\n PAR L(BCC_A2,MO,TI:C;0),, -459700;,, N 96Shi !\n PAR L(BCC_A2,MO,TI:C,VA;0),, -250000;,, N 15Hal1 !\n$\n PAR L(A2_BCC,MO,TI:C;0),, -459700;,, N 96Shi !\n PAR L(A2_BCC,MO,TI:C,VA;0),, -250000;,, N 15Hal1 !\n$\n PAR L(FCC_A1,MO,TI:C;0),, +32845-27.218*T;,, N 96Shi !\n PAR L(A1_FCC,MO,TI:C;0),, +32845-27.218*T;,, N 96Shi !\n$\n$PAR L(HCP_A3,MO,TI:C;0),, -15349.5;,, N 96Shi !\n PAR L(HCP_A3,MO,TI:C;0),, +ZERO;,, N 15Hal1 !\n$\n$PAR L(MC_ETA,MO,TI:C;0),, -110500;,, N 96Shi !\n PAR L(MC_ETA,MO,TI:C;0),, -90000;,, N 15Hal1 !\n$ ------------------------------------------------------------------------------\n$ Mo-Ti-N\n$ ------------------------------------------------------------------------------\n$ Mo-Ti-V\n$\n PAR G(SIGMA_D8B,MO:TI:V),, +10*GFCCMO+4*GBCCTI\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,MO:V:TI),, +10*GFCCMO+4*GHSERVV\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:MO:TI),, +10*GFCCVV+4*GHSERMO\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:MO),, +10*GFCCVV+4*GBCCTI\n +16*GHSERMO;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Mo-V-C\n$\n$ J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002).\n$\n PAR L(LIQUID,C,MO,V;0),, +120000;,, N 02Bra !\n$\n PAR L(BCC_A2,MO,V:C;0),, +330000;,, N 02Bra !\n PAR L(A2_BCC,MO,V:C;0),, +330000;,, N 02Bra !\n PAR L(FCC_A1,MO,V:C;0),, -28000;,, N 02Bra !\n PAR L(A1_FCC,MO,V:C;0),, -28000;,, N 02Bra !\n PAR L(HCP_A3,MO,V:C;0),, -30000;,, N 02Bra !\n PAR L(MC_ETA,MO,V:C;0),, -70000;,, N 02Bra !\n$ ------------------------------------------------------------------------------\n$ Mo-V-N\n$ ------------------------------------------------------------------------------\n$ Nb-C-N\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ Same as Lee 2001, but with a modified Nb-N.\n$\n$ Checked against paper.\n$\n$ This assessement shows better agreement with N2 pressure data than Nb-C-N\n$ from W. Huang 1997.\n$\n PAR L(FCC_A1,NB:C,N;0),, +12.5922*T;,, N 01Lee !\n PAR L(FCC_A1,NB:C,N,VA;0),, +ZERO;,, N 01Lee !\n PAR L(FCC_A1,NB:C,N,VA;1),, +ZERO;,, N 01Lee !\n PAR L(FCC_A1,NB:C,N,VA;2),, -312985;,, N 01Lee !\n$\n PAR L(A1_FCC,NB:C,N;0),, +12.5922*T;,, N 01Lee !\n PAR L(A1_FCC,NB:C,N,VA;0),, +ZERO;,, N 01Lee !\n PAR L(A1_FCC,NB:C,N,VA;1),, +ZERO;,, N 01Lee !\n PAR L(A1_FCC,NB:C,N,VA;2),, -312985;,, N 01Lee !\n$\n PAR L(HCP_A3,NB:C,N;0),, -15000;,, N 01Lee !\n PAR L(HCP_A3,NB:C,N,VA;0),, -30000;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Nb-Ni-C\n$ ------------------------------------------------------------------------------\n$ Nb-Ni-N\n$ ------------------------------------------------------------------------------\n$ Nb-Ni-Si\n$\n PAR G(SIGMA_D8B,NI:NB:SI),, +10*GHSERNI+4*GHSERNB\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-Ni-Ti\n$\n PAR G(SIGMA_D8B,NI:NB:TI),, +10*GHSERNI+4*GHSERNB\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,NI:TI:NB),, +10*GHSERNI+4*GBCCTI\n +16*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-Ni-V\n$\n PAR G(SIGMA_D8B,NI:NB:V),, +10*GHSERNI+4*GHSERNB\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:NB),, +10*GHSERNI+4*GHSERVV\n +16*GHSERNB;,, N Lin !\n PAR G(SIGMA_D8B,V:NB:NI),, +10*GFCCVV+4*GHSERNB\n +16*GBCCNI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-Si-C\n$ ------------------------------------------------------------------------------\n$ Nb-Si-N\n$ ------------------------------------------------------------------------------\n$ Nb-Si-Ti\n$ ------------------------------------------------------------------------------\n$ Nb-Si-V\n$\n PAR G(SIGMA_D8B,V:NB:SI),, +10*GFCCVV+4*GHSERNB\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-Ti-C\n$\n$ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001).\n$\n$ Checked against paper.\n$\n$ Nb-Ti from 01Zha instead of 98Sau.\n$\n$ There is a slight shift of the MC end point of the bcc+Nb2C+MC equilibrium.\n$\n PAR L(LIQUID,C,NB,TI;0),, +140812;,, N 01Lee !\n$\n PAR L(FCC_A1,NB,TI:C;0),, -33979;,, N 01Lee !\n PAR L(FCC_A1,NB,TI:C,VA;0),, +97661;,, N 01Lee !\n$\n PAR L(A1_FCC,NB,TI:C;0),, -33979;,, N 01Lee !\n PAR L(A1_FCC,NB,TI:C,VA;0),, +97661;,, N 01Lee !\n$\n PAR L(HCP_A3,NB,TI:C;0),, -10739+13.0928*T;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Nb-Ti-N\n$\n$ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001).\n$\n$ Checked against paper.\n$\n$ Nb-N from 13Khv instead of 96Hua.\n$ Nb-Ti from 01Zha instead of 98Sau.\n$\n$ There are slight shifts of the phase boundaries (mostly MN).\n$\n PAR L(FCC_A1,NB,TI:N;0),, +ZERO;,, N 01Lee !\n PAR L(FCC_A1,NB,TI:N,VA;0),, -50000;,, N 01Lee !\n$\n PAR L(A1_FCC,NB,TI:N;0),, +ZERO;,, N 01Lee !\n PAR L(A1_FCC,NB,TI:N,VA;0),, -50000;,, N 01Lee !\n$\n PAR L(HCP_A3,NB,TI:N;0),, -8430+13.0928*T;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Nb-Ti-V\n$\n PAR G(SIGMA_D8B,V:NB:TI),, +10*GFCCVV+4*GHSERNB\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:NB),, +10*GFCCVV+4*GBCCTI\n +16*GHSERNB;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Nb-V-C\n$\n$ K. Frisk, Calphad, 32, 326-37(2008).\n$\n$ The only plot shown in 08Fri is the miscibility gap in the MC carbide\n$ at acr(C)=1 (mur(C)=0). If L(FCC_A1,NB,V:VA;0) is set to zero then\n$ the critical temperature is at 1905 K, which is 10 to 20 K higher than in\n$ 08Fri. With L(FCC_A1,NB,V:VA;0)=+9080 the critical temperature is 1950 K.\n$\n$ At 1573 K M2C shows continuous solubility, in contrast to MC. There are\n$ no data to compare with.\n$\n PAR L(FCC_A1,NB,V:C;0),, +29000;,, N 08Fri !\n PAR L(FCC_A1,NB,V:C;1),, -5000;,, N 08Fri !\n$\n PAR L(A1_FCC,NB,V:C;0),, +29000;,, N 08Fri !\n PAR L(A1_FCC,NB,V:C;1),, -5000;,, N 08Fri !\n$ ------------------------------------------------------------------------------\n$ Nb-V-N\n$ ------------------------------------------------------------------------------\n$ Ni-C-N\n$ ------------------------------------------------------------------------------\n$ Ni-Si-C\n$\n$ Y. Du, J.C. Schuster, Metall. Mater. Trans. A, 30A, 2409-18(1999).\n$\n$ 4SL model for fcc with modified parameters (Ni-Si).\n$ Using Si-C from 91Lac instead of 96Gro.\n$\n$ Si-C from 91Lac is not good, but in order to use 96Gro Fe-Si-C has to be\n$ remodelled.\n$\n$ There are only minor differences in the solid state, but the liquid is more\n$ stable in 91Lac than in 96Gro. By removing the ternary interaction the\n$ 1443 and 1798 K sections and even the 10 at.% C vertical section are still\n$ well reproduced.\n$\n$PAR L(LIQUID,C,NI,SI;0),, -145240;,, N 99Du !\n$ ------------------------------------------------------------------------------\n$ Ni-Si-N\n$ ------------------------------------------------------------------------------\n$ Ni-Si-Ti\n$\n PAR G(SIGMA_D8B,NI:TI:SI),, +10*GHSERNI+4*GBCCTI\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Ni-Si-V\n$\n PAR G(SIGMA_D8B,NI:V:SI),, +10*GHSERNI+4*GHSERVV\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Ni-Ti-C\n$ ------------------------------------------------------------------------------\n$ Ni-Ti-N\n$ ------------------------------------------------------------------------------\n$ Ni-Ti-V\n$\n PAR G(SIGMA_D8B,NI:TI:V),, +10*GHSERNI+4*GBCCTI\n +16*GHSERVV;,, N Lin !\n PAR G(SIGMA_D8B,NI:V:TI),, +10*GHSERNI+4*GHSERVV\n +16*GBCCTI;,, N Lin !\n PAR G(SIGMA_D8B,V:TI:NI),, +10*GFCCVV+4*GBCCTI\n +16*GBCCNI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Ni-V-C\n$\n$ B. Hallstedt, unpublished, 2008\n$\n$ No parameters added for the ternary. Experimental data at 1373 K are\n$ reasonably reproduced. There is an experimental vertical section Ni-VC,\n$ but this probably does not represent the true vertical section,\n$ which is considerably more complex.\n$\n$ metastable\n$\n PAR G(M23C6_D84,NI:V:C),, +0.8695652*GNI23C6\n +0.1304348*GV23C6;,, N Lin !\n PAR G(M23C6_D84,V:NI:C),, +0.8695652*GV23C6\n +0.1304348*GNI23C6;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Ni-V-N\n$ ------------------------------------------------------------------------------\n$ Si-C-N\n$ ------------------------------------------------------------------------------\n$ Si-Ti-C\n$ ------------------------------------------------------------------------------\n$ Si-Ti-N\n$ ------------------------------------------------------------------------------\n$ Si-Ti-V\n$\n PAR G(SIGMA_D8B,V:TI:SI),, +10*GFCCVV+4*GBCCTI\n +16*GBCCSI;,, N Lin !\n$ ------------------------------------------------------------------------------\n$ Si-V-C\n$ ------------------------------------------------------------------------------\n$ Si-V-N\n$ ------------------------------------------------------------------------------\n$ Ti-C-N\n$\n$ B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001).\n$\n$ Checked against paper.\n$\n$ At 1423 K the hcp phase field is a bit wider than in the paper.\n$\n PAR L(FCC_A1,TI:C,N;0),, -54176;,, N 96Jon3 !\n PAR L(FCC_A1,TI:C,N,VA;0),, -160000;,, N 01Lee !\n$\n PAR L(A1_FCC,TI:C,N;0),, -54176;,, N 96Jon3 !\n PAR L(A1_FCC,TI:C,N,VA;0),, -160000;,, N 01Lee !\n$\n PAR L(HCP_A3,TI:C,N;0),, -32725;,, N 96Jon3 !\n PAR L(HCP_A3,TI:C,N,VA;0),, -15000;,, N 01Lee !\n$\n PAR L(TI2N_C4,TI:C,N;0),, -25000;,, N 01Lee !\n$ ------------------------------------------------------------------------------\n$ Ti-V-C\n$\n$ W. Zhang, Y. Peng, Y. Du, L. Chen, Y. Li, S. Wang, G. Wen, W. Xie,\n$ Int. J. Refract. Met. Hard Mater., 48, 346-54(2015).\n$\n$ Checked against paper.\n$\n$ Using Ti-C from 99Dum instead of 03Fri.\n$\n$ There are quite large differences between this dataset and the 08Mar dataset.\n$ In this dataset MC is shifted to higher C content, is more narrow and the\n$ MC end point of the bcc+V2C+MC equilibrium is at much lower V content.\n$\n$ 08Mar only considered a subset of the available experimental data. 15Zha\n$ reproduces experimental data considerably better, in particular the\n$ V2C+MC (hcp+fcc) two-phase region seems well supported by experiment.\n$ I.e. the 15Zha dataset should be given preference, although their parameters\n$ are considerably more ugly.\n$\n$ The change of Ti-C leads to a substantial increase of the Ti solubility\n$ in V2C and a shift of MC composition in the bcc+V2C+MC equilibrium to lower\n$ V content. There is also a substantial increase in the Ti content in the\n$ bcc phase. After a modification of the hcp interaction only the Ti content\n$ in bcc remains higher. This is a consequence of the less stable TiC from\n$ 99Dum compared to to 03Fri. This seems consistent with data from\n$ Eremenko and Tret'yachenko at 1723 K. However, a stronger temperature\n$ dependence of the Ti solubility in V2C does remain. The liquid interaction\n$ was drastically simplified. A eutectic just below 1898 K identifed by Rudy\n$ is reproduced, but its composition is somewhat shifted.\n$\n$PAR L(LIQUID,C,TI,V;0),, -111424.88-30.306*T;,, N 15Zha2 !\n$PAR L(LIQUID,C,TI,V;1),, -102629.55+11.569*T;,, N 15Zha2 !\n$PAR L(LIQUID,C,TI,V;2),, +180287.5-86.582*T;,, N 15Zha2 !\n PAR L(LIQUID,C,TI,V;0),, +30000;,, N 17Hal18 !\n$\n PAR L(FCC_A1,TI,V:C;0),, -130833.62+45.055*T;,, N 15Zha2 !\n PAR L(FCC_A1,TI,V:C,VA;0),, +219939.63-52.077*T;,, N 15Zha2 !\n$\n PAR L(BCC_A2,TI,V:C,VA;0),, -130142.15;,, N 15Zha2 !\n$\n$PAR L(HCP_A3,TI,V:C;0),, -43582.86+8.744*T;,, N 15Zha2 !\n PAR L(HCP_A3,TI,V:C;0),, -30000+8.744*T;,, N 17Hal18 !\n PAR L(HCP_A3,TI,V:C,VA;0),, +25869.21;,, N 15Zha2 !\n$ ------------------------------------------------------------------------------\n$ Ti-V-N\n$\n$ K. Zeng, R. Schmid-Fetzer, Mater. Sci. Technol., 14, 1083-91(1998).\n$\n$ Checked against paper.\n$\n$ The V-N and Ti-V binaries are different from those used by 98Zen1.\n$\n PAR L(BCC_A2,TI,V:N;0),, +90000;,, N 98Zen1 !\n PAR L(A2_BCC,TI,V:N;0),, +90000;,, N 98Zen1 !\n$\n PAR L(HCP_A3,TI,V:N;0),, +10000;,, N 98Zen1 !\n PAR L(HCP_A3,TI,V:N;1),, +10000;,, N 98Zen1 !\n$\n PAR L(TI2N_C4,TI,V:N;0),, -60000;,, N 98Zen1 ! \n$ ------------------------------------------------------------------------------\n$ V-C-N\n$\n$ K. Frisk, Calphad, 32, 326-37(2008).\n$\n$ The isothermal section at 1873 K is reproduced, but not data on N solubility\n$ in V(C,N). These data do not seem compatible with the isothermal section.\n$\n PAR L(FCC_A1,V:C,N;0),, -20000;,, N 08Fri !\n PAR L(A1_FCC,V:C,N;0),, -20000;,, N 08Fri !\n$ ------------------------------------------------------------------------------\n$ Quaternary systems\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-Mo-C\n$\n$ C. Qiu, ISIJ Int., 32, 1117-27(1992).\n$\n PAR L(HCP_A3,CR,FE,MO:C;0),, -57062;,, N 92Qiu2 !\n PAR L(M23C6_D84,CR,FE:MO:C;0),, -177850+153.905*T;,, N 92Qiu2 !\n PAR G(M6C_E93,FE:MO:CR:C),, +2*GHSERFE+2*GHSERCR\n +2*GHSERMO+GHSERCC-25298-54.8698*T;,, N 92Qiu2 !\n$ ------------------------------------------------------------------------------\n$ Cr-Fe-V-C\n$\n$ B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-364(1992).\n$\n PAR L(M7C3_D101,CR,FE,V:C;0),, -250158;,, N 92Lee2 !\n$\n PAR L(M23C6_D84,CR,FE:V:C;0),, -205342+141.6667*T;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,V:FE:C;0),, -382069;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,FE,V:CR:C;0),, -1499585;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,FE,V:FE:C;0),, -1499585;,, N 92Lee2 !\n PAR L(M23C6_D84,CR,FE,V:V:C;0),, -1499585;,, N 92Lee2 !\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Nb-C\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ See also 12Khv2.\n$\n$ No parameters for this system. Checked against manuscript.\n$\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-Nb-N\n$\n$ A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013).\n$\n$ No parameters for this system. Checked against manuscript.\n$\n$ ------------------------------------------------------------------------------\n$ Fe-Mn-V-C\n$\n$ W. Huang, Metall. Trans. A, 22A, 1911-20(1991).\n$\n$ There are no parameters for this system.\n$\n$ The vertical section at 1% Mn and 0.1% V is not quite reproduced for\n$ C > 1%.\n$\n$ ------------------------------------------------------------------------------\n$ Fe-Mo-Si-C\n$\n$ B. Hallstedt, unpublished, 2017.\n$\n$ This is not a model of the quaternary system, but just a parameter to\n$ allow Si solubility in M6C.\n$\n PAR G(M6C_E93,FE:MO:SI:C),, +2*GHSERFE+2*GHSERMO\n +2*GHSERSI+GHSERCC-350000;,, N 17Hal1 !\n$ ------------------------------------------------------------------------------\n$ Fe-Nb-Si-C\n$ ------------------------------------------------------------------------------\n$ Fe-Si-Ti-C\n$ ------------------------------------------------------------------------------\n$ Fe-Si-V-C\n$ ------------------------------------------------------------------------------\n$ Fe-Si-C-N\n$ ------------------------------------------------------------------------------\n$\n$\n LIST-OF-REFERENCE\n NUMBER SOURCE\n Null 'Unknown source'\n Lin 'Linear combination of lattice stabilities'\n Same 'Same or similar interaction as in the corresponding stable phase'\n REFLAV 'Laves phase convention: G(LAVES,X:X)=+3*GHSERXX+15000'\n NIST 'NIST-Ni0209 Database, Ursula Kattner, 2002'\n COST 'COST 507 database'\n SGCOST 'COST 507 database, SGTE unary database V.3.0, 1996; Al, B, Nd, Ti, Zn'\n 80Bre 'L. Brewer, R.H. Lamoreaux, Atomic Energy Rev., Spec. Iss., No. 7,\n IAEA, Vienna, 1980, pp. 119, 236-38; Cu-Mo'\n 82Fer 'A. Fernandez Guillermet, Calphad, 6, 127-40 (1982); Fe-Mo'\n 83And 'J.-O. Andersson, Calphad, 7, 305-15(1983); Fe-V'\n 85Gus 'P. Gustafson, Scand. J. Metall., 14, 259-67(1985); Fe-C'\n 85Xin 'Z.S. Xing, D.D. Gohil, A.T. Dinsdale, T. Chart,\n DMA(A) 103, National Physical Laboratory, London, 1985; Fe-Ni'\n 86Din 'A.T. Dinsdale, T.G. Chart, NPL, unpublished, 1986; Cr-Ni'\n 86Mur 'J.L. Murray, Bull. Alloy Phase Diagrams, 7, 245-48(1986); Mg-Ti'\n 87And1 'J.-O. Andersson, B. Sundman, Calphad, 11, 83-92(1987); Cr-Fe'\n 87And2 'J.-O. Andersson, Calphad, 11, 271-76(1987); Cr-C'\n 87Cha 'L. Chandrasekaran, unpublished work, 1987; Cu-C, Cu-Fe-C'\n 87Gab 'A. Gabriel, P. Gustafson, I. Ansara,\n Calphad, 11, 203-18(1987); Ni-C, Fe-Ni-C'\n 87Gus2 'P. Gustafson, TRITA-MAC 354 (1987); Cr-Fe-Mo-W-C'\n 87Jan 'A. Jansson, TRITA-MAC 340 (1987); Cu-Fe-Ni'\n 88And1 'J.-O. Andersson, Calphad, 12, 1-8(1988); Mo-C'\n 88And2 'J.-O. Andersson, Calphad, 12, 9-23(1988); Fe-Mo, Fe-Mo-C'\n 88And3 'J.-O. Andersson, Metall. Trans A, 19A, 627-36(1988); Cr-Fe-C'\n 88And4 'J.-O. Andersson, N. Lange,\n Metall. Trans. A, 19A, 1385-94(1988); Cr-Fe-Mo'\n 88Fer3 'A. Fernandez Guillermet, Z. Metallkd., 79, 524-36(1988);\n Co-Ni-C, Co-Fe-Ni-C'\n 88Fri 'K. Frisk, P. Gustafson, Calphad, 12, 247-254(1988); Cr-Mo'\n 88Gus4 'P. Gustafson, Metall. Trans. A, 19A, 2531-46(1988); Cr-Fe-W'\n 88Gus5 'P. Gustafson, Metall. Trans. A, 19A, 2547-54(1988); Cr-Fe-W-C'\n 88Gus6 'P. Gustafson, Calphad, 11, 277-92(1987); Cr-Ni-W'\n 89Hua2 'W. Huang, Calphad, 13, 243-52(1989); Fe-Mn'\n 89NPL 'NPL, unpublished, 1989; Mn-Si-C'\n 89Vah 'C. Vahlas, P.-Y. Chevalier, E. Blanquet,\n Calphad, 13, 273-92(1989); Mo-Si'\n 90Fri1 'K. Frisk, Metall. Trans. A, 21A, 2477-88(1990); Cr-Fe-N' \n 90Fri2 'K. Frisk, Calphad, 14, 371-380(1990); Mo-Ni'\n 90Fri3 'K. Frisk, TRITA-MAC 429, Stockholm 1990; Cr-Mo-Ni'\n 90Ham 'M. Hamalainen, K. Jaaskelainen, R. Luoma, M. Nuotio, P. Taskinen,\n O. Teppo, Calphad, 14, 125-37(1990); Cr-Cu, Cu-Nb'\n 90Hil 'M. Hillert, C. Qiu, Metall. Trans. A, 21A, 1673-80(1990); Cr-Fe-Ni'\n 90Hua1 'W. Huang, Scand. J. Metall., 19, 26-32(1990); C-Mn,'\n 90Hua2 'W. Huang, Metall. Trans. A, 21A, 2115-23(1990); Fe-Mn-C'\n 90Hua3 'W. Huang, Z. Metallkd., 81, 397-404(1990); Fe-Nb-C'\n 90Kaj 'M. Kajihara, M. Hillert,\n Metall. Mater. Trans. A, 21A, 2777-87(1990); Cr-C'\n 90SUB 'SGTE Substance Database, version 1990'\n 91Ans 'I Ansara, unpublished, 1991; Cr-Si'\n 91Din 'A.T. Dinsdale, Calphad, 15, 317-425(1991).'\n 91Du 'H. Du, M. Hillert, Z. Metallkd., 82, 310-16(1991); Fe-C-N'\n 91Fer1 'A. Fernandez Guillermet, K. Frisk,\n Int. J. Thermophys., 12, 417-31(1991); Ni-N'\n 91Fer2 'A. Fernandez Guillermet, W. Huang,\n Int. J. Thermophys., 12, 1077-1102(1991); Mn-V-C'\n 91Fri1 'K. Frisk, Calphad, 15, 79-106(1991); Cr-N, Fe-N, Mo-N'\n 91Fri2 'K. Frisk, Z. Metallkd., 82, 59-66(1991); Fe-Ni-N'\n 91Fri3 'K. Frisk, Z. Metallkd., 82, 108-17(1991); Cr-Fe-Ni-N'\n 91Fri4 'K. Frisk, Report IM-2929, 1991; Cu-N, Cu-Fe-C-N'\n 91Hua1 'W. Huang, Z. Metallkd., 82, 174-81(1991); V-C'\n 91Hua2 'W. Huang, Z. Metallkd., 82, 391-401(1991); Fe-V, Fe-V-C'\n 91Hua3 'W. Huang, Calphad, 15, 195-208(1991); Mn-V, Fe-Mn-V'\n 91Hua4 'W. Huang, Metall. Trans. A, 22A, 1911-20(1991); Fe-Mn-V-C'\n 91Lac 'J. Lacaze, B. Sundman,\n Metall. Mater. Trans. A, 22A, 2211-23(1991); Fe-Si, Si-C, Fe-Si-C'\n 91Lee 'B.-J. Lee, unpublished revision 1991; C-Cr-Fe-Ni'\n 91Oht1 'H. Ohtani, M. Hillert, Calphad, 15, 11-24(1991); V-N'\n 91Oht2 'H. Ohtani, M. Hillert, Calphad, 15, 25-39(1991); Fe-V-N'\n 91Tib 'J.E. Tibballs, SI-report 890221-5, 1991\n (also COST 507 report, 1998); Mn-Si'\n 92Fer 'A. Fernandez-Guillermet, G. Grimvall,\n J. Phys. Chem. Solids, 53, 105-25(1992); Cr-C, Ni-C'\n 92Fri1 'K. Frisk, Metall. Trans. A, 23A, 639-49(1992); Fe-Mo-Ni'\n 92Fri2 'K. Frisk, Metall. Trans. A, 23A, 1271-78(1992); Fe-Mo-N'\n 92Lee1 'B.-J. Lee, Calphad, 16, 121-49(1992);\n Cr-C, Ni-C, Cr-Ni-C'\n 92Lee2 'B.-J. Lee, D.N. Lee, J. Phase Equilib., 13, 349-64(1992); Cr-Fe-V-C'\n 92Lee3 'B.-J. Lee, Z. Metallkd., 83, 292-99(1992); Cr-V, Cr-Fe-V'\n 92Mey 'S. an Mey, Calphad 16, 255-60(1992); Cu-Ni'\n 92Qiu1 'C. Qiu, Calphad, 16, 281-89(1992); Cr-Fe-Mo'\n 92Qiu2 'C. Qiu, ISIJ Int., 32, 1117-27(1992); Cr-Fe-Mo-C'\n 93Cos 'J.G. Costa Neto, S.G. Fries, H.L. Lukas, S. Garna, G. Effenberg,\n Calphad, 17, 219-28(1993); Cr-Nb'\n 93Du 'H. Du, J. Phase Equilib., 14, 682-93(1993); Fe-N, Fe-C-N'\n 93For 'A. Forsberg, J. Agren, J. Phase Equilib., 14, 354-63(1993); Fe-Mn-Si'\n 93Fri 'K. Frisk, Calphad, 17, 335-49(1993); Cr-Mn-N'\n 93Jin 'Z.-P. Jin, C. Qiu,\n Metall. Trans. A, 24A, 2137-44(1993); Mo-Ti, Fe-Mo-Ti'\n 93Lee1 'B.-J. Lee, Calphad, 17, 251-68(1993); Cr-Fe, Fe-Ni, Cr-Fe-Ni'\n 93Lee2 'B.-J. Lee, Metall. Trans. A, 24A, 1017-25 (1993); Cr-Fe-Mn-C'\n 93Lee3 'B.-J. Lee, Metall. Trans. A, 24A, 1919-33(1993); Cr-Mn, Cr-Fe-Mn'\n 93Lee4 'B.-J. Lee, Taehan Kumsok Hakhoechi, 31, 480-89(1993); Cr-Fe-Ni'\n 93Qiu1 'C. Qiu, A. Fernandez Guillermet, Z. Metallkd., 84, 11-22(1993); Mn-N'\n 93Qiu2 'C. Qiu, Metall. Trans. A, 24A, 629-45(1993); Fe-Mn-N'\n 93Qiu3 'C. Qiu, Metall. Trans. A, 24A, 2393-2409(1993); Cr-Fe-Mn-N'\n 94Cou 'C.A. Coughanowr, I. Ansara, H.L. Lukas,\n Calphad, 18, 125-40(1994); Cr-Si'\n 94Har 'K.C. Hari Kumar, P. Wollants, L. Delaey,\n Calphad, 18, 71-79(1994); Nb-V'\n 95Che 'Q. Chen, Z.P. Jin, Metall. Mater. Trans. A, 26A, 417-26(1995); Cu-Fe'\n 95Dup 'N. Dupin, Thesis, LTPCM, France, 1995; Al-Cr-Ni, Cr-Ni-Ti'\n 95Lee 'B.-J. Lee, unpublished, 1993-95'\n 96Bel 'P. Bellen, K.C. Hari Kumar, P. Wollants,\n Z. Metallkd., 87, 972-78(1996); Ni-Ti'\n 96Bol 'A. Bolcavage, U.R. Kattner,\n J. Phase Equilib., 17, 92-100(1996); Nb-Ni'\n 96Fri 'K. Frisk, B. Uhrenius,\n Metall. Mater. Trans., 27A, 2869-80(1996); Mo-C-N'\n 96Har2 'K.C. Hari Kumar, I. Ansara, P. Wollants, L. Delaey,\n Z. Metallkd., 87, 666-72(1996); Cu-Ti'\n 96Hua 'W. Huang, Metall. Mater. Trans. A, 27A, 3591-3600(1996); Nb-N'\n 96Jon3 'S. Jonsson, Z. Metallkd., 87, 713-20(1996); Ti-C-N'\n 96Sei 'H.J. Seifert, H.L. Lukas, G. Petzow,\n Z. Metallkd., 87, 2-13(1996); Si-Ti'\n 96Shi 'J.-H. Shim, C.-S. Oh, D.N. Lee,\n Metall. Mater. Trans. B, 27B, 955-66(1996); Mo-Ti-C'\n 96Vre 'J. Vrestal, J. Stepankova, P. Broz,\n Scand. J. Metall., 25, 224-31(1996); Cu-Mn'\n 96Zen 'K. Zeng, R. Schmid-Fetzer, Z. Metallkd., 87, 540-54(1996); Ti-N'\n!\n\nADD_REFERENCES\n DUMMY1 'dummy 1'\n 97Lin 'M. Lindholm, J. Phase Equilib., 18, 432-40(1997); Cr-Fe-Si'\n 97Oht 'H. Ohtani, H. Suda, H. Ishida, ISIJ Int., 37, 207-16(1997); Cr-Cu-Fe'\n 97SUB 'SGTE substance database, version 1997'\n 98Ans 'I. Ansara, COST 507, Final report round 2, 1998; Cr-Mg'\n 98Hua 'W. Huang, UWM, unpublished research, 1998; Al-Mo-Ni'\n 98Jac2 'M.H.G. Jacobs, P.J. Spencer, COST 507,\n Final report round 2, 1998; Mg-Ni'\n 98Kor 'J. Korb, K. Hack, COST 507, Final report round 2, 1998; Ni-V'\n 98Lee 'B.-J. Lee, COST 507, Final report round 2, 1998; Cr-Mn'\n 98Lia2 'P. Liang, H.L. Lukas, H.J. Seifert, G. Ghosh, G. Effenberg,\n F. Aldinger, Calphad, 22, 527-44 (1998); Cu-Mg, Cu-Mg-Zn'\n 98Luk 'H.L. Lukas, COST 507, Final report round 2, 1998; Mg-Si'\n 98Mie 'J. Miettinen, Calphad 22, 231-56(1998); Fe-Si, Fe-Si-C'\n 98Ran 'M.H. Rand, N. Saunders, COST 507, Final report round 2, 1998; Si-V'\n 98Sau2 'N. Saunders, COST 507, Final report round 2, 1998; Mn-Ti'\n 98Sau3 'N. Saunders, COST 507, Final report round 2, 1998; Mo-Ti'\n 98Tib 'J. Tibballs, COST 507, Final report round 2, 1998; Fe-Mg'\n 98Zen1 'K. Zeng, R. Schmid-Fetzer, Mater. Sci. Technol., 14, 1083-91(1998);\n Ti-V-N'\n 98Zen2 'K. Zeng, M. Hamalainen, COST 507, Final report round 2, 1998; Cr-Cu'\n 99Dav 'A. Davydov, U.R. Kattner, J. Phase Equilib., 20, 5-16(1999); Co-Mo'\n 99Du 'Y. Du, J.C. Schuster,\n Metall. Mater. Trans. A, 30A, 2409-18(1999); Ni-Si, Ni-Si-C'\n 99Dum1 'L.F.S. Dumitrescu, M. Hillert, B. Sundman,\n Z. Metallkd., 90, 534-41(1999); Ti-C, Ti-C-N'\n 99Dum2 'L.F.S. Dumitrescu, M. Hillert, ISIJ Int., 39, 84-90(1999); Fe-Ti-C'\n 99Dup1 'N. Dupin, I. Ansara, Z. Metallkd., 90, 76-85(1999); Al-Ni'\n 99Dup2 'N. Dupin, unpublished, 1999; Cr-Ni-Ti, Al-Cr-Ni-Ti'\n 99Gho 'G. Ghosh, Metall. Mater. Trans. A, 30A, 1481-94(1999),\n SGTE unary database V.5.0, 2009; Ni'\n 99Lee 'B.-J. Lee, unpublished, 1999'\n 99Mie 'J. Miettinen, Calphad, 23, 249-62(1999); Fe-Ni-Si'\n 99SGUN 'SGTE unary database V.4.1, 1999.'\n 99Sun 'B. Sundman, unpublished, 1999; Fe-Si-C'\n 00Du1 'Y. Du, J.C. Schuster, J. Phase Equilib., 21, 281-86(2000); Cr-Si'\n 00Du2 'Y. Du, J.C. Schuster, L. Perring,\n J. Am. Ceram. Soc., 83, 2067-73(2000); Cr-Si-C'\n 00Dup 'N. Dupin, unpublished, 2000; Al-Ni-Ti'\n 00Moo 'K.-W. Moon, W.J. Boettinger, U.R. Kattner, F.S. Biancaniello,\n C.A. Handwerker, J. Electron. Mater., 29, 1122-36(2000); Cu'\n 00Sch 'J.C. Schuster, Y. Du,\n Metall. Mater. Trans. A, 31A, 1795-1803(2000); Cr-Ni-Si'\n 00SUB 'SGTE substance database, version 2000'\n 00Wan 'C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, S.M. Hao, K. Ishida,\n J. Phase Equilib., 21, 54-62(2000); Cu-Mo, Cu-Fe-Mo, Cu-Fe-Nb'\n 00Wes 'S. Westman, unpublished, 2000; Cr-Fe, Fe-Mo, Fe-V, Mn-V'\n 00Yan1 'X.Y. Yan, F. Zhang, Y.A. Zhang,\n J. Phase Equilib., 21, 379-84(2000); Mg-Si'\n 00Zhu 'W. Zhuang, J. Shen, Y. Liu, L. Ling, S. Shang, Y. Du, J.C. Schuster,\n Z. Metallkd., 91, 121-27(2000); Cr-Ti'\n 01Dup 'N. Dupin, I. Ansara, B. Sundman, Calphad, 25, 279-98(2001); Al-Cr-Ni'\n 01Lee 'B.-J. Lee, Metall. Mater. Trans. A, 32A, 2423-39(2001);\n Nb-C, Fe-Nb-C, Fe-Nb-N, Fe-Nb-Ti, Fe-Ti-N, Nb-C-N,\n Nb-Ti-C, Nb-Ti-N, Ti-C-N'\n 01Ser 'C. Servant et al., Calphad, 25, 79-95(2001); Cu-Fe-Ni'\n 01Sun 'B. Sundman, fix to avoid BCC with just Va (in LB1-v2).'\n 01Zha 'Y. Zhang, H. Liu, Z. Jin, Calphad, 25, 305-17(2001); Nb-Ti'\n 02Bra 'J. Bratberg, K. Frisk, Calphad, 26, 459-76(2002); Mo-V, Mo-V-C'\n 02Gho 'G. Ghosh, J. Phase Equilib., 23, 310-28(2002); Ti-V'\n 02Sun 'B. Sundman, modified sigma parameters, 2002;\n Fe-V, Mn-V, Ni-V, ternaries'\n 02Wan 'C.P. Wang, X.J. Liu, I. Ohnuma, R. Kainuma, K. Ishida,\n J. Phase Equilib., 23, 236-45(2002); Cr-Cu-Fe, Cu-Fe-Si'\n 03Che 'P.-Y. Chevalier, E. Fischer, unpublished research, 2003; Mo-Si'\n 03Dup 'N. Dupin, B. Sundman, March 2003 at JEEP,\n including SRO in Al-Ni and Fe-Ni'\n 03Ma 'X. Ma, C. Li, F. Wang, W. Zhang, Calphad, 27, 383-88(2003); Si-N'\n 03Mie2 'J. Miettinen, Calphad, 27, 103-14(2003); Cu, Cu-Mn'\n 03Mie3 'J. Miettinen, Calphad, 27, 141-45(2003); Cu-Fe-Mn'\n 04Din 'A.T. Dinsdale, unpublished, 2004; Cu-C'\n 04Guo 'C. Guo, Z. Du, J. Alloys Compd., 385, 109-13(2004); La, Mg'\n 04Xio 'W. Xiong, Y. Du, Y. Liu, B.Y. Huang, H.H. Xu, H.L. Chen, Z. Pan,\n Calphad, 28, 133-40(2004); Mo-Nb'\n 05Can 'S. Canderyd, Report IM-2005-109, KIMAB, Stockholm, 2005; Fe-Nb-C'\n 05Gro 'J. Groebner, D. Mirkovic, M. Ohno, R. Schmid-Fetzer,\n J. Phase Equilib. Diffus., 26, 234-39(2005); Mg-Mn'\n 05Guo 'C. Guo, Z. Du, Intermetallics, 13, 525-34(2005); Mn-Ni'\n 06Che 'H. Chen, Y. Du, Calphad, 30, 308-15(2006); Nb-Ni'\n 06Hal2 'B. Hallstedt, unpublished, 2006; Ni-C'\n 06Hal3 'B. Hallstedt, unpublished, 2006; Cr-Ni-C'\n 06Hal4 'B. Hallstedt, unpublished, 2006; Mg-C'\n 06Slu 'M.H.F. Sluiter, Calphad, 30, 357-66(2006); Endmember values'\n 06Tur 'P.E.A. Turchi, L. Kaufman, Z.-K. Liu,\n Calphad, 30, 70-87(2006); Cr-Mo-Ni, Cr-Mo-Ni-W'\n 07Fra 'P. Franke, Int. J. Mater. Res., 98, 954-60(2007); Mn-Ni'\n 07Hal1 'B. Hallstedt, unpublished, 2007; Cr-Si'\n 07Zha 'L. Zhang, Y. Du, Calphad, 31, 529-40(2007); Al-Fe-Ni'\n 08Fri 'K. Frisk, Calphad, 32, 326-37(2008); Nb-V-C, V-C-N'\n 08Hal1 'B. Hallstedt, unpublished, 2008; Fe-Ni-Si'\n 08Hal2 'B. Hallstedt, unpublished, 2008; Cu-C'\n 08Hal3 'B. Hallstedt, fcc ordering parameters, 2008; Fe-Mn'\n 08Hal4 'B. Hallstedt, unpublished, 2008; Cr-Fe-Si'\n 08Zha1 'J. Zhao, Y. Du, L.Zhang, H. Xu, Calphad, 32, 252-55(2008); Cu-V'\n 08Zha2 'L. Zhang, Y. Du, Q. Chen, H. Xu, F. Zheng, C. Tang, H. Chen,\n Int. J. Mater. Res., 99, 1306-18(2008); Cu-Fe-Mn'\n 08Zhu 'Z. Zhu, Y. Du, L. Zhang, H. Chen, H. Xu, C. Tang,\n J. Alloys Compd., 460, 632-38(2008); Al-Nb'\n 09Gen 'T. Geng, C. Li, J. Bao, X. Zhao, Z. Du, C. Guo,\n Intermetallics, 17, 343-57(2009); Nb-Si'\n 09Wan 'C.P. Wang, H.L. Zhang, S.L. Wang, Z. Lin, X.J. Liu, A.T. Tang,\n F.S. Pan, J. Alloys Compd., 481, 291-95(2009); Ho, Mn, Sm'\n 09Zha 'L. Zhang, Y. Du, H. Xu, S. Liu, Y. Liu, F. Zheng, N. Dupin, H. Zhou,\n C. Tang, Int. J. Mater. Res., 100, 160-75(2009); Fe-Mn-Ni'\n 10Dju 'D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski,\n Calphad, 34, 279-85(2010); Mn-C'\n 10Hal 'B. Hallstedt, D. Djurovic, J. von Appen, R. Dronskowski, A. Dick,\n F. Koermann, T. Hickel, J. Neugebauer,\n Calphad, 34, 129-33(2010); Fe-C'\n 10Pav 'J. Pavlu, J. Vrestal, M. Sob, Calphad, 34, 215-21(2010); Cr-Ti'\n 11Dju 'D. Djurovic, B. Hallstedt, J. von Appen, R. Dronskowski,\n Calphad, 35, 479-91(2011); Fe-Mn, Fe-Mn-C'\n 11Khv 'A.V. Khvan, slight modification of liquid interaction, 2011; V-C'\n 11Wan 'J. Wang, C. Liu, C. Leinenbach, U.E. Klotz, P.J. Uggowitzer,\n J.F. Loeffler, Calphad, 35, 82-94(2011); Cu-Ti, Cu-Sn-Ti'\n!\n\nADD_REFERENCES\n DUMMY2 'dummy 2'\n 12Bo 'H. Bo, J. Wang, L. Duarte, C. Leinenbach, L. Liu, H. Liu, Z. Jin,\n Trans. Nonferrous Met. Soc. China, 22, 2204-11(2012); Fe-Ti'\n 12Hal 'B. Hallstedt, adjusted magnetic parameters, 2012; Fe-Mn, Fe-Mn-C'\n 12Khv1 'A.V. Khvan, B. Hallstedt, K. Chang,\n Calphad, 39, 54-61(2012); Cr-C, Cr-Nb-C, Mn-Nb-C'\n 12Khv2 'A.V. Khvan, B. Hallstedt, Calphad, 39, 62-69(2012);\n Fe-Nb, Fe-Nb-C, Fe-Mn-Nb-C'\n 12Liu 'S.H. Liu, B. Hallstedt, D. Music, Y. Du,\n Calphad, 38, 43-58(2012); Fe-Nb, Mn-Nb, Fe-Mn-Nb'\n 12Yua 'X. Yuan, L. Zhang, Y. Du, W. Xiong, Y. Tang, A. Wang, S. Liu,\n Mater. Chem. Phys., 135, 94-105(2012); Ni-Si'\n 13Khv1 'A.V. Khvan, B. Hallstedt, Calphad, 40, 10-15(2013); Fe-Nb, Nb-C, \n Nb-N, Fe-Mn-Nb, Fe-Nb-C, Fe-Nb-N, Nb-C-N, Fe-Mn-Nb-C, Fe-Mn-Nb-N'\n 13Khv2 'A.V. Khvan, K. Chang, B. Hallstedt,\n Calphad, 43, 143-48(2013); Fe-Nb-V'\n 13Slu 'M.H.F. Sluiter, unpublished research (2013); More endmember values'\n 14Khv 'A.V. Khvan, B. Hallstedt, C. Broeckmann,\n Calphad, 46, 24-33(2014); Cr-Fe-C'\n 14Raj 'V.B. Rajkumar, K.C. Hari Kumar,\n J. Alloys Compd., 611, 303-12(2014); Fe-Mo'\n 14Sch 'C. Schmetterer, A. Khvan, A. Jacob, B. Hallstedt, T. Markus\n J. Phase Equilib. Diffus., 35, 434-44(2014); Cr-Nb'\n 14Shu 'K. Shubhank, Y.-B. Kang, Calphad, 45, 127-37(2014); Cu-C'\n 14Zhu 'W.J. Zhu, L.I. Duarte, C. Leinenbach,\n Calphad, 47, 9-22(2014); Cu-Ni-Ti'\n 15Hal1 'B. Hallstedt, changed parameters due to new binaries, 2015; Mo-Ti-C'\n 15Hal2 'B. Hallstedt, parameter to destabilise BCC_A2, 2015; Mg-C'\n 15Hal3 'B. Hallstedt, unpublished, 2015; Mg-N'\n 15Hal4 'B. Hallstedt, unpublished, 2015; Mg-Nb'\n 15Hal5 'B. Hallstedt, unpublished, 2015; Mg-V'\n 15Zha1 'C. Zhang, Y. Peng, P. Zhou, W. Zhang, Y. Du,\n Calphad, 51, 104-10(2015); Mo-Nb-C'\n 15Zha2 'W. Zhang, Y. Peng, Y. Du, L. Chen, Y. Li, S. Wang, G. Wen, W. Xie,\n Int. J. Refract. Met. Hard Mater., 48, 346-54(2015); Ti-V-C'\n 16Hal1 'B. Hallstedt, ternary fcc ordering parameter, 2016; Fe-Mn-Ni'\n 16Hal3 'B. Hallstedt, added reciprocal to fcc-ordering, 2016; Cr-Ni'\n 16Hal4 'B. Hallstedt, Cr-Ni sigma phase parameter adjusted, 2016; Cr-Fe-Ni'\n 16Hal5 'B. Hallstedt, changed U1FFENI, 2016'\n 16Hal6 'B. Hallstedt, refitted sigma parameters, 2016; Cr-Mn, Cr-Fe-Mn'\n 16Hal7 'B. Hallstedt, unpublished, 2016; Cr-Mn-Ni'\n 16Hal9 'B. Hallstedt, Modification of Cu2Mg and CuMg2 parameters; Cu-Mg'\n 16Hal10 'B. Hallstedt, J. Groebner, M. Hampl, R. Schmid-Fetzer,\n Calphad, 53, 25-38(2016); Cu-Si, Al-Cu-Si'\n 16Jac1 'A. Jacob, C. Schmetterer, A. Khvan, A. Kondratiev, D. Ivanov,\n B. Hallstedt, Calphad, 54, 1-15(2016); Fe-Nb, Cr-Fe-Nb'\n 16Jac2 'A. Jacob, unpublished, 2016; Nb-Si, Fe-Nb-Si'\n 16Lia 'S.-M. Liang, P. Wang, R. Schmid-Fetzer,\n Calphad, 54, 82-96(2016); Mg, Mg-Si'\n 16Tan 'F. Tang, B. Hallstedt, Calphad, 55, 260-69(2016); Cr-Ni'\n 17Hal1 'B. Hallstedt, Si solubility in M6C, 2017; Fe-Mo-Si-C'\n 17Hal2 'B. Hallstedt, New C14_LAVES parameters and Ti lattice stability,\n 2017; Cr-Ti, Fe-Ti, Mn-Ti'\n 17Hal3 'B. Hallstedt, adjusted liquid interaction, 2017; Fe-Ti-C'\n 17Hal4 'B. Hallstedt, new parameters for MU_D85, 2017; Fe-Mo, Mn-Mo, Cr-Fe-Mo'\n 17Hal5 'B. Hallstedt, New C14_LAVES parameters, 2017; Cr-Mo'\n 17Hal6 'B. Hallstedt, new parameters for SIGMA_D8B, 2017;\n Fe-Mo, Mn-Mo, Cr-Fe-Mo'\n 17Hal7 'B. Hallstedt, adjusted interaction MU_D85, 2017; Nb-Ni'\n 17Hal8 'B. Hallstedt, new parameters for SIGMA_D8B, MU_D85, C14_LAVES,\n 2017; Fe-Mo-Ni'\n 17Hal9 'B. Hallstedt, new parameters for MU_D85, C14_LAVES, 2017; Fe-Mo-Ti'\n 17Hal10 'B. Hallstedt, New parameters SIGMA_D8B, C14_LAVES, 2017; Cr-Fe-Si'\n 17Hal11 'B. Hallstedt, modified parameters for SIGMA_D8B and P_PHASE,\n 2017; Cr-Mo-Ni'\n 17Hal12 'B. Hallstedt, added parameters for FE4N_L1, 2017;\n Fe-N, Cr-Fe-N, Fe-Mn-N'\n 17Hal13 'B. Hallstedt, adjusted parameter for FCC_4SL, 2017; Ni-Si'\n 17Hal14 'B. Hallstedt, modified liquid interaction, 2017; Cr-V-C'\n 17Hal15 'B. Hallstedt, sanitized parameters for BCC_A2, 2017; Cu-C'\n 17Hal16 'B. Hallstedt, ternary liquid interaction, 2017; Cu-Fe-C'\n 17Hal17 'B. Hallstedt, unpublished, 2017; Fe-Nb-Ti'\n 17Hal18 'B. Hallstedt, changed hcp and liquid interaction, 2017; Ti-V-C'\n 17Hal19 'B. Hallstedt, modified MU_D85, 2017; Fe-Nb-V'\n 17Hal20 'B. Hallstedt, estimated fcc interaction, 2017; Cr-Fe-C'\n 17Jac 'A. Jacob, E. Povoden-Karadeniz, E. Kozeschnik,\n Calphad, 56, 80-91(2017); Cr-Si, Nb-Si, Cr-Nb-Si'\n!\n" }, { "path": "examples/macros/map1.OCM", "content": "new Y\n\nset echo Y\n\n@$ =========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map1.OCM\n@$ Calculate the phase diagram for Ag-Cu\n@$ =========================================================\n@&\n\nset echo\n\nr t ./agcu\n\n\nset cond t=1000 p=1e5 n=1 x(cu)=.2\n\nc e\n\nl r 2\n\n@&\n\nset ax 1 x(cu) 0 1 0.025\nset ax 2 t 800 1500 10\n\nl ax\n\nl sh\n\nset ref ag fcc,,,,,\nset ref cu fcc,,,,,\n\n\n@&\n\nmap\n\n@&\n\n@$ This is the normal x-T phase diagram plot\nplot\nx(*,cu)\nT\ntitle map 1 fig 1\nrender\n\n\n@&\n\n@$ Zoom of the Ag rich side\nplot\nx(*,cu)\nT\nscale\nx\nN\n0\n0.2\ntitle map 1 fig 2\n\n\n@&\n@$ Changing the axis\nplot\nT\nx(*,cu)\ntitle map 1 fig 3\nrender\n\n@&\n@$ We can plot with activity instead of phase composition !\nplot\nac(cu)\nT\ntitle map 1 fig 4\nrender\n\n@&\n@$ Another funny way to plot the phase diagram calculation !!\nplot x(*,cu)\ngm(*)\nextra tie 3\ntitle map 1 fig 5\n\n\n@$==========================================================================\n@$ end of map1 macro\n@$==========================================================================\n\nset inter\n" }, { "path": "examples/macros/map10.OCM", "content": "new Y\n\nset echo Y\n\n\n@$ ====================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map10.OCM\n@$ Calculating the isothermal section at 1200 K for Cr-Fe-Ni\n@$ ====================================================================\n@&\n\nset echo\n\nr t ./saf2507\nfe cr ni\n\nset c t=1200 p=1e5 n=1 x(cr)=.45 x(ni)=.5\n\nset ref cr bcc * ,,\n\nset ref ni fcc * ,,\n\nc e\n\nl,,,,\n\n\n@&\n\nset ax 1 x(cr) 0 1 ,,,,\n\nset ax 2 x(ni) 0 1 ,,,,\n\nmap\n\n\n@$ this diagram has no potential axis, that requires some special care\n@&\n\n@$ The graphics for this kind of diagram is not fully developed \n@$ The lines for the invariants are missing\n@$ Some graphical options set by user are ignored\n\nplot\n\n\ntitle map 10 fig 1\n\n@&\nplot\n\n\ntext\n0.47\n0.07\n.8\n0\nn\n{/Symbol s}\ntext n 0.6 0.02 .8 0 y\n\ntext n 0.2 0.5 .8 0 y\n\ntitle map 10 fig 2\n\n\n@&\nplot\n\n\nextra tie_line 2\ntitle map 10 fig 3\n\n\n@&\n@$ Testing Gibbs triangle\n\nplot\n\n\nextra gibbs\n\ntext n 0.51 0.25 .8 -48 y\n\ntitle map 10 fig 4\n\n\n@&\n@$ scale plots a whole square\n\nplot\n\n\nscale x\nn\n0\n.5\ntitle map 10 fig 5\n\n\n\n@&\n@$ Changing the plot axis reinitiates all plot options !!??\n\nplot\n\nx(*,fe)\ntitle map 10 fig 6\n\n\n@&\n@$ It looks a bit nicer as Gibbs triangle\n\nplot\n\n\nextra gibbs\ny\nextra tie\n3\ntitle map 10 fig 7\n\n\n@&\n@$ Finally plot activity lines\n\nplot\nac(cr)\nac(ni)\n\n\n\n\n@$==========================================================================\n@$ end of map10 macro\n@$==========================================================================\n\n\nset inter\n\n\n" }, { "path": "examples/macros/map11.OCM", "content": "new Y\n\nset echo Y\n\n\n@$=================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map11.OCM\n@$ Calculation of the Cr-Fe binary\n@$=================================================================\n@&\n\nset echo\n\n@$ 3 separate parts, now using 3 start equilibria\n@$\n\nr t ./steel1\ncr fe\n \nset c t=600 p=1e5 n=1 x(cr)=.2\nc e\nl\nRESULTS\n1\n\n@&\n\nset ref cr bcc * ,,\n\nset ref fe bcc * ,,\n\nset ax 1 x(cr)\n0\n1\n.025\n\nset ax 2 t\n400\n2500\n25\n\n@$ Set this as start point with a direction\nset as_start 0\n\n@&\n@$ Add one more start point for the gamma loop\n\nset c t=1200 x(cr)=.1\n\nc e\n\n@$ in this case the direction is important\nset as_start 1\n\n@$ Add one more for the liquidus\n\nset c x(cr)=.5 t=2200\n\nc e\n\nset as_start -2\n\n\n@&\n@$ To avoid metastable bcc/sigma line\n\nset adv map\n2\n\n\n@&\n\nli equil\n\n\n\n@&\n\nmap\n\n\nplot\nX(*,CR)\nT\ntitle map 11 fig 1\nRENDER\n\n@$\n@$ This diagram will sometimes have a metastable\n@$ extrapolation of the sigma+bcc lines because the\n@$ two bcc phases merges at hight T and the 3-phase line\n@$ is not found when lowering the T. \n@$ And/or it may have an invariant indicated at the congruent transition!\n@&\n\n\nplot\n\n\ntext\n0.46\n1000\n.8\n0\nn\n{/Symbol s}\ntext n .03 1300 .8 0 y \n\ntext n .4 1400 .8 0 y \n\ntext n .2 2000 .8 0 y \n\ntitle map 11 fig 2\n\n\n@&\n\n@$==========================================================================\n@$ end of map11 macro\n@$==========================================================================\n\nset interactive\n" }, { "path": "examples/macros/map12.OCM", "content": "new Y\n\nset echo Y\n\n@$ =============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map12.OCM\n@$ Calculating Mo-Re phase diagram from a database file\n@$ eventually this will test the XTDB format\n@$ =============================================================\n\nset echo\n\nread t ./MoRe\n\nset c t=1000 p=1e5 n=1 x(re)=.9\n\nc e\n\nl,,,,\n\n@&\n\nset ax 1 x(re) 0 1 ,,,\n\nset ax 2 t 300 4000 25\n\n\nmap\n\n\nplot\n\n\ntitle map 12 fig 1\n\n\n@&\n@$ add a label and move the keys\nplot\n\n\npos left bottom\n\ntext \n.6 2400\n.9\n0\nY\n\ntitle map 12 fig 2\n\n\n\n\n\n@$==========================================================================\n@$ end of map12 macro\n@$==========================================================================\n\n\nset inter\n\n\n\n\n" }, { "path": "examples/macros/map13.OCM", "content": "@$\nnew Y\n\nset echo Y\n\n@$\n@$ ===========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ Calculating Al-Ni binary phase diagram\n@$ with 4 sublattice order/disorder models for FCC, BCC (and HCP)\n@$ using partitioning and permutation of parameters\n@$ =================================================================== \n\nset echo Y\n\nr t ./alni-4slx\n\n@&\n\nset c t=1000 p=1E5 n=1 x(al)=.2\n\nc e\n\nl , 2\n\n@&\n\nset ax 1 x(al) 0 1 ,,\n\nset ax 2 t 400 2000 25\n\nmap\n\n\nplot\n\n\ntitle map 13 fig 1\n\n@&\n@$ =================================================================== \n@$ This time the whole diagram ... wow\n\n\n\n@&\n@$ Add some phase labels\nplot\n\n\ntitle map 13 fig 2\ntext\n0.3\n1900 \n.8\n0\ny\n\ntext n 0.05 1400 .8 0 y\n\ntext n 0.23 1200 .8 90 y\n\ntext n 0.45 1500 .8 0 y\n\n\n\n\n@&\n\n@$ =================================================================== \n@$ We can plot it in a strange way ...\n\nplot\n\nSM(*)\nextra tie 3\ntitle map 13 fig 3\npos bottom left\n\n\n\n\n@$==========================================================================\n@$ end of map13 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map14.OCM", "content": "new Y\n\nset echo Y\n\n\n@$ ====================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map14.OCM\n@$ Calculating the isothermal section for Cr-Fe-Mo\n@$ ====================================================================\n@&\n\nset echo\n\nr t ./steel1\nfe cr mo\n\nset c t=1400 p=1e5 n=1 x(cr)=.3 x(mo)=.05\n\nc e\n\nl,,,,\n\n\n@&\n\nset ax 1 x(cr) 0 1 ,,,,\n\nset ax 2 x(mo) 0 1 ,,,,\n\nmap\n\n\n\n@$ this diagram has no potential axis, that requires some special care\n@$ There is a small fcc/bcc region is missing\n\nset c x(mo)=.001 x(cr)=.12\n\nc e\n\n\nl,,,,,\n\n\n@&\n\nmap\nn\n\n\n\n@&\n@$ The graphics for this kind of diagram is not fully developed \n\nplot\n\n\ntitle map 14 fig 1\n\n@&\n\n@$ plot as Gibbs triangle with tie-lines\nplot\n\n\nextra gibbs Y\nextra tie 3\n@$ Also set the color of the monovariants to red\nextra color\nFF0000\n\ntitle map 14 fig 2\nextra lower Fe\n\n\n@&\n\nplot\n\n\nextra color\na0ffa0\n\ntitle map14 fig 3\ngra 3\ncrfemo-1400-leftcorner\nY\n\n\n\n@$==========================================================================\n@$ end of map14 macro\n@$==========================================================================\n\n\nset inter\n" }, { "path": "examples/macros/map15.OCM", "content": "@$\nnew Y\n\n\nset echo Y\n\n\n@$===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ MAP15 BEF isotherms at 3 T\n@$===============================================================\nset echo\n\nr t ./BEF\n\n\n@$ First at 500 K,\n@$ We have to start inside the small sigma miscibility gap\n\nset c t=500 p=1e5 n=1 x(re)=.37 x(ni)=.29\n\n\nc e\n\nl,,,,,\n\n\n@$ We have two sigma phases stable\n@&\n@$ Set axis\n\nset ax 1 x(re) 0 1 ,,\nset ax 2 x(ni) 0 1 ,,\n\n@&\n\n\nmap\n\n\n@&\n\nplot\n\n\ntitle map 15 fig 1a\n\n@&\n@$ Sometimes some parts are missing, try adding another startpoint\n\n@$ does not work on LINUX set c x(ni)=.2\nset c x(re)=.36 x(ni)=.1\n\nc e\n\nl,,,,,\n\n@&\n\nmap\nN\n\n\nplot\n\n\n\n@$ It looks OK, plot as a Gibbs triangle and add tie-lines\n@&\n\n\nplot\n\n\nextra ?\n@$ This gives the browser window and we must select from the extra menu\nextra ??\ngibbs\ny\nextra tie 3\nextra lower Mo\ntitle Map 15 fig 1b: BEF model Mo-Ni-Re isotherm 500 K\n\n\n\n@$ Usually some parts are missing or have spurious tei-line\n@$ Mapping is still to be improved with experience\n\n@&\n\n\n\n@$-------------------------------------------------\n@$ Then at 1500 K\n\nset c t=1500 x(re)=.2 x(ni)=.2\n\nc e\n\nl,,,,,\n\n@&\n\nmap\n\n\nplot\n\n\ntitle Map 15 fig 2a: BEF model Mo-Ni-Re isotherm 1500 K\nextra gib y\nextra tie 10\n@$ set a light gray monovariant\nextra color\nf0f0f0\nffff00\n\n\n\n@&\n\n@$ Sometimes a part on the Re rich side missing, add a new start point\n\nset c x(ni)=.1 x(re)=.8\n\nc e\n\nmap\nn\n\n\nplot\n\n\n@$ some extra options\nextra gibbs y\nextra tie 10\nextra color\nf0f0f0\nffff00\ntitle Map 15 fig 2b: BEF model Mo-Ni-Re isotherm 1500 K\n\n@&\n\n\n@$-------------------------------------------------------\n@$ Finally at 2500 K\n\nset c t=2500 p=1e5 n=1 x(re)=.7 x(ni)=.27\n\nc e\n\nl,,,,,\n\n\n@&\n\nset ax 1 x(re) 0 1 ,\n\nset ax 2 x(ni) 0 1 ,\n\n@$ Just to be sure ...\n\nc e\n\n\nmap\n\n\nplot\n\n\nextra gib y\nextra tie 3\ntitle Map 15 fig 3: BEF model Mo-Ni-Re isotherm 2500 K\n@$ restore default colors if we run several macros ...\nextra color\n7CFF40\n7CFF40\n@$ Set a text in the lower left corner\nextra lower Mo\n\n\n\n\n@$==========================================================================\n@$ end of map15 macro\n@$==========================================================================\n\nset inter\n\n\n\n" }, { "path": "examples/macros/map16.OCM", "content": "@$\nnew Y\n\nset echo Y\n\n@$===================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ Mapping of isopleth in C-Cr-Fe\n@$\n@$===================================================================\n@$ \n@$\nr t ./steel7\nfe cr c\n \nset c t=1200 p=1e5 n=1 w%(cr)=13 w%(c)=1\n\nset ref C graphite\n\n\n\n\nc e\n\n@&\n\nl\nRESULTS\n1\n\n@&\n\nset ax 1 w%(c)\n0\n2\n.02\n\nset ax 2 t 800 1800 ,,\n\nmap\n\n\n@&\n\nplot\n\nT_C\n@$ Plotting this text is a bit complicated\n@$ The Y coordinate must be in the units used to calculate the diagram (Kelvin)\n@$ but the text will be plotted using the units for the plot (Celcius)\n@$ This will eventually be corrected (until then edit the ocgnu.plt file)\ntext\n1\n1100\n2\n0\nY\n\ntitle map 16 Fig 1\n\n\n@$ The lines with the same phase fix has the same color\n@&\n\nl ax\n\n@$ Plot with chemical potential of C\n\n@&\n\nplot\nac(c)\nT\nTitle Map 16 Fig 2\n\n\n@$ This diagram a bit strange as we have 2 potential axis in a ternary system\n@$ Along all lines there is a phase fix and and one or 2 more phases stable.\n@$ The single phase and two-phase regions are areas\n@$ but the 3-phase regions are also lines (the line FCC+M7C+M23C!!)\n@$ The invariant equilibrium with 4 stable phases is just a point\n@$ All according to Gibbs phase rule.\n\n@&\n\nplot\nx(c)\nHM\ntitle map 16, Fig 3, composition vs enthalpy, the invariant is clearly visible\n\n\n@$ In this diagram the invariant looks like a road crossing. \n\n\n@$==========================================================================\n@$ end of map16 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map17.OCM", "content": "new Y\n\nset echo Y\n\n\n@$ ==============================================================\n@$\n@$ calculate Al-Fe phase diagram including A2/B2 line in BCC\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ ==============================================================\n@$\n\nr t ./AlFe-4SLBF\n \n@&\n\n@$ Calculate an equilibrium in the B2\nset c t=1000 p=1e5 n=1 x(al)=.3\n\nc e\n\nl , 2\n\n@&\n\n@$ Change to condition in difference of y to the current value\nset c y(bcc,fe#3)-y(bcc,fe#2)\n\nl c\n\nset c x(al)=none\n\nc e\n\nl,,,,\n\n@$ We must not use the gridminimizer but with the current\n@$ conditions it is not allowed. We can use \"c e\" but safer with \"c n\"\n@$\n@$ The phase has B2 ordering as two sublattices have equal and high Fe content\n@$ and the other equal but lower Fe content.\n@$\n@$ Here the difference in Fe content is high\n@$ We can to calculate a line when this difference is small\n@$ First ensure we can set the difference as condition\n@&\n\n@$ Change the value of the difference in y\n@$ That is easy using the notation specifying the condition number\nl c\n\n\nset c 4:=.2\n\nl c\n\n@&\nc n\n\nl,,,,\n\n\n@$ The overall composition has changed as we are closer to the A2/B2 line\n@$ Decrease the difference again\n@&\n\nset c 4:=.01\n\nl c\n\n\n\n@&\n@$ We are now sufficiently close to the A2/B2 transition line\n\nc n\n\nl,,,\n\n\n@&\n\n\n@$ Set a T axis\nset ax 1 T 300 2000 5\n\n\nstep\n\n\n@$ plot the a2/b2 transition line\nplot\nx(al)\nT\ntitle map 17 fig 1a\n\n\n@&\n@$ Sometimes the lie stops at 1200 because the line up to the liquid\n@$ is considered wrong. Make sure it is included\n\namend line\ny\ny\n\n@$ plot as dashed line on a file to be appended\nplot\nx(al)\nT\nextra line\n0\ntitle map 17 fig 1b\n@$ The final Y means overwrite any previous file\noutput alfe-a2b2\nY\n\n@&\n@$ set inter\n@$ ==============================================\n@$ Now the Al-Fe phase diagram\n\nnew Y\n\n\n\nr t ./AlFe-4SLBF\n \n@&\n@$ Start with the High Al side\n\nset c t=1000 p=1e5 n=1 x(al)=.52\nc e\n\nl\nRESULTS\n2\n\n@&\n@$ Axis for the diagram\nset ax 1 x(al) 0 1 .01\nset ax 2 t 300 2000 25\n\nmap\n\n@&\n\npl\nX(*,AL)\nT\ntitle map 17 fig 2a\n\n\n@$ Mapping stops at B2/A2 transition in equilibrium with liquid\n@$ That is an error which has to be fixed. \n@&\n\nset c t=1900 p=1e5 n=1 x(al)=.3\nc e\nl,,,\n\n@&\n\nmap\nn\n\n\npl\nX(*,AL)\nT\ntitle map 17 fig 2b\n\n\n@$ The line liquid/BCC is still not complete,\n@$ The part connectiong to the high Al curve was automatically\n@$ excluded by OC as mapping stopped when the B2 became stable\n@$ BUT we can restore that part!\n\n\namend line\nY\nY\nY\n\n\n\n\n@&\nplot\n\n\ntitle map 17 fig 2c\n\n\n@$ Note there are two curves for liq/bcc around 50% Al.\n@$ These can be removed by editing the ocgnu.plt file\n\n@$ Now just the BCC/D03/B2 region missing\n@&\n\nset c t=600 x(al)=.25\n\nc e\n\nl,,,\n\n@$ Note that one composition set hase equal fractions in all 4\n@$ sublattices whereas the other has high and equal fraction of Fe\n@$ in 2 sublattices, less high fraction of Fe in the third and\n@$ high fraction of Al in the fourth. This is D0_3 ordering.\n@$\n@$ The grid minimizer in OC must know that the BCC has B permutation to find\n@$ this ordering miscibility gap. With that information it generates\n@$ gridpoints taking the ordering into account.\n@&\n\nmap\nn\n\n\n@&\n\npl\nX(*,AL)\nT\ntitle map 17 fig 2d\n\n\n\n@&\n@$ Now the gamma loop\n\nset c x(al)=.015 t=1400\n\nc e\n\nl,,,,\n\n@&\n\nmap\nn\n\n\n@$ Now plot everyting and append the already calculated and plotted a2/b2 curve\n@&\n\nplot\n\n\nappend alfe-a2b2\ntext .1 1100 .8 0 n\nBCC-A2\ntext n\n.35 1100 .8 0 n\nBCC-B2\ntext n\n.3 500 .8 0 n\nBCC-D03\ntitle map 17 fig 3\n\n\n@$\n@$ Developing OC is a hobby for me,\n@$ I have no ambition to solve all your problems calculating phase diagrams ...\n\n\n@&\n\n@$ Calculating and adding the para/ferro magnetic transion\n@$ along the Curie T curve is a task you can do yourself!\n@$ If you want you can calculate and add the B2/D0_3 transition curve also.\n\n\n\n\n@$==========================================================================\n@$ end of map17 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map18.OCM", "content": "new Y\n\nset echo Y\n\n@$ =========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map18.OCM\n@$ Calculate an isopleth phase diagram for Al-Mg-Zn\n@$ =========================================================\n@&\n\nset echo y\n\n\nr t ./cost507R\nal mg zn\n\n\n@$ The map is sensitive to the startpoint !!\nset cond t=900 p=1e5 n=1 x(mg)=.8 x(zn)=.05\n\nc e\n\nl r 1\n\n@&\n\n\nset ax 1 x(mg) 0 1 0.025\nset ax 2 t 300 1000 25\n\n\nmap\n\n\nplot\n\n\ntitle map18 fig 1\n\n@&\n\n@$ magnify the T axis\nplot\n\n\ntitle map18 fig 2\nscale y\nn\n500\n750\nextra line 2\ntext .5 680 .8 0\n\n\n\n@$ A nice diagram but the step length control is not very good\n\n\n@$==========================================================================\n@$ end of map18 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map19.OCM", "content": "@$\r\n\r\nnew Y\r\n\r\nset echo Y\r\n\r\n@$========================================================================\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$\r\n@$ Calculating the NaCl-MgCl phase diagram and activity curves using MQMQA\r\n@$\r\n@$========================================================================\r\nr t ./MgNaClX\r\n\r\n\r\n@&\r\n\r\nl d\r\n\r\n\r\n\r\n@&\r\n\r\nl mq\r\n\r\n@$ Listing of the MQMQA quadruplets with bonds\r\n@&\r\n\r\nset stat ph liq-na liq-mg=s\r\n\r\nl sh a\r\n\r\n@$ These phases are the pure liquid chlorids, used only for activity curves\r\n@&\r\n\r\nset c t=2000 p=1e5 n(mg)=.5 n(na)+n(mg)=1 ac(cl)=1\r\n\r\nc n\r\n\r\n\r\n@&\r\n\r\nl , 2\r\n\t \r\n@&\r\n\r\nset ax 1 n(mg) 0 1 .01\r\n\r\nset ax 2 t 300 2000 10\r\n\r\n@&\r\n\r\nmap\r\n\r\n\r\n@&\r\n\r\nplot\r\nx(*,mg)\r\nT_C\r\nscale y n 300 850\r\ntitle map 19 Fig 1\r\nextra axis-factor x 3\r\ntext .15 350 .9 0 n\r\nNote fraction scale multiplied by 3, the composition of compounds wrong\r\n\r\n\r\n@$ The scaling on horisontal axis in in moles Mg in the phases.\r\n@$ MgCl2 has 1/3, MgNaCl3 has 1/5=0.2, MgNa2Cl4 has 1/7=0.143\r\n@$ As the axis is multiplied with 3 the compound fractions are wrong\r\n\r\n@&\r\n\r\n@$ ==============================\r\n@$ Now calculate activities in liquid SALT at 1073 K\r\n\r\n@$ The condition for Cl is that is has constant activity\r\n@$ because the salt is stable only in a quasi-binary section NaCl-MgCl2\r\n@$ The amount of Cl cannot vary outside this region.\r\n\r\n@$ If there are other phases (gas for example) \r\n@$ which can exist outside the NaCl-MgCl2 quasibinary\r\n@$ one can use a condition of the amount of Cl\r\n@$ The activity condition can cause numerical problems\r\n@&\r\n\r\nset c t=1073 \r\n\r\n@&\r\n\r\nset stat ph *=sus\r\n\r\nset stat ph liqref_mgcl2 liqref_nacl=d\r\n\r\nset stat ph salt=e 1\r\n\r\n@$ We must set the LIQREF phases as dormant to have DGM of NaCl and MgCl2.\r\n@$ The DGM is the driving force for these compounds as liquid\r\n@$ and related to the chemical potential of these compounds.\r\n\r\n@&\r\n\r\nc e\r\n\r\nl , 2\r\n\r\n@$ There should not be any probem so far\r\n@&\r\n\r\n@$ OC cannot plot the activities of MgCl2 and NaCl directly\r\n@$ as they are not components. We must also take care of the reference state.\r\n@$ The Gibbs energies of pure NaCl and MgCl2 liquids are calculated\r\n@$ in GM(liqref-NaCl) and GM(liqref-MgCl) for one mole of atoms\r\n\r\nent sym refmgcl2=3*gm(liqref-mgcl2);\r\n\r\n@$ MU(MG) is the chemical potential of 1 mole Mg (as mu(cl)=0 or ac(cl)=1)\r\n@$ Subtracting the reference state gives the chemical potential of MgCl2\r\n\r\nenter sym mumgcl2=mu(mg)-refmgcl2;\r\n\r\n@$ The activity is the exponential of the chemical potential divided by RT\r\nenter sym acmgcl2=exp((mu(mg)-refmgcl2)/RT);\r\n\r\n@$ The same for NaCl (with 2 moles of atoms) as for MgCl2\r\n\r\nenter sym refnacl=2*gm(liqref-nacl);\r\n\r\nenter sym munacl=mu(na)-refnacl;\r\n\r\nenter sym acnacl=exp((mu(na)-refnacl)/RT);\r\n\r\n@&\r\n\r\n@$ We must remove the second axis to calculate with STEP\r\nset ax 2 none\r\n\r\nl ax\r\n\r\n@&\r\n\r\n@$ For some unknown reason n(mg) axis does not go to lower values\r\n@$ Thus stat at n(mg)=.01\r\n\r\nset c n(mg)=.01\r\n\r\nc e\r\n\r\n\r\nstep\r\n\r\n\r\n@$ and there should be no problmens so far\r\n@&\r\n\r\nplot\r\n\r\ny(salt,*)\r\ntitle map 19 Fig 2\r\nout ./ymgnacl\r\nY\r\n\r\n\r\n@$ This plot show the fraction of the constituents (quadrupoles)\r\n@&\r\n\r\n\r\nplot\r\n\r\nacnacl\r\nout ./acnacl\r\nY\r\ntitle map 19 Fig 3\r\n\r\n\r\n@$ This plot is the activity of NaCl with liquid at same T as reference state\r\n@&\r\n\r\nplot\r\n\r\nacmgcl2\r\ntitle map 19 Fig 4\r\n\r\n\r\n@$ This plot is the activity of MgCl2 with liquid at same T as reference state\r\n@&\r\n\r\nplot\r\n\r\nacmgcl2\r\napp ./acnacl\r\ntitle map 19 Fig 5\r\nout ./acmgnacl\r\nY\r\n\r\n\r\n@$ Both activity plots together fit the Fig. 8 in the paper by Pelton 2001\r\n\r\n\r\n@$==========================================================================\r\n@$ end of map10 macro\r\n@$==========================================================================\r\n\r\nset inter\r\n\r\n\r\n" }, { "path": "examples/macros/map2.OCM", "content": "new Y\n\n\nset echo Y\n\n@$ =============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map2.OCM\n@$ Calculate the miscibility gap and liquidus for Cr-Mo\n@$ =============================================================\n@&\n\nset echo\n\nr t ./steel1\ncr mo\n\nset cond t=800 p=1e5 n=1 x(mo)=.5\n\nc e\n\nl r 1\n\n@&\n\nset ax 1 x(mo) 0 1 ,,\nset ax 2 t 500 3000 25\n\nl ax\n\nl sh\n\n@&\n\nmap \n\n\n@&\n\nplot\nx(*,cr)\nT\ntitle map 2 fig 1\nrender\n\n@&\nset cond t=2500 x(mo)=.3\nc e\n\nmap\nN\n\n\nplot\n\n\ntitle map 2 fig 2\n\n\n@&\n\nplot\n\n\n@$ One more option for scale of text!\ntext\n0.5 1400\n.8\n0\ny\n\ntext\nn 0.5 2800 .8 0 y\n\ntitle map 2 fig 3\n\n\n\n\n@&\n\n\n\n@$==========================================================================\n@$ end of map2 macro\n@$==========================================================================\n\n\nset inter\n" }, { "path": "examples/macros/map3.OCM", "content": "new Y\n\nset echo Y\n\n@$ =================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map3.OCM\n@$ Calculate the stable C-Fe phase diagram\n@$ =================================================================\n@&\n\nset echo\n\nr t ./steel1\nfe c\n\n\nset cond t=1200 p=1e5 n=1 x(c)=.2\n\nset ref-state c\ngraph\n\n\n\n\nc e\n\nl r 1\n\n@&\n\nset ax 1 x(c) 0 1 ,,,\nset ax 2 t 500 2000 10\n\nl ax\n\nl sh\n\n\n@&\n\nmap\n\n\n@&\n\nplot\nx(*,c)\nT\ntitle map 3 fig 1\nrender\n\n@&\n\n@$ Again this plot will be written on the WORKING DIRECTORY\n@$ and will be appended from there later\nplot\nw%(*,c)\nT_C\nscale x\nn\n0\n7\ntitle map 3 fig 2\nout ./stable\nY\nrender\n\n@&\n@$---------------------------------------------------------\n@$ Calculate the metastable Fe-C with cementite\nset st ph *=sus\nset st ph fcc bcc liquid cem=ent 0\n\nl c\n\nset c x(c)=.2 t=1200\n\nc e\n\nl,,,,,\n\n@&\n@$ Change the axis as we are not interested in high C content\n\nset ax 1 x(c) 0 .4 ,,,\n\n\nl ax\n\n\n@&\nmap\n\n\n\n@$ Plot the metastable Fe-C diagram\nplot\nw%(*,C)\nt_c\ntitle map 3 fig 3\n\n\n\n@&\n@$ now overlay the stable\n@$ NOTE the stable.plt file was saved on the WORKING DIRECTORY\nplot\n\n\ntitle map 3 fig 4\nappend ./stable\n\n\n@&\n@$ Scale the X-axis\nplot\n\n\ntitle map 3 fig 5\nscale\nx\nn\n0\n7\n\n\n@$\n@&\nplot\n\n\ntitle map 3 fig 6\nscale x\nn\n0\n2.5\nscale y\nn\n700\n1200\npos\ntop left\n12\ntext \n1 1100 \n1.2\n0\nn \naustenite\n\n\n\n@&\n@$ Finally, plot the metastable diagram with enthalpy axis !!\n@$ the state variable H(*) means the enthalpy of each phase\n\nplot\nx(*,c)\nHM(*)\nextra tie\n?\n3\ntitle map 3 fig 7\n\n\n@$ Normally we cannot plot tie-lines in a binary x-T diagram\n@$ but when T is exchanged for HM(*) both axis are exensive (normallized)\n@$ properties and then we can plot tie-lines!\n\n@&\n@$ Note: plotting with composition axis chenged to activity\n@$ will plot the (vertical) 3-phase lines at wrong activity .... why?\n\n\n@$==========================================================================\n@$ end of map3 macro\n@$==========================================================================\n\nset inter\n" }, { "path": "examples/macros/map4.OCM", "content": "new Y\n\n\nset echo Y\n\n\n@$ ===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map4.OCM\n@$ Calculate the phase diagram for O-U\n@$ ===============================================================\n@&\n\nset echo\n\nr t ./OU\n\n\nset c t=2800 p=1e5 n=1 x(o)=.5\n\nc e\n\nl r 2\n\n@&\n\nset ax 1 x(o) 0 1 0.005\n\nset ax 2 t 300 3500 20\n\nmap\n\nplot\nx(*,o)\nT\ntitle map 4 fig 1a\nrender\n\n\n\n@&\n\n@$ Sometimes lower O-rich side at low T is missing\n@&\n\nset c t=500 x(o)=.68\nc e\n\nmap\nN\n\n\n\nplot\n\n\ntitle map4 fig 1b\n\n\n@&\n@$ Now add some layout features\nplot\n\n\ntitle map 4 fig 2\n@$ this command moves the idenification of lines in bottom left\n@$ the empty line means accept curront font and size\nposition bottom left\n\n@$ This command adds the names of phases stable at given positions\ntext\n0.59\n3300\n.8\n0\ny\n\n@$ First question asked for 2nd and later \"text\" is if to amend an existing one\n@$ This is inside the C1 phase\ntext\nn\n0.65\n2600 .8 90 y\n\n@$ This is inside the gas phase\ntext\nn\n0.9\n3100\n.8 0 y\n\ntitle map 4 fig 2B\nrender\n\n@&\n\n\n@$ To add a label at 700 K and high oxygen I need to calculate\n@$ that equilibria explicitly first!!\nset c t=700 x(o)=.8\nc e\n\nl,,,,\n\n@&\nplot\n\n\ntext n\n0.8 700 .8 0 y\n\ntitle map 4 fig 3\n\n\n\n\n@&\n\nplot\n\n\ntitle map 4 fig 4\nscale x\nN \n.58 \n.78\nrender\n\n@&\nplot\n\n\ntitle map 4 fig 5\nscale y\nN\n2500\n3200\n\n\n\n@&\n@$-------------------------------------------------------------\n@$ As a final touch calculate the congruent melting of UO2\n@$ First calculate an equilibrium in the liquid (or solid) above it\n\nl c\n\nset c x(o)=.66 t=3300\n\nc e\n\nl,,,,,\n\n@&\n@$----------------------------------------------------------\n@$ Then set C1_MO2 as fix with zero amount\n\nset stat ph c1_mo2=f 0\nset c t=none\nl c\n\nc e\n\nl,,,,,\n\n@&\n@$---------------------------------------------------------\n@$ Finally replace the condition of U with the condition\n@$ that it should be the same in liquid and C1\n@$ IT IS IMPORTANT TO USE THE COMPOSITION SETS THAT ARE STABLE ABOVE\n\nset c x(ion_liquid,u)-x(c1_mo2,u)=0\nset c x(o)=none\nl c\n\nc e\n\nl,,,,\n\n@$ Voila! \n@$ T=3139 K and x(o)=.6638, slightly on the U rich side.\ndebug symbol t 3139.16\n\n@&\n\n@$==========================================================================\n@$ end of map4 macro\n@$==========================================================================\n\nset interactive\n\n" }, { "path": "examples/macros/map5.OCM", "content": "new Y\n\nset echo Y\n\n@$ ===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map5.OCM\n@$ Calculate the phase diagram for Fe-Mo\n@$ ===============================================================\n@&\n\nset echo\n\nr t ./steel1\nfe mo\n\n@&\n@$------------------------------------------------------------------------\n@$ Create an extra composition set for BCC ... not really necessay\n\namend phase\nbcc\ncomp\nY\nFE\n\n>.5\n<.1\n\namend phase\nbcc\ndef\n<.1\n>.5\n\n\n@&\n@$--------------------------------------------------------------------\n@$ Set conditions\n\nset cond t=2000 p=1e5 n=1 x(mo)=.7\n\nc e\n\nl r 1\n\n@&\n@$--------------------------------------------------------------------\n@$ Set axis for phase diagram\n\nset ax 1 x(mo) 0 1 ,,\nset ax 2 t 300 3000 25\n\nl ax\n\nl sh\n\n\n@&\n@$--------------------------------------------------------------------\n\nmap\n\n\n@&\n@$--------------------------------------------------------------------\n@$ Plot the diagram\nplot\nx(*,mo)\nT\ntitle map 5 fig 1\nrender\n\n\n@&\n\n@$--------------------------------------------------------------------\n@$ we must calculate the gamma loop separately\n\nset c t=1400 x(mo)=.002\n\nc e\n\nl,,,,,\n\n@&\n@$--------------------------------------------------------------------\n\nmap \nN\n\n\nplot\nx(*,mo)\nT\nposition bottom right\n\ntitle map 5 fig 2\nrender\n\n\n@&\n@$ Set range (scaling) of T\nplot\nx(*,mo)\nT\nscale y\nN\n1400\n1900\ntitle map5 fig 3\nrender\n\n@&\n\n@$ Add some labels\n\nplot\n\n\ntitle map 5 fig 4\ntext \n.5 1700\n.8\n0\ny\n\ntext\nn .4 1530 .8 0 y\n\ntext n .1 1850 .8 0 y\n\ntext n .36 1650 .8 0 n\nR\n\n@&\n@$ Change to greek phase names\nplot\n\n\ntitle map 5 fig 5\ntext\ny \n4\n{/Symbol s}\n\n\n\n\ntext\ny\n3\n{/Symbol m}\n\n\n\n\n\n\n\n@&\n\n\n@$==========================================================================\n@$ end of map5 macro\n@$==========================================================================\n\n\n\nset inter\n" }, { "path": "examples/macros/map6.OCM", "content": "new Y\n\nset echo Y\n\n\n@$ ===========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map6.OCM\n@$ Calculate an isopleth for Cr-Fe-Ni at 8 mass% Ni\n@$ ===========================================================\n@&\n\nset echo\n\nr t ./saf2507\ncr fe ni\n \nset c t=1200 p=1e5 w(cr)=.2 w(ni)=.08 n=1\n\nc e\nl\n\n4\n\n@&\n\nset ax 1 w(cr) 0 1 0.01\nset ax 2 t 800 2200 25\n\n\nmap\n\n\n@&\n\nplot\nw(CR)\nT\ntitle map 6 fig 1\nrender\n \n \n@$ All lines at at w(cr)=0.92 at the rght because there is 8% Ni\n\n@$ A line in the lower middle end above 800 K, add a start point\n\nset c w(cr)=.3 t=1000\n\nc e\n\nmap\nn\n\n@$ now plot\n@&\n@$ add some labels\nplot\n\n\nscale y n 800 2200\ntitle map 6 fig 2\ntext \n0.1 2000\n.9\n0\ny\n\ntext n\n.5 1500 .9 0 y\n\ntext n\n.05 1200 .9 0 y\n\ntext n\n.46 1160 .9 0 y\n{/Symbol s}\ntext n\n.75 1200 .9 0 y\n\n\n@&\n\nplot\n\n\ntitle map 6 fig 3\nscale y\nn\n1700\n1800\n\n\n@&\nplot\n\n\ntitle map 6 fig 4\nscale y\nn\n1150\n1250\n\n\n\n@&\n\n\n@$==========================================================================\n@$ end of map6 macro\n@$==========================================================================\n\n\nset interactive\n" }, { "path": "examples/macros/map7.OCM", "content": "new Y\n\n\nset echo Y\n\n\n@$ =============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map7.OCM\n@$ Calculate an isopleth for a HSS\n@$ =============================================================\n@&\n\nset echo\n\nr t ./steel1 c cr fe mo v\n\n@$ There will be a cubic carbide stable in this system\n@$ create a composition set of the fcc phase for that\namend phase \nfcc\n\nY\nMC\n\nNONE\n<.5\n\n>.5\n>.5\n<.5\n\n@$ amend the default composition also of the austenite\namend phase\nfcc\ndefault\n<.1\n>.5\n<.1\n<.1\n<.1\n>.9\n\n@&\n@$ calculate a first equilibrium at 1200 where we have both fcc phases \n\nset reference C graph\n\n\n\n\n@$ Startpoint change needed for new gridminimizer, same diagram\nset c t=1300 p=1e5 n=1 w%(c)=0.8 w%(cr)=5, w%(mo)=8 w%(v)=1\n\n@$ It is important that the grid minimizer provide gridpoints with small\n@$ amounts of alloying elements !!!\n\n\nc e\n\nl r 4\n\n@&\n\nset axis 1 w%(c) 0 2 ,,,\nset axis 2 T 800 1800 25\n\nl ax\n\n@&\n\nmap\n\n\n@$ You may get a buffer overflow error here\n@$ but there is not yet any way saving of results on file implemented\n@$ Until then you have to restrict yourself to smaller diagrams\n@&\n\n\nplot\n\n\ntitle map 7 fig 1\n\n@&\n@$ Some lines are still missing but the invariants are OK\n@$ There is a need for several automatic startpoints\n@$ add some labels\n\nplot\n\n\ntitle map 7 fig 2\nscale x\nn\n0\n2\n@$ Position of keys, Size of font must be on separate line!\npos\nbottom left\n12\n@$ Label some areas\ntext\n0.7 1150\n.8\n0\ny\n\ntext\nn\n0.4 1050\n.8\n0\ny\n\ntext\nn .55 1300 .8 0 y \n\ntext\nn .5 1470 .8 0 y\n\ntext \nn 0.1 1450 .8 0 y\n\ntext \nn 0.8 1580 .8 0 y\n\n\n@&\n@$ We can list all calculated equilibria\n\nl l\n\n@&\n\n@$ or all node points\n\nl eq\n\nplot\n\n\nscale y\nn\n1500\n1700\nscale x\nn\n0\n1\ntext\nn 0.3 1670 .8 0 y\n\ntitle map 7 fig 3\n\n\n\n@&\n\nplot\n\n\nscale y\nn\n1000\n1350\nscale x\nn\n0\n2\ntitle map7 fig 4\n\n\n\n@$==========================================================================\n@$ end of map7 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map8.OCM", "content": "new Y\n\nset echo Y\n\n\n@$ ====================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map8.OCM\n@$ Enter the data interactively and\n@$ Calculate a phase diagram for FCC ordering in the Fe-Ni system\n@$ using partition and permutations\n@$\n@$ NOTE in this case we use the option to set FCC_PERMUTATIONS\n@$ so each unique parameters is entered only once (compare with map4.OCM)\n@$\n@$ We also set the bit 23 of the phase not to subtract the ordered part\n@& as disordered. Thus the disordered part has just a regular parameter,\n@$ we do not have to add the ordered part as disordered as in map4.OCM.\n@$ =========================================================================\n@&\n\nset echo\n\n@$ Enter the elements and their reference states\nenter element Fe Iron BCC 55.847 0 0 \n\nenter element Ni Nickel FCC 58.69 0 0\n\n@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3\n@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are:\n@$ Fe3Ni1 -0.071689 eV for 1 atom??\n@$ Fe2Ni2 -0.138536 eV for 1 atom??\n@$ Fe1Ni3 -0.125748 eV for 1 atom??\n@$ To modify to J/mol atoms multiply with 96500\n@$ bond energy multiplied with 3, 4 and 3 respectively.\n\nenter tp-sym evtoj constant 96500\n\nenter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,,\nenter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,,\nenter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,,\n \n@$ We set a positive regular solution parameter\nenter tp-sym L0 fun 1 12000; ,,,,,\n\n@$ this is an approximate SRO contribution to the LRO phase. It is\n@$ set to about a quater of the L1_0 ordering energy, \n@$ equal to the Fe-Ni bond energy\nenter tp-sym GSRO fun 1 -0.034*evtoj;,,,,,\n\n@$ Using the partitioned model the contribition from the ordered parameters\n@$ will cancel when the phase is disordered. If we want them to contribute\n@$ we must add them to the disordered part\nenter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,,\nenter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,,\nenter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,,\n\n@$ ==================================================\n@$ This is an fcc phase with lro but no explicit sro\n@$ described with the sublattice model\n\nenter phase PARTITIONED_FCC \nCEF\n4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI;\n\n@$ we must set that this has FCC permutations before entering parameters\namend phase part-fcc\n?\nfcc-perm\n\n@&\n\n@$ we must add disordered set before entering parameters\n@$ We are not modeling the disordered part independently\namend phase part dis 4\nNO\n\n@&\n\n@$ enter the parameter, note permutations taken into account\nenter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test\nenter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test\nenter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test\n\nenter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test\n\namend biblio test VASP calculation by test;\n\n@$ These are possible disordered parameters\nenter param GD(part,Fe,Ni;0),,L0; 6000 N test\n\n\nlist data ,,\n\n\n@&\n\n@$ we should create composition for the ordered sets sets manually\n\n@$ this default constitution is Fe3Ni_L12\namend phase part comp-set y , ,\n<.2 >.5\n>.2 <.5\n>.2 <.5\n>.5 <.2\n\n@$ this default constitution is FeNi_L10\namend phase part comp-set y , ,\n<.2 >.5\n<.2 >.5\n>.5 <.2\n>.5 <.2\n\n@$ this default constitution is FeNi3_L12\namend phase part comp-set y , ,\n<.2 >.5\n<.2 >.5\n<.2 >.5\n>.5 <.2\n\n@$ However, the L12 can have max Ni or Fe on any sublattice, there is no\n@$ check that it is always the first or last sublattice with the highest\n@$ fraction of the minor element. This should be arranged in todo_after ...\n\n\nl sh a\n\n@&\n@$ First start point between the A1 and L1_2 phases in the middle\nset c t=350 p=1e5 n=1 x(ni)=.57\n\nc e\n\nl r 2\n\n\n@&\n\nset ax 1 x(ni) 0 1 0.025\n\nset ax 2 t 10 1000 10\n\n\nmap\n\n\n@&\n\nplot\n\n\ntitle map 8 fig 1\n\n\n@$ Sometimes parts are missing, add a point on Ni-rich side\n@&\n\n\n@$ this falis for oc6d\n@$ set c x(ni)=.60 T=500\n\nset c x(ni)=.9 t=400\n\nc e\n\nl,,,,\n\n@&\n\nmap\nN\n\n\nplot\n\n\ntitle map 8 fig 2\n\n\n@&\n\n@$ Sometimes parts are missing, add a point an on Fe-rich side\n\nset c x(ni)=.45 t=200\n\nc e\n\nmap\nN\n\n\nplot\n\n\ntitle map 8 fig 3\n\n\n@&\n\n\n@$ The mapping is not really good handling the order/disorder transitions\n\nset inter\n\n\n@$ Third start point on the Fe-rich side\nset c x(ni)=.4 T=300\n\nc e\n\nl,,,,\n\n@&\n\nmap\nN\n\n\nplot\n\n\npos\ntop left\n\ntitle map 8 fig 3\n\n\n@&\n\n\n@$==========================================================================\n@$ end of map8 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/map9.OCM", "content": "new Y\n\nset echo Y\n\n@$ ===================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ map9.OCM\n@$ OC macro file for RE-W system, \n@$ Data is entered interactively\n@$ M Palumbo, S G Fries, T Hammerschmidt et al, \n@$ Comp. Mat. Sci, Vol 81 (2014) 433-445; \n@$ ===================================================================\n@&\n\nset echo\n\nenter element RE Rhenium HCP 186.21 5355.5 36.526\nenter element W Tungsten BCC 183.85 4970.0 32.62\n\nenter tpfun GHSERRE fun 298.15 0;,,,,\nenter tpfun GHSERW fun 298.15 0;,,,,\nenter tpfun UNASS fun 298.15 0; 300,,,,\nenter tpfun ZERO fun 298.15 0; 6000,,,,\n\n@$ eVtoJ is J/eV per atom, eVtoJ29 the same for 29 atoms etc.\nenter tpfun eVtoJ const 96490,,,,\nenter tpfun eVtoJ8 fun 298.15 8*eVtoJ;,,,,,\nenter tpfun eVtoJ12 fun 298.15 12*eVtoJ;,,,,,\nenter tpfun eVtoJ13 fun 298.15 13*eVtoJ;,,,,,\nenter tpfun eVtoJ24 fun 298.15 24*eVtoJ;,,,,,\nenter tpfun eVtoJ29 fun 298.15 29*eVtoJ;,,,,\nenter tpfun eVtoJ30 fun 298.15 30*eVtoJ;,,,,,\n\nl tp *\n\n@$---------------\n@&\n\nenter phase fcc \nCEF\n4 \n.25 RE W;\n.25 RE W;\n.25 RE W;\n.25 RE W;\n\n@$ mark that we have parameter permutations according to fcc tetrahedrons\namend phase fcc\n?\nfcc_perm\n\n@&\n\nent par G(fcc,RE:RE:RE:RE) 298.15 0.062787*eVtoJ;,,,14Pal fcc.A\n@$ The L1_2 ordering parameter on the Re side\nent par G(fcc,W:RE:RE:RE) 298.15 0.11703575*eVtoJ;,,,14Pal L12.A3B\n@$ The L1_0 ordering parameter\nent par G(fcc,W:W:RE:RE) 298.15 0.2098125*eVtoJ;,,,14Pal L10.AB \n@$ The L1_2 ordering parameter on the W side\nent par G(fcc,W:W:W:RE) 298.15 0.33351125*eVtoJ;,,,14Pal L12.AB3 \nent par G(fcc,W:W:W:W) 298.15 0.474125*eVtoJ;,,,14Pal fcc.B \n@$-----------\n\nlist data\n\n@&\n\namend bib 14Pal M Palumbo, S G Fries, T Hammerschmidt et al,\nComp. Mat. Sci, Vol 81 (2014) 439-445;\n\nlist data\n\n@&\n\nenter phase bcc \nCEF\n4 .25 RE W; .25 RE W; .25 RE W; .25 RE W;\n\n@$ mark that we have parameter permutations according to bcc tetrahedrons\namend phase bcc bcc_perm\n\nent par G(bcc,RE:RE:RE:RE) 298.15 0.320286*eVtoJ;,,,14Pal bcc.A\n@$ The D03 ordering parameter on Re side\nent par G(bcc,W:RE:RE:RE) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B\n@$ The B2 ordering parameter, sublattice 1&2 are next nearest neighbours\nent par G(bcc,W:W:RE:RE) 298.15 0.0971185*eVtoJ;,,,14Pal B2.AB\n@$ The B32 ordering parameter\nent par G(bcc,W:RE:W:RE) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB\n@$ The D03 ordering parameter on W side\nent par G(bcc,W:W:W:RE) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3\nent par G(bcc,W:W:W:W) 298.15 0*eVtoJ;,,,14Pal bcc.B\n@$-----------\n\nlist data\n\n@&\n\nlist phase bcc data\n\n@&\n\n@$-------\n\nenter phase hcp \nCEF\n4 .25 RE W; .25 RE W; .25 RE W; .25 RE W;\n@$ The HCP tetrahedron is the same as FCC\n\namend phase hcp fcc_perm\n\nent par G(hcp,RE:RE:RE:RE) 298.15 0*eVtoJ;,,,14Pal hcp.A\nent par G(hcp,W:RE:RE:RE) 298.15 0.12874775*eVtoJ;,,,14Pal D0_19.A3B\nent par G(hcp,W:W:RE:RE) 298.15 0.2823905*eVtoJ;,,,14Pal B19.AB\nent par G(hcp,W:W:W:RE) 298.15 0.38047325*eVtoJ;,,,14Pal D0_19.AB3\nent par G(hcp,W:W:W:W) 298.15 0.490701*eVtoJ;,,,14Pal hcp.B\n\nlist phase hcp data\n\n@&\n@$-------\n\nent phase A15 \nCEF\n2 2 RE W; 6 RE W;\nent par G(A15,RE:RE) 298.15 0.185144*eVtoJ8;,,,14Pal A15.A\nent par G(A15,RE:W) 298.15 0.19109475*eVtoJ8;,,,14Pal A15.AB\nent par G(A15,W:RE) 298.15 0.02878425*eVtoJ8;,,,14Pal A15.BA\nent par G(A15,W:W) 298.15 0.089645*eVtoJ8;,,,14Pal A15.B\n\nlist phase A15 data\n\n@&\n@$--------\n\nent phase sigma \nCEF \n5 2 RE W; 4 RE W; 8 RE W; 8 RE W; 8 RE W;\n\nent par G(sigma,RE:RE:RE:RE:RE) 298.15 0.103465*eVtoJ30;,,,14Pal sigma.A\nent par G(sigma,W:RE:RE:RE:RE) 298.15 0.117920533*eVtoJ30;,,,14Pal sigma.BAAAA\nent par G(sigma,RE:W:RE:RE:RE) 298.15 0.074164067*eVtoJ30;,,,14Pal sigma.ABAAA\nent par G(sigma,W:W:RE:RE:RE) 298.15 0.0887456*eVtoJ30;,,,14Pal sigma.BBAAA\nent par G(sigma,RE:RE:RE:RE:W) 298.15 0.075425133*eVtoJ30;,,,14Pal sigma.AAAAB\nent par G(sigma,RE:RE:RE:W:RE) 298.15 0.144846133*eVtoJ30;,,,14Pal sigma.AAABA\nent par G(sigma,RE:RE:W:RE:RE) 298.15 0.062163133*eVtoJ30;,,,14Pal sigma.AABAA\nent par G(sigma,W:RE:RE:RE:W) 298.15 0.096883667*eVtoJ30;,,,14Pal sigma.BAAAB \nent par G(sigma,W:RE:RE:W:RE) 298.15 0.166788667*eVtoJ30;,,,14Pal sigma.BAABA \nent par G(sigma,W:RE:W:RE:RE) 298.15 0.078029667*eVtoJ30;,,,14Pal sigma.BABAA \nent par G(sigma,RE:W:RE:RE:W) 298.15 0.0425622*eVtoJ30;,,,14Pal sigma.ABAAB\nent par G(sigma,RE:W:RE:W:RE) 298.15 0.1150282*eVtoJ30;,,,14Pal sigma.ABABA\nent par G(sigma,RE:W:W:RE:RE) 298.15 0.0432172*eVtoJ30;,,,14Pal sigma.ABBAA\nent par G(sigma,W:W:RE:RE:W) 298.15 0.067439733*eVtoJ30;,,,14Pal sigma.BBAAB\nent par G(sigma,W:W:RE:W:RE) 298.15 0.141463733*eVtoJ30;,,,14Pal sigma.BBABA\nent par G(sigma,W:W:W:RE:RE) 298.15 0.062896733*eVtoJ30;,,,14Pal sigma.BBBAA\nent par G(sigma,RE:RE:RE:W:W) 298.15 0.145899267*eVtoJ30;,,,14Pal sigma.AAABB\nent par G(sigma,RE:RE:W:RE:W) 298.15 0.052479267*eVtoJ30;,,,14Pal sigma.AABAB\nent par G(sigma,RE:RE:W:W:RE) 298.15 0.151518267*eVtoJ30;,,,14Pal sigma.AABBA\nent par G(sigma,W:RE:RE:W:W) 298.15 0.1732738*eVtoJ30;,,,14Pal sigma.BAABB\nent par G(sigma,W:RE:W:RE:W) 298.15 0.0767538*eVtoJ30;,,,14Pal sigma.BABAB\nent par G(sigma,W:RE:W:W:RE) 298.15 0.1743168*eVtoJ30;,,,14Pal sigma.BABBA\nent par G(sigma,RE:W:RE:W:W) 298.15 0.117787333*eVtoJ30;,,,14Pal sigma.ABABB\nent par G(sigma,RE:W:W:RE:W) 298.15 0.031243333*eVtoJ30;,,,14Pal sigma.ABBAB\nent par G(sigma,RE:W:W:W:RE) 298.15 0.135710333*eVtoJ30;,,,14Pal sigma.ABBBA\nent par G(sigma,W:W:RE:W:W) 298.15 0.149161867*eVtoJ30;,,,14Pal sigma.BBABB \nent par G(sigma,W:W:W:RE:W) 298.15 0.059292867*eVtoJ30;,,,14Pal sigma.BBBAB \nent par G(sigma,W:W:W:W:RE) 298.15 0.165621867*eVtoJ30;,,,14Pal sigma.BBBBA \nent par G(sigma,RE:RE:W:W:W) 298.15 0.1662344*eVtoJ30;,,,14Pal sigma.AABBB\nent par G(sigma,W:RE:W:W:W) 298.15 0.192115933*eVtoJ30;,,,14Pal sigma.BABBB\nent par G(sigma,RE:W:W:W:W) 298.15 0.142513467*eVtoJ30;,,,14Pal sigma.ABBBB\nent par G(sigma,W:W:W:W:W) 298.15 0.17298*eVtoJ30;,,,14Pal sigma.B\n\nlist phase sigma data\n\n@&\n@$-------------\n\nent phase chi \nCEF\n4 1 RE W; 4 RE W; 12 RE W; 12 RE W;\nent par G(chi,RE:RE:RE:RE) 298.15 0.057085*eVtoJ29;,,,14Pal chi.A\nent par G(chi,W:RE:RE:RE) 298.15 0.044341138*eVtoJ29;,,,14Pal chi.BAAA\nent par G(chi,RE:W:RE:RE) 298.15 0.010266552*eVtoJ29;,,,14Pal chi.ABAA\nent par G(chi,W:W:RE:RE) 298.15 0.00176469*eVtoJ29;,,,14Pal chi.BBAA\nent par G(chi,RE:RE:RE:W) 298.15 0.222213655*eVtoJ29;,,,14Pal chi.AAAB\nent par G(chi,RE:RE:W:RE) 298.15 0.107317655*eVtoJ29;,,,14Pal chi.AABA\nent par G(chi,W:RE:RE:W) 298.15 0.203353793*eVtoJ29;,,,14Pal chi.BAAB \nent par G(chi,W:RE:W:RE) 298.15 0.093724793*eVtoJ29;,,,14Pal chi.BABA \nent par G(chi,RE:W:RE:W) 298.15 0.154246207*eVtoJ29;,,,14Pal chi.ABAB \nent par G(chi,RE:W:W:RE) 298.15 0.065460207*eVtoJ29;,,,14Pal chi.ABBA\nent par G(chi,W:W:RE:W) 298.15 0.138812345*eVtoJ29;,,,14Pal chi.BBAB\nent par G(chi,W:W:W:RE) 298.15 0.059790345*eVtoJ29;,,,14Pal chi.BBBA\nent par G(chi,RE:RE:W:W) 298.15 0.32744331*eVtoJ29;,,,14Pal chi.AABB\nent par G(chi,W:RE:W:W) 298.15 0.312474448*eVtoJ29;,,,14Pal chi.BABB\nent par G(chi,RE:W:W:W) 298.15 0.294603862*eVtoJ29;,,,14Pal chi.ABBB\nent par G(chi,W:W:W:W) 298.15 0.283917*eVtoJ29;,,,14Pal chi.B \n\nlist phase chi data\n\n@&\n@$----------\n\nent phase mu \nCEF\n5 1 RE W; 6 RE W; 2 RE W; 2 RE W; 2 RE W;\nent par G(mu,RE:RE:RE:RE:RE) 298.15 0.213904*eVtoJ13;,,,14Pal mu.A\nent par G(mu,W:RE:RE:RE:RE) 298.15 0.232698923*eVtoJ13;,,,14Pal mu.BAAAA\nent par G(mu,RE:RE:RE:RE:W) 298.15 0.237154846*eVtoJ13;,,,14Pal mu.AAAAB\nent par G(mu,RE:RE:RE:W:RE) 298.15 0.172403846*eVtoJ13;,,,14Pal mu.AAABA\nent par G(mu,RE:RE:W:RE:RE) 298.15 0.166768846*eVtoJ13;,,,14Pal mu.AABAA\nent par G(mu,W:RE:RE:RE:W) 298.15 0.261267769*eVtoJ13;,,,14Pal mu.BAAAB \nent par G(mu,W:RE:RE:W:RE) 298.15 0.187943769*eVtoJ13;,,,14Pal mu.BAABA \nent par G(mu,W:RE:W:RE:RE) 298.15 0.189324769*eVtoJ13;,,,14Pal mu.BABAA \nent par G(mu,RE:RE:RE:W:W) 298.15 0.195145692*eVtoJ13;,,,14Pal mu.AAABB \nent par G(mu,RE:RE:W:RE:W) 298.15 0.193476692*eVtoJ13;,,,14Pal mu.AABAB \nent par G(mu,RE:RE:W:W:RE) 298.15 0.136986692*eVtoJ13;,,,14Pal mu.AABBA \nent par G(mu,W:RE:RE:W:W) 298.15 0.216702615*eVtoJ13;,,,14Pal mu.BAABB\nent par G(mu,W:RE:W:RE:W) 298.15 0.216780615*eVtoJ13;,,,14Pal mu.BABAB\nent par G(mu,W:RE:W:W:RE) 298.15 0.156615615*eVtoJ13;,,,14Pal mu.BABBA\nent par G(mu,RE:RE:W:W:W) 298.15 0.157312538*eVtoJ13;,,,14Pal mu.AABBB\nent par G(mu,RE:W:RE:RE:RE) 298.15 0.340443538*eVtoJ13;,,,14Pal mu.ABAAA\nent par G(mu,W:RE:W:W:W) 298.15 0.174036462*eVtoJ13;,,,14Pal mu.BABBB\nent par G(mu,W:W:RE:RE:RE) 298.15 0.369531462*eVtoJ13;,,,14Pal mu.BBAAA \nent par G(mu,RE:W:RE:RE:W) 298.15 0.385507385*eVtoJ13;,,,14Pal mu.ABAAB\nent par G(mu,RE:W:RE:W:RE) 298.15 0.294760385*eVtoJ13;,,,14Pal mu.ABABA\nent par G(mu,RE:W:W:RE:RE) 298.15 0.314514385*eVtoJ13;,,,14Pal mu.ABBAA\nent par G(mu,W:W:RE:RE:W) 298.15 0.421966308*eVtoJ13;,,,14Pal mu.BBAAB\nent par G(mu,W:W:RE:W:RE) 298.15 0.326644308*eVtoJ13;,,,14Pal mu.BBABA\nent par G(mu,W:W:W:RE:RE) 298.15 0.344868308*eVtoJ13;,,,14Pal mu.BBBAA\nent par G(mu,RE:W:RE:W:W) 298.15 0.346191231*eVtoJ13;,,,14Pal mu.ABABB\nent par G(mu,RE:W:W:RE:W) 298.15 0.355482231*eVtoJ13;,,,14Pal mu.ABBAB\nent par G(mu,RE:W:W:W:RE) 298.15 0.276514231*eVtoJ13;,,,14Pal mu.ABBBA\nent par G(mu,W:W:RE:W:W) 298.15 0.381076154*eVtoJ13;,,,14Pal mu.BBABB\nent par G(mu,W:W:W:RE:W) 298.15 0.393287154*eVtoJ13;,,,14Pal mu.BBBAB\nent par G(mu,W:W:W:W:RE) 298.15 0.310854154*eVtoJ13;,,,14Pal mu.BBBBA\nent par G(mu,RE:W:W:W:W) 298.15 0.320410077*eVtoJ13;,,,14Pal mu.ABBBB\nent par G(mu,W:W:W:W:W) 298.15 0.356369*eVtoJ13;,,,14Pal mu.B\n\nlist phase mu data\n\n@&\n@$--------\n\nent phase C14 \nCEF\n3 2 RE W; 6 RE W; 4 RE W;\nent par G(C14,RE:RE:RE) 298.15 0.286726*eVtoJ12;,,,14Pal C14.A\nent par G(C14,RE:W:RE) 298.15 0.331349833*eVtoJ12;,,,14Pal C14.ABA\nent par G(C14,W:RE:RE) 298.15 0.203029667*eVtoJ12;,,,14Pal C14.BAA\nent par G(C14,RE:RE:W) 298.15 0.4255515*eVtoJ12;,,,14Pal C14.AAB\nent par G(C14,W:W:RE) 298.15 0.2850135*eVtoJ12;,,,14Pal C14.BBA\nent par G(C14,RE:W:W) 298.15 0.527325333*eVtoJ12;,,,14Pal C14.ABB\nent par G(C14,W:RE:W) 298.15 0.380295167*eVtoJ12;,,,14Pal C14.BAB\nent par G(C14,W:W:W) 298.15 0.459543*eVtoJ12;,,,14Pal C14.B\n\nlist phase C14 data\n\n@&\n\n@$-----------\n\nent phase C15 \nCEF\n2 8 RE W; 16 RE W;\nent par G(C15,RE:RE) 298.15 0.345061*eVtoJ24;,,,14Pal C15.A\nent par G(C15,W:RE) 298.15 0.250001667*eVtoJ24;,,,14Pal C15.A2B\nent par G(C15,RE:W) 298.15 0.491933333*eVtoJ24;,,,14Pal C15.AB2\nent par G(C15,W:W) 298.15 0.454032*eVtoJ24;,,,14Pal C15.B\n\nlist phase C15 data\n\n@&\n\n@$----------\n\nent phase C36 \nCEF\n5 4 RE W; 4 RE W; 4 RE W; 6 RE W; 6 RE W;\nent par G(C36,RE:RE:RE:RE:RE) 298.15 0.31195*eVtoJ24;,,,14Pal C36.A\nent par G(C36,RE:RE:W:RE:RE) 298.15 0.337458833*eVtoJ24;,,,14Pal C36.AABAA\nent par G(C36,RE:W:RE:RE:RE) 298.15 0.250287833*eVtoJ24;,,,14Pal C36.ABAAA\nent par G(C36,W:RE:RE:RE:RE) 298.15 0.247355833*eVtoJ24;,,,14Pal C36.BAAAA\nent par G(C36,RE:RE:RE:RE:W) 298.15 0.37904175*eVtoJ24;,,,14Pal C36.AAAAB\nent par G(C36,RE:RE:RE:W:RE) 298.15 0.34407575*eVtoJ24;,,,14Pal C36.AAABA\nent par G(C36,RE:W:W:RE:RE) 298.15 0.315368667*eVtoJ24;,,,14Pal C36.ABBAA\nent par G(C36,W:RE:W:RE:RE) 298.15 0.305384667*eVtoJ24;,,,14Pal C36.BABAA\nent par G(C36,W:W:RE:RE:RE) 298.15 0.224973667*eVtoJ24;,,,14Pal C36.BBAAA\nent par G(C36,RE:RE:W:RE:W) 298.15 0.442608583*eVtoJ24;,,,14Pal C36.AABAB\nent par G(C36,RE:RE:W:W:RE) 298.15 0.410960583*eVtoJ24;,,,14Pal C36.AABBA\nent par G(C36,RE:W:RE:RE:W) 298.15 0.353971583*eVtoJ24;,,,14Pal C36.ABAAB\nent par G(C36,RE:W:RE:W:RE) 298.15 0.321842583*eVtoJ24;,,,14Pal C36.ABABA\nent par G(C36,W:RE:RE:RE:W) 298.15 0.346623583*eVtoJ24;,,,14Pal C36.BAAAB\nent par G(C36,W:RE:RE:W:RE) 298.15 0.315309583*eVtoJ24;,,,14Pal C36.BAABA\nent par G(C36,RE:RE:RE:W:W) 298.15 0.4229085*eVtoJ24;,,,14Pal C36.AAABB\nent par G(C36,W:W:W:RE:RE) 298.15 0.2877075*eVtoJ24;,,,14Pal C36.BBBAA\nent par G(C36,RE:W:W:RE:W) 298.15 0.415114417*eVtoJ24;,,,14Pal C36.ABBAB\nent par G(C36,RE:W:W:W:RE) 298.15 0.397507417*eVtoJ24;,,,14Pal C36.ABBBA\nent par G(C36,W:RE:W:W:RE) 298.15 0.380724417*eVtoJ24;,,,14Pal C36.BABBA\nent par G(C36,W:W:RE:RE:W) 298.15 0.328912417*eVtoJ24;,,,14Pal C36.BBAAB\nent par G(C36,W:W:RE:W:RE) 298.15 0.295539417*eVtoJ24;,,,14Pal C36.BBABA\nent par G(C36,RE:RE:W:W:W) 298.15 0.506832333*eVtoJ24;,,,14Pal C36.AABBB\nent par G(C36,RE:W:RE:W:W) 298.15 0.416418333*eVtoJ24;,,,14Pal C36.ABABB\nent par G(C36,W:RE:RE:W:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BAABB\nent par G(C36,W:RE:W:RE:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BABAB\nent par G(C36,W:W:W:RE:W) 298.15 0.38162625*eVtoJ24;,,,14Pal C36.BBBAB\nent par G(C36,W:W:W:W:RE) 298.15 0.36110925*eVtoJ24;,,,14Pal C36.BBBBA\nent par G(C36,RE:W:W:W:W) 298.15 0.496471167*eVtoJ24;,,,14Pal C36.ABBBB\nent par G(C36,W:RE:W:W:W) 298.15 0.481127167*eVtoJ24;,,,14Pal C36.BABBB\nent par G(C36,W:W:RE:W:W) 298.15 0.382497167*eVtoJ24;,,,14Pal C36.BBABB\nent par G(C36,W:W:W:W:W) 298.15 0.459342*eVtoJ24;,,,14Pal C36.B\n\nlist phase C36 data\n\n@&\n\nlist short\n\n@&\n@$---------\n\n@$ Calculate the stable phase diagram\n\nset c t=2000 p=1e5 n=1 x(w)=.3\n\nc e\n\nl r\n\n\n@&\n\nl r 2\n\n@&\n\nset ax 1 x(w) 0 1 ,,\n\nset ax 2 T 300 4000 25\n\nmap\n\nplot\n\n\ntitle map 9 fig 1\ntext\n.02 5000\n.8\n0\ny\n\ntext n\n.22 5000\n.8\n0\ny\n\ntext n\n.4 5000\n.8\n0\ny\n\ntext n\n.8 4000 .8 0 y\n\ntext n\n.6 2610 .8 0 y\n\nrender\n\n@&\n\n@$ Calculate speciation in sigma across the whole diagram at 1000 K\n@$ take smaller steps in x(w) to have nicer plots\n\nset ax 1 x(w) 0 1 .01\n\nset ax \n2 \nnone\n\nlist ax\n\n@&\n\nset stat phase *=sus\n\nset stat phase sigma=ent 1\n\nl short\n\n@&\n\n@$ conditions not restored after map\nl c\nset c x(w)=.3 t=2000\n\n\n@$ avoid using grid minimizer as that creates two composition sets\nc n\n\nl,,,,\n\n@&\n\n@$ when using step delete previous map results\nstep\nnormal\nY\n\nplot\nx(w)\ny(sigma,*)\ntitle map 9 fig 2\nrender\n\n@&\n@$ also plot the Gibbs energy, enthalpy and heat capacity\n\nplot\nx(w)\ngm\ntitle map 9 fig 3\nrender\n\n@&\nplot\nx(w)\nhm\ntitle map 9 fig 4\n\n@&\nenter symbol\ncp\nhm.t;\n\n\nplot\nx(w)\ncp\ntitle map 9 fig 5\nrender\n\n@&\n@$ Calculate the Gibbs energy curves for all phases at 3000 K\n\nset stat ph *=ent 0\n\nc e\n\nstep\nsep\nY\n\n\nplot\nx(w)\ngm(*)\nposition outside right\n\ntitle map 9 fig 6\nrender\n\n@&\nplot\nx(w)\nhm(*)\ntitle map 9 fig 7\nrender\n\n@&\n\n@$ Plot the constitution of the chi phase\n\nplot\nx(w)\ny(chi,*)\ntitle map 9 fig 8\n\n\nlist phase chi model\n\n\n\n@&\n@$ Finally calculate the Gibbs energy of an endmember\n\nc ph\nsigma\n1\nn\n1\n0\n1\n0\n1\nonly\n\n\n@&\n\n\n@$==========================================================================\n@$ end of map9 macro\n@$==========================================================================\n\n\nset inter\n\n" }, { "path": "examples/macros/maplast.OCM", "content": "@$ running test macros from map15\n@$ Frequetly there is a crash after map15, I assume because no memory left\n\nset echo Y\n\n@& *********************************************************\n@$ The Mo-Ni-Re isothermal section at 2500, 1500 and 500 K.\n@$ *********************************************************\n\nmac ./map15\n\n@& *********************************************************\n@$ The isopleth C-13wCr-Fe with a 4 phase invariant equilinrium\n@$ *********************************************************\n\nmac ./map16\n\n@& *********************************************************\n@$ The Al-Fe binary with a dashed A2/B2 transition line\n@$ *********************************************************\n\nmac ./map17\n\n@& *********************************************************\n@$ The Al-Mg-Zn isopleth at x(zn)=0.05\n@$ *********************************************************\n\nmac ./map18\n\n@& *********************************************************\n@$ Testing the UNIQUAC model\n@$ *********************************************************\n\nmac ./uniquac\n\n@& *********************************************************\n@$ Calculation for 20 elements and 191 phases using COST507\n@$ *********************************************************\n\nmac ./allcost\n\n@& *********************************************************\n@$ Calculating 21 equilibria in parallel\n@$ First test of parallel calculations\n@$ *********************************************************\n\nmac ./parallel1\n\n@& *********************************************************\n@$ Enter a table with many equilibria and calculate all\n@$ Can be used to test parallel calculations\n@$ *********************************************************\n\nmac ./parallel2\n\n@& *********************************************************\n@$ Assessment using fictitious binary experimental data\n@$ *********************************************************\n\nmac ./opttest1\n\n@& *********************************************************\n@$ Assessment start of the Cu-Mg case study must be run by itself\n@$ on the directory with the macro files\n@$ *********************************************************\n@$\n@$ mac ./opttest2\n@$\n@& *********************************************************\n@$ that is all\n@$ *********************************************************\n\nset inter\n\n" }, { "path": "examples/macros/melting.OCM", "content": "new YES\n\nset echo Y\n\n@$ =========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ melting.OCM\n@$ Calculating multicomponent single equilibria\n@$ Including the melting point of the alloy\n@$\n@$ At the end test using the grid minimizer after \"c n\"\n@$ to detect any gripoint below the current equilibrium\n@$ =========================================================\n@&\n\nset echo\n\nr t ./steel7\n\n\n@$ -------------------------------------------------------------\n@&\nset c t=1173 p=1e5 n=1 x(c)=.04 x(cr)=.06, x(mo)=.05 x(si)=.003 x(v)=.01\n\nc e\n\nl ,,,\n\n@$ The equilibrium has two FCC phases, one represent cunbic carbide\n@$ Check result with a denser grid\n@$ -------------------------------------------------------------\n@&\n\nset advanced\n?\n\n2\n\nc e\n\n@$ The denser grid has about 10 times more gridpoints, here 145000 compared\n@$ with 21000 with normal grid. The result in this case is the same\n@$ but with complicated cases it is important to check.\n@&\n\nl ,,,\n\n@$ -------------------------------------------------------------\n@&\n@$ We can also list the constitution of the phases\n\nl , 2\n\n@$ Note how the carbon content is different in the two FCC phases\n@$ -------------------------------------------------------------\n@&\n@$ Now calculate the melting T of this alloy \n@$ by setting liquid fix and remove condition on T\nc tran\nliq\n1\n\nl , 1\n\n@$ Note that the grid minimizer could not be used for this calculation\n@$ but is is automatically called afterwards to check if there is any\n@$ gridpoint below the calculated equilibrium. The melting T is 1501 K.\n@&\n@$ -------------------------------------------------------------\n@$ Turn off the dense grid as it is not really necessary here\n\nset adv grid 1\n\n@&\n@$ Test setting a condition on the carbon content of the metallic FCC\n@$ Note that the metallic FCC (austenite) is the second composition set !!!\nset c x%(fcc#2,c)\n\nset c x(c)=none\n\nc e\n\nl,,,,\n\n@$ This is the same equilibrium calculated with different conditions\n@$ The liquid is not listed but has a very small driving force as\n@&\n@$ shown in the next command, -0.00000000172\nl sh p\n\n\n@&\n@$ Now decrease the carbon content of the austenite\nset c x%(fcc#2,c)=3\n\nc e\n\nl,,,,\n\n@$ Note that the total amount of C also decreases\n@$ to 0.03618 in mole fraction\n@$ and the liquid is no longer stable.\n@&\n@$-------------------------------------------------------------\n@$ Calculate the new melting T for a steel with 3 mole percent C in the fcc\n@$ now using the \"set phase ... status\" command\n@$ and remove the condition on T\n\nset ph liq \nstatus \nfix 0\n\nset c t=none\n\nl c\n\n@&\nc e\n\nl,,,,\n\n@$ The melting T with the new carbon content is 1518.89 K\n@$ -------------------------------------------------------------\n@&\n@$ Now set condition on current H and remove condition on N\n\nset c H\n\nset c N=none\n\nc e\nl r 1\n\n@$ We have the same quilibrium with different conditions\n@$ -------------------------------------------------------------\n@&\n@$ Now decrease H a little\nset c H=40000\nc e\n\nl,,,,\n\n@$ Note the size of the system has changed, N=0.84874 !!\n@$ -------------------------------------------------------------\n@&\n\n@$ Now test a new feature, recalculating an equilibrium if the gridtest\n@$ after a calculation shows a new phase should be stable\n\n@$ First reinitiate and read the database again\n\nnew Y\n\nr t ./steel7\n\n\nset c t=2000 p=1e5 n=1 x(c)=.04 x(cr)=.06, x(mo)=.05 x(si)=.003 x(v)=.01\n\n@&\n\nc e\n\nl,,,,\n\n@$ nothing particular, we have just the liquid stable\n@$ If we now set T=1173 and calculate without the grid minimizer ...\n@&\n@$ OC will not discover that the FCC phase should have a second comp.set\n\nset c T=1173\n\nc n\n\nl,,,,\n\n@$ We have FCC, M6 and M7C3 stable but there is no FCC#2 phase!\n@$ This is not the global equilibrium we we calculated in the beginning\n\n@$ We have G=-57639.4 J\ndebug symbol g -57639.4\n@&\n@$ Instead of \"c n\" we can use \"calculate with_check_after\"\n@$ and then OC will use the current equilibrium as start values to calculate\n@$ and then use the grid minimizer to check if there are any point below\n@&\n\nc w\n\nl ,,,,\n\n@$ We now have a more stable equilibrium with the FCC#2 phase\n@$ and G=-57673.8 J, 34 J less than previous metastable equilibrium\n@$\n@$ The use of a grid test \"after\" the equilibrium calculation is useful for \n@$ simulations as the \"c n\" is much faster but now and again\n@$ it must be checked with a grid.\n@&\n@$ ------------------------------------------------------------------\n@$ That is all for now\n@&\n@$==========================================================================\n@$ end of melting macro\n@$==========================================================================\nset inter\n\n" }, { "path": "examples/macros/mqtest-1C.OCM", "content": "@$ test entering an A-AB-B system with SRO\n\nnew Y\n\nset echo Y\n\n\n@$ ============== ELEMENTS\n\nenter element Fe Fe LIQUID 10 0 0\n\nenter element C C LIQUID 10 0 0\n\n@$================= SPECIEES\n\n@$ enter specie AB A0.5B0.5\n\n@$ Constituents in the MQMQA liquid specify 2-4 elements. \n@$ The / separate elements in sublattice 1 and 2 (A+,B+)(Va)\n@$ The -Q (without numner) to avoid ambiguety in paramameters\n@$ All endmembers (quadrupoles) must be electrically neutral and the\n@$ stochiometry of the species must be set to obtain that\n\n@$================= FUNCTIONS\n\n \n@$================= PHASES AND CONSTITUENTS\n\n\n@$ This is to have a baseline\nenter phase gas ideal\nFe C\n\nenter PARAMETER G(GAS,Fe;0) 298.15 100000; 6000 N REF3\nenter PARAMETER G(GAS,C;0) 298.15 100000; 6000 N REF2\n\n@$================= MQMQA\n@$\n@$ The constituents are created when entering the phase. The user must\n@$ give all quadrupoles (endmembers) specifying the elements with a \",\"\n@$ between elements in same sublattice and \"/\" separating elements in\n@$ first and second sublattice. No spaces in the sequence of elements in a\n@$ quadrupole. For each element in a quad it must be followed by one real\n@$ number for each element (in the order of the elements). The real number\n@$ is related to the charge of the element. Each quad must be neutral.\n@$\n@$ The species for the quad is created when tereting the phase and it\n@$ has a suffic -Q to make their names unique\n\n@$ quadrupoles are Fe1/3, Fe1/3C1/6, C1/3, corresponding to C-Fe2C-Fe\n@$ according to Max\nenter phase liquid MQMQA\nFe/VA 6.0 6.0 2.4 C,Fe/VA 6.0 3.0 6.0 C/VA 6.0 6.0 2.4 \n\nenter parameter g(liquid,Fe/VA-q) 298.15 0; 6000 N ref6\nenter parameter g(liquid,CFe/VA-q) 298.15 -5000; 6000 N ref6\nenter parameter g(liquid,C/VA-q) 298.15 0; 6000 N ref6\n\n@$================= I2SL skipped\n\n\n@&\n\n@$ thermochimica gives these quadrupole fractions\nc ph liq 2.171\n\n.0327\n.76375\nALL\n\n@&\n@$ last fraction .20356 of Fe-Fe/Va-Va. First fraction C-C/Va-Va\n@$\n@$ Thermochimica G -26595 J/mol atoms\n\nl , 2\n\nset c t=1000 p=1e5 n=1 x(Fe)=.7\n\n\n@$ \n\nset inter\n\n\nFIRST TRY:\n--->OC6:... echo: c ph liq 1\nCurrent (Y), default (D) or new (N) constitution? /N/: Fraction of C/VA-Q03 /1/: ... echo: .038899\nFraction of CFE/VA-Q02 /0.961101/: ... echo: .74600\nLast fraction set to: 2.1510E-01\nCalculate what for phase? /ONLY_G/: Using T= 1000.00 K and P= 1.000000E+05 Pa, results in J/F.U.\n 3X calling MQMQA liquid model\n3X in MQMQA, version 3: 3 2.185E+00\n 3X summed all amounts, next normallize\n 3X no mixing in sublattice 2\n3X SSUB: -6.1086E-01 -4.32E-01 -3.09E-02 1.85E-01\n3X SEND: 0.0000E+00 -3.43E+00 -2.06E+00 -2.70E+00\n3X SQUAD: 1.6257E-01 -9.51E+00 -4.81E+00 -5.29E+00\n 3X second derivatives are approximate. Atoms/FU: 0.45766666666666667\n\nG, dG/dT dG/dP d2G/dT2: -2.208775E+04 6.350502E-01 0.000000E+00 0.000000E+00\nG/RT, H, atoms/F.U: -5.804510E+00 -2.272280E+04 4.576667E-01\n--->OC6:--->OC6:--->OC6:... echo: @$ last fraction .2151 of Fe-Fe/Va-Va. First fraction C-C/Va-Va\n--->OC6:... echo: @$\n--->OC6:... echo: @$ Thermochimica G -24392.8 J\n--->OC6:--->OC6:... echo: set c t=1000 p=1e5 n=1 x(Fe)=.7\n--->OC6:--->OC6:--->OC6:... echo: @$\n--->OC6:--->OC6:... echo: set inter\n--->OC6:\n--->OC6:sh g\n... echo: sh g\n *** Warning, values can be inconsistent with current conditions\n G= -2.2087752E+04\n\n------------------------------------------------------------------\n\n" }, { "path": "examples/macros/opttest1.OCM", "content": "new Y\n@$ ==================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ opttest1.OCM\n@$ setup file for simple assessment\n@$ ==================================================================\n\nset echo\n\n@$ step 1: enter binary data a phase\n\nenter element A A FCC 10. 0. 0. \nenter element B B FCC 10. 0. 0. \n \nenter phase FCC \nCEF\n1 1.0 A B\n\n@$ enter 100 optimizing coefficients\n\nenter opt 100\n2500\n\n@$ parameter to be optimized\n\nenter parameter G(FCC,A,B) 298.15 A10+A11*T+A12*T*LN(T)+A13*T**2; 6000 N myref\n\nl d\n\n@&\n@$ amend the bibliographic reference\namend bib\nmyref\ncurrent assessment;\n\nl d\n\n@$ We will need some symbols, the heat capacity\nenter symbol cp1=hm.T;\n\n@$ We have also enthalpy differences so we need a symbol for the\n@$ enthalpy at a fix T, 298.15 K. We first enter the symbols\n@$ and will show later how to use them\nenter symbol h298=hm;\n\nenter symbol hdiff=hm-h298;\n\nl symb\n\n@$ Note that the \"dot derivative\" is prefixed by the \"special\" letter D\n@&\n@$ We will also use a symbol to specify the experimental uncertainty\n@$ of the heat capacities\n\nenter symbol dcp=1;\n\n@$----------------------------------------------------\n@&\n@$ step 2: set start values for the optimizing coefficients\n@$ sometimes these are very important, sometimes one can start from zero\n\nset \noptcoeff_variab\n11\n10\n\nset opt_var 12 -10\n\nset opt_var 13 0.001\n\n@$ list the optimizing variables\nlist opt short\n\n@$ Note the experimental information is not sufficient to determine H298\n@$ that means A10 cannot be optimized\n@&\n@$ The coefficients are TP constants \nl tp\n\n\n@&============================================\n@$ Make sure we can save this on unformatted file\n\nsave unf ./opttest1\nY\n\n@&\n@$ reinitiate and read back\nnew Y\n\nread unf ./opttest1\n\n@&\n@$ Check we have parameters and data\n\nl data\n\n@&\n\nl opt short\n\n@$ No experimental data entered and no optimization made\n@$ All parameters have their starting values and sum of error irrelevant\n@&\n@$----------------------------------------------------\n@$ We will use a feaure that a certain symbol must be calculated at a certain\n@$ equilibrium. This means we cannot use parallel calculation because\n@$ the code to handle this is not yet implemented.\n@$ We must turn off parallelization\n\nset adv level n Y\n\nset bit glo 15\n\n@&\n@$----------------------------------------------------\n@$ step 3: experiments, enter equilibrium Y where Y means the\n@$ following command will refer to the new equilibrium\n@$ first experimental equilibrium, will be equil 2\n\nenter equil FCC1_ZA Y\nenter comment the reference enthalpy\nset c t=298.15 p=1e5 n=1 x(b)=.5\n\nc n\nl,,,,,\n@&\n@$ list equilibria, we have now two and the ** indicate \"current\"\nl eq\n\n@$\n@$ specify that the symbol H298 should be calculated at this equilibrium\namend symbol H298\nx\n2\n\nl symb\n\n@$ Note that H298 now is prefixed by the equilibrium number and an X\n@&\nc n\nl,,,,,\n\n\nc symb h298\n\nshow hm h298\n\n\n@$ The value of HM and H298 is 723.1516\n@&\n@$ At this equilibrium we also provide experimental values of\n@$ S298 = SM (integrated Cp from 0 K) and CP\n\nenter experiment SM=17:1\n\nenter experiment CP1=18:1\n\nc n\n\nl,,,\n\n\n@$ The calculated values of SM is 19.858 and CP1 2.35095\n@$----------------------------------------------------\n@&\n@$ enter a second experiment, the enthalpy difference \nenter equil FCC2_ZB Y\nset c t=800 p=1e5 n=1 x(b)=.5\n\nenter experiment hdiff=2000:500\n\nc n\n\nl,,,,\n\nc symb *\n\nshow hm h298 hdiff\n\n@$ Note H298 is the value calculated at 298.15 K, 723.15164,\n@$ Current value of HM is 1840 and HDIFF 1116.8\n@$ --------------------------------------------------------------\n@&\n\nenter experiment cp1=20:dcp\n\n\nenter experiment hdiff=9000:500\n\n@$ Calculate without gridminimizer\nc n\n\nl,,,,\n\n@$ The experiments, prescribed and actual values are also listed\n@$ \n@$ -------------------------------------------------------------\n@&\nl equil\n\n\n@$ There are now 3 equilibria\n@&\n\n@$ a third experiment (4th equilibria)............................. 3\nenter equil FCC3_ZC Y\nset c t=1000 p=1e5 n=1 x(b)=.5\nenter experiment hdiff=15000:500\nenter experiment cp1=22:dcp\n\nl equil\n@$ Forth experiment an enthalpy of mixing.......................... 4\nenter equil FCC4_ZD Y\nset c t=1200 p=1e5 n=1 x(b)=.5\nenter experiment hdiff=20000:500\nenter experiment cp1=24:dcp\n\n\nl equil\n\n@&\n\n@$ This command tells OC which equilibria has experiments\n@$ The last experiment is by default\nset range_exp\n2\n\n\n@$ Calculate all experimental equilibria without grid minimizer\n\nc all N\n\n\n@&\n\nl opt short\n\n\n@$ As we have not optimized the coefficients this command gives nothing\n@$ except the inital values of the coefficients.\n@$ The column labeld RSD should be the \"Relative Standard Deviation\"\n@$ i.e. an estimated uncertainty of the coefficients, should be less than 1.0\n@$ The last column lists the model parameter where the coefficent is used\n@$ is a kind of shorthand, _G means an endmember parameter followed by the\n@$ first 4 character of the phase and then the constituents and the degree\n\n@&\n@$ We optimize zere times to calculate with the initial parameters\n\nopt 0\n\nl opt short\n\n\n@$ The total error with the start values of the coefficients is 3745\n@$ The normalized error, 748.91, is the total error divided by the \n@$ degrees of freedom. The temperature dependence of Cp should \n@$ normally increase with T. Now we optimize!\n@&\n\nopt 100\n\n@&\n\nl opt short\n\n\n@$ The total sum of errors has decreased to 11.45, the normalized to 2.29\n@$ A11 is 400.095; A12 -65.2871; A13 -0.0120393\n@$ The coefficent A11 is positive and A12 is negative as one should expect.\n@$ The negative value of A13 indicates that Cp increases with T\n@$ As already mentioned there is no experimenatal data to determine H298\n@$ at x(b)=.5. That value depend on the enthalpy of mixing or formation\n@$ relative the pure elements.\n@$ A normallized error around one means that we have fitted the experiments\n@$ on the average within the experimental uncertainty.\n@$ We should not attept to make this value zero!\n@&\n\n@$ Rescale the coefficients if they have changed a lot\namend opt\ny\n\nl opt chort\n\n@&\n\nopt 100\n\nl opt short\n\n@$ No change of the normalized sum of errors: 2.2907\n@$ or the coefficients: 400.095; -65.2871; -0.0120393\n@$ but the values of RSD are now viable.\n@$ If an RSD is larger than 1 that coefficient is meaningless\n@$ and should not not be optimized.\n@$ If it is less than 1 but larger than 0.1 only the first digit of the\n@$ coefficient is significant. For example A13 has RSD=0.318483 and\n@$ the coefficient has only one significant digit, i.e -0.01\n@$ =============================0\n@$ At an end of an assessment the RSD can be used to reduce the number\n@$ of digits in the published result by fixing their values\n@$ rounded to the significant number of digits one by one\n@$ starting from the coefficient with the highest RSD\n@$\n@&\n\n\n@$ Save the results to take a coffee break\n\n@$ Answer Y if file already exist\nsave unf ./opttest1\nY\n\n@&\n@$ =========================\n@$ Back from coffee break\n@$ =========================\nnew Y\n\n@$ ******************************************************************\n@$ rerun the optimization with larger experimental uncertainties for Cp\n@&\n\nread unf ./opttest1\n\nl opt short\n \n@&\nl symb\n\n\n@$ Assuming the experiment of Cp are less reliable than HDIFF we can\n@$ increase their uncertainty of the Cp values.\n@&\n\namend symb dcp 100\n\n\nl symb\n\n\n@&\n@$ optimize again\n\nopt 0\n\nl opt\n\n@&\n\nopt 100\n\nl opt short\n\n\n@$ The coefficients do not change much but total sum of errors is now 4.886\n@$ and the normallized 0.97723\n@$ The calculated Cp values has increased and better fit to HDIFF\n@$ The coefficients A11 is 346.818; A12 is -56.6234; A13 is -0.0210028\n@$ The RSD are 0.114988, 0.1121 and 0.232735 respectively\n\namend opt Y\n\nopt 100\n\nl opt short\n\n\n@$ Test a value, we cannot test optimizing variables ...\nsel eq 3\nc e\ndebug symbol hdiff 9997.8138\n@$\nset inter\n\n\n\n \n" }, { "path": "examples/macros/opttest2-map-diagram.OCM", "content": "@$\n@$ Cu-Mg phase diagram\n@$ Calculation and comparison to experiments\n@$\n\nsel eq 1\n\nset stat ph *=ent 0\n\nset cond *:=none\n\nset cond t=500 p=1e5 n=1 x(mg)=0.1\n\ncalc eq\n\nset axis 1 x(mg) 0 1,,\n\nset axis 2 t 300 1500 25\n\nc e\n\n@&\n\nmap\nY\n\n\n@&\nl c\n@$ add an extra start point\n\nset c t=1000 x(mg)=.9\n\nc e\n\nmap\nN\n\n\n@&\n\nplot\n\n\nappend ./oc_many9\n\n\n\n\nset interactive\n" }, { "path": "examples/macros/opttest2-plot-cpcumg2.OCM", "content": "@$\n@$ CuMg2 heat capacity\n@$ Calculation and comparison to experiments\n@$\n\nsel eq 1\n\nset stat ph *=sus\nset stat ph cumg2=e 1\n\nset condition *:=none\nset condition t=1100 p=1e5 n(cu)=1 n(mg)=2\n\nset axis 1 t 10 1500 10\n\n@$ The phase is stoichiometric do not use grid minimizer\n\nc n\n\nstep sep\nY\n\nplot\nT\ncpm1\nappend ./oc_many2\nscale y n 0 100\naxis-label x T/K\naxis-label y Heat capacity CuMg2 (J.Mol-1.K-1)\n\n@&\n\nset inter\n" }, { "path": "examples/macros/opttest2-plot-cplaves.OCM", "content": "@$\n@$ Cu2Mg (C15 Laves) heat capacity\n@$ Calculation and comparison to experiments\n@$\n@$ Modified to avoid creating composition sets 220808/BoS\n\nsel eq 1\n\nset stat ph *=sus\nset stat ph laves=e 0\n\nset condition *:=none\nset condition t=1100 p=1e5 n=1 x(mg)=.3333333\n\nl cond\n\nc ph laves 1\nN\n1\n1e-6\n\n\n@&\n\nset axis 1 t 10 2500 10\nc n\nl res 2\n\n\nstep norm\nY\n\nplot\nT\nCPM2\nappend ./oc_many1\nscale y n 0 100\naxis-label x T/K\naxis-label y Heat capacity Cu2Mg (J.Mol-1.K-1)\n\n\nset interactive\n" }, { "path": "examples/macros/opttest2-plot-hliq.OCM", "content": "@$\n@$ Mixing enthalpy in the liquid phase\n@$ Calculation and comparison to experiments\n@$\n\n@$ step and map is done in equilibrium 1\nselect eq 1\n\nset stat phase *=sus\nset stat phase LIQUID=entered 0\n\n@$ This removes all conditions\nset condition *:=none\n\nset condition t=1100 p=1e5 n=1 x(mg)=.5\nset reference-state mg LIQUID * 1e5\nset reference-state cu LIQUID * 1e5\nset axis 1 x(mg) 0 1 ,,,\ncalculate equilibrium\n\nstep normal\nY\n\n@&\n\nplot\nx(mg)\nHM\nappend ./oc_many5\naxis-label y\nMixing enthalpy (J.mol-1)\nscale y n -15000 0\nrender\n\n@&\n\n\nset interactive\n\n" }, { "path": "examples/macros/opttest2.OCM", "content": "@$\nnew Y\n@$ ================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ opttest2.OCM\n@$ Assessment example for the Cu-Mg system in steps\n@$ There are memory leaks during STEP/MAP\n@$ ================================================================\n@$\n@$ IMPORTANT:\n@$ Before running this macro use the command:\n@$ SET ADVANCED WORSPACE\n@$ to set the working directory to the directory with the optttest2.OCM\n@$\n@$ This is required because the macro create oc_manyi.plt and *.OCU files\n@$ which are used in later submacros\n@$\n@$ There are some error messages calculating some equilibria but\n@$ the final result is still reasonable\n@$\n@$ ================================================================\n@&\n\nset echo\n\nmac ./opttest2A\n\n@&\n\nmac ./opttest2B\n\n@&\n\nmac ./opttest2C\n\n@&\n\nmac ./opttest2D\n\n@&\n\nmac ./opttest2E\n\n@&\n\nmac ./opttest2F\n\n@&\n\nmac ./opttest2G\n\nset inter\n\n\n" }, { "path": "examples/macros/opttest2A.OCM", "content": "@$\n\nnew Y\n\n@$ ================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ opttest2.OCM\n@$ Assessment example for the Cu-Mg system.\n@$ This macro will run also the following steps or they can be run\n@$ separately as each step saves the result on an UNFORMATTED file\n@$===================================================================\n@$===================================================================\n@$============== Cu-Mg assment: step 0: enter models and experimental data\n@$===================================================================\n@$===================================================================\n@&\n\nset echo\n\n@&\n\n@$----------------------------------------------------------------\n@$ Enter 100 optimizing coefficient called A00 to A99\n@$ This must be done ebfore using them in parameters or functions.\n@$ Also the dimension of workspace (can be changed)\n@$----------------------------------------------------------------\nenter opt_coef\n100\n2500\n\n@&\n@$----------------------------------------------------------------\n@$ enter the phases and parameters\n@$----------------------------------------------------------------\n\nenter element CU Cupper FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01\n\nenter element MG Magnesium HCP_A3 2.4305E+01 4.9980E+03 3.2671E+01\n \n@$ OC requires that functions are in calling order here\n ent tp GHSERCU fun 298.15 -7770.458+130.485235*T-24.112392*T*LN(T)\n -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y\n -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); \n 3.20000E+03 N\n ent tp GLIQCU fun 298.15 +GHSERCU +12964.735-9.511904*T\n -5.8489E-21*T**7; 1.35777E+03 Y\n -46.545+173.881484*T-31.38*T*LN(T); 3.20000E+03 N\n ent tp GHSERMG fun 298.15 -8367.34+143.675547*T-26.1849782*T*LN(T)\n +4.858E-04*T**2-1.393669E-06*T**3+78950*T**(-1); 9.23000E+02 Y\n -14130.185+204.716215*T-34.3088*T*LN(T)+1.038192E+28*T**(-9); \n 3.00000E+03 N\n ent tp GHCPCU fun 298.15 +GHSERCU +600+.2*T; 3.20000E+03 N\n ent tp GLIQMG fun 298.15 +GHSERMG +8202.243-8.83693*T\n -8.0176E-20*T**7; 9.23000E+02 Y\n -5439.869+195.324057*T-34.3088*T*LN(T); 3.00000E+03 N\n ent tp GFCCMG fun 298.15 +GHSERMG +2600-.9*T; 3.00000E+03 N\n \n enter phase LIQUID \n CEF 1 1.0 CU,MG ;\n\n enter param G(LIQUID,CU;0) 298.15 +GLIQCU ; 3.20000E+03 N 91Din\n enter param G(LIQUID,MG;0) 298.15 +GLIQMG ; 3.00000E+03 N 91DIN\n enter param G(LIQUID,CU,MG;0) 2.98150E+02 A00+A01*T; 6.00000E+03 N MYVAL\n enter param G(LIQUID,CU,MG;1) 2.98150E+02 A02+A03*T; 6.00000E+03 N MYVAL\n enter param G(LIQUID,CU,MG;2) 2.98150E+02 A04+A05*T; 6.00000E+03 N MYVAL\n\n\n@$ OC BUG: The coefficent for T*ln(T) sometimes disappear when plotting\n@$ enter phase CUMG2 \n@$ CEF 2 1.0 CU; 2.0 MG;\n@$ enter param G(CUMG2,CU:MG;0) 298.15 +A30+A31*T+A99*T*LN(T)+A32*T*LN(T)+\n@$ A33*T**2+A34*T**(-1)+A35*T**3; 6.00000E+03 N MYVAL\n@$ Temporarily avoid the bug by entering T*LN(T) as a separate TP function\n@$ The bug will be fixed when I understand how it happen\n@$ enter TP TLNT fun 1 T*LN(T); 20000 N\n\n enter phase CUMG2 \n CEF 2 1.0 CU; 2.0 MG;\n enter param G(CUMG2,CU:MG;0) 298.15 +A30+A31*T+A32*T*LN(T)+\n A33*T**2+A34*T**(-1)+A35*T**3; 6.00000E+03 N MYVAL\n\n\n enter phase FCC_A1 \n CEF 2 1.0 CU MG; 1.0 VA;\n amend phase FCC_A1 add magnetic -3.0 2.80000E-01\n\n enter param G(FCC_A1,CU:VA;0) 298.15 +GHSERCU ; 3.20000E+03 N 91DIN\n enter param G(FCC_A1,MG:VA;0) 298.15 +GFCCMG ; 3.00000E+03 N 91DIN\n enter param G(FCC_A1,CU,MG:VA;0) 298.15 +A11 +A12*T; 6.00000E+03 N MYVAL\n enter param G(FCC_A1,CU,MG:VA;1) 298.15 +A13 +A14*T; 6.00000E+03 N MYVAL\n\n\n enter phase HCP_A3 \n CEF 2 1.0 CU MG; 0.5 VA; \n amend phase HCP_A3 add magnetic -3.0 2.80000E-01\n\n enter param G(HCP_A3,CU:VA;0) 298.15 +GHCPCU ; 3.20000E+03 N 91DIN\n enter param G(HCP_A3,MG:VA;0) 298.15 +GHSERMG ; 3.00000E+03 N 91DIN\n enter param G(HCP_A3,CU,MG:VA;0) 298.15 +A21 +A22*T; 6.00000E+03 N MYVAL\n enter param G(HCP_A3,CU,MG:VA;1) 298.15 +A23 +A24*T; 6.00000E+03 N MYVAL\n\n\n enter phase LAVES_C15 \n CEF 2 2.0 CU MG; 1.0 CU MG; \n\n enter param G(LAVES_C15,CU:CU;0) 298.15 +45000+3*GHSERCU ; \n 6.00000E+03 N SL\n enter param G(LAVES_C15,MG:CU;0) 298.15 +104160+2*GHSERMG +GHSERCU; \n 6.00000E+03 N SL\n enter param G(LAVES_C15,CU:MG;0) 298.15 +A40+A41*T+A42*T*LN(T)\n +A43*T**2+A44*T**(-1)+A45*T**3; 6.00000E+03 N MYVAL\n enter param G(LAVES_C15,MG:MG;0) 298.15 +17700+3*GFCCMG ; \n 6.00000E+03 N SL\n enter param G(LAVES_C15,CU,MG:CU;0) 298.15 +A46 ; 6.00000E+03 N MYVAL\n enter param G(LAVES_C15,CU:CU,MG;0) 298.15 +A47 ; 6.00000E+03 N MYVAL\n enter param G(LAVES_C15,MG:CU,MG;0) 298.15 +A47 ; 6.00000E+03 N MYVAL\n enter param G(LAVES_C15,CU,MG:MG;0) 298.15 +A46 ; 6.00000E+03 N MYVAL\n\n amend bib 91DIN A Dinsdale Calphad 1991;\n amend bib SL M H F Sluiter Calphad 2006;\n amend bib MYVAL My assessed value; \n\n@&\n\n l data\n\n\n@&\n@$------------------------------------------------------------------------\n@$ Now the experimental data converted from a POP file\n@$ created by Nathalie Dupin, Malin Selleby and Christine Gueneau.\n@$ The equilibria with experiments can be identified by a number (assigned\n@$ sequentially) or a name (max 24 characters).\n@$ A range of numbers or an abbreviations of the name can be used to select\n@$ which equilibria should be involved by setting its weight.\n@$ Equilibria with zero weight will be ignored.\n@$------------------------------------------------------------------------\n@$\n@&\n\n@$ NOTE a ; or an empty line following is needed\nenter symbol P0=101325;\n@$ ==========================================\nenter equilibrium EQ_1_CP15 YES\nset status phase *=sus\nset status PHASE LAVES_C15=ENT 1\nset cond P=P0 T=298.15 N(MG)=1 N(CU)=2\n@$ These are special symbols for \"dot derivatives\". Cp is the T derivative of H\nenter symbol CPM2=HM(LAVES).T;\nenter symbol CPM1=HM(CUMG2).T;\n@$ experiments have an uncertainty after a colon \":\"\nenter experiment CPM2=24.4 : .1\n@$ we cannot enter plot_data before the first \"enter many_equilibria\"\n@$ enter plot_data 1 298.15 24.4 8 Feufel\nenter comment C15 - CP 298 - FEUFEL\n@$ This is a single equilibrium with experimental data\n@&\n@$=================================\nenter many_equilibria\nENT 1 LAVES_C15\ncondition P=P0 T=@1 N(MG)=1 N(CU)=2\nexperiment CPM2=@2 :.1\ncomment FEUFEL C15 - CP DSC\nplot_data 1 @1 @2 8 Feufel\n@$ The plot_data command saves the whole line \n@$ (after plot_data) on a file\n@$ that will be opened inside the many_equilibria \n@$ command. The first number is a dataset number, \n@$ can be 1 to 9 and data for the same dataset\n@$ will be saved on the same file oc_manyj.plt where\n@$ j is the dataset number. The next two numbers\n@$ are coordinates, the last number, 1-15, a plot symbol.\n@$ Finally a text reference can be given\n@$ The oc_manyj.plt data can be plotted as is but\n@$ will be nicer after they have some editing\n@&\ntable_start\nEQ_T1_2_CP15_F 100 17\nEQ_T1_3_CP15_F 343 24.90\nEQ_T1_4_CP15_F 363 25.24\nEQ_T1_5_CP15_F 383 25.37\nEQ_T1_6_CP15_F 403 25.44\nEQ_T1_7_CP15_F 423 25.50\nEQ_T1_8_CP15_F 443 25.60\nEQ_T1_9_CP15_F 463 25.64\nEQ_T1_10_CP15_F 483 25.74\nEQ_T1_11_CP15_F 503 25.82\nEQ_T1_12_CP15_F 523 25.83\nEQ_T1_13_CP15_F 543 25.87\nEQ_T1_14_CP15_F 563 25.94\nEQ_T1_15_CP15_F 583 26.03\nEQ_T1_16_CP15_F 603 26.18\nEQ_T1_17_CP15_F 623 26.23\nEQ_T1_18_CP15_F 643 26.31\nEQ_T1_19_CP15_F 663 26.39\nEQ_T1_20_CP15_F 683 26.64\nEQ_T1_21_CP15_F 703 26.75\nEQ_T1_22_CP15_F 723 26.95\nEQ_T1_23_CP15_F 743 27.47\nEQ_T1_24_CP15_F 763 27.43\ntable_end\n@$\n@&\n@$=================================\nenter many_equilibria\nENT 1 LAVES_C15\ncondition P=P0 T=@2 N(MG)=1 N(CU)=2\nexperiment CPM2=@3: .1\ncomment C15 - PHONON CALC - CRIVELLO\nplot_data 1 @2 @3 2 Crivello\ntable_start\nEQ_T2_30_CP15_P 30 20 0.72162\nEQ_T2_31_CP15_P 31 30 2.1669\nEQ_T2_32_CP15_P 32 40 4.3074\nEQ_T2_33_CP15_P 33 50 6.7287\nEQ_T2_34_CP15_P 34 60 9.11073\nEQ_T2_35_CP15_P 35 70 11.28642\nEQ_T2_36_CP15_P 36 80 13.19342\nEQ_T2_37_CP15_P 37 90 14.82796\nEQ_T2_38_CP15_P 38 100 16.21377\nEQ_T2_39_CP15_P 39 110 17.3842\nEQ_T2_40_CP15_P 40 120 18.3733\nEQ_T2_41_CP15_P 41 130 19.21185\nEQ_T2_42_CP15_P 42 140 19.9262\nEQ_T2_43_CP15_P 43 150 20.53826\nEQ_T2_44_CP15_P 44 160 21.06597\nEQ_T2_45_CP15_P 45 170 21.52387\nEQ_T2_46_CP15_P 46 180 21.9238\nEQ_T2_47_CP15_P 47 190 22.27536\nEQ_T2_48_CP15_P 48 200 22.58634\nEQ_T2_49_CP15_P 49 210 22.8631\nEQ_T2_50_CP15_P 50 220 23.11088\nEQ_T2_51_CP15_P 51 230 23.33401\nEQ_T2_52_CP15_P 52 240 23.53603\nEQ_T2_53_CP15_P 53 250 23.71991\nEQ_T2_54_CP15_P 54 260 23.88818\nEQ_T2_55_CP15_P 55 270 24.04287\nEQ_T2_56_CP15_P 56 280 24.18579\nEQ_T2_57_CP15_P 57 290 24.31843\nEQ_T2_58_CP15_P 58 300 24.44204\nEQ_T2_59_CP15_P 59 310 24.55777\nEQ_T2_60_CP15_P 60 320 24.66653\nEQ_T2_61_CP15_P 61 330 24.7691\nEQ_T2_62_CP15_P 62 340 24.86624\nEQ_T2_63_CP15_P 63 350 24.95854\nEQ_T2_64_CP15_P 64 360 25.04652\nEQ_T2_65_CP15_P 65 370 25.13065\nEQ_T2_66_CP15_P 66 380 25.2114\nEQ_T2_67_CP15_P 67 390 25.28911\nEQ_T2_68_CP15_P 68 400 25.36401\nEQ_T2_69_CP15_P 69 410 25.43645\nEQ_T2_70_CP15_P 70 420 25.50675\nEQ_T2_71_CP15_P 71 430 25.57505\nEQ_T2_72_CP15_P 72 440 25.64156\nEQ_T2_73_CP15_P 73 450 25.70655\nEQ_T2_74_CP15_P 74 460 25.77003\nEQ_T2_75_CP15_P 75 470 25.83227\nEQ_T2_76_CP15_P 76 480 25.89344\nEQ_T2_77_CP15_P 77 490 25.95348\nEQ_T2_78_CP15_P 78 500 26.01259\nEQ_T2_79_CP15_P 79 510 26.07098\nEQ_T2_80_CP15_P 80 520 26.12865\nEQ_T2_81_CP15_P 81 530 26.18561\nEQ_T2_82_CP15_P 82 540 26.24207\nEQ_T2_83_CP15_P 83 550 26.29805\nEQ_T2_84_CP15_P 84 560 26.35354\nEQ_T2_85_CP15_P 85 570 26.4087\nEQ_T2_86_CP15_P 86 580 26.46352\nEQ_T2_87_CP15_P 87 590 26.5182\nEQ_T2_88_CP15_P 88 600 26.57262\nEQ_T2_89_CP15_P 89 610 26.62678\nEQ_T2_90_CP15_P 90 620 26.68089\nEQ_T2_91_CP15_P 91 630 26.73492\nEQ_T2_92_CP15_P 92 640 26.7889\nEQ_T2_93_CP15_P 93 650 26.84285\nEQ_T2_94_CP15_P 94 660 26.89681\nEQ_T2_95_CP15_P 95 670 26.95088\nEQ_T2_96_CP15_P 96 680 27.005\nEQ_T2_97_CP15_P 97 690 27.05915\nEQ_T2_98_CP15_P 98 700 27.11354\nEQ_T2_99_CP15_P 99 710 27.16812\nEQ_T2_100_CP15_P 100 720 27.22276\nEQ_T2_101_CP15_P 101 730 27.27771\nEQ_T2_102_CP15_P 102 740 27.33283\nEQ_T2_103_CP15_P 103 750 27.38814\nEQ_T2_104_CP15_P 104 760 27.44385\nEQ_T2_105_CP15_P 105 770 27.49973\nEQ_T2_106_CP15_P 106 780 27.55588\nEQ_T2_107_CP15_P 107 790 27.6125\nEQ_T2_108_CP15_P 108 800 27.66953\nEQ_T2_109_CP15_P 109 810 27.72683\nEQ_T2_110_CP15_P 110 820 27.78436\nEQ_T2_111_CP15_P 111 830 27.84238\nEQ_T2_112_CP15_P 112 840 27.9009\nEQ_T2_113_CP15_P 113 850 27.95975\nEQ_T2_114_CP15_P 114 860 28.01896\nEQ_T2_115_CP15_P 115 870 28.07876\nEQ_T2_116_CP15_P 116 880 28.13917\nEQ_T2_117_CP15_P 117 890 28.19976\nEQ_T2_118_CP15_P 118 900 28.26095\nEQ_T2_119_CP15_P 119 910 28.32291\nEQ_T2_120_CP15_P 120 920 28.38519\nEQ_T2_121_CP15_P 121 930 28.44783\nEQ_T2_122_CP15_P 122 940 28.51116\nEQ_T2_123_CP15_P 123 950 28.57536\nEQ_T2_124_CP15_P 124 960 28.63981\nEQ_T2_125_CP15_P 125 970 28.70504\nEQ_T2_126_CP15_P 126 980 28.77107\nEQ_T2_127_CP15_P 127 990 28.8372\nEQ_T2_128_CP15_P 128 1000 28.90433\nEQ_T2_129_CP15_P 129 1500 33.47658\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 CUMG2\ncondition P=P0 T=@1 N(MG)=2 N(CU)=1\nexperiment CPM1=@2:.1\ncomment CUMG2 - CP - FEUFEL\nplot_data 2 @1 @2 8 Feufel\ntable_start\nEQ_T3_130_CP2 100 12\nEQ_T3_131_CP2 298.15 24.12\nEQ_T3_132_CP2 343 24.81\nEQ_T3_133_CP2 363 25.02\nEQ_T3_134_CP2 383 25.24\nEQ_T3_135_CP2 403 25.33\nEQ_T3_136_CP2 423 25.49\nEQ_T3_137_CP2 443 25.60\nEQ_T3_138_CP2 463 25.70\nEQ_T3_139_CP2 483 25.81\nEQ_T3_140_CP2 503 25.89\nEQ_T3_141_CP2 523 25.98\nEQ_T3_142_CP2 543 26.04\nEQ_T3_143_CP2 563 26.17\nEQ_T3_144_CP2 583 26.27\nEQ_T3_145_CP2 603 26.40\nEQ_T3_146_CP2 623 26.49\nEQ_T3_147_CP2 643 26.59\nEQ_T3_148_CP2 663 26.69\nEQ_T3_149_CP2 683 26.81\nEQ_T3_150_CP2 703 26.96\nEQ_T3_151_CP2 723 27.13\nEQ_T3_152_CP2 743 27.47\nEQ_T3_153_CP2 763 27.76\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\ncondition P=P0 N=1 T=@3 X(MG)=@4\nreference MG LIQ * 1E5\n@$ experiment MUR(MG)=@2:20%\nexperiment MU(MG)=@2:20%\ncomment LIQ - MG PRESS - SCHMAHL AND SIEBEN\nplot_data 4 @4 @2 7 Schmahl\ntable_start\nEQ_T4_190_MUL_S 190 -83 865 .936\nEQ_T4_191_MUL_S 191 -385 895 .936\nEQ_T4_192_MUL_S 192 -685 925 .936\nEQ_T4_193_MUL_S 193 -687 940 .936\nEQ_T4_194_MUL_S 194 -952 872 .857\nEQ_T4_195_MUL_S 195 -1255 902 .857\nEQ_T4_196_MUL_S 196 -1485 922 .857\nEQ_T4_197_MUL_S 197 -1488 941 .857\nEQ_T4_198_MUL_S 198 -2079 881 .765\nEQ_T4_199_MUL_S 199 -2286 901 .765\nEQ_T4_200_MUL_S 200 -2494 921 .765\nEQ_T4_201_MUL_S 201 -2550 960 .765\nEQ_T4_202_MUL_S 202 -4384 891 .667\nEQ_T4_203_MUL_S 203 -4600 911 .667\nEQ_T4_204_MUL_S 204 -4758 931 .667\nEQ_T4_205_MUL_S 205 -4793 966 .667\nEQ_T4_206_MUL_S 206 -7762 925 .581\nEQ_T4_207_MUL_S 207 -7958 1005 .581\nEQ_T4_208_MUL_S 208 -8980 942 .521\nEQ_T4_209_MUL_S 209 -9259 1052 .521\nEQ_T4_210_MUL_S 210 -21123 1096 .330\nEQ_T4_211_MUL_S 211 -30969 1118 .224\nEQ_T4_212_MUL_S 212 -31495 1198 .224\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\ncondition P=P0 N=1 X(MG)=@6 T=@2\nreference MG LIQ * 1E5\n@$ experiment ACR(MG)=@5:16%\nexperiment AC(MG)=@5:16%\ncomment LIQ - MG PRESSURE - JUNEJA\nplot_data 3 @6 @5 8 Juneja\ntable_start\nEQ_T5_220_MUL_J 220 1056 9.4698 -0.0466 0.8982 0.9005 -943\nEQ_T5_221_MUL_J 221 1032 9.6927 -0.0471 0.8972 0.9005 -931\nEQ_T5_222_MUL_J 222 1018 9.8254 -0.0474 0.8966 0.9005 -924\nEQ_T5_223_MUL_J 223 1010 9.9028 -0.0476 0.8962 0.9005 -920\nEQ_T5_224_MUL_J 224 990 10.1019 -0.048 0.8953 0.9005 -910\nEQ_T5_225_MUL_J 225 979 10.2125 -0.0483 0.8948 0.9005 -905\nEQ_T5_226_MUL_J 226 1052 9.5102 -0.1367 0.7299 0.7652 -2754\nEQ_T5_227_MUL_J 227 1039 9.6208 -0.1377 0.7283 0.7652 -2739\nEQ_T5_228_MUL_J 228 1036 9.654 -0.138 0.7278 0.7652 -2737\nEQ_T5_229_MUL_J 229 1018 9.8254 -0.1395 0.7253 0.7652 -2718\nEQ_T5_230_MUL_J 230 995 10.0521 -0.1415 0.722 0.7652 -2695\nEQ_T5_231_MUL_J 231 989 10.1074 -0.1419 0.7212 0.7652 -2687\nEQ_T5_232_MUL_J 232 976 10.2457 -0.1431 0.7192 0.7652 -2675\nEQ_T5_233_MUL_J 233 957 10.4503 -0.1449 0.7163 0.7652 -2655\nEQ_T5_234_MUL_J 234 1073 9.3222 -0.2433 0.5711 0.6728 -4997\nEQ_T5_235_MUL_J 235 1050 9.5268 -0.2471 0.5661 0.6728 -4967\nEQ_T5_236_MUL_J 236 1038 9.6319 -0.2491 0.5636 0.6728 -4948\nEQ_T5_237_MUL_J 237 1009 9.9084 -0.2542 0.5569 0.6728 -4911\nEQ_T5_238_MUL_J 238 980 10.2015 -0.2596 0.55 0.6728 -4871\nEQ_T5_239_MUL_J 239 1122 8.913 -0.5165 0.3044 0.5053 -11095\nEQ_T5_240_MUL_J 240 1089 9.1839 -0.5295 0.2954 0.5053 -11041\nEQ_T5_241_MUL_J 241 1086 9.2116 -0.5309 0.2945 0.5053 -11038\nEQ_T5_242_MUL_J 242 1041 9.6042 -0.5498 0.282 0.5053 -10956\nEQ_T5_243_MUL_J 243 1025 9.7591 -0.5572 0.2772 0.5053 -10934\nEQ_T5_244_MUL_J 244 1005 9.9471 -0.5663 0.2715 0.5053 -10894\nEQ_T5_245_MUL_J 245 1150 8.6973 -0.7575 0.1748 0.4449 -16676\nEQ_T5_246_MUL_J 246 1119 8.9351 -0.7728 0.1687 0.4449 -16557\nEQ_T5_247_MUL_J 247 1103 9.0623 -0.781 0.1656 0.4449 -16490\nEQ_T5_248_MUL_J 248 1063 9.4107 -0.8035 0.1572 0.4449 -16352\nEQ_T5_249_MUL_J 249 1143 8.7471 -1.0032 0.0993 0.3704 -21948\nEQ_T5_250_MUL_J 250 1132 8.8355 -1.0108 0.0976 0.3704 -21899\nEQ_T5_251_MUL_J 251 1105 9.0512 -1.0292 0.0935 0.3704 -21771\nEQ_T5_252_MUL_J 252 1082 9.2448 -1.0457 0.09 0.3704 -21661\nEQ_T5_253_MUL_J 253 1235 8.0945 -1.1301 0.0741 0.3007 -26720\nEQ_T5_254_MUL_J 254 1216 8.2217 -1.1435 0.0719 0.3007 -26614\nEQ_T5_255_MUL_J 255 1188 8.4153 -1.1638 0.0686 0.3007 -26465\nEQ_T5_256_MUL_J 256 1145 8.736 -1.1974 0.0635 0.3007 -26243\nEQ_T5_257_MUL_J 257 1137 8.7968 -1.2038 0.0625 0.3007 -26209\nEQ_T5_258_MUL_J 258 1122 8.913 -1.216 0.0608 0.3007 -26121\nEQ_T5_259_MUL_J 259 1101 9.0789 -1.2334 0.0584 0.3007 -26001\nEQ_T5_260_MUL_J 260 1229 8.1388 -1.4613 0.0346 0.2366 -34372\nEQ_T5_261_MUL_J 261 1218 8.2106 -1.4704 0.0339 0.2366 -34271\nEQ_T5_262_MUL_J 262 1209 8.2715 -1.4782 0.0332 0.2366 -34228\nEQ_T5_263_MUL_J 263 1185 8.4374 -1.4994 0.0317 0.2366 -34004\nEQ_T5_264_MUL_J 264 1156 8.6475 -1.5263 0.0298 0.2366 -33766\nEQ_T5_265_MUL_J 265 1246 8.0226 -1.6589 0.0219 0.1729 -39585\nEQ_T5_266_MUL_J 266 1227 8.1498 -1.6783 0.021 0.1729 -39410\nEQ_T5_267_MUL_J 267 1203 8.3102 -1.7026 0.0198 0.1729 -39228\nEQ_T5_268_MUL_J 268 1185 8.4374 -1.7219 0.019 0.1729 -39047\nEQ_T5_269_MUL_J 268 1171 8.5369 -1.7371 0.0183 0.1729 -38951\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\ncondition P=P0 N=1 T=@3 X(MG)=@2\nreference MG LIQ * 1E5\n@$ experiment ACR(MG)=@6:20%\nexperiment AC(MG)=@6:20%\ncomment LIQ - MG PRESSURE - GARG\nplot_data 3 @2 @6 9 Garg\ntable_start\nEQ_T6_270_ACL_G 270 0.11 1173 8.52514919 -2.1844 0.0065 -49053.0\nEQ_T6_271_ACL_G 271 0.11 1200 8.333333333 -2.1543 0.0070 -49490.3\nEQ_T6_272_ACL_G 272 0.11 1300 7.692307692 -2.0536 0.0088 -51109.8\nEQ_T6_273_ACL_G 273 0.11 1342 7.451564829 -2.0159 0.0096 -51790.0\nEQ_T6_274_ACL_G 274 0.18 1148 8.710801394 -1.7634 0.0172 -38753.7\nEQ_T6_275_ACL_G 275 0.18 1232 8.116883117 -1.6820 0.0208 -39670.3\nEQ_T6_276_ACL_G 276 0.22 1013 9.871668312 -1.6637 0.0217 -32263.4\nEQ_T6_277_ACL_G 277 0.22 1100 9.090909091 -1.5645 0.0273 -32946.3\nEQ_T6_278_ACL_G 278 0.22 1221 8.19000819 -1.4501 0.0355 -33896.0\nEQ_T6_279_ACL_G 279 0.29 1073 9.319664492 -1.2135 0.0612 -24926.4\nEQ_T6_280_ACL_G 280 0.29 1100 9.090909091 -1.1881 0.0648 -25018.9\nEQ_T6_281_ACL_G 281 0.29 1188 8.417508418 -1.1133 0.0770 -25320.4\nEQ_T6_282_ACL_G 282 0.37 1085 9.216589862 -0.8874 0.1296 -18432.3\nEQ_T6_283_ACL_G 283 0.37 1100 9.090909091 -0.8767 0.1328 -18462.2\nEQ_T6_284_ACL_G 284 0.37 1139 8.779631255 -0.8503 0.1412 -18539.8\nEQ_T6_285_ACL_G 285 0.42 1048 9.541984733 -0.7958 0.1600 -15966.9\nEQ_T6_286_ACL_G 286 0.42 1100 9.090909091 -0.7652 0.1717 -16113.2\nEQ_T6_287_ACL_G 287 0.5 1049 9.532888465 -0.6406 0.2288 -12863.9\nEQ_T6_288_ACL_G 288 0.5 1100 9.090909091 -0.6194 0.2402 -13042.6\nEQ_T6_289_ACL_G 289 0.66 845 11.83431953 -0.3770 0.4197 -6098.9\nEQ_T6_290_ACL_G 290 0.66 900 11.11111111 -0.3597 0.4369 -6196.8\nEQ_T6_291_ACL_G 291 0.66 1022 9.784735812 -0.3278 0.4701 -6414.0\nEQ_T6_292_ACL_G 292 0.76 913 10.95290252 -0.1985 0.6332 -3469.1\nEQ_T6_293_ACL_G 293 0.76 1003 9.970089731 -0.1877 0.6491 -3603.5\nEQ_T6_294_ACL_G 294 0.9 892 11.21076233 -0.0718 0.8475 -1226.8\nEQ_T6_295_ACL_G 295 0.9 1003 9.970089731 -0.0669 0.8573 -1284.2\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 CUMG2,LAVES\ncondition P=P0 N=1 X(MG)=.5 T=@2\nreference MG HCP * 1E5\n@$ experiment MUR(MG)=@6:20%\nexperiment MU(MG)=@6:20%\ncomment C15+CUMG2 - MG PRESSURE - SMITH\nplot_data 4 @2 @6 7 Smith\ntable_start\nEQ_T7_300_MU2 AC2 675 -6.4800 3.3113E-07 0.0786 -14276\nEQ_T7_301_MU2 AC2 725 -5.6800 2.0893E-06 0.0839 -14937\nEQ_T7_302_MU2 AC2 775 -4.9832 1.0394E-05 0.0889 -15597\nEQ_T7_303_MU2 AC2 825 -4.3709 4.2569E-05 0.0935 -16258\nEQ_T7_304_MU2 AC2 875 -3.8286 1.4840E-04 0.0977 -16918\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 FCC,LAVES\ncondition P=P0 N=1 X(MG)=.2 T=@2\nreference MG HCP * 1E5\n@$ experiment MUR(MG)=@6:20%\nexperiment MU(MG)=@6:20%\ncomment CU+C15 - MG PRESSURE - SMITH\nplot_data 4 @2 @6 7 Smith\ntable_start\nEQ_T8_310_MUF2 AF2 751 -6.3515 4.4514E-07 0.0078 -30310\nEQ_T8_311_MUF2 AF2 801 -5.6417 2.2821E-06 0.0094 -31066\nEQ_T8_312_MUF2 AF2 851 -5.0153 9.6549E-06 0.0111 -31822\nEQ_T8_313_MUF2 AF2 901 -4.4584 3.4805E-05 0.0129 -32579\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 @2,@3\ncondition P=P0 N=1 T=@6 X(MG)=@9\nreference MG HCP * 1E5\n@$ experiment MUR(MG)=@4:@5\nexperiment MU(MG)=@4:@5\nplot_data 4 @6 @4 8 Eremenko\ncomment EMF - EREMENKO\ntable_start\nEQ_T9_320_MU3 AFC FCC_A1 L_C15 -34373 1050 723 .0400 .333300 .2\nEQ_T9_321_MU3 AFC FCC_A1 L_C15 -34078 1050 873 .0550 .333300 .2\nEQ_T9_322_MU2 AC2 L_C15 CUMG2 -5638 840 823 .3333 .666667 .5\nEQ_T9_323_MU2 AC2 L_C15 CUMG2 -5977 840 723 .3333 .666667 .5\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQUID\ncondition P=P0 N=1 T=1100 X(MG)=@3\nreference CU LIQUID * 1E5\nreference MG LIQUID * 1E5\n@$ experiment HMR=@2:5%\nexperiment HM=@2:5%\ncomment BATALIN LIQ - CALO - \nplot_data 5 @3 @2 2 Batalin\ntable_start\nEQ_T10_330_HLIQ_B 330 -3.7240E3 1.0222E-01\nEQ_T10_331_HLIQ_B 331 -5.9639E3 2.0807E-01\nEQ_T10_332_HLIQ_B 332 -7.0270E3 3.0134E-01\nEQ_T10_333_HLIQ_B 333 -7.5960E3 4.0118E-01\nEQ_T10_334_HLIQ_B 334 -7.8558E3 5.0111E-01\nEQ_T10_335_HLIQ_B 335 -7.5589E3 6.0119E-01\nEQ_T10_336_HLIQ_B 336 -6.5816E3 7.0146E-01\nEQ_T10_337_HLIQ_B 337 -4.9239E3 8.0190E-01\nEQ_T10_338_HLIQ_B 338 -2.8333E3 9.0246E-01\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQUID\ncondition P=P0 N=1 T=1100 X(MG)=@2\nreference CU LIQUID * 1E5\nreference MG LIQUID * 1E5\n@$ experiment HMR=@3:5%\nexperiment HM=@3:5%\ncomment HULTGREN LIQ - CALO - \nplot_data 5 @2 @3 8 Hultgren\ntable_start\nEQ_T11_340_HLIQ_H 340 1.9481E-01 -7.3231E3\nEQ_T11_341_HLIQ_H 341 3.0398E-01 -9.1922E3\nEQ_T11_342_HLIQ_H 342 3.9729E-01 -1.0070E4\nEQ_T11_343_HLIQ_H 343 4.9084E-01 -1.0081E4\nEQ_T11_344_HLIQ_H 344 5.9750E-01 -9.2904E3\nEQ_T11_345_HLIQ_H 345 7.0753E-01 -8.0051E3\nEQ_T11_346_HLIQ_H 346 8.0478E-01 -6.2233E3\nEQ_T11_347_HLIQ_H 347 8.9570E-01 -4.0077E3\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQUID\ncondition P=P0 N=1 T=1120 X(CU)=@3\nreference CU LIQUID * 1E5\nreference MG LIQUID * 1E5\n@$ experiment HMR=@2:5%\nexperiment HM=@2:5%\ncomment SOMMER LIQ - CALO - \nplot_data 5 @4 @2 3 Sommer\ntable_start\nEQ_T12_350_HLIQ_S 350 -1900 .075 .925\nEQ_T12_351_HLIQ_S 351 -3200 .13 .87\nEQ_T12_352_HLIQ_S 352 -3500 .15 .85\nEQ_T12_353_HLIQ_S 353 -4800 .21 .79\nEQ_T12_354_HLIQ_S 354 -5600 .245 .755\nEQ_T12_355_HLIQ_S 355 -5800 .27 .73\nEQ_T12_356_HLIQ_S 356 -7000 .33 .67\nEQ_T12_357_HLIQ_S 357 -6600 .33 .67\nEQ_T12_358_HLIQ_S 358 -7500 .38 .62\nEQ_T12_359_HLIQ_S 359 -7900 .425 .575\nEQ_T12_360_HLIQ_S 360 -8100 .43 .57\nEQ_T12_361_HLIQ_S 361 -8400 .47 .53\nEQ_T12_362_HLIQ_S 362 -8300 .475 .525\nEQ_T12_363_HLIQ_S 363 -8700 .505 .495\nEQ_T12_364_HLIQ_S 364 -8600 .515 .485\nEQ_T12_365_HLIQ_S 365 -8500 .52 .48\nEQ_T12_366_HLIQ_S 366 -8900 .54 .46\nEQ_T12_367_HLIQ_S 367 -8900 .54 .46\nEQ_T12_368_HLIQ_S 368 -8500 .565 .435\nEQ_T12_369_HLIQ_S 369 -9000 .59 .41\nEQ_T12_370_HLIQ_S 370 -8900 .61 .39\nEQ_T12_371_HLIQ_S 371 -8950 .635 .365\nEQ_T12_372_HLIQ_S 372 -8850 .65 .35\nEQ_T12_373_HLIQ_S 373 -8800 .67 .33\nEQ_T12_374_HLIQ_S 374 -8650 .685 .315\nEQ_T12_375_HLIQ_S 375 -8550 .7 .3\ntable_end\n@$ ==========================================\nenter equilibrium EQ_400_HC15_K YES\nset status phase *=sus\nset status PHASE LAVES_C15=ENT 1\nset cond P=P0 T=299 N(CU)=2 N(MG)=1\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-11171.3:420\nenter experiment HM=-11171.3:420\nenter plot_data 6 .33 -11171.3 7 King\nenter comment C15 - CALORIMETRY - KING\n@$ ==========================================\nenter equilibrium EQ_401_HCUMG2_K YES\nset status phase *=sus\nset status PHASE CUMG2=ENT 1\nset cond P=P0 T=299 N(MG)=2 N(CU)=1\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-9539.5:420\nenter experiment HM=-9539.5:420\nenter plot_data 6 .67 -9539.5 7 King\nenter comment CUMG2 - CALORIMETRY - KING\n@$ ==========================================\nenter equilibrium EQ_402_HC15_F YES\nset status phase *=sus\nset status PHASE LAVES_C15=ENT 1\nset cond P=P0 T=299 N(MG)=1 N(CU)=2\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-12700:2000\nenter experiment HM=-12700:2000\nenter plot_data 6 .33 -12700 8 Feufel\nenter comment C15 - SOLUTION CALORIMETRY - FEUFEL\n@$ ==========================================\nenter equilibrium EQ_403_HCUMG2_F YES\nset status phase *=sus\nset status PHASE CUMG2=ENT 1\nset cond P=P0 T=299 N(MG)=2 N(CU)=1\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-9800:1800\nenter experiment HM=-9800:1800\nenter plot_data 6 .67 -9800 8 Feufel\nenter comment CUMG2 - SOLUTION CALORIMETRY - FEUFEL\nenter symbol HFUS=HM(LIQUID)-HM;\n@$ ==========================================\nenter equilibrium EQ_410_HTC15 YES\nset status phase *=sus\nset status PHASE LIQUID=FIX 0\nset status PHASE L_C15=ENT 1\nset cond P=P0 N(MG)=1 N(CU)=2\nenter experiment HFUS=15200:1500\nenter plot_data 7 .33 15200 8 Feufel\nenter comment C15 - MELTING ENTHALPY - FEUFEL 95\n@$ ==========================================\nenter equilibrium EQ_411_HTCUMG2 YES\nset status phase *=sus\nset status PHASE LIQUID=FIX 0\nset status PHASE CUMG2=FIX 1\nset cond P=P0 X(LIQ,MG)-X(CUMG2,MG)=0\nenter experiment HFUS=13700:1400\nenter plot_data 7 .67 13700:1400 8 Feufel\nenter comment CUMG2 - MELTING ENTHALPY - FEUFEL 95\n@$ ==========================================\nenter equilibrium EQ_470_HC15_C YES\nset status phase *=sus\nset status PHASE LAVES_C15=ENT 1\nset cond P=P0 T=298.15 N(MG)=1 N(CU)=2\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-14369:1000\nenter experiment HM=-14369:1000\nenter plot_data 6 0.333333 -14369 10 12Cur\nenter comment C15 - DFT FORMATION H - 12CUR\n@$ ==========================================\nenter equilibrium EQ_471_HCUMG2_C YES\nset status phase *=sus\nset status PHASE CUMG2=ENT 1\nset cond P=P0 T=298.15 N(CU)=1 N(MG)=2\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-10700:1000\nenter experiment HM=-10700:1000\nenter plot_data 6 0.6666667 -10700 10 12Cur\nenter comment CUMG2 - DFT FORMATION H - 12CUR\n@$ ==========================================\nenter equilibrium EQ_472_HC15_Z YES\nset status phase *=sus\nset status PHASE LAVES_C15=ENT 1\nset cond P=P0 T=298.15 N(MG)=1 N(CU)=2\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-15720:1000\nenter experiment HM=-15720:1000\nenter plot_data 6 0.3333333 -15720 6 07Zho\nenter comment C15 - DFT FORMATION H - 07ZHO\n@$ ==========================================\nenter equilibrium EQ_473_HCUMG2_Z YES\nset status phase *=sus\nset status PHASE CUMG2=ENT 1\nset cond P=P0 T=298.15 N(CU)=1 N(MG)=2\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG HCP_A3 * 1E5\n@$ enter experiment HMR=-13200:1000\nenter experiment HM=-13200:1000\nenter comment CUMG2 - DFT FORMATION H - 07ZHO\nenter plot_data 6 0.66666667 -13200 6 07Zho\n@$\n@$=================================\nenter many_equilibria\nENT 1 @3\ncondition P=P0 N=1 T=298.15 X(MG)=@4\nreference CU @3 * 1E5\nreference MG @3 * 1E5\n@$ experiment HMR=@5:500\nexperiment HM=@5:500\nplot_data @7 @4 @5 @6 07Shi\ncomment @3 - SQS - 07SHI\ntable_start\nEQ_T13_480_HFSQS_S 480 AFS FCC_A1 0.25 1580 2 8\nEQ_T13_481_HFSQS_S 481 AFS FCC_A1 0.5 8070 2 8\nEQ_T13_482_HFSQS_S 482 AFS FCC_A1 0.75 6980 2 8\nEQ_T13_483_HHSQS_S 483 AHS HCP_A3 0.25 1120 2 8\nEQ_T13_484_HHSQS_S 484 AHS HCP_A3 0.5 5650 2 8\nEQ_T13_485_HHSQS_S 485 AHS HCP_A3 0.75 5810 2 8\ntable_end\n@$ ==========================================\nenter equilibrium EQ_486_HSSQS_W YES\nset status phase *=sus\nset status PHASE FCC_A1=FIX 1\nset cond P=P0,T=298.15,X(MG)=0.5\nset reference_state CU FCC_A1 * 1E5\nset reference_state MG FCC_A1 * 1E5\n@$ enter experiment HMR=-2600:500\nenter experiment HM=-2600:500\nenter plot_data 8 0.5 -2600 3 07Wol\nenter comment FCC_A1 - SQS - 07WOL\n@$\n@$=================================\n@$ BOSSE: CHANGED FIX PHASE, eq 504 strange and removed\nenter many_equilibria\nENT 1 LIQ\nFIX 0 @3\ncondition P=P0 N=1 X(LIQ,MG)=@4\nexperiment T=@5:5\ncomment LIQUIDUS @7\nplot_data 9 @4 @5 7 @7\ntable_start\nEQ_T14_501_XLIQ_F 501 ALF FCC_A1 0.026 1338 9 08SAH\nEQ_T14_502_XLIQ_F 502 ALF FCC_A1 0.075 1263 9 08SAH\nEQ_T14_503_XLIQ_F 503 ALF FCC_A1 0.132 1174 9 08SAH\n@$ EQ_T14_504_XLIQ_F 504 ALF FCC_A1,L_C15 0.223 1009 9 08SAH\nEQ_T14_505_XLIQ_C 505 ALC L_C15 0.283 1062 9 08SAH\nEQ_T14_506_XLIQ_C 506 ALC L_C15 0.339 1070 9 08SAH\nEQ_T14_507_XLIQ_C 507 ALC L_C15 0.351 1070 9 08SAH\nEQ_T14_508_XLIQ_C 508 ALC L_C15 0.366 1065 9 08SAH\nEQ_T14_509_XLIQ_C 509 ALC L_C15 0.425 1064 9 08SAH\nEQ_T14_510_XLIQ_C 510 ALC L_C15 0.462 1049 9 08SAH\nEQ_T14_511_XLIQ_C 511 ALC L_C15 0.468 1051 9 08SAH\nEQ_T14_512_XLIQ_C 512 ALC L_C15 0.547 878 9 08SAH\nEQ_T14_513_XLIQ_C 513 ALC CUMG2 0.616 837 9 08SAH\nEQ_T14_514_XLIQ_C 514 ALC CUMG2 0.638 846 9 08SAH\nEQ_T14_515_XLIQ_C 515 ALC CUMG2 0.643 840 9 08SAH\nEQ_T14_516_XLIQ_2 516 AL2 CUMG2 0.655 844 9 08SAH\nEQ_T14_517_XLIQ_2 517 AL2 CUMG2 0.668 841 9 08SAH\nEQ_T14_518_XLIQ_2 518 AL2 CUMG2 0.672 846 9 08SAH\nEQ_T14_519_XLIQ_2 519 AL2 CUMG2 0.681 840 9 08SAH\nEQ_T14_520_XLIQ_2 520 AL2 CUMG2 0.724 833 9 08SAH\nEQ_T14_521_XLIQ_2 521 AL2 CUMG2 0.796 783 9 08SAH\nEQ_T14_522_XLIQ_H 522 ALH HCP_A3 0.920 823 9 08SAH\nEQ_T14_523_XLIQ_H 523 ALH HCP_A3 0.980 890 9 08SAH\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\nFIX 0 @3\ncondition P=P0 N=1 X(LIQ,MG)=@4\nexperiment T=@5:5\ncomment LIQUIDUS @7\nplot_data 9 @4 @5 8 @7\ntable_start\nEQ_T15_530_XLIQ_H 530 ALH HCP_A3 0.999988522 920.45 2 31JON\nEQ_T15_531_XLIQ_H 531 ALH HCP_A3 0.999973217 920.15 2 31JON\nEQ_T15_532_XLIQ_H 532 ALH HCP_A3 0.999908164 921.15 2 31JON\nEQ_T15_533_XLIQ_H 533 ALH HCP_A3 0.999881373 920.15 2 31JON\nEQ_T15_534_XLIQ_H 534 ALH HCP_A3 0.999843097 919.15 2 31JON\nEQ_T15_535_XLIQ_H 535 ALH HCP_A3 0.998984465 919.15 2 31JON\nEQ_T15_536_XLIQ_H 536 ALH HCP_A3 0.997961745 919.15 2 31JON\nEQ_T15_537_XLIQ_H 537 ALH HCP_A3 0.995188155 918.15 2 31JON\nEQ_T15_538_XLIQ_H 538 ALH HCP_A3 0.993501152 919.15 2 31JON\nEQ_T15_539_XLIQ_H 539 ALH HCP_A3 0.992926354 916.65 2 31JON\nEQ_T15_540_XLIQ_H 540 ALH HCP_A3 0.990245739 915.15 2 31JON\nEQ_T15_541_XLIQ_H 541 ALH HCP_A3 0.988861134 913.15 2 31JON\nEQ_T15_542_XLIQ_H 542 ALH HCP_A3 0.976614827 903.15 2 31JON\nEQ_T15_543_XLIQ_H 543 ALH HCP_A3 0.965379917 892.15 2 31JON\nEQ_T15_544_XLIQ_H 544 ALH HCP_A3 0.954980318 881.65 2 31JON\nEQ_T15_545_XLIQ_H 545 ALH HCP_A3 0.936288656 861.15 2 31JON\nEQ_T15_546_XLIQ_H 546 ALH HCP_A3 0.932310502 858.65 2 31JON\nEQ_T15_547_XLIQ_H 547 ALH HCP_A3 0.929569307 853.15 2 31JON\nEQ_T15_548_XLIQ_H 548 ALH HCP_A3 0.907484295 829.15 2 31JON\nEQ_T15_549_XLIQ_H 549 ALH HCP_A3 0.888068531 804.15 2 31JON\nEQ_T15_550_XLIQ_H 550 ALH HCP_A3 0.875924532 787.15 2 31JON\nEQ_T15_551_XLIQ_H 551 ALH HCP_A3 0.862229041 769.15 2 31JON\nEQ_T15_552_XLIQ_2 552 AL2 CUMG2 0.858552878 762.15 2 31JON\nEQ_T15_553_XLIQ_2 553 AL2 CUMG2 0.846831335 764.15 2 31JON\nEQ_T15_554_XLIQ_2 554 AL2 CUMG2 0.842221712 768.15 2 31JON\nEQ_T15_555_XLIQ_2 555 AL2 CUMG2 0.841739635 767.15 2 31JON\nEQ_T15_556_XLIQ_2 556 AL2 CUMG2 0.832897191 773.15 2 31JON\nEQ_T15_557_XLIQ_2 557 AL2 CUMG2 0.815949094 785.15 2 31JON\nEQ_T15_558_XLIQ_2 558 AL2 CUMG2 0.802468294 791.65 2 31JON\nEQ_T15_559_XLIQ_2 559 AL2 CUMG2 0.793793729 799.15 2 31JON\nEQ_T15_560_XLIQ_2 560 AL2 CUMG2 0.78389036 804.15 2 31JON\nEQ_T15_561_XLIQ_2 561 AL2 CUMG2 0.780606398 805.65 2 31JON\nEQ_T15_562_XLIQ_2 562 AL2 CUMG2 0.773960441 813.15 2 31JON\nEQ_T15_563_XLIQ_2 563 AL2 CUMG2 0.772389773 811.15 2 31JON\nEQ_T15_564_XLIQ_2 564 AL2 CUMG2 0.764885119 816.15 2 31JON\nEQ_T15_565_XLIQ_2 565 AL2 CUMG2 0.750072965 824.15 2 31JON\nEQ_T15_566_XLIQ_2 566 AL2 CUMG2 0.739626826 829.15 2 31JON\nEQ_T15_567_XLIQ_2 567 AL2 CUMG2 0.732548319 833.15 2 31JON\nEQ_T15_568_XLIQ_2 568 AL2 CUMG2 0.731291959 831.15 2 31JON\nEQ_T15_569_XLIQ_2 569 AL2 CUMG2 0.719661136 835.15 2 31JON\nEQ_T15_570_XLIQ_2 570 AL2 CUMG2 0.710283223 837.65 2 31JON\nEQ_T15_571_XLIQ_2 571 AL2 CUMG2 0.70372695 838.15 2 31JON\nEQ_T15_572_XLIQ_2 572 AL2 CUMG2 0.680499863 840.15 2 31JON\nEQ_T15_573_XLIQ_2 573 AL2 CUMG2 0.671897202 839.65 2 31JON\nEQ_T15_574_XLIQ_2 574 AL2 CUMG2 0.668934483 840.15 2 31JON\nEQ_T15_575_XLIQ_2 575 AL2 CUMG2 0.667039454 840.65 2 31JON\nEQ_T15_576_XLIQ_2 576 AL2 CUMG2 0.666315549 840.65 2 31JON\nEQ_T15_577_XLIQ_2 577 AL2 CUMG2 0.651882892 840.15 2 31JON\nEQ_T15_578_XLIQ_2 578 AL2 CUMG2 0.65150947 840.15 2 31JON\nEQ_T15_579_XLIQ_2 579 AL2 CUMG2 0.645873363 839.65 2 31JON\nEQ_T15_580_XLIQ_2 580 AL2 CUMG2 0.643695418 840.15 2 31JON\nEQ_T15_581_XLIQ_2 581 AL2 CUMG2 0.643505571 840.15 2 31JON\nEQ_T15_582_XLIQ_2 582 AL2 CUMG2 0.640935388 840.15 2 31JON\nEQ_T15_583_XLIQ_2 583 AL2 CUMG2 0.628564323 837.15 2 31JON\nEQ_T15_584_XLIQ_2 584 AL2 CUMG2 0.622954123 835.15 2 31JON\nEQ_T15_585_XLIQ_2 585 AL2 CUMG2 0.618679657 836.15 2 31JON\nEQ_T15_586_XLIQ_2 586 AL2 CUMG2 0.610628824 834.15 2 31JON\nEQ_T15_587_XLIQ_2 587 AL2 CUMG2 0.592452931 829.15 2 31JON\nEQ_T15_588_XLIQ_2 588 AL2 CUMG2 0.580218717 825.15 2 31JON\nEQ_T15_589_XLIQ_C 589 ALC L_C15 0.579895663 825.15 2 31JON\nEQ_T15_590_XLIQ_C 590 ALC L_C15 0.569011059 841.15 2 31JON\nEQ_T15_591_XLIQ_C 591 ALC L_C15 0.567358682 843.15 2 31JON\nEQ_T15_592_XLIQ_C 592 ALC L_C15 0.561701517 853.15 2 31JON\nEQ_T15_593_XLIQ_C 593 ALC L_C15 0.545394958 877.15 2 31JON\nEQ_T15_594_XLIQ_C 594 ALC L_C15 0.534711099 892.15 2 31JON\nEQ_T15_595_XLIQ_C 595 ALC L_C15 0.515007836 921.15 2 31JON\nEQ_T15_596_XLIQ_C 596 ALC L_C15 0.494197213 954.65 2 31JON\nEQ_T15_597_XLIQ_C 597 ALC L_C15 0.483495071 965.15 2 31JON\nEQ_T15_598_XLIQ_C 598 ALC L_C15 0.479623384 970.15 2 31JON\nEQ_T15_599_XLIQ_C 599 ALC L_C15 0.469827734 982.15 2 31JON\nEQ_T15_600_XLIQ_C 600 ALC L_C15 0.459862291 999.15 2 31JON\nEQ_T15_601_XLIQ_C 601 ALC L_C15 0.458117356 997.65 2 31JON\nEQ_T15_602_XLIQ_C 602 ALC L_C15 0.453664234 1000.15 2 31JON\nEQ_T15_603_XLIQ_C 603 ALC L_C15 0.436900467 1025.15 2 31JON\nEQ_T15_604_XLIQ_C 604 ALC L_C15 0.434945874 1027.15 2 31JON\nEQ_T15_605_XLIQ_C 605 ALC L_C15 0.433125101 1034.15 2 31JON\nEQ_T15_606_XLIQ_C 606 ALC L_C15 0.426495355 1037.65 2 31JON\nEQ_T15_607_XLIQ_C 607 ALC L_C15 0.42677898 1043.65 2 31JON\nEQ_T15_608_XLIQ_C 608 ALC L_C15 0.424079079 1041.15 2 31JON\nEQ_T15_609_XLIQ_C 609 ALC L_C15 0.41170404 1058.15 2 31JON\nEQ_T15_610_XLIQ_C 610 ALC L_C15 0.40791216 1060.15 2 31JON\nEQ_T15_611_XLIQ_C 611 ALC L_C15 0.405566839 1063.15 2 31JON\nEQ_T15_612_XLIQ_C 612 ALC L_C15 0.402622391 1062.15 2 31JON\nEQ_T15_613_XLIQ_C 613 ALC L_C15 0.394750088 1066.15 2 31JON\nEQ_T15_614_XLIQ_C 614 ALC L_C15 0.39160263 1069.15 2 31JON\nEQ_T15_615_XLIQ_C 615 ALC L_C15 0.384347345 1073.15 2 31JON\nEQ_T15_616_XLIQ_C 616 ALC L_C15 0.374230206 1081.15 2 31JON\nEQ_T15_617_XLIQ_C 617 ALC L_C15 0.366454694 1083.65 2 31JON\nEQ_T15_618_XLIQ_C 618 ALC L_C15 0.354448192 1089.15 2 31JON\nEQ_T15_619_XLIQ_C 619 ALC L_C15 0.345453039 1091.15 2 31JON\nEQ_T15_620_XLIQ_C 620 ALC L_C15 0.327905307 1093.15 2 31JON\nEQ_T15_621_XLIQ_C 621 ALC L_C15 0.325239723 1089.15 2 31JON\nEQ_T15_622_XLIQ_C 622 ALC L_C15 0.322563115 1081.15 2 31JON\nEQ_T15_623_XLIQ_C 623 ALC L_C15 0.309354522 1073.15 2 31JON\nEQ_T15_624_XLIQ_C 624 ALC L_C15 0.300571712 1069.15 2 31JON\nEQ_T15_625_XLIQ_C 625 ALC L_C15 0.297269508 1065.15 2 31JON\nEQ_T15_626_XLIQ_C 626 ALC L_C15 0.289910903 1061.15 2 31JON\nEQ_T15_627_XLIQ_C 627 ALC L_C15 0.281756937 1052.15 2 31JON\nEQ_T15_628_XLIQ_C 628 ALC L_C15 0.26879151 1045.15 2 31JON\nEQ_T15_629_XLIQ_C 629 ALC L_C15 0.263681279 1035.15 2 31JON\nEQ_T15_630_XLIQ_C 630 ALC L_C15 0.248490703 1026.65 2 31JON\nEQ_T15_631_XLIQ_C 631 ALC L_C15 0.219022491 1007.15 2 31JON\nEQ_T15_632_XLIQ_C 632 ALC L_C15 0.218044486 995.15 2 31JON\nEQ_T15_633_XLIQ_F 633 ALF FCC_A1 0.182109202 1074.15 2 31JON\nEQ_T15_634_XLIQ_F 634 ALF FCC_A1 0.161855238 1118.15 2 31JON\nEQ_T15_635_XLIQ_F 635 ALF FCC_A1 0.149254262 1131.15 2 31JON\nEQ_T15_636_XLIQ_F 636 ALF FCC_A1 0.137528714 1153.15 2 31JON\nEQ_T15_637_XLIQ_F 637 ALF FCC_A1 0.098210146 1231.15 2 31JON\nEQ_T15_638_XLIQ_F 638 ALF FCC_A1 0.087292384 1241.15 2 31JON\nEQ_T15_639_XLIQ_F 639 ALF FCC_A1 0.065702085 1278.15 2 31JON\nEQ_T15_640_XLIQ_F 640 ALF FCC_A1 0.056748638 1283.15 2 31JON\nEQ_T15_641_XLIQ_F 641 ALF FCC_A1 0.038279491 1315.15 2 31JON\nEQ_T15_642_XLIQ_F 642 ALF FCC_A1 0.043247143 1303.15 2 31JON\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\nFIX 0 @3\ncondition P=P0 N=1 X(LIQ,MG)=@4\nexperiment T=@5:5\ncomment LIQUIDUS @7\nplot_data 9 @4 @5 2 @7\ntable_start\nEQ_T16_650_XLIQ_C 650 ALC L_C15 0.29042 1056.11423 2 78BAG\nEQ_T16_651_XLIQ_C 651 ALC L_C15 0.30246 1062.70164 2 78BAG\nEQ_T16_652_XLIQ_C 652 ALC L_C15 0.31664 1066.7251 2 78BAG\nEQ_T16_653_XLIQ_C 653 ALC L_C15 0.32455 1068.30283 2 78BAG\nEQ_T16_654_XLIQ_C 654 ALC L_C15 0.33098 1069.057 2 78BAG\nEQ_T16_655_XLIQ_C 655 ALC L_C15 0.33955 1065.55796 2 78BAG\nEQ_T16_656_XLIQ_C 656 ALC L_C15 0.34894 1062.8919 2 78BAG\nEQ_T16_657_XLIQ_C 657 ALC L_C15 0.35718 1058.5529 2 78BAG\nEQ_T16_658_XLIQ_C 658 ALC L_C15 0.36806 1049.95383 2 78BAG\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 LIQ\nFIX 0 @3\ncondition P=P0 N=1 X(LIQ,MG)=@4\nexperiment T=@5:5\ncomment LIQUIDUS @7\nplot_data 9 @4 @5 6 @7\ntable_start\nEQ_T17_659_XLIQ_F 659 ALF FCC_A1 0.008 1348.15 6 07URA\nEQ_T17_660_XLIQ_F 660 ALF FCC_A1 0.0515 1289.15 6 07URA\nEQ_T17_661_XLIQ_F 661 ALF FCC_A1 0.1 1221.15 6 07URA\nEQ_T17_662_XLIQ_F 662 ALF FCC_A1 0.1252 1171.15 6 07URA\nEQ_T17_663_XLIQ_F 663 ALF FCC_A1 0.143 1134.15 6 07URA\nEQ_T17_664_XLIQ_F 664 ALF FCC_A1 0.155 1091.15 6 07URA\nEQ_T17_665_XLIQ_F 665 ALF FCC_A1 0.175 1064.15 6 07URA\nEQ_T17_666_XLIQ_F 666 ALF FCC_A1 0.1898 1047.15 6 07URA\nEQ_T17_667_XLIQ_F 667 ALF FCC_A1 0.202 1021.15 6 07URA\nEQ_T17_668_XLIQ_F 668 ALF FCC_A1 0.22 998.15 6 07URA\nEQ_T17_669_XLIQ_C 669 ALC L_C15 0.225 1001.15 6 07URA\nEQ_T17_670_XLIQ_C 670 ALC L_C15 0.23 1008.15 6 07URA\nEQ_T17_671_XLIQ_C 671 ALC L_C15 0.232 1013.15 6 07URA\nEQ_T17_672_XLIQ_C 672 ALC L_C15 0.27 1038.15 6 07URA\nEQ_T17_673_XLIQ_C 673 ALC L_C15 0.269 1044.15 6 07URA\nEQ_T17_674_XLIQ_C 674 ALC L_C15 0.275 1050.15 6 07URA\nEQ_T17_675_XLIQ_C 675 ALC L_C15 0.28 1052.15 6 07URA\nEQ_T17_676_XLIQ_C 676 ALC L_C15 0.2875 1055.15 6 07URA\nEQ_T17_677_XLIQ_C 677 ALC L_C15 0.3 1059.15 6 07URA\nEQ_T17_678_XLIQ_C 678 ALC L_C15 0.316 1066.15 6 07URA\nEQ_T17_679_XLIQ_C 679 ALC L_C15 0.32 1068.15 6 07URA\nEQ_T17_680_XLIQ_C 680 ALC L_C15 0.33 1069.15 6 07URA\nEQ_T17_681_XLIQ_C 681 ALC L_C15 0.3307 1070.15 6 07URA\nEQ_T17_682_XLIQ_C 682 ALC L_C15 0.334 1072.15 6 07URA\nEQ_T17_683_XLIQ_C 683 ALC L_C15 0.34 1072.15 6 07URA\nEQ_T17_684_XLIQ_C 684 ALC L_C15 0.346 1071.15 6 07URA\nEQ_T17_685_XLIQ_C 685 ALC L_C15 0.3505 1069.15 6 07URA\nEQ_T17_686_XLIQ_C 686 ALC L_C15 0.3583 1067.15 6 07URA\nEQ_T17_687_XLIQ_C 687 ALC L_C15 0.3832 1067.15 6 07URA\nEQ_T17_688_XLIQ_C 688 ALC L_C15 0.3913 1065.15 6 07URA\nEQ_T17_689_XLIQ_C 689 ALC L_C15 0.395 1059.15 6 07URA\nEQ_T17_690_XLIQ_C 690 ALC L_C15 0.4 1060.15 6 07URA\nEQ_T17_691_XLIQ_C 691 ALC L_C15 0.41 1052.15 6 07URA\nEQ_T17_692_XLIQ_C 692 ALC L_C15 0.425 1051.15 6 07URA\nEQ_T17_693_XLIQ_C 693 ALC L_C15 0.4375 1036.15 6 07URA\nEQ_T17_694_XLIQ_C 694 ALC L_C15 0.4437 1035.15 6 07URA\nEQ_T17_695_XLIQ_C 695 ALC L_C15 0.475 1021.15 6 07URA\nEQ_T17_696_XLIQ_C 696 ALC L_C15 0.49 998.15 6 07URA\nEQ_T17_697_XLIQ_C 697 ALC L_C15 0.4927 998.15 6 07URA\nEQ_T17_698_XLIQ_C 698 ALC L_C15 0.4963 994.15 6 07URA\nEQ_T17_699_XLIQ_C 699 ALC L_C15 0.5062 980.15 6 07URA\nEQ_T17_700_XLIQ_C 700 ALC L_C15 0.51 978.15 6 07URA\nEQ_T17_701_XLIQ_C 701 ALC L_C15 0.5414 945.15 6 07URA\nEQ_T17_702_XLIQ_C 702 ALC L_C15 0.519 934.15 6 07URA\nEQ_T17_703_XLIQ_C 703 ALC L_C15 0.552 933.15 6 07URA\nEQ_T17_704_XLIQ_C 704 ALC L_C15 0.5581 919.15 6 07URA\nEQ_T17_705_XLIQ_C 705 ALC L_C15 0.5635 897.15 6 07URA\nEQ_T17_706_XLIQ_C 706 ALC L_C15 0.569 888.15 6 07URA\nEQ_T17_707_XLIQ_C 707 ALC L_C15 0.5742 873.15 6 07URA\nEQ_T17_708_XLIQ_C 708 ALC L_C15 0.585 828.15 6 07URA\nEQ_T17_709_XLIQ_2 709 AL2 CUMG2 0.5955 830.15 6 07URA\nEQ_T17_710_XLIQ_2 710 AL2 CUMG2 0.6077 835.15 6 07URA\nEQ_T17_711_XLIQ_2 711 AL2 CUMG2 0.622 837.15 6 07URA\nEQ_T17_712_XLIQ_2 712 AL2 CUMG2 0.6282 838.15 6 07URA\nEQ_T17_713_XLIQ_2 713 AL2 CUMG2 0.6328 839.15 6 07URA\nEQ_T17_714_XLIQ_2 714 AL2 CUMG2 0.6597 841.15 6 07URA\nEQ_T17_715_XLIQ_2 715 AL2 CUMG2 0.6614 842.15 6 07URA\nEQ_T17_716_XLIQ_2 716 AL2 CUMG2 0.667 843.15 6 07URA\nEQ_T17_717_XLIQ_2 717 AL2 CUMG2 0.6795 842.15 6 07URA\nEQ_T17_718_XLIQ_2 718 AL2 CUMG2 0.681 842.15 6 07URA\nEQ_T17_719_XLIQ_2 719 AL2 CUMG2 0.6918 841.15 6 07URA\nEQ_T17_720_XLIQ_2 720 AL2 CUMG2 0.706 839.15 6 07URA\nEQ_T17_721_XLIQ_2 721 AL2 CUMG2 0.7147 838.15 6 07URA\nEQ_T17_722_XLIQ_2 722 AL2 CUMG2 0.7915 795.15 6 07URA\nEQ_T17_723_XLIQ_2 723 AL2 CUMG2 0.83 767.15 6 07URA\nEQ_T17_724_XLIQ_2 724 AL2 CUMG2 0.84 753.15 6 07URA\nEQ_T17_725_XLIQ_H 725 ALH HCP_A3 0.8552 773.15 6 07URA\nEQ_T17_726_XLIQ_H 726 ALH HCP_A3 0.8805 803.15 6 07URA\nEQ_T17_727_XLIQ_H 727 ALH HCP_A3 0.936 753.15 6 07URA\nEQ_T17_728_XLIQ_H 728 ALH HCP_A3 0.9615 884.15 6 07URA\nEQ_T17_729_XLIQ_H 729 ALH HCP_A3 0.9679 895.15 6 07URA\nEQ_T17_730_XLIQ_H 730 ALH HCP_A3 0.9833 907.15 6 07URA\nEQ_T17_731_XLIQ_H 731 ALH HCP_A3 0.988 912.15 6 07URA\nEQ_T17_732_XLIQ_H 732 ALH HCP_A3 0.99 914.15 6 07URA\ntable_end\n@$ ==========================================\nenter equilibrium EQ_800_ALCF_AEUT YES\nset status phase *=sus\nset status PHASE LIQUID =FIX 0\nset status PHASE FCC_A1 L_C15=ENT 1\nset cond P=P0 N=1 X(MG)=.2\nenter experiment T=995.15:5\nenter experiment X(LIQ,MG)=0.219:0.01\nenter plot_data 9 .219 995 8 31Jon\nenter comment CU+C15 EUTECTIC - 31JON\n@$ ==========================================\nenter equilibrium EQ_801_ALCF_AEUT YES\nset status phase *=sus\nset status PHASE LIQUID =FIX 0\nset status PHASE FCC_A1 L_C15=ENT 1\nset cond P=P0 N=1 X(MG)=.2\nenter experiment T=998.15:5\nenter comment CU+C15 EUTECTIC - 78BAG\n@$ ==========================================\nenter equilibrium EQ_802_ALC2_AEUT YES\nset status phase *=sus\nset status PHASE LIQUID =FIX 0\nset status PHASE L_C15 CUMG2=FIX 1\nset cond P=P0\nenter experiment T=825.15:5\nenter experiment X(LIQ,MG)=0.580:0.01\nenter plot_data 9 .580 825 8 31Jon\nenter comment C15+CUMG2 EUTECTIC - 31JON\n@$ ==========================================\nenter equilibrium EQ_803_ALC2_AEUT YES\nset status phase *=sus\nset status PHASE LIQUID=FIX 0\nset status PHASE L_C15 CUMG2=ENT 1\nset cond P=P0 N=1 X(MG)=.4\nenter experiment T=825.15:5\nenter comment C15+CUMG2 EUTECTIC - 78BAG\n@$ ==========================================\nenter equilibrium EQ_804_ALCH_AEUT YES\nset status phase *=sus\nset status PHASE LIQUID=FIX 0\nset status PHASE CUMG2 HCP_A3=ENT 1\nset cond P=P0 N=1 X(MG)=.8\nenter experiment T= 758.15:5\nenter experiment X(LIQ,MG)=0.855:0.01\nenter plot_data 9 .855 758 8 31Jon\nenter comment CUM2+MG EUTECTIC - 31JON\n@$ ==========================================\nenter equilibrium EQ_805_CMELT YES\nset status phase *=sus\nset status PHASE LIQUID = ENT 1\nset status PHASE L_C15=FIX 0\nset cond P=P0 N=1\nset cond X(LIQUID,MG)-X(L_C15,MG)=0\nenter experiment T=1093.15:5\nenter experiment X(MG)=.33333:.01\nenter plot_data 9 .333 1093 8 31Jon\nenter comment C15 - CONGRUENT MELTING - 31JON\n@$ ==========================================\nenter equilibrium EQ_806_CMELT YES\nset status phase *=sus\nset status PHASE LIQUID = ENT 1\nset status PHASE L_C15=FIX 0\nset cond P=P0 N=1\nset cond X(LIQUID,MG)-X(L_C15,MG)=0\nenter experiment T=1066.15:5\nenter experiment X(MG)=.33333:.01\nenter plot_data 9 .333 1066 12 78Bag\nenter comment C15 - CONGRUENT MELTING - 78BAG\n@$ ==========================================\nenter equilibrium EQ_807_MELT2 YES\nset status phase *=sus\nset status PHASE LIQUID CUMG2=FIX 1\nset cond P=P0\nset cond X(LIQUID,MG)-X(CUMG2,MG)=0\nenter experiment T=840.15:5\nenter plot_data 9 .667 840 8 31Jon\nenter comment CUMG2 - CONGRUENT MELTING - 31JON\n@$ ==========================================\nenter equilibrium EQ_808_MELT2 YES\nset status phase *=sus\nset status PHASE LIQUID CUMG2=FIX 1\nset cond P=P0\nset cond X(LIQUID,MG)-X(CUMG2,MG)=0\nenter experiment T=841.15:5\nenter plot_data 9 .667 841 12 78Bag\nenter comment CUMG2 - CONGRUENT MELTING - 78BAG\n@$\n@$=================================\nenter many_equilibria\nENT 1 @3\nFIX 0 @4\ncondition P=P0 N=1 X(MG)=@9 T=@6\nexperiment X(L_C15,MG)=@5:0.001\nplot_data 9 @5 @6 12 @8\ncomment C15 HOMOGENEITY RANGE @8\ntable_start\nEQ_T18_901_RC15 901 ACF L_C15 FCC_A1 0.32632 572.281 2 78BAG .2\nEQ_T18_902_RC15 902 ACF L_C15 FCC_A1 0.32595 668.01 2 78BAG .2\nEQ_T18_903_RC15 903 ACF L_C15 FCC_A1 0.3247 771.64 2 78BAG .2\nEQ_T18_904_RC15 904 ACF L_C15 FCC_A1 0.3223 812.226 2 78BAG .2\nEQ_T18_905_RC15 905 ACF L_C15 FCC_A1 0.31903 867.469 2 78BAG .2\nEQ_T18_906_RC15 906 ACF L_C15 FCC_A1 0.31598 918.203 2 78BAG .2\nEQ_T18_907_RC15 907 ACF L_C15 FCC_A1 0.3103 989.257 2 78BAG .2\nEQ_T18_908_RINT 908 AC2 L_C15 CUMG2 0.33581 573.229 2 78BAG .5\nEQ_T18_909_RINT 909 AC2 L_C15 CUMG2 0.3372 667.799 2 78BAG .5\nEQ_T18_910_RINT 910 AC2 L_C15 CUMG2 0.34477 771.263 2 78BAG .5\nEQ_T18_911_RINT 911 AC2 L_C15 CUMG2 0.35054 812.822 2 78BAG .5\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 @3,@4\ncondition P=P0 N=1 T=@6 X(MG)=.2\nexperiment X(@3,MG)=@5:0.001\ncomment CU SOLVUS @8\nplot_data 9 @5 @6 @7 @8\ntable_start\nEQ_T19_921_XFCC 921 AFC FCC_A1 L_C15 0.07 990.15 12 78BAG\nEQ_T19_922_XFCC 922 AFC FCC_A1 L_C15 0.0553 773.15 8 31JON\nEQ_T19_923_XFCC 923 AFC FCC_A1 L_C15 0.0553 873.15 8 31JON\nEQ_T19_924_XFCC 924 AFC FCC_A1 L_C15 0.0616 953.15 8 31JON\nEQ_T19_925_XFCC 925 AFC FCC_A1 L_C15 0.0655 973.15 8 31JON\nEQ_T19_926_XFCC 926 AFC FCC_A1 L_C15 0.0669 995.15 8 31JON\nEQ_T19_927_XFCC 927 AFC FCC_A1 L_C15 0.0231 573.15 5 57ROG\nEQ_T19_928_XFCC 928 AFC FCC_A1 L_C15 0.033 673.15 5 57ROG\nEQ_T19_929_XFCC 929 AFC FCC_A1 L_C15 0.0445 773.15 5 57ROG\nEQ_T19_930_XFCC 930 AFC FCC_A1 L_C15 0.0579 873.15 5 57ROG\nEQ_T19_931_XFCC 931 AFC FCC_A1 L_C15 0.0748 973.15 5 57ROG\nEQ_T19_932_XFCC 932 AFC FCC_A1 L_C15 0.083 995.15 5 57ROG\ntable_end\n@$\n@$=================================\nenter many_equilibria\nENT 1 @3,@4\ncondition P=P0 N=1 X(MG)=.8 T=@6\nexperiment X(HCP_A3,MG)=@5:0.001\ncomment MG SOLVUS @8\nplot_data 9 @5 @6 @7 @8\ntable_start\nEQ_T20_941_XHCP 941 AH2 HCP_A3 CUMG2 0.99993 298.15 8 31JON\nEQ_T20_942_XHCP 942 AH2 HCP_A3 CUMG2 0.99989 738.15 8 31JON\nEQ_T20_943_XHCP 943 AH2 HCP_A3 CUMG2 0.99988 753.15 8 31JON\nEQ_T20_944_XHCP 944 AH2 HCP_A3 CUMG2 0.99987 758.15 8 31JON\nEQ_T20_945_XHCP 945 AH2 HCP_A3 CUMG2 0.99962 298 10 27HAN\nEQ_T20_946_XHCP 946 AH2 HCP_A3 CUMG2 0.9983 758.15 10 27HAN\nEQ_T20_947_XHCP 947 AH2 HCP_A3 CUMG2 0.99885 673.15 7 35STE\nEQ_T20_948_XHCP 948 AH2 HCP_A3 CUMG2 0.99789 753.15 7 35STE\ntable_end\n@$ ===========================\n\n@$--------------------------------------------------------------\n@$ Now we have entered all experimental equilibria\n@$--------------------------------------------------------------\n@&\n\n@$ A blank line after this command means the last equilibrium is the end\nset range\n2\n\n\n@$--------------------------------------------------------------\n@$ The command above defines the range of equilibria for assessment\n@$ We will later use the command \"calculate all\" which will\n@$ calculate all equilibra withing this range that have nonzero weight.\n@$ The default for last equilibrium is the current\n@$\n@$ The range command also closes all \"plot_data\" files with a correct\n@$ termination for the GNUPLOT software.\n@$--------------------------------------------------------------\n@&\n\n@$ list the symbols entered\nl sym\n\n\n@&\n@$ set the weight to zero for all experiments\n\nset wei 0 *\n\n@&\n\nl eq\n\n\n@$ listing of all equilibria\n@&\n\nsave unf ./opttest2-cumg1\nY\n\n@$-----------------------------------------------------------------\n@$ The save command can be used to save all data and results on an\n@$ unformatted file. This can be read back into the program and\n@$ calculations can continue from the point where the save was mande.\n@$ This is an important feature to \"freeze\" different versions\n@$ not to loose results.\n@$ It is also a way to save the current status when taking a coffee break.\n@$\n@$ Note that axis and calculated diagrams are not saved\n@$-----------------------------------------------------------------\n@&\n@$ Please read the text above carefully!!\n@$-----------------------------------------------------------------\n@&\n@$ Check the phase diagram with all parameters zero !!\n\nmac ./opttest2-map-diagram\n\n\n\nset inter\n" }, { "path": "examples/macros/opttest2B.OCM", "content": "@$===================================================================\n@$===================================================================\n@$===================== Cu-Mg assment: step 1: fit Hmix in liquid\n@$===================================================================\n@$===================================================================\n\n@$\n\nnew Y\n\n@$-----------------------------------------------------------------\n@$ The new command removes all data\n@$-----------------------------------------------------------------\n\nset echo\n\nread unf ./opttest2-cumg1\n\n@$-----------------------------------------------------------------\n@$ Here we read back the data from the save command.\n@$-----------------------------------------------------------------\n@&\n\nlist active\n\n@$ All experiments have weight zero\n@&\n\nset wei 1 ACL\n\nset wei 1 HLIQ\n\nset wei 0 HLIQ_B\n\nset wei 0 HLIQ_H\n\nlist active\n\n@$ Now we have selected data for the liquid\n@&\n@$-----------------------------------------------------------------\n@$ Here we Select experiments with H for liquid from Sommer and Garg\n@$ using abbreviations of the names of the equilibria\n@$-----------------------------------------------------------------\n@&\n@$ Calculate all non-zero experiments\n\ncalc all\nn\n\n\n@$-----------------------------------------------------------------\n@$ The \"calculate all\" command calculates all equilibra in the range\n@$ given previously with non-zero weight. We do not use the grid\n@$ minimizer as all equilibria are for a single phase (liquid).\n@$ There is a listing of all calculated equilibria and in this\n@$ list the first colimn is the (sequentially assigned) equilibrium\n@$ number, then the first 12 characters of the quilibrium name (which is\n@$ 24 characters long) then T and then a list of stable phases at each\n@$ equilibrium.\n@$-----------------------------------------------------------------\n@&\n@$ List the model for the liquid\n\nl ph liq data\n\n@&\n@$ Select the T-independent regular parameter of the liquid to be\n@$ optimized. You must set a non-zero start value!!\n\nset opt_var 0 1\n\nlist opt\n\n@$------------------------------------------------------------------------\n@$ Note that the rightmost column \"Used in\" give the names of TP functions\n@$ where this coefficient is used.\n@$ For coefficients used directly in model parameters the TP function name\n@$ start with an underscore, then a letter indentifying the type of property,\n@$ G means a Gibbs energy, then 6 max letters from the phase name and after\n@$ the constituent in order oof sublattices but with all special characters\n@$ like , or : removed. At the end the degree, 0-9.\n@$ The name is maximum 16 characters so it may be truncated.\n@$ But it is anyway useful in order to remember in phase the parameter is\n@$ associated with.\n@$ Calculation of RSD (Relative Standard Deviation) is not yet implemented.\n@$------------------------------------------------------------------------\n@&\n@$ Optimize just one parameter\n\nopt 100\n\n@$------------------------------------------------------------------------\n@$ The optimize command requires a maximum numer of iterations.\n@$ It lists at regular intervals the sum of errors squared\n@$ and the current values of the model parameters.\n@$ At the end the final and initial sum of squares\n@$------------------------------------------------------------------------\n@&\n@$ List the result\n\nlist opt\n\n@$------------------------------------------------------------------------\n@$ This lists the final value of the model parameters and for\n@$ each experiment with non-zero weight the data and error.\n@$ The list may be long and you may have to scroll bacwards\n@$ to see all experiments.\n@$------------------------------------------------------------------------\n@&\n@$ The optimizing coefficients are also TP sysmbols\n\nl tp\n\n\n@&\n@$ Plot the enthalpy of mixing in the liquid \n\nmacro ./opttest2-plot-hliq\n\n@&\n@$ -----------------------------------------------\n@$ Now vary also the subregular T-independent parameter\n\nset opt_var 2 1\n\nopt 100\n\n@&\n\nl opt\n\n@$ -------------------------------------------------------\n@$ With two parameters the sum of errors decreased\n@$ -------------------------------------------------------\n@&\n@$ We can also list just the coefficients\n\nl opt coef\n\n@&\n@$ And plot the new fit to the experiments.\n\nmacro ./opttest2-plot-hliq\n\n@&\n@$ -----------------------------------------------\n@$ Vary the T-dependent regular parameter\n@$ -----------------------------------------------\n\nset opt_var 1 0.1\n\n@&\n\nopt 100\n\nl opt coef\n\n@$ It may now be intersting to have correct RSD\n\namend opt y\n\nopt 100\n\nl opt coef\n\n@$ The RSD values reflect the number of significant digits of\n@$ the coefficients, if RSD is around 0.1 the coeffcient\n@$ as only one significant digit.\n@$ If 0.1>RSD>.001 there are two significant digits and so on\n@&\n\nmacro ./opttest2-plot-hliq\n\n\n@&\n@$ We can plot the phase diagram with the new liquid parameters\n\nmacro ./opttest2-map-diagram\n\n@$-----------------------------------------------------------\n@$ The liquid is now very stable down to low T \n@$ because we have not fitted any other parameters\n@$-----------------------------------------------------------\n@&\n@$-----------------------------------------------------------\n@$ Now we can make a break but before save the current results\n@$ Fix the liquid parameters\n\nset opt_fix 0-3\n\n@$ Remove all equilibria created by STEP/MAP\n\ndelete step_map\n\nsave unf ./opttest2-cumg2\nY\n\nset inter\n" }, { "path": "examples/macros/opttest2C.OCM", "content": "@$================================================================\n@$================================================================\n@$===== STEP 2 Fit Cp for the CuMg2 compound\n@$================================================================\n@$================================================================\n@&\n\nnew Y\n\nset echo\n\nread unf ./opttest2-cumg2\n\n@$ ----------------------------------------------------\n@$ As before we start by reading the unformatted file with previous results\n@$ ----------------------------------------------------\n@&\n\nset wei 0 *\n\nset wei 1 CP2\n\nlist active\n\n@&\n@$ ----------------------------------------------------\n@$ These commands set the weight of all equilibria to zero\n@$ and then set the weight of those equilibria with \"CP2\" in the name\n@$ to unity.\n@$ ----------------------------------------------------\n@&\n@$ List assessed coefficients\n\nl opt coef\n\n@&\n@$ list the parameters for the CuMg2 phase\n\nl ph cumg2 data\n\n@$ Optimize the coefficent in front of T*ln(T) (constant Cp)\nset opt_var 32 -10\n\ncalc all N 1\n\n\n@&\n@$ make a \"dry run\" to have the initial error\n@$ NOTE important to give \"N\" for no gridmin and \"1\" to calculate once\nopt 0\n\n\n@&\n@$ When runing this at the end of the \"all.OCM\" macro the values of CP\n@$ are all crazy and total sum of error \"Infiniy\" meaning the assessment fails\n@$ When running it by itslf no problem\n@$ Evidently some variable is not intitiated correctly after the \"all\" macro\n\nsel eq 126\n\nc n\nl,,,,\n\n@&\n\nopt 100\n\n@&\n\n\nl opt\n\n@&\n\nmacro ./opttest2-plot-cpcumg2\n\n@$ -----------------------------------------------\n@$ The plot of the Cp is linear as we have just one parameter.\n@$ -----------------------------------------------\n@&\n@$ Now add linear T dependence, set a small value\n\nset opt_var 33 .01\n\nopt 100\n\n@&\n\nl opt\n\n@&\n\nmacro ./opttest2-plot-cpcumg2\n\n@$ -----------------------------------------------\n@$ The Cp in the plot has now a small slope in T\n@$ -----------------------------------------------\n@&\n@$ Which more parameters can we vary?\n\nl ph cumg2 data\n\n@&\n@$ Add more coefficients for T**(-1) and T**2\n\nset opt_var 34 1000\nset opt_var 35 0.001\n\nopt 100\n\n@&\n\nl opt\n\n@&\n\n@$ To obtain the RSD values\n\namend opt-coef y\n\nopt 100\n\n\nl opt short\n\n@$\n@&\n\nmacro ./opttest2-plot-cpcumg2\n\n@$ -----------------------------------------------\n@$ The plot of the Cp is now reasonable in the range 300-2000 K\n@$ -----------------------------------------------\n@&\n@$ -----------------------------------------------\n@$ we have finished this step, set variables fix and save\n\nset opt_fix 32-35\n\nl opt\n\n@&\n@$ remove all selected experimental equilibria\n\nset wei 0 *\n\n@&\n@$ Delete equilibria created during STEP/MAP\n\ndel step_map\n\nsave unf ./opttest2-cumg3\nY\n\n@$----------------------------------------------------\n@$ We can now take a coffee break\n@$----------------------------------------------------\n\n\nset inter\n\n" }, { "path": "examples/macros/opttest2D.OCM", "content": "@$===================================================================\n@$===================================================================\n@$======= step 3: fit H formation of CuMg2 compound\n@$===================================================================\n@$===================================================================\n\nset echo\n\nnew Y\n\nr u ./opttest2-cumg3\n\n@$---------------------------------------------------\n@$ Start by reading the unformatted file\n@$ and list previous results\n@$---------------------------------------------------\n@&\n\nl ph cumg2 data\n\nl opt coef\n\n@&\n\nset wei 0 *\n\nset wei 1 HCUMG2_K\n\nlist active\n\n@&\n@$---------------------------------------------------\n@$ First set the weight of all experimenatal equilibria to zero\n@$ and then set the equilibrium with the enthalpy of\n@$ formation of the CuMg2 compoint to unity.\n@$ Optimize the T-independent coefficient for the CuMg2 phase\n@$---------------------------------------------------\n@&\n\nset opt_var 30 1\n\nopt 100\n\n@&\n\nl opt\n\n@&\n\nmacro ./opttest2-map-diagram\n\n@$---------------------------------------------------------\n@$ The CuMg2 phase is stable to very high T, add the entropy\n@$ of formation (the linear T dependent term)\n@$ to destabilize CuMg2\n@$ Use the experimental equilibrium for the congruent melting point\n@$---------------------------------------------------------\n\nl ph cumg2 data\n\nset opt_var 31 1\n\n@&\n\nset wei 1 MELT2\n\nc all n 1\n\n@$ Sometimes error calculating the melting points, equilibria 547 and 547\n@&\n@$ Check conditions\nsel eq 547\nl,,,,\n\n@&\n@$ Instead of calculating with both phases fix we can set CuMG2 as dormant\n@$ and T=840 as condition and the driving force of CUMG2=0 as experiment\nset status phase cumg=dorm\nset cond t=840\nenter exper dgm(cumg2)=0:.01\n\nc e\nl,,,,,\n\n@$ Now we can calculate the equilibrium and\n@$ we can fit V31 by forcing DGM(CUMG2) to be zero \n@&\n@$ Remove the next equilibrium with the same experiment\nsel eq next\nl,,,,,\n\nset wei 0\n@&\n\nopt 100\n\nl opt\n\n\n@$ set inter\n\n@$---------------------------------------------------------\n@$ We are optimizing two experiments with 2 coefficents.\n@$ We get a good fit.\n@$---------------------------------------------------------\n@&\nlist opt\n\n@&\n\nmacro ./opttest2-map-diagram\n\n@&\n@$------------------------------------------------------\n@$ The CuMg2 phase is now reasonably fitted in the phase diagram\n@$ Take a break but first save !!\n@$------------------------------------------------------\n\nset opt_fix 0-99\n\nl opt\n\nset wei 0 *\n\ndel step_map\n\n@&\n\nsave unf ./opttest2-cumg4\nY\n\nset inter\n\n\n" }, { "path": "examples/macros/opttest2E.OCM", "content": "@$===================================================================\n@$===================================================================\n@$======= step 4: fit Cp of the Laves phase\n@$===================================================================\n@$===================================================================\n@$ Back from the break ...\n\nnew Y\n\nset echo\n\nr u ./opttest2-cumg4\n\n@&\n@$ List previous results\n\nl opt\n\n@&\n@$ Ensure all expeimental equilibria has zero weight\nset wei 0 *\n\n@&\n@$ list the data for the Laves phas\n\nl ph laves_c15 data\n\n@&\n\nset opt_var 42 -10\n\n@$ Estimate a start value for the coefficient of the T*ln(T) term \n@$ This value can be critical for the convergence in the beginning\n@$ and a bad estimate can complicate the calculations.\n@&\n\nset wei 1 CP15_F\n\n@$ Select experiments\n@&\n\nlist active\n\n@$ And list them\n@& Remove eq 3 as we do not fit data below 298.15 K\n\nset wei 0 3\n\n\nlist active\n\n\n@&\n\ncalc all n 1\n\nc a n 1\n\n@$ And calculate them\n@$ Sometimes there are problems, several calculate all may help\n@&\n\nopt 100\n\n@&\n\nl opt\n\n@&\n\nmacro ./opttest2-plot-cplaves\n\n@$---------------------------------------------------------\n@$ There is a strange maximum of the Cp at low T. Why?\n@$ Check the constitution of the Laves phase\n@$---------------------------------------------------------\n@&\n\nplot\nT\ny(laves,*)\n\n\n@$--------------------------------------------------------------------\n@$ The constitution to totally wrong, we should have almost pure Cu in first\n@$ sublattice at all T.\n@$ The drastic change in constitution gives a big contribution to Cp\n@$ because when entropy change so does Cp!\n@&\n@$ We must set a the enthalpy of fromation of the Laves phase\n@$ to enshuring that we have Cu in first and Mg in second\n@$--------------------------------------------------------------------\n\nl ph laves data\n\n\nset opt_fix 40 -300000\n\n@& Set the T-independent parameter to a large negative value\n@&\n\nmacro ./opttest2-plot-cplaves\n\n@&\n@$--------------------------------------------------------\n@$ There is still a maximum but at a higher T\n@$ Check how the constitution varies!\n@$--------------------------------------------------------\nplot\nT\ny(laves,*)\n\n@$--------------------------------------------------------------------\n@$ Now we have the correct constitution at least up to the melting point\n@$--------------------------------------------------------------------\n@&\n\nopt 0\n\n@$--------------------------------------------------------------------\n@$ Frequently many errors here ... we have to recalculate all equilibria\n@$ using the global gridminimizer\n@$--------------------------------------------------------------------\n@&\n\n@$ set inter\n\n@$========================================\n@$ Use calc all with grid minimizer\n\nc a y 1\n\n\nopt 0\n\n@$ Sometimes error still here for equilibrium 4\n@& \n\nsel eq 4 \n\ncalc ph laves\n1\nn\n1\n0\n\n@$ and calculate the equilibrium\n\nc n\n\nl,,,,,\n\n@$ This is OK. If you have errors in other equilibria\n@$ try to fix them in the same way.\n@&\n\n@$ Otherwise try to calculate all again\n\nc a n 1\n\n@$ Now no errors.\n\n@$ If you have more problem maybe stop the macro or add commands here\n@$ set inter\n@&\n\n@$--------------------------------------------------------------------\n@$ Fit very bad, use more parameters\n@$ Here the start values of the parameters are critical\n@$ Consider that A43 is multipled with T**2, A44 with T**(-1)\n@$ and A45 with T**3\n@$--------------------------------------------------------------------\n\nset opt_var 43 .01\nset opt_var 44 1000\nset opt_var 45 .0001\n\nlist opt coef\n\n@&\n\nc a n 1\n\n@&\n@$---------------------------------------------------------------------\n@$ Check one equilibrium that constitution is OK, Cu in first, Mg in second\n@$---------------------------------------------------------------------\n\nsel eq 4\nl , 2\n\n@$---------------------------------------------------------------------\n@$ The constitution is reasonable for thie equilibrium\n@$---------------------------------------------------------------------\n@&\n@$ now optimize A42-A45\n\nopt 100\n\nl opt\n\n@&\n@$ now include equilibrium 3 when parameters better\n\nsel eq 3\nc ph lav 1\nN\n1\n1e-12\n\n\nc n\n\nl ,,,,\n\n@$ The heat capacity negative !!! add it\n@&\n\nset wei 1\n\n\n@&\n@$ and run one more time\n\nopt 100\n\nl opt\n\n\n\n@$ set inter\n@$--------------------------------------------------------------\n@$ The sum or errors does not decrease, plot to check\n@$--------------------------------------------------------------\n@&\n\nmac ./opttest2-plot-cplaves\n\n@&\n@$---------------------------------------------------------\n@$ The Cp is OK but increase too mich at high T\n@$ Add a Cp estimation at high T (by phonon calculation)\n@$---------------------------------------------------------\n\nsel eq 125\n\nl,,,\n\nset wei 1\n\n\nc e\n\nl,,,,\n\nc sym cpm2\n\n@$ This heat capacity is calculated by DFT\n@&\n\nlist active\n\n\n@$ set inter\n\n@$---------------------------------------------------------\n@$ By adding this extimated Cp we can lower the Cp at high T\n@$---------------------------------------------------------\n@&\n\nopt 100\n\n@&\n\nl opt short\n\n@&\n@$ Plot the Cp\n\nmac ./opttest2-plot-cplaves\n\n\n@$ We have a reasonable fit to Cp\n@&\n@$---------------------------------------------------------\n@$ Use the AMEND OPT Y command to set the current values as start values\n@$ and optimize again. This is important if the coefficents have\n@$ changed a lot\n@$---------------------------------------------------------\n\namend opt y\n\n@&\n\nopt 100\n\n@&\n\nl opt\n\n\n@&\n@$ Finally plot again and check the constitution\n\nmac ./opttest2-plot-cplaves\n\n@&\n\nplot\nT\ny(laves,*)\n\n\n\n@$---------------------------------------------------------\n@$ The constitution is perfectly ordered at all T\n@$---------------------------------------------------------\n@&\n@$ Clean up for next step\n\nset opt_fix 0-99\n\nl opt\n\nset wei 0 *\n\ndel step_map_result\n\n@$---------------------------------------------------------\n@$ Do not forget to remove STEP and MAP results before saving!\n@$---------------------------------------------------------\n@&\n\nsave unf ./opttest2-cumg5\nY\n\nset inter\n\n\n" }, { "path": "examples/macros/opttest2F.OCM", "content": "@$===================================================================\n@$===================================================================\n@$======= step 5: fit H formation of the Laves phase\n@$===================================================================\n@$===================================================================\n\n@$ Consider Laves phase formation\n\nnew Y\n\nset echo\n\nr u ./opttest2-cumg5\n\n@&\n@$ Check we do not have any experimental equilibria\n\nl opt short\n\n\n@&\n@$ Check which parameters we should optimize for the Laves phase\n\nl ph laves_c15 data\n\n@&\n@$----------------------------------------------------------\n@$ Include experiments HC15_K for the enthalpy of formation\n@$ and set the previously fixed enthalpy as variable\n@$----------------------------------------------------------\nset wei 1 HC15_K\n\nset opt_var 40\n\n@&\n@$-----------------------------------------------------\n@$ Calculate the experimental equilibria with gridminimizer\n@$-----------------------------------------------------\nc a y 1\n\nc a n 1\n\n@$ Error calculating the only equilibrium 305, we have to handle this\n@&\n\nsel eq 305\n\n@$ Use the calculate phase command again!!\nc ph laves\n1\nn\n1\n0\n\nc n\n\nl,,,,\n\n@$ Now it seems to work to calculate the equilibrium\n@&\n\n\nopt 0\n\n@&\n\nl opt\n\n@&\n\nopt 100\n\n@$----------------------------------------------------\n@$ We have one experimental datum and one variable coefficient\n@$ A perfect fit\n@$----------------------------------------------------\n@&\n\nl opt\n\n@$ Here the error is OK, almost zero \n@&\n\nmacro ./opttest2-map-diagram\n\n@$----------------------------------------------------\n@$ The Laves phase is too stable\n@$ Optimize the entropy of formation together with the\n@$ congruent melting\n@$----------------------------------------------------\n@&\n\nset opt_var 41 400\n\nset wei 1 CMELT\n\nl opt\n\n\n@&\n\nsel eq 546\n\nc e\n\nl,,,,\n\n@$-----------------------------------------------------------\n@$ The calculation failed and we cannot use the grid minimizer\n@$ because of the constions. Note that LAVES is set as FIX\n@$ and the condition that x(mg) should be the same in liquid and laves.\n@$\n@$ As T is too small try to set\n@$ a new start value for T with the command SET T_AND_P ...\n@$ This does not set a condition on T, just a start value\n@$-----------------------------------------------------------\n\nset init_t_and_p\n1000\n1e5\n\n@&\n@$-----------------------------------------------------------\n@$ Also ensure that the liquid and Laves composition is correct\n@$ Use the command CALC PHASE for that\n@$-----------------------------------------------------------\n\ncalc ph\nliq\n1\nn\n.333\n\n\ncalc ph\nlav\n\nn\n.99\n.01\n\n\n@&\n@$ Then try to calculate the equilibrium again!\n\nc n\n\nl,,,,,\n\n@$----------------------------------------------------\n@$ Now we have a reasonable equilibrium. Note the composition\n@$ is the same in both phases but the T is too high.\n@$ We will optimize the coefficients to fit that.\n@$----------------------------------------------------\n@&\n@$ We have to check the previous equilibrium also\n\nsel eq prev\n\nl,,,,,\n\n@$ This represent the same congruent melting. We do not need it.\n@&\n\nset wei 0\n\n\n@&\n@$----------------------------------------------------\n@$ Oprimize the enthalpy and congruent melting\n@$----------------------------------------------------\n\nopt 0\n\n@&\nl opt\n\n@&\nopt 100\n\n@&\nl opt\n\n@&\n@$ plot the phase diagram\n\nmac ./opttest2-map-diagram\n\n@&\n@$---------------------------------------------------------\n@$ Add some tie-line data between liquid and Laves\n@$---------------------------------------------------------\n\nset wei 1 XLIQ_C\n\n@&\n\nc a y 1\n\n@&\n@$ Optimize all these\n\nopt 0\n\n@&\n\nl opt\n\n@&\n@$ Calculate all equilibria\nc a n 1\n\n@&\n@$ Optimize a dry run\n\nopt 0\n\n@&\n\nl opt\n\n@&\n@$ Optimize the coefficients\n\nopt 100\n\n@&\n\nl opt\n\n@&\n\nmac ./opttest2-map-diagram\n\n\n@&\n@$------------------------------------------------------\n@$ Also plot the heat capacity\n@$ NOTE to do this we must remove axis 2 as that is set!!\n@$------------------------------------------------------\n\nset axis 2 none\n\n@&\n\nmac ./opttest2-plot-cplaves\n\n\n\n@&\n@$------------------------------------------------------\n@$ We have some differences because the\n@$ constitution varies. Verify the stoichiometry is correct\n@$------------------------------------------------------\n\nplot\nT\ny(laves,*)\n\n\n\n@$ The fraction of defects influences the heat capacity\n@&\n@$---------------------------------------------------------\n@$ Clean up for next step\n\nset opt_fix 0-99\n\nl opt\n\n@&\n\nset wei 0 *\n\ndel step_map\n\nsave unf ./opttest2-cumg6\nY\n\nset inter\n" }, { "path": "examples/macros/opttest2G.OCM", "content": "@$===================================================================\n@$===================================================================\n@$======= step 6: fit solubilities in FCC and HCP\n@$===================================================================\n@$===================================================================\n\n\n@$ Fit solubilities in FCC and HCP\n\nnew Y\n\nset echo\n\nr u ./opttest2-cumg6\n\n@&\n@$ Remove any previous selections\n\nset wei 0 *\n\nset opt-fix 0-99\n\nl eq\n\n@&\n\nl opt\n\n@&\n@$ Regular parameters in FCC and HCP\n\nset opt-var 11 -10000\n\nset opt-var 21 10000\n\n@&\n@$ Include experiments AFC and AH2\nset wei 1 MU3\n\nset wei 1 XFCC\n\nset wei 1 XLIQ_F\n\nset wei 1 XHCP\n\nset wei 1 XLIQ_H\n\n@&\n@$---------------------------------------------------------\n@$ Handling some converge problems\n\nc a y 1\n\n@&\n\nc a n 1\n\n@&\nopt 0\n\n@&\n\nl opt\n\n@&\n\nopt 100\n\n@&\n\nl opt\n\n@&\n@$---------------------------------------------------------\n@$ rescale the coefficients and optimize more\n@$---------------------------------------------------------\namend ?\n\namend opt-coef\ny\n\n\n@&\n\nopt 100\n\n@&\nl opt\n\n@&\n@$ ------------------------------------------------------\n@$ sometimes mapping phase diagram memory crash here\n@$ problems with memory leaks during STEP/MAP\n@$ ------------------------------------------------------\n\nmac ./opttest2-map-diagram\n\n@$---------------------------------------------------------\n@$ We have now fitted the solubilities in FCC and HCP\n@$ and the compounds have correct melting T\n@$ but the solubility range of the Laves phase is too small\n@$---------------------------------------------------------\n@$ Clean up for next step\n\nset opt-fix 0-99\n\ndel step_map\n\nl opt\n\nset wei 0 *\n\n@&\n\nsave unf ./opttest2-cumg7\nY\n\n@&\n\n@$ Just for fun, check how the diagram looks like without the intermetallics\n\nl cond\n\nset c x(mg)=.3\n\nset stat ph lav cumg2=s\n\nc e\n\nl,,,,\n\n@&\n\nset ax 1 x(mg)\n0\n1\n\n\nset ax 2 t 300 1500 25\n\nmap\n\n\nplot\n\n\n\n@$ Without the intermetallic phases the FCC phase is stable\n@$ across almost the whole diagram.\n@&\n@$===================================================================\n@$===================================================================\n@$======= step 7: fit solubilities in Laves phase (not done)\n@$===================================================================\n@$===================================================================\n\n@$ We have not checked the fit to chemical potentials \n@$\n@$ At the end a total optimization of all parameters together with\n@$ most of the experimental data must be made.\n@$\n@$ IMPORTANT: The coefficients for the Cp should NOT be assessed\n@$ together with phase diagram data, they should remain fixed.\n\nset inter\n\n\n" }, { "path": "examples/macros/parallel1.OCM", "content": "new Y\n\nset echo Y\n\n@$ =================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ parallel1.OCM\n@$ testing parallelization\n@$ If you run this macro without using oc3P version it\n@$ will be executed sequentially.\n@&\n@$\n@$ This macro should work but unless I calculate the equilibria one by one\n@$ when I enter them I get problems. There are probably some errors ...\n@$\n@$ The problem may be connected with changing set of stable phases\n@$ but I have tested to change a few equilibria and recalculate so a few\n@$ equilibria with phase changes seems to work. Any help fixing this is\n@$ appreciated.\n@$ =================================================================\n@$\nset echo\n\nr t ./steel1\n\n\nset c t=1200 p=1e5 n=1 w(c)=.01 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01\n\nc e\n\nl,,,,\n\n@&\n@$ enter a second equilibrium and test we can calculate it\nenter equil para1 Y\n\nl c\n\n@&\nset c t=1200 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nl c\n\nc e\n\nl,,,,\n@$ it seems to work, the result is different and the first unchanged\n\nsel eq 1\n\nl,,,,\n\n@&\n@$ enter 20 more equilibria, just different T\nenter equil para3 Y\n\nset c t=1250 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para4 Y\n\nset c t=1300 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para5 Y\n\nset c t=1350 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para6 Y\n\nset c t=1400 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para7 Y\n\nset c t=1450 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para8 Y\n\nset c t=1500 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para9 Y\n\nset c t=1550 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para10 Y\n\nset c t=1600 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para11 Y\n\nset c t=1650 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para12 Y\n\nset c t=1700 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para13 Y\n\nset c t=1750 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para14 Y\n\nset c t=1800 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para15 Y\n\nset c t=1150 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para16 Y\n\nset c t=1100 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para17 Y\n\nset c t=1050 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para18 Y\n\nset c t=1000 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para19 Y\n\nset c t=950 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para20 Y\n\nset c t=900 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para21 Y\n\nset c t=850 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\nc e\n\nenter equil para22 Y\n\nset c t=800 p=1e5 n=1 w(c)=.008 x(cr)=.045 x(mo)=.1 x(si)=.005 x(v)=0.011\n\n@&\nl eq\n\n@&\n@$ set all equilibria (except first) available for calc all\n\nset range 2 22\n\n@&\n\n@$ calculate all with grid minimizer\nc a Y \n1\n\n@$ calculate all without grid minimmizer (and in parallel if oc3P)\nc a N 1\n\n\n@$ Turn off parallel (if on)\nset bit glo 2 \nset bit glo 15\n\nc a N 1\n\n\n@&\n\n@$ =================================================================\n@$ end of parallel1 macro\n@$ =================================================================\n@$\n\nset inter\n\n \n" }, { "path": "examples/macros/parallel2.OCM", "content": "new Y\n\nset echo Y\n\n@$ ================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$>\n@$\n@$\n@$\n@$\n@$\n@$ parallel2.OCM\n@$ testing enter many equilibria and calculate in parallel\n@&\n@$ The calculate all command using the grid minimizer does not calculate\n@$ in parallel as I get problems creating composition sets ...\n@$ Calculating without grid minimizer with oc3P will use parallel calculation\n@$\n@$ I also allow the user to output extra data for each equlibrium\n@$ according to a suggestion by Andre\n@$ ================================================================\n@&\n\nr t ./steel1\n\n\nset cond t=1000 p=1e5 n=1 w(c)=0.01 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01\n\nc e\n\nl,,,,,\n@&\n\nenter symbol cp=h.t;\n\ncalc symb cp\n\nl state \nx(bcc,c)\ntc(bcc)\n\n@&\n\nenter many_equil\n@$ set all phases as entered\nentered 0 *\n@$ set conditions and refer some values to table columns\ncondition t=@1 p=1e5 n=1 w(c)=@2 w(cr)=.05 w(mo)=.08 w(si)=.003 w(v)=0.01\n@$ add a (predefined) symbol to be calculated at each equilibrium\ncalc cp\n@$ add a list of (state) variables to be listed at each equilibrium\nlist x(fcc,c) tc(bcc)\n@$ Now starts the table values\n@&\ntable_start\n@$ comment line NOTE first value (column 0) on each line is equilibrium name!!\n@$ equilibrium names like FIRST, NEXT, PREVIOUS, DEFAULT, LAST forbidden\n@$ T is column 1, x(c) is column 2 (Preferably no TAB characters)\nettan 760 0.008\ntvaan 770 0.008\n@&\nequil_003 780 0.008\nequil_004 790 0.008\nequil_005 800 0.008\nequil_006 810 0.008\nequil_007 820 0.008\nequil_008 830 0.008\nequil_009 840 0.008\nequil_010 850 0.008\nequil_011 860 0.008\nequil_012 870 0.008\nequil_013 880 0.008\nequil_014 900 0.008\nequil_015 910 0.008\nequil_016 920 0.008\nequil_017 930 0.008\nequil_018 940 0.008\nequil_019 950 0.008\nequil_020 960 0.008\nequil_021 970 0.008\nequil_022 970 0.008\nequil_023 980 0.008\nequiL_024 990 0.008\nequiL_025 1000 0.008\nequiL_026 1070 0.008\nequiL_027 1080 0.008\nequiL_028 1110 0.008\nequiL_029 1120 0.008\nequiL_030 1130 0.008\nequiL_031 1140 0.008\nequiL_032 1150 0.008\nequiL_033 1160 0.008\nequiL_034 1170 0.008\nequiL_035 1180 0.008\nequiL_036 1190 0.008\nequiL_037 1200 0.008\nequiL_038 1210 0.008\nequiL_039 1220 0.008\nequiL_040 1230 0.008\nequiL_041 1240 0.008\nequil_042 1250 0.008\nequil_043 1250 0.008\nequil_044 1260 0.008\nequiL_045 1270 0.008\nequiL_046 1280 0.008\nequiL_047 1290 0.008\nequiL_048 1300 0.008\nequiL_049 1320 0.008\nequiL_050 1330 0.008\nequiL_051 1340 0.008\nequiL_052 1350 0.008\nequiL_053 1360 0.008\nequiL_054 1370 0.008\nequiL_055 1380 0.008\nequiL_056 1390 0.008\nequiL_057 1400 0.008\nequiL_058 1410 0.008\nequiL_059 1420 0.008\nequiL_060 1430 0.008\nequiL_061 1440 0.008\nequiL_062 1450 0.008\nequil_063 1460 0.007\nequil_064 1460 0.008\nequil_065 1470 0.008\nequiL_066 1480 0.008\nequiL_067 1490 0.008\nequiL_068 1500 0.008\nequiL_069 1510 0.008\nequiL_070 1520 0.008\nequiL_071 1530 0.008\nequiL_072 1540 0.008\nequiL_073 1550 0.008\nequiL_074 1560 0.008\nequiL_075 1570 0.008\nequiL_076 1580 0.008\nequiL_077 1590 0.008\nequiL_078 1600 0.008\nequiL_079 1610 0.008\nequiL_080 1620 0.008\nequiL_081 1630 0.008\nequiL_082 1640 0.008\nequiL_083 1650 0.008\n@$\nequil_101 760 0.009\nequil_102 770 0.009\nequil_103 780 0.009\nequil_104 790 0.009\nequil_105 800 0.009\nequil_106 810 0.009\nequil_107 820 0.009\nequil_108 830 0.009\nequil_109 840 0.009\nequil_110 850 0.009\nequil_111 860 0.009\nequil_112 870 0.009\nequil_113 880 0.009\nequil_114 900 0.009\nequil_115 910 0.009\nequil_116 920 0.009\nequil_117 930 0.009\nequil_118 940 0.009\nequil_119 950 0.009\nequil_120 960 0.009\nequil_121 970 0.009\nequil_122 980 0.009\nequiL_123 990 0.009\nequiL_124 1000 0.009\nequiL_125 1070 0.009\nequiL_126 1080 0.009\nequiL_127 1110 0.009\nequiL_128 1120 0.009\nequiL_129 1130 0.009\nequiL_130 1140 0.009\nequiL_131 1150 0.009\nequiL_132 1160 0.009\nequiL_133 1170 0.009\nequiL_134 1180 0.009\nequiL_135 1190 0.009\nequiL_136 1200 0.009\nequiL_137 1210 0.009\nequiL_138 1220 0.009\nequiL_139 1230 0.009\nequiL_140 1240 0.009\nequil_141 1250 0.009\nequil_142 1260 0.009\nequiL_143 1270 0.009\nequiL_144 1280 0.009\nequiL_145 1290 0.009\nequiL_146 1300 0.009\nequiL_147 1320 0.009\nequiL_148 1330 0.009\nequiL_149 1340 0.009\nequiL_150 1350 0.009\nequiL_151 1360 0.009\nequiL_152 1370 0.009\nequiL_153 1380 0.009\nequiL_154 1390 0.009\nequiL_155 1400 0.009\nequiL_156 1410 0.009\nequiL_157 1420 0.009\nequiL_158 1430 0.009\nequiL_159 1440 0.009\nequiL_160 1450 0.009\nequil_161 1460 0.009\nequil_162 1470 0.009\nequiL_163 1480 0.009\nequiL_164 1490 0.009\nequiL_165 1500 0.009\nequiL_166 1510 0.009\nequiL_167 1520 0.009\nequiL_168 1530 0.009\nequiL_169 1540 0.009\nequiL_170 1550 0.009\nequiL_171 1560 0.009\nequiL_172 1570 0.009\nequiL_173 1580 0.009\nequiL_174 1590 0.009\nequiL_175 1600 0.009\nequiL_176 1610 0.009\nequiL_177 1620 0.009\nequiL_178 1630 0.009\nequiL_179 1640 0.009\nequiL_180 1650 0.009\n@&\nequil_201 760 0.010\nequil_202 770 0.010\nequil_203 780 0.010\nequil_204 790 0.010\nequil_205 800 0.010\nequil_206 810 0.010\nequil_207 820 0.010\nequil_208 830 0.010\nequil_209 840 0.010\nequil_210 850 0.010\nequil_211 860 0.010\nequil_212 870 0.010\nequil_213 880 0.010\nequil_214 900 0.010\nequil_215 910 0.010\nequil_216 920 0.010\nequil_217 930 0.010\nequil_218 940 0.010\nequil_219 950 0.010\nequil_220 960 0.010\nequil_221 870 0.010\nequil_222 980 0.010\nequiL_223 990 0.010\nequiL_224 1000 0.010\nequiL_225 1070 0.010\nequiL_226 1080 0.010\nequiL_227 1110 0.010\nequiL_228 1120 0.010\nequiL_229 1130 0.010\nequiL_230 1140 0.010\nequiL_231 1150 0.010\nequiL_232 1160 0.010\nequiL_233 1170 0.010\nequiL_234 1180 0.010\nequiL_235 1190 0.010\nequiL_236 1200 0.010\nequiL_237 1210 0.010\nequiL_238 1220 0.010\nequiL_239 1230 0.010\nequiL_240 1240 0.010\nequil_241 1250 0.010\nequil_242 1260 0.010\nequiL_243 1270 0.010\nequiL_244 1280 0.010\nequiL_245 1290 0.010\nequiL_246 1300 0.010\nequiL_247 1320 0.010\nequiL_248 1330 0.010\nequiL_249 1340 0.010\nequiL_250 1350 0.010\nequiL_251 1360 0.010\nequiL_252 1370 0.010\nequiL_253 1380 0.010\nequiL_254 1390 0.010\nequiL_255 1400 0.010\nequiL_256 1410 0.010\nequiL_257 1420 0.010\nequiL_258 1430 0.010\nequiL_259 1440 0.010\nequiL_260 1450 0.010\nequil_261 1460 0.010\nequil_262 1470 0.010\nequiL_263 1480 0.010\nequiL_264 1490 0.010\nequiL_265 1500 0.010\nequiL_266 1510 0.010\nequiL_267 1520 0.010\nequiL_268 1530 0.010\nequiL_269 1540 0.010\nequiL_270 1550 0.010\nequiL_271 1560 0.010\nequiL_272 1570 0.010\nequiL_273 1580 0.010\nequiL_274 1590 0.010\nequiL_275 1600 0.010\nequiL_276 1610 0.010\nequiL_277 1620 0.010\nequiL_278 1630 0.010\nequiL_279 1640 0.010\nequiL_280 1650 0.010\n@$\nequil_301 760 0.011\nequil_302 770 0.011\nequil_303 780 0.011\nequil_304 790 0.011\nequil_305 800 0.011\nequil_306 810 0.011\nequil_307 820 0.011\nequil_308 830 0.011\nequil_309 840 0.011\nequil_310 850 0.011\nequil_311 860 0.011\nequil_312 870 0.011\nequil_313 880 0.011\nequil_314 900 0.011\nequil_315 920 0.011\nequil_316 930 0.011\nequil_317 940 0.011\nequil_318 950 0.011\nequil_319 960 0.011\nequil_320 970 0.011\nequil_321 980 0.011\nequiL_322 990 0.011\nequiL_323 1000 0.011\nequiL_324 1070 0.011\nequiL_325 1080 0.011\nequiL_326 1110 0.011\nequiL_327 1120 0.011\nequiL_328 1130 0.011\nequiL_329 1140 0.011\nequiL_330 1150 0.011\nequiL_331 1160 0.011\nequiL_332 1170 0.011\nequiL_333 1180 0.011\nequiL_334 1190 0.011\nequiL_335 1200 0.011\nequiL_336 1220 0.011\nequiL_337 1230 0.011\nequiL_338 1240 0.011\nequil_339 1250 0.011\nequil_340 1260 0.011\nequiL_341 1270 0.011\nequiL_342 1280 0.011\nequiL_343 1290 0.011\nequiL_344 1300 0.011\nequiL_345 1310 0.012\nequiL_346 1320 0.011\nequiL_347 1330 0.011\nequiL_348 1340 0.011\nequiL_349 1350 0.011\nequiL_350 1360 0.011\nequiL_351 1370 0.011\nequiL_352 1380 0.011\nequiL_353 1390 0.011\nequiL_354 1400 0.011\nequiL_355 1410 0.011\nequiL_356 1420 0.011\nequiL_357 1430 0.011\nequiL_358 1440 0.011\nequiL_359 1450 0.011\nequil_360 1460 0.011\nequil_361 1470 0.011\nequiL_362 1480 0.011\nequiL_363 1490 0.011\nequiL_364 1500 0.011\nequiL_365 1510 0.011\nequiL_366 1520 0.011\nequiL_367 1530 0.011\nequiL_368 1540 0.011\nequiL_369 1550 0.011\nequiL_370 1560 0.011\nequiL_371 1570 0.011\nequiL_372 1580 0.011\nequiL_373 1590 0.011\nequiL_374 1600 0.011\nequiL_375 1610 0.011\nequiL_376 1620 0.011\nequiL_377 1630 0.011\nequiL_378 1640 0.011\nequiL_379 1650 0.011\nequil_380 1660 0.011\n@$\nequil_401 760 0.012\nequil_402 770 0.012\nequil_403 780 0.012\nequil_404 790 0.012\nequil_405 800 0.012\nequil_406 810 0.012\nequil_407 820 0.012\nequil_408 830 0.012\nequil_409 840 0.012\nequil_410 850 0.012\nequil_411 860 0.012\nequil_412 870 0.012\nequil_413 880 0.012\nequil_414 900 0.012\nequil_415 910 0.012\nequil_416 920 0.012\nequil_417 930 0.012\nequil_418 940 0.012\nequil_419 950 0.012\nequil_420 970 0.012\nequiL_421 980 0.012\nequiL_422 990 0.012\nequiL_423 1100 0.012\nequiL_424 1110 0.012\nequiL_425 1120 0.012\nequiL_426 1130 0.012\nequiL_427 1070 0.012\nequiL_428 1080 0.012\nequiL_429 1140 0.012\nequiL_430 1150 0.012\nequiL_431 1160 0.012\nequiL_432 1170 0.012\nequiL_433 1190 0.012\nequiL_434 1200 0.012\nequiL_435 1210 0.012\nequiL_436 1210 0.011\nequiL_437 1220 0.012\nequiL_438 1230 0.012\nequil_439 1250 0.012\nequiL_440 1260 0.012\nequiL_441 1270 0.012\nequiL_442 1280 0.012\nequiL_443 1290 0.012\nequiL_444 1320 0.012\nequiL_445 1330 0.012\nequiL_446 1340 0.012\nequiL_447 1350 0.012\nequiL_448 1360 0.012\nequiL_449 1370 0.012\nequiL_450 1380 0.012\nequiL_451 1390 0.012\nequiL_452 1400 0.012\nequiL_453 1410 0.012\nequiL_454 1420 0.012\nequiL_455 1430 0.012\nequiL_456 1440 0.012\nequil_457 1460 0.012\nequiL_458 1470 0.012\nequiL_459 1480 0.012\nequiL_460 1490 0.012\nequiL_461 1500 0.012\nequiL_462 1510 0.012\nequiL_463 1520 0.012\nequiL_464 1530 0.012\nequiL_465 1540 0.012\nequiL_466 1550 0.012\nequiL_467 1560 0.012\nequiL_468 1570 0.012\nequiL_469 1580 0.012\nequiL_470 1590 0.012\nequiL_471 1600 0.012\nequiL_472 1610 0.012\nequiL_473 1620 0.012\nequiL_474 1630 0.012\nequiL_475 1640 0.012\nequiL_476 1650 0.011\nequiL_477 1660 0.012\ntable_end\n\n@&\n\n@$ Just list the equilibria\nl eq\n\n@&\n@$ Set range so they can be calculated by the \"calculate all\" command\nset range 2 401\n\n@&\n@$ Calculate once with gridminimizer, we may create composition sets\n@$ Calculate with gridminimizer disables parallel calculation\n\n@$ To speed up this a little we select the smaller grid\n\nset adv grid 0\n\n@&\n@$ Note the composition of x(fcc,c) is in most cases the cubic carbide,\n@$ it is difficult to specify the austenite. Evidently redundant composition\n@$ sets are not removed after the equilibrium calculation. \n@$ There are also problems to make sure user defined composition sets\n@$ have the most similar stable composition.\n@$ Some work is needed with the grid minimizer and the cleanup process.\n@$ I have added that if the phase specified for a state variable is not stable\n@$ the program searches for another stable composition set, \n@$ thus TC(BCC) is sometimes TC(BCC#2)\ncalc all Y\n1\n\n@&\n@$ calculate and write the output on a file ... -1 means info about threads\ncalc /out=outpara all N\n-1\n@&\n@$ Calculate without gridminimizer, note the speed\n@$ When calculated in parallel even more\n@$ calc all N -1 <<<<<<<<<<< problem ? too slow output on screen??\n\n@&\n@$ Run without parallel with output on file for comparison\n@$ First I must declare me as an expert, then use bit 15 to turns off parallel\nset advanced level\nN\nY\n\n@$ set bit 15 which prevents parallel execution\nset bit glo 15\n\n@$ ------------------------ BE PATIENT -----------------------------\n\ncalc /out=outseq all N\n1\n\n\n@$ prepare for more tests in parallel\n\n@$ clear bit 15\nset bit glo 15 no\n\n\n\n@&\n\n@&\n\n@$ Check data for one equilibrium\nsel eq 103\nc e\ndebug symbol cp 51.1372166\ndebug symbol x(fcc,c) 0.463272739\ndebug symbol tc(bcc) 1033.90240\n@&\n\n@$\n@$ =================================================================\n@$ 2026-03-19 with OC6-108\n@$ on my Mac Pro with 14 threads calculating 400 equilibria\n@$ 0.4 seconds CPU and 410 clockcykles with 1 thread\n@$ 0.8 seconds CPU and 71 clockcykles with 14 threads, \n@$ factor 5.77 faster \n@$ =================================================================\n@$ end of parallel2 macro\n@$ =================================================================\n@$\n\nset inter\n\n@$ =============== measuring ====================\n@$ Running OC5-49 2019-08-17 looping \"c a n 10\"\n@$ on my MacPro with 4 CPU 2.2 GHz Intel Core i7, 16 GB 1600 MHz DDR3:\n@$ 13.65 seconds CPU and 13654 clockycles with 1 thread\n@$ 23.98 seconds CPU and 3140 clockycles with 8 threads, factor 4.37 faster!\n@$\n@$ on my DELL with 2 CPU 2.80/2.90 GHz Intel Core i7-7600U, 16 GB RAM \n@$ 10.33 seconds CPU and 10453 clockcycles with 1 thread\n@$ 17.14 seconds CPU and 4407 clockcycles with 4 threads, factor 2.37 faster\n@$\n@$ This loop calculates 4000 equilibria, each requires 9 iterations\n@$ which means 0.379 miliseconds/iteration on MAC\n@$ which means 0.286 miliseconds/iteration on DELL, 1.3 times faster CPU\n@$\n@$ This system has 6 component system with 40 phases, 503 TPfuns and parameters\n@$ (the times also includes listing some results on a file)\n@$ ==============================================\n@$ Running OC6-14 2020-10-04 looping \"c a n 10\"\n@$ on my DELL 5511 Latitude with Intel core i7-1085H 10 gen 2.27 GHz, 16 GB RAM\n@$ 6.94 seconds CPU and 6938 clockcykles with 1 thread\n@$ 12.97 seconds CPU and 1234 clockcykles with 12 threads, factor 5.62 faster \n@$ New DELL is 1.48 times faster than the old DELL (single CPU)\n@$ New DELL is 1.97 times faster than the MAC (single CPU)\n@$ ==============================================\n@$ Running OC6-28 2021-05-08 looping \"c a n 10\"\n@$ on my DELL 5511 Latitude with Intel core i7-1085H 10 gen 2.27 GHz, 16 GB RAM\n@$ 8.16 seconds CPU and 8156 clockcykles with 1 thread\n@$ 18.83 seconds CPU and 1671 clockcykles with 12 threads, factor 4.88 faster \n@$ ==============================================\n@$ Running OC6-108 2026-03-19 \n@$ on my Mac Pro with 14 threads calculating 400 equilibria\n@$ 0.4 seconds CPU and 410 clockcykles with 1 thread\n@$ 0.8 seconds CPU and 71 clockcykles with 14 threads, factor 5.77 faster \n@$ ==============================================\n\n" }, { "path": "examples/macros/saf2507.TDB", "content": "\n$ Database file written 2014-10- 1\n$ From database: SSOL2 \n DATABASE_INFO about the SAF2507 database\n It contains an extract of the SGTE SSOL2 database from 2001 for 6 elements.\n Most binaries and ternary systems have been assessed and bibliographic\n references are provided. Most assessments has been made at MSE, KTH, Sweden\n for the development of duplex stainless steels like Sandvik 2507!\n$\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT N 1/2_MOLE_N2(G) 1.4007E+01 4.3350E+03 9.5751E+01!\n ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01!\n \n SPECIES N2 N2!\n \n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GHSERMN 2.98150E+02 -8115.28+130.059*T-23.4582*T*LN(T)\n -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y\n -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2.89600E+03 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); \n 5.00000E+03 N !\n FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N !\n FUNCTION GHSERNN 2.98150E+02 -3750.675-9.45425*T-12.7819*T*LN(T)\n -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 9.50000E+02 Y\n -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3\n +563070*T**(-1); 3.35000E+03 Y\n -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3\n +4596375*T**(-1); 6.00000E+03 N !\n FUNCTION GHCPNI 2.98150E+02 +6610.72+GHSERNI#; 6.00000E+03 N !\n FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T)\n -.0048407*T**2; 1.72800E+03 Y\n -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N \n !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GMNBCC 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T)\n -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y\n -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N !\n FUNCTION GNIBCC 2.98150E+02 +8715.084-3.556*T+GHSERNI#; 6.00000E+03 \n N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GMNFCC 2.98150E+02 -3439.3+131.884*T-24.5177*T*LN(T)\n -.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N !\n FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N !\n FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N !\n FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N !\n FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N !\n FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N !\n FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N !\n FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N !\n FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 \n N !\n FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N !\n FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 \n N !\n FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N !\n FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 \n N !\n FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N !\n FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 \n N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N !\n FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P\n +1.2675E-19*T**2*P; 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :CR,FE,MN,MO,N,NI : !\n\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,MN;0) 2.98150E+02 +17859.91-12.6208*T\n -4.41929E-21*T**7+GHSERMN#; 1.51900E+03 Y\n +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N REF283 !\n PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T\n +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y\n +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; \n 5.00000E+03 N REF283 !\n PARAMETER G(LIQUID,N;0) 2.98150E+02 +29950+59.02*T+GHSERNN#; \n 6.00000E+03 N REF283 !\n PARAMETER G(LIQUID,NI;0) 2.98150E+02 +11235.527+108.457*T\n -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1.72800E+03 Y\n -9549.775+268.598*T-43.1*T*LN(T); 3.00000E+03 N REF283 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n PARAMETER G(LIQUID,CR,FE,N;0) 2.98150E+02 -340750+187.4*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(LIQUID,CR,FE,N,NI;0) 2.98150E+02 -261500; 6.00000E+03 N \n REF129 !\n PARAMETER G(LIQUID,CR,FE,NI;0) 2.98150E+02 14510; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,CR,FE,NI;1) 2.98150E+02 11977; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,CR,FE,NI;2) 2.98150E+02 5147; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 \n N REF326 !\n PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N \n REF326 !\n PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,CR,N;0) 2.98150E+02 -161800-16.11*T; 6.00000E+03 \n N REF128 !\n PARAMETER G(LIQUID,CR,N;1) 2.98150E+02 65508; 6.00000E+03 N REF128 !\n PARAMETER G(LIQUID,CR,N,NI;0) 2.98150E+02 -89400; 6.00000E+03 N \n REF129 !\n PARAMETER G(LIQUID,CR,NI;0) 2.98150E+02 +318-7.3318*T; 6.00000E+03 \n N REF322 !\n PARAMETER G(LIQUID,CR,NI;1) 2.98150E+02 +16941-6.3696*T; 6.00000E+03 \n N REF322 !\n PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N \n REF261 !\n PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF261 !\n PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N \n REF10 !\n PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 \n N REF10 !\n PARAMETER G(LIQUID,FE,MO,NI;0) 2.98150E+02 50000; 6.00000E+03 N \n REF132 !\n PARAMETER G(LIQUID,FE,N;0) 2.98150E+02 -19930-12.01*T; 6.00000E+03 \n N REF128 !\n PARAMETER G(LIQUID,FE,NI;0) 2.98150E+02 -18378.86+6.03912*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(LIQUID,FE,NI;1) 2.98150E+02 +9228.1-3.54642*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(LIQUID,MN,N;0) 2.98150E+02 -142308+6.0759*T; 2.50000E+03 \n N REF317 !\n PARAMETER G(LIQUID,MN,N;1) 2.98150E+02 32906; 2.50000E+03 N REF317 !\n PARAMETER G(LIQUID,MN,NI;0) 2.98150E+02 -69233.16+10.54315*T; \n 6.00000E+03 N REF182 !\n PARAMETER G(LIQUID,MN,NI;1) 2.98150E+02 7258.05; 6.00000E+03 N \n REF182 !\n PARAMETER G(LIQUID,MO,N;0) 2.98150E+02 -198280+37.49*T; 6.00000E+03 \n N REF128 !\n PARAMETER G(LIQUID,MO,NI;0) 2.98150E+02 -46540+19.53*T; 6.00000E+03 \n N REF125 !\n PARAMETER G(LIQUID,MO,NI;1) 2.98150E+02 2915; 6.00000E+03 N REF125 !\n PARAMETER G(LIQUID,N,NI;0) 2.98150E+02 14981; 6.00000E+03 N REF129 !\n\n\n PHASE AL3NI2 % 2 .6 .4 !\n CONSTITUENT AL3NI2 :NI : NI% : !\n\n PARAMETER G(AL3NI2,NI:NI;0) 2.98150E+02 +GHCPNI#; 6.00000E+03 N \n REF95 !\n\n\n PHASE ALNI_B2 % 2 .5 .5 !\n CONSTITUENT ALNI_B2 :NI%,VA : NI : !\n\n PARAMETER G(ALNI_B2,NI:NI;0) 2.98150E+02 +3109+4.721*T-.0043572*T**2\n +1.06896E-06*T**3+GHSERNI#; 6.00000E+03 N REF95 !\n PARAMETER G(ALNI_B2,VA:NI;0) 2.98150E+02 +108736-5.062*T+.5*GHSERNI#; \n 6.00000E+03 N REF95 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE%,MN,MO%,NI : N,VA% : !\n\n PARAMETER G(BCC_A2,CR:N;0) 2.98150E+02 +GHSERCR#+3*GHSERNN#+311870\n +29.12*T; 6.00000E+03 N REF128 !\n PARAMETER TC(BCC_A2,CR:N;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF128 !\n PARAMETER BMAGN(BCC_A2,CR:N;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF128 !\n PARAMETER G(BCC_A2,FE:N;0) 2.98150E+02 +93562+165.07*T+GHSERFE#\n +3*GHSERNN#; 6.00000E+03 N REF128 !\n PARAMETER TC(BCC_A2,FE:N;0) 2.98150E+02 1043; 6.00000E+03 N REF128 !\n PARAMETER BMAGN(BCC_A2,FE:N;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF128 !\n PARAMETER G(BCC_A2,MN:N;0) 2.98150E+02 -55600+606.648*T-100.41*T*LN(T)\n +844897*T**(-1); 2.50000E+03 N REF317 !\n PARAMETER G(BCC_A2,MO:N;0) 2.98150E+02 +GHSERMO#+3*GHSERNN#+299700\n +79.73*T; 6.00000E+03 N REF128 !\n PARAMETER G(BCC_A2,NI:N;0) 2.98150E+02 +200000+200*T+GHSERNI#\n +3*GHSERNN#; 6.00000E+03 N REF123 !\n PARAMETER TC(BCC_A2,NI:N;0) 2.98150E+02 575; 6.00000E+03 N REF123 !\n PARAMETER BMAGN(BCC_A2,NI:N;0) 2.98150E+02 .85; 6.00000E+03 N \n REF123 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N \n REF283 !\n PARAMETER TC(BCC_A2,MN:VA;0) 2.98150E+02 -580; 2.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98150E+02 -.27; 2.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(BCC_A2,NI:VA;0) 2.98150E+02 +GNIBCC#; 3.00000E+03 N \n REF283 !\n PARAMETER TC(BCC_A2,NI:VA;0) 2.98150E+02 575; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,NI:VA;0) 2.98150E+02 .85; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,CR,FE:N;0) 2.98150E+02 -799379+293*T; 6.00000E+03 \n N REF126 !\n PARAMETER TC(BCC_A2,CR,FE:N;0) 2.98150E+02 1650; 6.00000E+03 N \n REF126 !\n PARAMETER TC(BCC_A2,CR,FE:N;1) 2.98150E+02 550; 6.00000E+03 N \n REF126 !\n PARAMETER BMAGN(BCC_A2,CR,FE:N;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF126 !\n PARAMETER BMAGN(BCC_A2,CR,NI:N;0) 2.98150E+02 4; 6.00000E+03 N \n REF129 !\n PARAMETER TC(BCC_A2,CR,NI:N;0) 2.98150E+02 2373; 6.00000E+03 N \n REF128 !\n PARAMETER TC(BCC_A2,CR,NI:N;1) 2.98150E+02 617; 6.00000E+03 N \n REF128 !\n PARAMETER G(BCC_A2,CR:N,VA;0) 2.98150E+02 -200000; 6.00000E+03 N \n REF128 !\n PARAMETER G(BCC_A2,FE,MO:N;0) 2.98150E+02 -151200; 6.00000E+03 N \n REF134 !\n PARAMETER G(BCC_A2,MN:N,VA;0) 2.98150E+02 -185000; 2.50000E+03 N \n REF317 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -8374; 6.00000E+03 N \n REF326 !\n PARAMETER G(BCC_A2,CR,FE,NI:VA;0) 2.98150E+02 -2673+2.0415*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; \n 6.00000E+03 N REF326 !\n PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N \n REF326 !\n PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N \n REF326 !\n PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N \n REF326 !\n PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N \n REF326 !\n PARAMETER TC(BCC_A2,CR,MN:VA;8) 2.98150E+02 -28117; 6.00000E+03 N \n REF326 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 \n N REF326 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 \n N REF326 !\n PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 \n N REF326 !\n PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(BCC_A2,CR,NI:VA;0) 2.98150E+02 +17170-11.8199*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(BCC_A2,CR,NI:VA;1) 2.98150E+02 +34418-11.8577*T; \n 6.00000E+03 N REF322 !\n PARAMETER TC(BCC_A2,CR,NI:VA;0) 2.98150E+02 2373; 6.00000E+03 N \n REF162 !\n PARAMETER TC(BCC_A2,CR,NI:VA;1) 2.98150E+02 617; 6.00000E+03 N \n REF162 !\n PARAMETER BMAGN(BCC_A2,CR,NI:VA;0) 2.98150E+02 4; 6.00000E+03 N \n REF162 !\n PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 \n N REF261 !\n PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N \n REF261 !\n PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 \n N REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N \n REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N \n REF10 !\n PARAMETER G(BCC_A2,FE,MO,NI:VA;0) 2.98150E+02 -35743; 6.00000E+03 N \n REF132 !\n PARAMETER G(BCC_A2,FE,NI:VA;0) 2.98150E+02 -956.63-1.28726*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(BCC_A2,FE,NI:VA;1) 2.98150E+02 +1789.03-1.92912*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(BCC_A2,MN,NI:VA;0) 2.98150E+02 -51638.31+3.64*T; \n 6.00000E+03 N REF182 !\n PARAMETER G(BCC_A2,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N \n REF182 !\n PARAMETER G(BCC_A2,MO,NI:VA;0) 2.98150E+02 46422; 6.00000E+03 N \n REF125 !\n\n\n TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %' 2 1 1 !\n CONSTITUENT CBCC_A12 :CR,FE,MN%,NI : N,VA% : !\n\n PARAMETER G(CBCC_A12,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,MN:N;0) 2.98150E+02 -53114+299.266*T\n -50.216*T*LN(T)+358309*T**(-1); 2.50000E+03 N REF317 !\n PARAMETER G(CBCC_A12,NI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CBCC_A12,MN:VA;0) 2.98150E+02 +GHSERMN#; 2.00000E+03 N \n REF283 !\n PARAMETER TC(CBCC_A12,MN:VA;0) 2.98150E+02 -285; 2.00000E+03 N REF281 !\n PARAMETER BMAGN(CBCC_A12,MN:VA;0) 2.98150E+02 -.66; 2.00000E+03 N \n REF281 !\n PARAMETER G(CBCC_A12,NI:VA;0) 2.98150E+02 +3556+GHSERNI#; 3.00000E+03 \n N REF283 !\n PARAMETER G(CBCC_A12,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N \n REF317 !\n PARAMETER G(CBCC_A12,CR,MN:VA;0) 2.98150E+02 -36796+20.385*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(CBCC_A12,FE,MN:VA;0) 2.98150E+02 -10184; 6.00000E+03 N \n REF261 !\n PARAMETER G(CBCC_A12,MN,NI:VA;0) 2.98150E+02 -54754.84+17.991*T; \n 6.00000E+03 N REF0 !\n PARAMETER G(CBCC_A12,MN,NI:VA;1) 2.98150E+02 -11924; 6.00000E+03 N \n REF0 !\n\n\n PHASE CEMENTITE % 2 3 1 !\n CONSTITUENT CEMENTITE :CR,FE%,MN,MO,NI : N : !\n\n PARAMETER G(CEMENTITE,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CEMENTITE,FE:N;0) 2.98150E+02 -20060+538.7902*T\n -99.7371*T*LN(T)+226735*T**(-1); 6.00000E+03 N REF319 !\n PARAMETER G(CEMENTITE,MN:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CEMENTITE,MO:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CEMENTITE,NI:N;0) 298.15 UN_ASS; 300 N REF0 !\n\n\n PHASE CHI_A12 % 3 24 10 24 !\n CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : !\n\n PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR#\n +109000+123*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GCRFCC#-26000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR#\n +57300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO#\n +305210-270*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GMOFCC#+100000; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 !\n\n\n PHASE CR3MN5 % 2 3 5 !\n CONSTITUENT CR3MN5 :CR : MN : !\n\n PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550\n +21.1732*T; 6.00000E+03 N REF326 !\n\n\n PHASE CR3SI % 2 3 1 !\n CONSTITUENT CR3SI :CR% : CR : !\n\n PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; \n 6.00000E+03 N REF90 !\n\n\n PHASE CRSI2 % 2 1 2 !\n CONSTITUENT CRSI2 :CR% : CR : !\n\n PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; \n 6.00000E+03 N REF90 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :CR,FE,MN%,NI : N,VA% : !\n\n PARAMETER G(CUB_A13,CR:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,MN:N;0) 2.98150E+02 -67484+299.266*T-50.216*T*LN(T)\n +358309*T**(-1); 2.50000E+03 N REF317 !\n PARAMETER G(CUB_A13,NI:N;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CUB_A13,MN:VA;0) 2.98150E+02 -5800.4+135.995*T\n -24.8785*T*LN(T)-.00583359*T**2+70269*T**(-1); 1.51900E+03 Y\n -28290.76+311.2933*T-48*T*LN(T)+3.96757E+30*T**(-9); 2.00000E+03 N \n REF283 !\n PARAMETER G(CUB_A13,NI:VA;0) 2.98150E+02 +2092+GHSERNI#; 3.00000E+03 \n N REF283 !\n PARAMETER G(CUB_A13,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N \n REF317 !\n PARAMETER G(CUB_A13,CR,MN:VA;0) 2.98150E+02 -31260+16.4919*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(CUB_A13,FE,MN:VA;0) 2.98150E+02 -11518+2.819*T; \n 6.00000E+03 N REF261 !\n PARAMETER G(CUB_A13,MN,NI:VA;0) 2.98150E+02 -62040.75+26.82825*T; \n 6.00000E+03 N REF182 !\n PARAMETER G(CUB_A13,MN,NI:VA;1) 2.98150E+02 -12370.01; 6.00000E+03 \n N REF182 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE%,MN,MO,NI% : N,VA% : !\n\n PARAMETER G(FCC_A1,CR:N;0) 2.98150E+02 -124460+142.16*T-8.5*T*LN(T)\n +GHSERCR#+GHSERNN#; 6.00000E+03 N REF128 !\n PARAMETER G(FCC_A1,FE:N;0) 2.98150E+02 -20277+245.3931*T\n -21.2984*T*LN(T)+GHSERFE#+GHSERNN#; 6.00000E+03 N REF319 !\n PARAMETER G(FCC_A1,MN:N;0) 2.98150E+02 -75940+292.226*T-50.294*T*LN(T)\n +265051*T**(-1); 2.50000E+03 N REF317 !\n PARAMETER G(FCC_A1,MO:N;0) 2.98150E+02 +GHSERMO#+GHSERNN#-65344+149.7*T\n -9.78*T*LN(T); 6.00000E+03 N REF128 !\n PARAMETER G(FCC_A1,NI:N;0) 2.98150E+02 +38680+143.09*T-10.9*T*LN(T)\n +.00438*T**2+GHSERNI#+GHSERNN#; 6.00000E+03 N REF123 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N \n REF283 !\n PARAMETER TC(FCC_A1,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 3.00000E+03 N \n REF283 !\n PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,CR,FE:N;0) 2.98150E+02 -128930+86.49*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(FCC_A1,CR,FE:N;1) 2.98150E+02 24330; 6.00000E+03 N \n REF126 !\n PARAMETER G(FCC_A1,CR,FE:N,VA;0) 2.98150E+02 -162516; 6.00000E+03 N \n REF126 !\n PARAMETER G(FCC_A1,CR,MO:N;0) 2.98150E+02 -40000; 6.00000E+03 N \n REF128 !\n PARAMETER G(FCC_A1,CR,NI:N,VA;0) 2.98150E+02 -661270+305*T; \n 6.00000E+03 N REF129 !\n PARAMETER G(FCC_A1,CR:N,VA;0) 2.98150E+02 20000; 6.00000E+03 N \n REF128 !\n PARAMETER G(FCC_A1,FE,NI:N;0) 2.98150E+02 -22710+5.19*T; 6.00000E+03 \n N REF129 !\n PARAMETER G(FCC_A1,FE,NI:N;1) 2.98150E+02 3334; 6.00000E+03 N \n REF129 !\n PARAMETER G(FCC_A1,FE:N,VA;0) 2.98150E+02 -26150; 6.00000E+03 N \n REF128 !\n PARAMETER G(FCC_A1,MN:N,VA;0) 2.98150E+02 -69698+11.5845*T; \n 2.50000E+03 N REF317 !\n PARAMETER G(FCC_A1,MO:N,VA;0) 2.98150E+02 -52565; 6.00000E+03 N \n REF128 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 -6815; 6.00000E+03 N \n REF326 !\n PARAMETER G(FCC_A1,CR,FE,NI:VA;0) 2.98150E+02 +16580-9.783*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF58 !\n PARAMETER G(FCC_A1,CR,MO,NI:VA;0) 2.98150E+02 -30000; 6.00000E+03 N \n REF58 !\n PARAMETER G(FCC_A1,CR,NI:VA;0) 2.98150E+02 +8030-12.8801*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,CR,NI:VA;1) 2.98150E+02 +33080-16.0362*T; \n 6.00000E+03 N REF322 !\n PARAMETER TC(FCC_A1,CR,NI:VA;0) 2.98150E+02 -3605; 6.00000E+03 N \n REF162 !\n PARAMETER BMAGN(FCC_A1,CR,NI:VA;0) 2.98150E+02 -1.91; 6.00000E+03 N \n REF162 !\n PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 \n N REF261 !\n PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N \n REF261 !\n PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N \n REF261 !\n PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N \n REF261 !\n PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(FCC_A1,FE,MO,NI:VA;0) 2.98150E+02 -204791+163.93*T; \n 6.00000E+03 N REF132 !\n PARAMETER G(FCC_A1,FE,MO,NI:VA;1) 2.98150E+02 +11555-55.81*T; \n 6.00000E+03 N REF132 !\n PARAMETER G(FCC_A1,FE,MO,NI:VA;2) 2.98150E+02 77975; 6.00000E+03 N \n REF132 !\n PARAMETER G(FCC_A1,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;1) 2.98150E+02 +11082.1315-4.45077*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(FCC_A1,FE,NI:VA;2) 2.98150E+02 -725.805174; 6.00000E+03 \n N REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;0) 2.98150E+02 2133; 6.00000E+03 N \n REF158 !\n PARAMETER TC(FCC_A1,FE,NI:VA;1) 2.98150E+02 -682; 6.00000E+03 N \n REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 2.98150E+02 9.55; 6.00000E+03 N \n REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 2.98150E+02 7.23; 6.00000E+03 N \n REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 2.98150E+02 5.93; 6.00000E+03 N \n REF158 !\n PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 2.98150E+02 6.18; 6.00000E+03 N \n REF158 !\n PARAMETER G(FCC_A1,MN,NI:VA;0) 2.98150E+02 -58158+10.878*T; \n 6.00000E+03 N REF182 !\n PARAMETER G(FCC_A1,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N \n REF182 !\n PARAMETER G(FCC_A1,MO,NI:VA;0) 2.98150E+02 +4803.7-5.96*T; \n 6.00000E+03 N REF125 !\n PARAMETER G(FCC_A1,MO,NI:VA;1) 2.98150E+02 10880; 6.00000E+03 N \n REF125 !\n\n\n PHASE FE4N % 2 4 1 !\n CONSTITUENT FE4N :FE,NI : N,VA : !\n\n PARAMETER G(FE4N,FE:N;0) 2.98150E+02 -37514+72.6235*T+4*GHSERFE#\n +GHSERNN#; 6.00000E+03 N REF319 !\n PARAMETER G(FE4N,NI:N;0) 2.98150E+02 -5393+142.97*T-15.65*T*LN(T)\n +.0154*T**2+4*GHSERNI#+GHSERNN#; 6.00000E+03 N REF129 !\n PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N \n REF319 !\n PARAMETER G(FE4N,NI:VA;0) 2.98150E+02 +4*GHSERNI#+10; 6.00000E+03 N \n REF59 !\n PARAMETER G(FE4N,FE:N,VA;0) 2.98150E+02 +64679-21.9574*T; 6.00000E+03 \n N REF319 !\n PARAMETER G(FE4N,FE:N,VA;1) 2.98150E+02 -27905-3.0409*T; 6.00000E+03 \n N REF319 !\n\n\n PHASE FECN_CHI % 2 5 2 !\n CONSTITUENT FECN_CHI :FE : N : !\n\n PARAMETER G(FECN_CHI,FE:N;0) 2.98150E+02 -53838+952.0774*T\n -174.5248*T*LN(T)+438672*T**(-1); 6.00000E+03 N REF319 !\n\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONSTITUENT HCP_A3 :CR,FE,MN,MO,NI : N,VA% : !\n\n PARAMETER G(HCP_A3,CR:N;0) 2.98150E+02 -65760+64.69*T-3.93*T*LN(T)\n +GHSERCR#+.5*GHSERNN#; 6.00000E+03 N REF128 !\n PARAMETER G(HCP_A3,FE:N;0) 2.98150E+02 -13863+40.2123*T+GHSERFE#\n +.5*GHSERNN#; 6.00000E+03 N REF319 !\n PARAMETER G(HCP_A3,MN:N;0) 2.98150E+02 -60607+211.1804*T\n -37.7331*T*LN(T)+129442*T**(-1); 2.50000E+03 N REF317 !\n PARAMETER G(HCP_A3,MO:N;0) 2.98150E+02 +GHSERMO#+.5*GHSERNN#-29450\n +28.7*T; 6.00000E+03 N REF128 !\n PARAMETER G(HCP_A3,NI:N;0) 2.98150E+02 -4409.6+72.93*T-7.36*T*LN(T)\n +.00614*T**2+GHSERNI#+.5*GHSERNN#; 6.00000E+03 N REF123 !\n PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y\n -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N \n REF283 !\n PARAMETER G(HCP_A3,MN:VA;0) 2.98150E+02 -4439.3+133.007*T\n -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y\n -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N \n REF283 !\n PARAMETER TC(HCP_A3,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 !\n PARAMETER BMAGN(HCP_A3,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N \n REF281 !\n PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,NI:VA;0) 2.98150E+02 +1046+1.255*T+GHSERNI#; \n 3.00000E+03 N REF283 !\n PARAMETER TC(HCP_A3,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF26 !\n PARAMETER BMAGN(HCP_A3,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N \n REF26 !\n PARAMETER G(HCP_A3,CR,FE:N;0) 2.98150E+02 +12826-19.48*T; 6.00000E+03 \n N REF126 !\n PARAMETER G(HCP_A3,CR,MO:N;0) 2.98150E+02 -8754; 6.00000E+03 N \n REF128 !\n PARAMETER G(HCP_A3,CR,NI:N;0) 2.98150E+02 1443; 6.00000E+03 N \n REF129 !\n PARAMETER G(HCP_A3,CR:N,VA;0) 2.98150E+02 +21120-10.61*T; 6.00000E+03 \n N REF128 !\n PARAMETER G(HCP_A3,CR:N,VA;1) 2.98150E+02 -6204; 6.00000E+03 N \n REF128 !\n PARAMETER G(HCP_A3,FE:N,VA;0) 2.98150E+02 +10012-19.9853*T; \n 6.00000E+03 N REF319 !\n PARAMETER G(HCP_A3,FE:N,VA;1) 2.98150E+02 -9446+9.3472*T; 6.00000E+03 \n N REF319 !\n PARAMETER G(HCP_A3,MN:N,VA;0) 2.98150E+02 -7194-5.2075*T; 2.50000E+03 \n N REF317 !\n PARAMETER G(HCP_A3,MN:N,VA;1) 2.98150E+02 -11810+6.9538*T; 2.50000E+03 \n N REF317 !\n PARAMETER G(HCP_A3,MO,NI:N;0) 2.98150E+02 -80000; 6.00000E+03 N \n REF134 !\n PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(HCP_A3,CR,MN:VA;0) 2.98150E+02 41800; 6.00000E+03 N \n REF326 !\n PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF117 !\n PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF117 !\n PARAMETER G(HCP_A3,FE,MN:VA;0) 2.98150E+02 -5582+3.865*T; 6.00000E+03 \n N REF261 !\n PARAMETER G(HCP_A3,FE,MN:VA;1) 2.98150E+02 273; 6.00000E+03 N \n REF261 !\n PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(HCP_A3,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(HCP_A3,FE,NI:VA;1) 2.98150E+02 +11082-4.45077*T; \n 6.00000E+03 N REF158 !\n PARAMETER G(HCP_A3,FE,NI:VA;2) 2.98150E+02 -725.8; 6.00000E+03 N \n REF158 !\n\n\n PHASE HIGH_SIGMA % 3 8 4 18 !\n CONSTITUENT HIGH_SIGMA :MN : CR : CR,MN : !\n\n PARAMETER G(HIGH_SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR#\n -192369+152.4742*T; 6.00000E+03 N REF326 !\n PARAMETER G(HIGH_SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR#\n +18*GMNBCC#-74263-10.7082*T; 6.00000E+03 N REF326 !\n PARAMETER G(HIGH_SIGMA,MN:CR:CR,MN;0) 2.98150E+02 90000; 6.00000E+03 \n N REF326 !\n\n\n PHASE LAVES_PHASE % 2 2 1 !\n CONSTITUENT LAVES_PHASE :CR,FE : MO : !\n\n PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000\n -6*T; 6.00000E+03 N REF214 !\n PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC#\n +GHSERMO#; 6.00000E+03 N REF10 !\n\n\n PHASE MC_ETA % 2 1 1 !\n CONSTITUENT MC_ETA :MO% : VA : !\n\n PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; \n 6.00000E+03 N REF113 !\n\n\n PHASE MN4N % 2 4 1 !\n CONSTITUENT MN4N :MN : N : !\n\n PARAMETER G(MN4N,MN:N;0) 2.98150E+02 -155790+691.0638*T\n -126.9328*T*LN(T)+307417*T**(-1); 2.50000E+03 N REF317 !\n\n\n PHASE MN6N4 % 2 6 4 !\n CONSTITUENT MN6N4 :MN : N : !\n\n PARAMETER G(MN6N4,MN:N;0) 2.98150E+02 -465614+1428.332*T\n -251.337*T*LN(T)+1027898*T**(-1); 2.50000E+03 N REF317 !\n\n\n PHASE MN6N5 % 2 6 5 !\n CONSTITUENT MN6N5 :MN : N : !\n\n PARAMETER G(MN6N5,MN:N;0) 2.98150E+02 -546880+1591.607*T\n -276.668*T*LN(T)+1297983*T**(-1); 2.50000E+03 N REF317 !\n\n\n PHASE MONI3_GAMMA % 2 1 3 !\n CONSTITUENT MONI3_GAMMA :MO : NI : !\n\n PARAMETER G(MONI3_GAMMA,MO:NI;0) 2.98150E+02 +3*GHSERNI#+GHSERMO#-4199\n -7*T; 6.00000E+03 N REF125 !\n\n\n PHASE MONI4_BETA % 2 1 4 !\n CONSTITUENT MONI4_BETA :MO : NI : !\n\n PARAMETER G(MONI4_BETA,MO:NI;0) 2.98150E+02 +4*GHSERNI#+GHSERMO#-4330\n -9.21*T; 6.00000E+03 N REF125 !\n\n\n PHASE MONI_DELTA % 3 24 20 12 !\n CONSTITUENT MONI_DELTA :CR,FE,NI : CR,FE,MO,NI : MO : !\n\n PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+50000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR#\n +12*GHSERMO#-200000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+100000; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE#\n +12*GHSERMO#; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO#\n -212100+1089*T-142*T*LN(T); 6.00000E+03 N REF125 !\n PARAMETER G(MONI_DELTA,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC#\n +12*GHSERMO#-200000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERNI#\n +12*GHSERMO#; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC#\n +12*GHSERMO#-1030-93.5*T+13.5*T*LN(T); 6.00000E+03 N REF125 !\n\n\n PHASE MU_PHASE % 3 7 2 4 !\n CONSTITUENT MU_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : !\n\n PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,NI:MO:CR;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO#\n +4*GHSERCR#; 6.00000E+03 N REF136 !\n PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC#\n +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,NI:MO:FE;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO#\n +4*GHSERFE#+784294-249.607*T; 6.00000E+03 N REF132 !\n PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO#\n +130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC#\n +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,NI:MO:MO;0) 2.98150E+02 +7*GHSERNI#+6*GHSERMO#\n +28506-47.3*T; 6.00000E+03 N REF132 !\n PARAMETER G(MU_PHASE,CR:MO:NI;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GNIBCC#; 6.00000E+03 N REF136 !\n PARAMETER G(MU_PHASE,FE:MO:NI;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO#\n +4*GHSERNI#+354030-229.4*T; 6.00000E+03 N REF132 !\n PARAMETER G(MU_PHASE,NI:MO:NI;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO#\n +4*GNIBCC#+398566-200*T; 6.00000E+03 N REF132 !\n PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 \n N REF115 !\n\n\n PHASE PI % 3 12.8 7.2 4 !\n CONSTITUENT PI :CR : FE,NI : N : !\n\n PARAMETER G(PI,CR:FE:N;0) 2.98150E+02 -160994+12.8*GHSERCR#\n +7.2*GHSERFE#+4*GHSERNN#; 6.00000E+03 N REF129 !\n PARAMETER G(PI,CR:NI:N;0) 2.98150E+02 -651800+316*T+12.8*GHSERCR#\n +7.2*GHSERNI#+4*GHSERNN#; 6.00000E+03 N REF129 !\n\n\n PHASE P_PHASE % 3 24 20 12 !\n CONSTITUENT P_PHASE :CR,FE,NI : CR,FE,MO,NI : MO : !\n\n PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR#\n +12*GHSERMO#-341858; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+111361; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE#\n +12*GHSERMO#-170245+100*T; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +95573-200*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +362525-332.7*T; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO#\n +26739-100*T; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC#\n +12*GHSERMO#-434085; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GNIBCC#\n +12*GHSERMO#; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC#\n +12*GHSERMO#+208845-100*T; 6.00000E+03 N REF132 !\n\n\n PHASE R_PHASE % 3 27 14 12 !\n CONSTITUENT R_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : !\n\n PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERCR#-20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO#\n +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,NI:MO:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC#\n +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 !\n PARAMETER G(R_PHASE,NI:MO:FE;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO#\n +12*GHSERFE#; 6.00000E+03 N REF132 !\n PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO#\n -20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T\n +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 !\n PARAMETER G(R_PHASE,NI:MO:MO;0) 2.98150E+02 +27*GHSERNI#+26*GHSERMO#\n -18000; 6.00000E+03 N REF132 !\n PARAMETER G(R_PHASE,CR:MO:NI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(R_PHASE,FE:MO:NI;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO#\n +12*GNIBCC#; 6.00000E+03 N REF132 !\n PARAMETER G(R_PHASE,NI:MO:NI;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO#\n +12*GNIBCC#+100000; 6.00000E+03 N REF132 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE,MN,NI : CR,MO : CR,FE,MN,MO,NI : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR#\n +65859.5; 6.00000E+03 N REF326 !\n PARAMETER G(SIGMA,NI:CR:CR;0) 2.98150E+02 +8*GHSERNI#+22*GHSERCR#\n +221157-227*T; 6.00000E+03 N REF322 !\n PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,MN:MO:CR;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:MO:CR;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO#\n +18*GHSERCR#+386423; 6.00000E+03 N REF133 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,MN:CR:FE;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR#\n +18*GHSERFE#-95576-45.2*T; 6.00000E+03 N REF0 !\n PARAMETER G(SIGMA,NI:CR:FE;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR#\n +18*GHSERFE#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC#\n +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,MN:MO:FE;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:MO:FE;0) 2.98150E+02 +8*GHSERNI#+18*GHSERFE#\n +4*GHSERMO#+658600-200*T; 6.00000E+03 N REF132 !\n PARAMETER G(SIGMA,FE:CR:MN;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GMNBCC#-83640+18.26*T; 6.00000E+03 N REF0 !\n PARAMETER G(SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR#\n +18*GMNBCC#-172946+69.0245*T; 6.00000E+03 N REF326 !\n PARAMETER G(SIGMA,NI:CR:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,FE:MO:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,MN:MO:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:MO:MN;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,MN:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:CR:MO;0) 2.98150E+02 +8*GHSERNI#+18*GHSERMO#\n +4*GHSERCR#-131651; 6.00000E+03 N REF133 !\n PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC#\n +22*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,MN:MO:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:MO:MO;0) 2.98150E+02 +8*GHSERNI#+22*GHSERMO#+85662;\n 6.00000E+03 N REF133 !\n PARAMETER G(SIGMA,FE:CR:NI;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GNIBCC#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,MN:CR:NI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:CR:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR#\n +18*GNIBCC#+175400; 6.00000E+03 N REF200 !\n PARAMETER G(SIGMA,FE:MO:NI;0) 2.98150E+02 +8*GFEFCC#+18*GNIBCC#\n +4*GHSERMO#+408600-200*T; 6.00000E+03 N REF132 !\n PARAMETER G(SIGMA,MN:MO:NI;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(SIGMA,NI:MO:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO#\n +18*GNIBCC#-16385; 6.00000E+03 N REF133 !\n PARAMETER G(SIGMA,FE:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,MN:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; \n 6.00000E+03 N REF326 !\n PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N \n REF10 !\n PARAMETER G(SIGMA,FE,NI:MO:MO;0) 2.98150E+02 -164570-10*T; \n 6.00000E+03 N REF132 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF95 'I Ansara, P Willemin B Sundman (1988); Al-Ni'\n REF128 'K. Frisk, TRITA-MAC 393 (1989); CR-N,FE-N,MO-N,CR-MO-N'\n REF317 'Caian Qui and Armando Fernandez Guillermet, Trita-MAC 472 (1991);\n Mn-N'\n REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO'\n REF319 'H. Du and M. Hillert, revision; C-Fe-N'\n REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W'\n REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 \n TRITA 0322 (1986); CR-FE-MO'\n REF326 'Byeong-Joo Lee, unpublished revision (1991), Cr-Mn'\n REF90 'I Ansara, unpublished work (1991); Cr-Si'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF129 'K. Frisk, TRITA-MAC 422 (1990); CR-FE-N-NI'\n REF59 'B. Sundman, fix'\n REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W'\n REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 \n (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO'\n REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 \n TRITA 0321 (1986); C-FE-MO'\n REF125 'K. Frisk, Calphad (1990), Vol 14, p 311-320; MO-NI'\n REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI'\n REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI'\n REF136 'Unassessed parameter, linear combination of unary data. (MU, \n SIGMA)'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni'\n REF200 'P. Gustafson, Calphad Vol 11 (1987) p 277-292, \n TRITA-MAC 320 (1986); CR-NI-W '\n REF261 'W. Huang, Calphad Vol 13 (1989) pp 243-252, \n TRITA-MAC 388 (rev 1989); FE-MN'\n REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI'\n REF182 'NPL, unpublished work (1989); Mn-Ni'\n REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, \n TRITA 0409 (1989); CR-FE-N'\n REF134 'K. Frisk, TRITA-MAC 433 (1990); FE-CR-MO-NI-N'\n REF58 'B. Sundman, TEST'\n REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO'\n REF162 'A. Dinsdale, T. Chart, MTDS NPL, Unpublished work (1986); CR-NI'\n REF26 'A. Fernandez Guillermet, Z. Metallkde. Vol 79(1988) p.524-536, \n TRITA-MAC 362 (1988); C-CO-NI AND C-CO-FE-NI'\n ! \n \n" }, { "path": "examples/macros/save.OCM", "content": "new YES\n\n@$ ====================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ save.OCM\n@$ testing unformatted save and read\n@$ ====================================================================\n@$\n@&\n@$ read a TDB file and make a calculation\n\nset echo Y\n\nr t ./steel7\n\n@&\n\nl sh a\n\n@&\n@$ Set reference state for Cr\n\nset ref cr bcc * 1e5\n\nset c t=1200 p=1e5 n=1 x(c)=.05 x(cr)=.05 x(mo)=.05 x(si)=.003 x(v)=.01\n\nc e\n\n@&\n\nl,,,,\n\n@$ We will check this again after save/read unformatted\ndebug symbol gs -5.9405966E4\n@&\n@$ enter some state variable functions\n\nenter symb cp = h.t;\n\ncalc sym cp\n\nenter symb htr = hm(liq)-hm(bcc);\n\nenter symb gcr = ac(cr)/x(bcc,cr);\n\n@&\n\nlist symb\n\ncalc symb\n\n\n@&\n@$ list the equilibrium status code\nl sh p\n\n@&\n@$ Save workspaces unformatted on a file, final Y to overwrite!!\n\nsave\nunf\nsteel7unf\nY\n\n@$ NOTE steel7unf.OCU will be saved on the WORKING DIRECTORY\n@$ which may not be the same as the directory of the macro!\n@$ This means we must not use \"./\" as prefix when we read the file ...\n@&\n@$ Reinitiate the program and delete all data and results\n\nnew Y\n\nl d,,,\n\n@&\n@$ Read the the unformatted file with data and the last calculation\n@$ DO NOT USE the prefix ./ as this file was written on the working directory\n\nread\nunf\nsteel7unf\n\n@&\n@$ Check we can list the equilibrium\nl r,,,,\n\n@&\n@$ Check the equilibrium status code\nl sh p\n\n@&\n@$ Check the symbols are there\n\nl sym\n\n\n@&\n@$ and all the model parameters\n\nl d\n\n@&\n\n@$ We can recalculate the equilibrium\n\nc n\n\nl,,,,\n\n@$ Check we have the same results as before save/read\ndebug symbol gs -5.9405966E4\n@&\n@$ and change conditions and calculate again\n\nset c t=800\n\nc e\n\nl,,,,,\n\n@&\n@$ Just to test that one can set the fraction of any component\n@$ as the \"rest\" or \"balance\"\n\nc ph liq 1 n \n.02\n.05\nrest\n.08\n.005\n.01\nall\n\n\nnew Y\n\n@&\n@$ ===================================================================\n@$ testing unformatted save and read using an XTDB file\n@$ NOT YET IMPLEMENTED use the TDB file ....\n@$ with disordered fraction set and a second equilibrium\n\nr t ./MoRe\n\n@&\n\nl sh a\n\n@$ Calculate an equilibrium\n\nset c t=1000 p=1e5 n=1 x(re)=.3\n\nc e\n\nl r 2\n\n\n@&\n@$ Create a second equilibrium with different conditions\n\nenter equil second y\n\nl c\n\n@&\n\nset c t=3000 p=1e5 n=1 x(re)=.7\n\nc e\n\nl,,,\n\n\n@$ check the Gibbs energy of this equilibrium\ndebug symbol g -2.2969105E5\n@&\n@$ Save workspaces unformatted on a file, final Y to overwrite!!\n\n\nl d\n\n@&\n\nsave\nunf\nmore1unf\nY\n\n@$ NOTE FILE SAVED in WORKING DIRECTORY !!\n@&\n@$ Reinitiate the program and delete all data and results\n\nnew Y\n\nl d,,,\n\n@&\n@$ Read the the unformatted file with data and the last calculation\n\nread\nunf\nmore1unf\n\n\n@$ NOTE FILE is in working directory \n@&\n@$ list the equilibria\n\nl eq\n\n@&\n@$ list the results for default equilibrium\n\nl r\n\n\n@&\n@$ list the results for the second equilibrium\n\nsel eq\n\nl,,,,\n\n@$ Is the G value saved? The value has been calculated before save/read\ndebug symbol g -2.2969105E5\n@&\n@$ Set a new condition and calculate without grid minimizer\n\nset c t=2800\n\nc n\n\nl r 2\n@&\n@$==========================================================================\n@$ end of save macro\n@$==========================================================================\nset inter\n\n" }, { "path": "examples/macros/sro-cef.OCM", "content": "new Y\n\nset echo Y\n\n@$ ====================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ FCC prototype ordering using CEF SRO model\n@$ The data interactively and\n@$ a phase diagram for FCC prototype ordering is calculated\n@$ using partition and permutations\n@$\n@$ NOTE in this case we use the option to set FCC_PERMUTATIONS\n@$ so each unique parameters is entered only once (compare with map4.OCM)\n@$\n@$ =========================================================================\n@&\n\nset echo Y\n\n@$ Enter the elements and their reference states\nenter element A A FCC 55. 0 0 \n\nenter element B B FCC 58 0 0\n\n@$ the bond energy is -100*R at T=100 K, enter it as T dependent\nenter tp-sym UAB fun 1 -100*R; ,,,,\n\n@$ These functions describe the end-member energies at A3B1, A2B2 and A1B3\nenter tp-sym GA3B1 fun 1 3*UAB; ,,,,\nenter tp-sym GA2B2 fun 1 4*UAB; ,,,,\nenter tp-sym GA1B3 fun 1 3*UAB; ,,,,\n \n@$ We set a regular solution parameter to avoid the F' phase\n@$ It also forces the ordered phases to be perfectly ordered at T=0\nenter tp-sym L0 fun 1 200; ,,,,,\n\n@$ The SRO contribution is UAB\nenter tp-sym GSRO fun 1 UAB; ,,,,,\n\n@$ Using the partitioned model the contribition from the ordered parameters\n@$ will cancel when the phase is disordered. If we want them to contribute\n@$ we must add them to the disordered part\nenter tp-sym LD0 fun 1 -0.25*UAB; ,,,,\nenter tp-sym LD1 fun 1 0; ,,,,\nenter tp-sym LD2 fun 1 0.25*UAB; ,,,,\n\n@$ ==================================================\n@$ This is an fcc phase with lro but no explicit sro\n@$ described with the sublattice model\n\nenter phase FCC_4SL\nCEF\n4 .25 A B; .25 A B; .25 A B; .25 A B;\n\n@$ we must set that this has FCC permutations before entering parameters\namend phase fcc-4sl\n?\nfcc-perm\n\n@&\n\n@$ we must add disordered set before entering parameters\namend phase fcc-4sl dis 4\nNO\n\n@&\n\n@$ enter the parameter, note permutations taken into account\nenter param G(FCC_4SL,A:A:A:B) 1 GA3B1; 6000 N test\nenter param G(FCC_4SL,A:B:B:B) 1 GA1B3; 6000 N test\nenter param G(FCC_4SL,A:A:B:B) 1 GA2B2; 6000 N test\n\nenter param G(FCC_4SL,A,B:A,B:*:*) 1 GSRO; 6000 N test\n\namend biblio test prototype FCC ordering;\n\n@$ The disordered paramaters has a suffix D (This may be changed!!)\n@$ This is the SRO parameter for the disordered FCC_4SL\nenter param GD(FCC_4SL,A,B;0) 1 L0+LD0; 6000 N test\nenter param GD(FCC_4SL,A,B;2) 1 LD2; 6000 N test\n\n\nlist data ,,\n\n\n@&\n\n@$ We have to help the mapping in OC, it is not very good\n@$ Here 3 composition sets are added for the two L1_2 and the L1_0 ordering\n\n@$ this default constitution is A3B_L12\namend phase fcc_4sl comp-set y , ,\n<.2 >.5\n>.2 <.5\n>.2 <.5\n>.5 <.2\n\n@$ this default constitution is AB_L10\namend phase fcc_4sl comp-set y , ,\n<.2 >.5\n<.2 >.5\n>.5 <.2\n>.5 <.2\n\n@$ this default constitution is AB3_L12\namend phase fcc_4sl comp-set y , ,\n<.2 >.5\n<.2 >.5\n<.2 >.5\n>.5 <.2\n\n@$ However, the L12 can have max B or A on any sublattice, there is no\n@$ check that it is always the first or last sublattice with the highest\n@$ fraction of the minor element. This should be arranged in todo_after ...\n\n\nl sh a\n\nset c t=70 p=1e5 n=1 x(b)=.37\n\nc e\n\nl , 2\n\n\n@&\n\nset ax 1 x(b) 0 .5 0.01\n\nset ax 2 t 1 100 2\n\n\nmap\n\n\n@&\n\nplot\n\n\ntitle Fig 1, SRO-CEF fcc prototype phase diagram\n\n\n@$ Sometimes parts are missing, one may have to add a second start point\n@$ although that can be complicated to find.\n@&\n\n@$ Calculate and plot Cp and y at the equiatomic composition with T axis\n@$ The L1_0 ordered phase not stable above 92.23 K\n\nset ax 2 none\nset ax 1 t 1 200 1\n\nset c x(b)=.5\n\nc e\n\nstep\n\n\nenter sym cp=hm.t;\n\nplot\nt\ncp\ntitle Fig 2, SRO-CEF heat capacity at equiatomic composition\n\n@$ There is a lot of error messages as cp calculation failes for \n@$ the unstable composition sets\n@$ Note the peak of the heat capacity is above the order/disorder T\n@$ when the ordered phase is actually metatsble\n\n@&\n\n@$ Plot also the constitution\n\nplot\nt\ny(fcc#2,*)\ntitle Fig 3, SRO-CEF constituent fractions\n\n\n@$ \n\n@&\n\n@$ Calculate at 50 K how the G, S and H varies with the composition\n@$ \n\nset c t=50\nset c x(b)=.4\n\nc e\n\nl ,,,\n\n@$ Normally this calculation just gives the F' phase with two\n@$ sublattices with mainly A, one mainly B and one intermediate\n@$ Fix that by using calculate phase!\n\nc ph fcc\n1\nN\n.99\n.99\n.01\n.01\n\n\n@$ Then calculate without gridminimizer\n\nc n\n\nl ,,,\n\n\n@$ and simsalabim, we should now have a two-phase equilibrium with\n@$ L12 and L10 phases with lower Gibbs energy than the previous F' phase\n@$ OC has a rather primitive gridminimizer\n\n@&\n\n@$ now vary the composition from 0 to 0.5\n\nset ax 1 x(b)\n0\n.5\n.005\n\nstep sep\nY\n\nplot\nx(b)\ngm(*)\ntitle Fig 4, SRO-CEF Gibbs energy for A1,L12 and L10 at T=50\n\n@$ The Gibbs energy curves for the A1, L12 and L10 phases acress the\n@$ composition range\n@&\n\npl\nx(b)\nsm(*)\ntitle Fig 5, SRO-CEF Entropy curves for A1,L12 and L10 at T=50\n\n\n@$ The entropy curves for the A1, L12 and L10 phases acress the\n@$ composition range\n\n@$ Note the entropy is zero at the ideal ordering composition.\n@&\n\npl\nx(b)\nhm(*)\ntitle Fig 6, SRO CEF Entropy curves for A1,L12 and L10 at T=50\n\n\n@$ The enthalpy curves for the A1, L12 and L10 phases acress the\n@$ composition range\n@&\n\npl\nx(b)\ny(fcc#3,*)\ntitle Fig 7, SRO-CEF fraction curves for one of the phases at T=50\n\n\n@$ One can also plot the individual phase fractions and figure out\n@$ which composition set is A1, L12 or L10\n@&\n\n\nenter symbol\ncp1\nhm(fcc#1).T;\n\npl\n\ncp1\ntitle Fig 8, Heat capacity for L1_2 including metastable ranges\n\n@$ This is the heat capacity of the L1_2 phase. It remains metatsble\n@$ up to 50% B but disorder to A1 arount 10% B (also as metastable)\n@$ There is a small peak of the heat capacity at x(b)=0.25, the ideal ordering\n\n\n\n@$==========================================================================\n@$ end of sro-cef macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/steel1.TDB", "content": "\n$ Database file written 2012- 2-11\n$ From database: SSOL2 \n DATABASE_INFO about the steel1 database\n It is an extract from the SGTE SSOL2 database from 2001 for 6 elements.\n Most binary and ternary systems have been assessed and bibliographic\n references are provided. Most assessments has been made at MSE, KTH, Sweden.\n for the developent of steels.!\n$\n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01!\n ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01!\n \n SPECIES C1 C!\n SPECIES C2 C2!\n SPECIES C3 C3!\n SPECIES C4 C4!\n SPECIES C5 C5!\n SPECIES C6 C6!\n SPECIES C7 C7!\n SPECIES V1C1 V1C1!\n \n FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N !\n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2.89600E+03 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); \n 5.00000E+03 N !\n FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N !\n FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T)\n -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y\n -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); \n 3.60000E+03 N !\n FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 2.18300E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 4.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N !\n FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N !\n FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; \n 6.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N !\n FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N !\n FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 4.00000E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 6.00000E+03 N !\n FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N !\n FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T)\n -.126431*T**2; 6.00000E+03 N !\n FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920\n -40*T; 6.00000E+03 N !\n FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T)\n +5003425*T**(-1); 6.00000E+03 N !\n FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T)\n -.0301188*T**2; 6.00000E+03 N !\n FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T)\n -.0578207*T**2; 6.00000E+03 N !\n FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N !\n FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N !\n FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N !\n FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N !\n FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N !\n FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N !\n FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N !\n FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N !\n FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N !\n FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N !\n FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N !\n FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N !\n FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N !\n FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N !\n FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N !\n FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N !\n FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N !\n FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N !\n FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N !\n FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N !\n FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 \n N !\n FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N !\n FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N !\n FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N !\n FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 \n N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 \n N !\n FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N !\n FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N !\n FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N !\n FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N !\n FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N !\n FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 \n N !\n FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N !\n FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 \n N !\n FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N !\n FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N !\n FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N !\n FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N !\n FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N !\n FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N !\n FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N !\n FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N !\n FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P\n +1.2675E-19*T**2*P; 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : !\n\n PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; \n 6.00000E+03 N REF283 !\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T\n +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y\n +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; \n 5.00000E+03 N REF283 !\n PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T\n +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y\n +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N \n REF283 !\n PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T\n -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y\n +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y\n +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 !\n PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 \n N REF101 !\n PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 !\n PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 \n N REF190 !\n PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 !\n PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N \n REF113 !\n PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 \n N REF104 !\n PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N \n REF10 !\n PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 \n N REF10 !\n PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : !\n\n PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC#\n +3*GPCGRA#+416000; 6.00000E+03 N REF101 !\n PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF101 !\n PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE#\n +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 !\n PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#;\n 6.00000E+03 N REF104 !\n PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC#\n +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; \n 6.00000E+03 N REF256 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF322 !\n PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N \n REF102 !\n PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N \n REF102 !\n PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF102 !\n PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF325 !\n PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N \n REF104 !\n PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N \n REF104 !\n PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N \n REF99 !\n PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 !\n PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N \n REF256 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 \n N REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N \n REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N \n REF10 !\n PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; \n 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N \n REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 \n N REF98 !\n PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 \n N REF98 !\n PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N \n REF269 !\n PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N \n REF111 !\n PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N \n REF111 !\n\n\n TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %' 2 1 1 !\n CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE CEMENTITE % 2 3 1 !\n CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : !\n\n PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000\n -9.2888*T; 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N \n REF190 !\n PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000\n -57.4*T; 6.00000E+03 N REF104 !\n PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T\n -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N \n REF316 !\n PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; \n 6.00000E+03 N REF270 !\n\n\n PHASE CHI_A12 % 3 24 10 24 !\n CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : !\n\n PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR#\n +109000+123*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GCRFCC#-26000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR#\n +57300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO#\n +305210-270*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GMOFCC#+100000; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 !\n\n\n PHASE CR2VC2 % 3 2 1 2 !\n CONSTITUENT CR2VC2 :CR : V : C : !\n\n PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR#\n +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 !\n\n\n PHASE CR3SI % 2 3 1 !\n CONSTITUENT CR3SI :CR%,SI : CR,SI% : !\n\n PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR#\n +3*GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR#\n +GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; \n 6.00000E+03 N REF90 !\n\n\n PHASE CR5SI3 % 2 5 3 !\n CONSTITUENT CR5SI3 :CR : SI : !\n\n PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T\n -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N \n REF90 !\n\n\n PHASE CR1SI1 % 2 1 1 !\n CONSTITUENT CR1SI1 :CR : SI : !\n\n PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T\n -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 !\n\n\n PHASE CRSI2 % 2 1 2 !\n CONSTITUENT CRSI2 :CR%,SI : CR,SI% : !\n\n PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T\n -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE DIAMOND_A4 % 1 1.0 !\n CONSTITUENT DIAMOND_A4 :C,SI% : !\n\n PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T\n -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)\n +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 !\n PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N \n REF283 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : !\n\n PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC#\n +GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T)\n -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N \n REF113 !\n PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N \n REF99 !\n PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N \n REF270 !\n PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N \n REF220 !\n PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N \n REF104 !\n PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N \n REF256 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF269 !\n\n\n PHASE FE1SI1 % 2 .5 .5 !\n CONSTITUENT FE1SI1 :FE : SI : !\n\n PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381\n +2.22*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE2SI % 2 .666667 .333333 !\n CONSTITUENT FE2SI :FE : SI : !\n\n PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE#\n +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE4N % 2 4 1 !\n CONSTITUENT FE4N :FE : C,VA : !\n\n PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF319 !\n PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N \n REF319 !\n\n\n PHASE FE5SI3 % 2 .625 .375 !\n CONSTITUENT FE5SI3 :FE : SI : !\n\n PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI#\n -30143+.27*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE8SI2C % 3 8 2 1 !\n CONSTITUENT FE8SI2C :FE : SI : C : !\n\n PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI#\n +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 !\n\n\n PHASE FECN_CHI % 2 5 2 !\n CONSTITUENT FECN_CHI :FE : C : !\n\n PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T\n -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 !\n\n\n PHASE FESI2_H % 2 .3 .7 !\n CONSTITUENT FESI2_H :FE : SI : !\n\n PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649\n -.92*T; 6.00000E+03 N REF98 !\n\n\n PHASE FESI2_L % 2 .333333 .666667 !\n CONSTITUENT FESI2_L :FE : SI : !\n\n PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE#\n +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :C : !\n\n PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 \n N REF283 !\n\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : !\n\n PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504\n +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 !\n PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC#\n +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1)\n +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T)\n -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y\n -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N \n REF283 !\n PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N \n REF316 !\n PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N \n REF207 !\n PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 \n N REF113 !\n PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N \n REF319 !\n PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N \n REF104 !\n PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF117 !\n PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF117 !\n PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n\n\n PHASE KSI_CARBIDE % 2 3 1 !\n CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : !\n\n PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060\n -47.2519*T; 6.00000E+03 N REF316 !\n PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 \n N REF113 !\n\n\n PHASE LAVES_PHASE % 2 2 1 !\n CONSTITUENT LAVES_PHASE :CR,FE : MO : !\n\n PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000\n -6*T; 6.00000E+03 N REF214 !\n PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC#\n +GHSERMO#; 6.00000E+03 N REF10 !\n\n\n PHASE M23C6 % 3 20 3 6 !\n CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : !\n\n PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6#\n +.8695652*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GCRM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6#\n +.1304348*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GFEM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO#\n +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO#\n +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N \n REF323 !\n PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n\n\n PHASE M3C2 % 2 3 2 !\n CONSTITUENT M3C2 :CR,MO,V : C : !\n\n PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; \n 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF324 !\n PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 !\n\n\n PHASE M3SI % 2 3 1 !\n CONSTITUENT M3SI :FE : SI : !\n\n PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T;\n 6.00000E+03 N REF42 !\n\n\n PHASE M5C2 % 2 5 2 !\n CONSTITUENT M5C2 :FE,V : C : !\n\n PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852\n -33.7518*T; 6.00000E+03 N REF322 !\n PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T)\n +1453274*T**(-1); 6.00000E+03 N REF275 !\n\n\n PHASE M6C % 4 2 2 2 1 !\n CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : !\n\n PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR#\n +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 !\n PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO#\n +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO#\n +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO#\n +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 !\n PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N \n REF113 !\n\n\n PHASE M7C3 % 2 7 3 !\n CONSTITUENT M7C3 :CR%,FE,MO,V : C : !\n\n PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000\n -48.2168*T; 6.00000E+03 N REF322 !\n PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415\n +24.24*T; 6.00000E+03 N REF316 !\n PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T)\n +2148691*T**(-1); 6.00000E+03 N REF324 !\n PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N \n REF324 !\n PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N \n REF316 !\n PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N \n REF324 !\n\n\n PHASE MC_ETA % 2 1 1 !\n CONSTITUENT MC_ETA :MO% : C%,VA : !\n\n PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N \n REF104 !\n\n\n PHASE MC_SHP % 2 1 1 !\n CONSTITUENT MC_SHP :MO : C : !\n\n PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; \n 6.00000E+03 N REF104 !\n\n\n PHASE MONI_DELTA % 3 24 20 12 !\n CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+50000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+100000; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF132 !\n\n\n PHASE MU_PHASE % 3 7 2 4 !\n CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC#\n +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO#\n +130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC#\n +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 \n N REF115 !\n\n\n PHASE P_PHASE % 3 24 20 12 !\n CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+111361; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +95573-200*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +362525-332.7*T; 6.00000E+03 N REF132 !\n\n\n PHASE R_PHASE % 3 27 14 12 !\n CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERCR#-20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO#\n +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC#\n +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 !\n PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO#\n -20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T\n +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 !\n\n\n PHASE SIC % 2 1 1 !\n CONSTITUENT SIC :SI : C : !\n\n PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T\n -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); \n 7.00000E+02 Y\n -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2\n +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y\n -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2\n +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC#\n +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC#\n +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC#\n +22*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERMO#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC#\n +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERVV#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321\n -60.967*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N \n REF323 !\n PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N \n REF10 !\n PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N \n REF269 !\n\n\n PHASE V3C2 % 2 3 2 !\n CONSTITUENT V3C2 :FE,V : C : !\n\n PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T)\n +779485*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF256 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR'\n REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 \n TRITA 0237 (1984); C-FE'\n REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C\n -MO'\n REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si'\n REF256 'W. Huang, TRITA-MAC 431 (1990); C-V'\n REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, \n TRITA-MAC 411 (Rev 1989); C-FE-MN'\n REF177 'NPL, unpublished work (1989); C-Mn-Si'\n REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *'\n REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni'\n REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W'\n REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 \n TRITA 0322 (1986); CR-FE-MO'\n REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V'\n REF90 'I Ansara, unpublished work (1991); Cr-Si'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF319 'H. Du and M. Hillert, revision; C-Fe-N'\n REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) \n pp 2211-2223; C-Fe-Si'\n REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo'\n REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 \n TRITA 0321 (1986); C-FE-MO'\n REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W'\n REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 \n (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO'\n REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 \n TRITA 0207 (1986); C-CR-FE'\n REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V'\n REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si'\n REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of \n 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 -N, \n FE-MO-N, CR-N-W, CR-TI-N'\n REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI'\n REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI'\n REF286 'SGTE Substance database, AUG 1989.'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V'\n REF136 'Unassessed parameter, linear combination of unary data. (MU, \n SIGMA)'\n REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO'\n REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni'\n REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V'\n REF58 'B. Sundman, TEST'\n REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, \n TRITA-MAC 348, (1987); C-CR-FE-W'\n REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, \n TRITA 0409 (1989); CR-FE-N'\n REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO'\n REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters \n revised \n 1986 due to new decription of V) TRITA 0201 (1982); FE-V'\n ! \n \n" }, { "path": "examples/macros/steel7.TDB", "content": "\n$ Database file written 2012- 2-11\n$ From database: SSOL2 \n DATABASE_INFO about the steel1 database\n It is an extract from the SGTE SSOL2 database from 2001 for 6 elements.\n Most binary and ternary systems have been assessed and bibliographic\n references are provided. Most assessments has been made at MSE, KTH, Sweden.\n for the developent of steels.!\n$ \n ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00!\n ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00!\n ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01!\n ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01!\n ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01!\n ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01!\n \n SPECIES C1 C!\n SPECIES C2 C2!\n SPECIES C6 C6!\n SPECIES C3 C3!\n SPECIES C7 C7!\n SPECIES V1C1 V1C1!\n SPECIES C4 C4!\n SPECIES C5 C5!\n \n FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T)\n -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); \n 6.00000E+03 N !\n FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N !\n FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y\n -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N !\n FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N !\n FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7\n +GHSERFE#; 1.81100E+03 Y\n -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N !\n FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N !\n FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T)\n -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; \n 2.89600E+03 Y\n -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); \n 5.00000E+03 N !\n FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N !\n FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T)\n -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y\n -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); \n 3.60000E+03 N !\n FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 2.18300E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 4.00000E+03 N !\n FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N !\n FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N !\n FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T)\n -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y\n -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N !\n FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N !\n FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N !\n FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; \n 6.00000E+03 N !\n FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N !\n FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2\n +GHSERFE#; 1.81100E+03 Y\n -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N \n !\n FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N !\n FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N !\n FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N !\n FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T)\n -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y\n -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; \n 4.00000E+03 Y\n -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); \n 6.00000E+03 N !\n FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N !\n FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T)\n -.126431*T**2; 6.00000E+03 N !\n FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920\n -40*T; 6.00000E+03 N !\n FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T)\n +5003425*T**(-1); 6.00000E+03 N !\n FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T)\n -.0301188*T**2; 6.00000E+03 N !\n FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T)\n -.0578207*T**2; 6.00000E+03 N !\n FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N !\n FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N !\n FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N !\n FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N !\n FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N !\n FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N !\n FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N !\n FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N !\n FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N !\n FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N !\n FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N !\n FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N !\n FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N !\n FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N !\n FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N !\n FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N !\n FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N !\n FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N !\n FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N !\n FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N !\n FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N !\n FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N !\n FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N !\n FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N !\n FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N !\n FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N !\n FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N !\n FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N !\n FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N !\n FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N !\n FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N !\n FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N !\n FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N !\n FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N !\n FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N !\n FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N !\n FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N \n !\n FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N !\n FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N !\n FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 \n N !\n FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N !\n FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 \n N !\n FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 \n N !\n FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N !\n FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N \n !\n FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N !\n FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N !\n FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N !\n FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N !\n FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 \n N !\n FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 \n N !\n FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N !\n FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 \n N !\n FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N !\n FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 \n N !\n FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N !\n FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N !\n FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N !\n FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N !\n FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N !\n FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N !\n FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 \n N !\n FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 \n N !\n FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 \n N !\n FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N !\n FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 \n N !\n FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N !\n FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N !\n FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N !\n FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N !\n FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N !\n FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; \n 6.00000E+03 N !\n FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N !\n FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N !\n FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N \n !\n FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N !\n FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N !\n FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 \n N !\n FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N !\n FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N !\n FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; \n 6.00000E+03 N !\n FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N !\n FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2\n +1.14687E-12*T**3; 6.00000E+03 N !\n FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; \n 6.00000E+03 N !\n FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N !\n FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N !\n FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N !\n FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N !\n FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N !\n FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N !\n FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N !\n FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N !\n FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; \n 6.00000E+03 N !\n FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N !\n FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N !\n FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N !\n FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; \n 6.00000E+03 N !\n FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P\n +1.2675E-19*T**2*P; 6.00000E+03 N !\n FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N !\n FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N !\n FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N !\n FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; \n 6.00000E+03 N !\n FUNCTION UN_ASS 298.15 0; 300 N !\n \n TYPE_DEFINITION % SEQ *!\n DEFINE_SYSTEM_DEFAULT ELEMENT 2 !\n DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !\n\n\n PHASE SIC % 2 1 1 !\n CONSTITUENT SIC :SI : C : !\n\n PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T\n -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); \n 7.00000E+02 Y\n -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2\n +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y\n -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2\n +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 !\n\n\n TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n PHASE BCC_A2 %& 2 1 3 !\n CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : !\n\n PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC#\n +3*GPCGRA#+416000; 6.00000E+03 N REF101 !\n PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF101 !\n PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE#\n +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 !\n PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#;\n 6.00000E+03 N REF104 !\n PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC#\n +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; \n 6.00000E+03 N REF256 !\n PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N \n REF281 !\n PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N \n REF283 !\n PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF322 !\n PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N \n REF102 !\n PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N \n REF102 !\n PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF102 !\n PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF101 !\n PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; \n 6.00000E+03 N REF325 !\n PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N \n REF104 !\n PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N \n REF104 !\n PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N \n REF99 !\n PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 !\n PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N \n REF256 !\n PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 \n N REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N \n REF107 !\n PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N \n REF107 !\n PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N \n REF107 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF123 !\n PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 \n N REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N \n REF10 !\n PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N \n REF10 !\n PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; \n 6.00000E+03 N REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N \n REF98 !\n PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 \n N REF98 !\n PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 \n N REF98 !\n PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N \n REF269 !\n PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N \n REF111 !\n PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N \n REF111 !\n PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N \n REF111 !\n\n\n PHASE CEMENTITE % 2 3 1 !\n CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : !\n\n PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000\n -9.2888*T; 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N \n REF190 !\n PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000\n -57.4*T; 6.00000E+03 N REF104 !\n PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T\n -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N \n REF316 !\n PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; \n 6.00000E+03 N REF270 !\n\n\n PHASE CHI_A12 % 3 24 10 24 !\n CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : !\n\n PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR#\n +109000+123*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GCRFCC#-26000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR#\n +57300-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GFEFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO#\n +305210-270*T; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR#\n +24*GMOFCC#+100000; 6.00000E+03 N REF115 !\n PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO#\n +24*GMOFCC#+500000; 6.00000E+03 N REF213 !\n PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO#\n +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 !\n\n\n PHASE CR2VC2 % 3 2 1 2 !\n CONSTITUENT CR2VC2 :CR : V : C : !\n\n PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR#\n +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 !\n\n\n PHASE CR3SI % 2 3 1 !\n CONSTITUENT CR3SI :CR%,SI : CR,SI% : !\n\n PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR#\n +3*GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR#\n +GHSERSI#; 6.00000E+03 N REF90 !\n PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; \n 6.00000E+03 N REF90 !\n\n\n PHASE CR5SI3 % 2 5 3 !\n CONSTITUENT CR5SI3 :CR : SI : !\n\n PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T\n -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N \n REF90 !\n\n\n PHASE CR1SI1 % 2 1 1 !\n CONSTITUENT CR1SI1 :CR : SI : !\n\n PARAMETER G(CR1SI1,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T\n -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 !\n\n\n PHASE CRSI2 % 2 1 2 !\n CONSTITUENT CRSI2 :CR%,SI : CR,SI% : !\n\n PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T\n -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; \n 6.00000E+03 N REF90 !\n\n\n PHASE CUB_A13 % 2 1 1 !\n CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE DIAMOND_A4 % 1 1.0 !\n CONSTITUENT DIAMOND_A4 :C,SI% : !\n\n PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T\n -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2)\n +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 !\n PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N \n REF283 !\n\n\n TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 !\n PHASE FCC_A1 %( 2 1 1 !\n CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : !\n\n PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC#\n +GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 !\n PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T)\n -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; \n 6.00000E+03 N REF281 !\n PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 !\n PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N \n REF281 !\n PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N \n REF113 !\n PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N \n REF99 !\n PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N \n REF270 !\n PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF190 !\n PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N \n REF220 !\n PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N \n REF104 !\n PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N \n REF256 !\n PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF107 !\n PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N \n REF107 !\n PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; \n 6.00000E+03 N REF58 !\n PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; \n 6.00000E+03 N REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF98 !\n PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF269 !\n\n\n PHASE FE1SI1 % 2 .5 .5 !\n CONSTITUENT FE1SI1 :FE : SI : !\n\n PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381\n +2.22*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE2SI % 2 .666667 .333333 !\n CONSTITUENT FE2SI :FE : SI : !\n\n PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE#\n +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE4N % 2 4 1 !\n CONSTITUENT FE4N :FE : C,VA : !\n\n PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF319 !\n PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N \n REF319 !\n\n\n PHASE FE5SI3 % 2 .625 .375 !\n CONSTITUENT FE5SI3 :FE : SI : !\n\n PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI#\n -30143+.27*T; 6.00000E+03 N REF98 !\n\n\n PHASE FE8SI2C % 3 8 2 1 !\n CONSTITUENT FE8SI2C :FE : SI : C : !\n\n PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI#\n +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 !\n\n\n PHASE FECN_CHI % 2 5 2 !\n CONSTITUENT FECN_CHI :FE : C : !\n\n PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T\n -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 !\n\n\n PHASE FESI2_H % 2 .3 .7 !\n CONSTITUENT FESI2_H :FE : SI : !\n\n PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649\n -.92*T; 6.00000E+03 N REF98 !\n\n\n PHASE FESI2_L % 2 .333333 .666667 !\n CONSTITUENT FESI2_L :FE : SI : !\n\n PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE#\n +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 !\n\n\n PHASE GRAPHITE % 1 1.0 !\n CONSTITUENT GRAPHITE :C : !\n\n PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 \n N REF283 !\n\n\n TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 !\n PHASE HCP_A3 %) 2 1 .5 !\n CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : !\n\n PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504\n +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 !\n PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC#\n +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 !\n PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1)\n +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 !\n PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T)\n -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 !\n PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; \n 6.00000E+03 N REF283 !\n PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N \n REF281 !\n PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N \n REF281 !\n PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T)\n +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y\n -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N \n REF283 !\n PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; \n 5.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; \n 4.00000E+03 N REF283 !\n PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N \n REF316 !\n PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N \n REF207 !\n PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 \n N REF113 !\n PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N \n REF319 !\n PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N \n REF104 !\n PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; \n 6.00000E+03 N REF126 !\n PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; \n 6.00000E+03 N REF117 !\n PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 \n N REF117 !\n PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; \n 6.00000E+03 N REF10 !\n PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N \n REF42 !\n PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 \n N REF270 !\n\n\n PHASE KSI_CARBIDE % 2 3 1 !\n CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : !\n\n PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060\n -47.2519*T; 6.00000E+03 N REF316 !\n PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO#\n +GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 \n N REF316 !\n PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 \n N REF113 !\n\n\n PHASE LAVES_PHASE % 2 2 1 !\n CONSTITUENT LAVES_PHASE :CR,FE : MO : !\n\n PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000\n -6*T; 6.00000E+03 N REF214 !\n PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC#\n +GHSERMO#; 6.00000E+03 N REF10 !\n\n\n PHASE M23C6 % 3 20 3 6 !\n CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : !\n\n PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6#\n +.8695652*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GCRM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6#\n +.1304348*GFEM23C6#; 6.00000E+03 N REF102 !\n PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N \n REF102 !\n PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6#\n +.130435*GFEM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO#\n +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO#\n +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6#\n +.130435*GVM23C6#; 6.00000E+03 N REF323 !\n PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N \n REF323 !\n PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF322 !\n PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; \n 6.00000E+03 N REF316 !\n PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; \n 6.00000E+03 N REF324 !\n PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 \n N REF324 !\n PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N \n REF324 !\n\n\n PHASE M3C2 % 2 3 2 !\n CONSTITUENT M3C2 :CR,MO,V : C : !\n\n PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; \n 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF324 !\n PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 !\n PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 !\n\n\n PHASE M3SI % 2 3 1 !\n CONSTITUENT M3SI :FE : SI : !\n\n PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T;\n 6.00000E+03 N REF42 !\n\n\n PHASE M5C2 % 2 5 2 !\n CONSTITUENT M5C2 :FE,V : C : !\n\n PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852\n -33.7518*T; 6.00000E+03 N REF322 !\n PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T)\n +1453274*T**(-1); 6.00000E+03 N REF275 !\n\n\n PHASE M6C % 4 2 2 2 1 !\n CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : !\n\n PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR#\n +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 !\n PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO#\n +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO#\n +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 !\n PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO#\n +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 !\n PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N \n REF113 !\n\n\n PHASE M7C3 % 2 7 3 !\n CONSTITUENT M7C3 :CR%,FE,MO,V : C : !\n\n PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000\n -48.2168*T; 6.00000E+03 N REF322 !\n PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415\n +24.24*T; 6.00000E+03 N REF316 !\n PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T)\n +2148691*T**(-1); 6.00000E+03 N REF324 !\n PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N \n REF322 !\n PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N \n REF324 !\n PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N \n REF316 !\n PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N \n REF324 !\n\n\n PHASE MC_ETA % 2 1 1 !\n CONSTITUENT MC_ETA :MO% : C%,VA : !\n\n PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1)\n +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; \n 6.00000E+03 N REF113 !\n PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N \n REF104 !\n\n\n PHASE MC_SHP % 2 1 1 !\n CONSTITUENT MC_SHP :MO : C : !\n\n PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; \n 6.00000E+03 N REF104 !\n\n\n PHASE MONI_DELTA % 3 24 20 12 !\n CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+50000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+100000; 6.00000E+03 N REF132 !\n PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF133 !\n PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +100000; 6.00000E+03 N REF132 !\n\n\n PHASE MU_PHASE % 3 7 2 4 !\n CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO#\n +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO#\n +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC#\n +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO#\n +130000-100*T; 6.00000E+03 N REF115 !\n PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC#\n +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 !\n PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 \n N REF115 !\n\n\n PHASE P_PHASE % 3 24 20 12 !\n CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : !\n\n PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR#\n +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE#\n +12*GHSERMO#+111361; 6.00000E+03 N REF132 !\n PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO#\n +95573-200*T; 6.00000E+03 N REF133 !\n PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO#\n +362525-332.7*T; 6.00000E+03 N REF132 !\n\n\n PHASE R_PHASE % 3 27 14 12 !\n CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : !\n\n PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERCR#-20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO#\n +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO#\n +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC#\n +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 !\n PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO#\n -20000; 6.00000E+03 N REF115 !\n PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T\n +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 !\n\n\n PHASE LIQUID:L % 1 1.0 !\n CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : !\n\n PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; \n 6.00000E+03 N REF283 !\n PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y\n +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 \n N REF283 !\n PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T\n +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y\n +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; \n 5.00000E+03 N REF283 !\n PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T\n +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y\n +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N \n REF283 !\n PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T\n -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y\n +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y\n +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 !\n PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 \n N REF101 !\n PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 !\n PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N \n REF322 !\n PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N \n REF324 !\n PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 !\n PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 \n N REF190 !\n PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 !\n PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N \n REF190 !\n PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; \n 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N \n REF270 !\n PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N \n REF113 !\n PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 \n N REF104 !\n PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 !\n PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 \n N REF256 !\n PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 !\n PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 \n N REF107 !\n PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N \n REF323 !\n PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 \n N REF123 !\n PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 !\n PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; \n 6.00000E+03 N REF90 !\n PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 \n N REF323 !\n PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N \n REF10 !\n PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 \n N REF10 !\n PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N \n REF99 !\n PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 \n N REF99 !\n PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 !\n PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 \n N REF269 !\n PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 !\n\n\n PHASE SIGMA % 3 8 4 18 !\n CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : !\n\n PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300\n -95.96*T+GPSIG1#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC#\n +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 !\n PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC#\n +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR#\n +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 !\n PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC#\n +22*GHSERMO#; 6.00000E+03 N REF10 !\n PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV#\n +18*GHSERMO#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC#\n +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 !\n PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO#\n +18*GHSERVV#; 6.00000E+03 N REF136 !\n PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321\n -60.967*T; 6.00000E+03 N REF269 !\n PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N \n REF115 !\n PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N \n REF323 !\n PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N \n REF10 !\n PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N \n REF269 !\n\n\n TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 !\n PHASE CBCC_A12 %' 2 1 1 !\n CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : !\n\n PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; \n 6.00000E+03 N REF267 !\n PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T\n -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); \n 3.00000E+03 N REF177 !\n PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; \n 6.00000E+03 N REF275 !\n PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; \n 6.00000E+03 N REF283 !\n PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 \n N REF283 !\n PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; \n 3.60000E+03 N REF283 !\n PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 !\n PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N \n REF267 !\n PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; \n 6.00000E+03 N REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N \n REF42 !\n PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N \n REF275 !\n\n\n PHASE V3C2 % 2 3 2 !\n CONSTITUENT V3C2 :FE,V : C : !\n\n PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T)\n +779485*T**(-1); 6.00000E+03 N REF275 !\n PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV#\n +2*GHSERCC#; 6.00000E+03 N REF256 !\n\n LIST_OF_REFERENCES\n NUMBER SOURCE\n REF283 'Alan Dinsdale, SGTE Data for Pure Elements, \n Calphad Vol 15(1991) p 317-425, \n also in NPL Report DMA(A)195 Rev. August 1990'\n REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR'\n REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 \n TRITA 0237 (1984); C-FE'\n REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C\n -MO'\n REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si'\n REF256 'W. Huang, TRITA-MAC 431 (1990); C-V'\n REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, \n TRITA-MAC 411 (Rev 1989); C-FE-MN'\n REF177 'NPL, unpublished work (1989); C-Mn-Si'\n REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *'\n REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni'\n REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W'\n REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 \n TRITA 0322 (1986); CR-FE-MO'\n REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V'\n REF90 'I Ansara, unpublished work (1991); Cr-Si'\n REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 \n September 1989'\n REF319 'H. Du and M. Hillert, revision; C-Fe-N'\n REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) \n pp 2211-2223; C-Fe-Si'\n REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo'\n REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 \n TRITA 0321 (1986); C-FE-MO'\n REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W'\n REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 \n (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO'\n REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 \n TRITA 0207 (1986); C-CR-FE'\n REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V'\n REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si'\n REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of \n 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 -N, \n FE-MO-N, CR-N-W, CR-TI-N'\n REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI'\n REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI'\n REF286 'SGTE Substance database, AUG 1989.'\n REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 \n TRITA 0270 (1986); CR-FE'\n REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V'\n REF136 'Unassessed parameter, linear combination of unary data. (MU, \n SIGMA)'\n REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO'\n REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni'\n REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V'\n REF58 'B. Sundman, TEST'\n REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, \n TRITA-MAC 348, (1987); C-CR-FE-W'\n REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, \n TRITA 0409 (1989); CR-FE-N'\n REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO'\n REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters \n revised \n 1986 due to new decription of V) TRITA 0201 (1982); FE-V'\n ! \n \n" }, { "path": "examples/macros/step-epz.OCM", "content": "@$\nnew Y\n\nset echo Y\n\n@$===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ Macro showing calculation of equilibrium diagram,\n@$ paraequilibrium and tzero line for the same system\n@$\n@$ Same as TC example 23 (but not same database)\n@$\n@$ macro file at oc/oc6/\n@&\n@$===============================================================\n@$ \n\n\n@$ Use Bengt Hallstedt's special database for cast iron\n@$ Using read selected to avoid graphite and all carbides except cementite\n@$ read selected tdb ./iron4cd\n@$ fe mn c si\n\n@$ fcc bcc cementit\n\nread tdb ./iron4cd\nfe mn c si\n\n\n@$ ignore the warnings ...\n@&\n\nl sh a\n\n\n@$ Normally graphite is never formed in steel\nset st ph gra=dor\n\n@&\n@$ Conditions for a low alloyed steel\n\nset c t=1000 p=1e5 n=1 w(mn)=0.015 w(si)=.003 w(c)=.001\nc e\n\nl , 4\n\n\n@$ Set reference states for C and Fe\nset ref c gra * 1e5\n\nset ref fe bcc * 1e5\n\n@$ Set axis to calculate the equilibrium isopleth\n\nset ax 1 w(c) 0 0.02 0.0005\nset ax 2 t 750 1200 10\n\n@&\n\nmap\n\n\n@&\nplot\n\n\ntitle map Fe-Mn-Si-C Fig 1a\n\n\n@&\n@$ For plotting one can use T_C, in degrees Celsius\nplot\nw%(c)\nT_C\nscale x n 0 1\nscale y n 500 900\ntitle map-epz Fig 1b\n@$ label the FCC region\ntext \n.4\n840\n2\n0\nN\nFCC\n@$ Label the FCC+BCC+CEMENTITE\ntext\nN\n.65\n710\n.8\n2\nN\nFCC+BCC+CEMENTITE\ntext\nN\n.65\n600\n.8\n0\nN\nBCC+CEMENTITE\nout ./map-epz1\ny\n\n@$===========================================\n@$\n@$ Calculate a paraequilibrium diagram between fcc and bcc\n@$ Suspend all phases except fcc and bcc\n@$ set st ph *=sus\nset st ph fcc bcc=ent 0\n\n@$ Use \"c n\" using previous results and\n@$ to avoid creating additional composition sets\nc n\n\nl,,,,\n\n\n@$\n@&\n@$ Prepare to calculate a paraequilibrium fcc/bcc at this T\nset st ph *=sus\nset st ph fcc bcc=ent 1\n\nc n\n\nl,,,,,\n\n@&\n@$ Now calculate the para equilibrium just for C\n@$ because C can diffuse must faster than Mn and Si\ncalc para\nfcc\nbcc\nc\n\n\n@&\nl,,,,\n\n\n@$ The composition of the two phases is listed\n@$ Compare with the full equilibrium above (sometimes called ortho-equil)\n@$ Note the content of Mn and Si are the same in bcc and fcc\n@$ The Gibbs energy is higher, -43869.0 J/mol\n@$ as it is not the stable equilibrium.\n@&\n\n@$ set an axis to calculate the paraequilibrium for various T\n@$ Remove the second axis\nset ax 1 t 750 1200 5\nset ax 2 none\n\n@&\n@$ First y is to delete previous map results, \n@$ second y that we have done all necessary things\nstep para\ny\ny\nfcc\nbcc\nC\n\n\n\n@$ The step command calculates the carbon contenet\n@$ in bcc and fcc with same carbon activity and\n@$ same fractions of Mn and Si, i.e. the para-equilibrium\n@&\n\nplot\n\n\nTitle step-epz Fig 2a\n\n\n@&\n\n@$ Scale the x-axis\nplot\nw%(*,c)\nT_C\nscale x n 0 1\nscale y n 500 900\ntext\n.15\n800\n.8\n-23\nFCC paraequilibrium line\nTitle step-epz Fig 2b\n\n@$ ==============================================================\n@$ Overlay the carbon solubility curves, in fcc and bcc with the phase diagram\n@&\n@$ Append this on the previous diagram\n\nplot\n\n\napp ./map-epz1\nTitle step-epz Fig 3\nout ./epzpdpara\ny\n\n\n@$ This is the paraequilibrium lines together with the equilibrium diagram\n@$ The paraequilibrium solubility lines are inside\n@$ the stable two-phase region fcc/bcc\n\n@&\n\n@$================================================\n@$ Finally calculate the tzero line with equal\n@$ Gibbs energy for FCC and BCC\n@$ This is the limit for diffusionless transformation (martensite)\n\nl c\n\n\nc tz\nfcc\nbcc\n1\n\n@$ The last line with \"1\" means release the condition on T\n@&\n\n@$ For the tzero diagram the axis must be w(c) !!\nset ax 1 w(c) 0 .008 .0001\n\nstep tz\ny\ny\nfcc\nbcc\n\n\n\n@&\n\nplot\nw%(c)\nT_C\ntext\n.39\n620\n.8\n-33\nT-zero line\nTitle T-zero Fig 4\nout ./tzero-noG-nucleation\n\n\n@$ We have plotted the Tzero line with a label\n@$ *************************************\n\n@&\n\n@$\n@$ Now plot all together, the phase diagram,\n@$ the paraequilibrium lines and the tzero line\n\nplot\n\n\nscale x n 0 1\nscale y n 500 900\nTitle step-epz Fig 5\napp ./epzpdpara\n\n\n\n@$ This diagran gives some indication of possible transitions\n@$ because carbon can diffuse rapidly even at low T\n\n@$==========================================================================\n@$ end of step-epz macro\n@$==========================================================================\n\n\nset inter\n\n" }, { "path": "examples/macros/step-scheil.OCM", "content": "@$\n\nnew Y\n\nset echo Y\n\n@$===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step-scheil_Gulliver.OCM\n@$\n@$ Step in carbon contenr to follow T-zero line between BCC and FCC\n@$ The tzero line is the limit of diffusionless transformation\n@$ Below the tzero line FCC may transform to metastable BCC\n@$ without carbon diffusion.\n@&\n@$===============================================================\n@$ \n\nset echo\n\n\nr t ./cost507R\nal mg si zn\n\nset c t=1000 p=1e5 n=1 x(mg)=.02 x(si)=.03 x(zn)=0.02\n\nc e\n\nl,,,\n\n\n@&\n@$ Slow cooling will maintain equilibrium and can be simulated\n@$ by a step command with axis T\n\nset ax 1 t\n600\n1000\n2\n\n\nstep\n\n\n\nplot\nnp(*)\nT\ntitle step-scheil Fig 1\ntext\n.15\n830\n.8\n24\nEquilibrium liquid fraction\noutput ./equil-solidific\nY\nrender\n\n\n@$ This is a solidification assuming full equilibrium in the system\n@$ But as diffusion in the solid is slow a normal solidification\n@$ frequently create non-equilibrium structures.\n@&\n\n@$====================================\n@$ In a Scheil-Gulliver simulation the liquid is assumed to be\n@$ homogeneous and in equilibrium with the most recently formed solid.\n@$ The at each step in T the solid formed is removed\n@$ and the liquid composition modified according to the quilibrium\n@$ This means the liquid composition will vary until we reach\n@$ an invariant equilibrium where the last liquid will disappear.\n\n\nstep scheil\nY\ny\n\n\n\n\n@$ The output during the step command is temporary but indicates\n@$ how the fraction liquid and its composition changes with T.\n@&\n\n\nplot\nPFL\nT\ntitle step-scheil Fig 2\n\n@$ PFL is a special symbol for the \"phase fraction liquid\"\n@$ Which is the most interesting result of the simulation.\n@$ Note that the liquid is stable to very much lower T than\n@$ when the equilibrium is assumed. We can overlay the figures\n\n@&\n\n\n\n\n@$ set inter some plotting problems here\n@$\n@$ GNUPLOT has modified reading from datafiles with different\n@$ number od columns. The plot is not totaly coherent\n\nplot\n\n\ntitle step-scheil Fig 3\nappend ./equil-solidific.plt\n\n\n@$----------------------------------------------------------------------\n@$ With gnuplot 5.2 from 2019 there are no messages from gnuplot\n@$ but with gnuplot 6 from 2024 there are messages but the plot the same\n@$----------------------------------------------------------------------\n\n\n@&\n@$ Segregation is also important, we can plot the liquid composition\n@$ in the Scheil simulation\n\n\nplot\nx(liq,*)\nT\ntitle step-scheil Fig 4\n\n\n\n@$ and note the last liquid is 70% Zn\n@$ This can be very bad for the mechanical properties\n@$ and require complex heat treatments to homogenize the alloy\n\n\n@$==========================================================================\n@$ end of step-scheil macro\n@$==========================================================================\n\n\nset inter\n\n" }, { "path": "examples/macros/step-tzero.OCM", "content": "new Y\n\n\nset echo Y\n\n@$===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step-tzero.OCM\n@$\n@$ This example show the T limit of diffusionless transformation\n@$ from austenite (FCC) to ferrite (FCC) depending on the\n@$ alloy composition.\n@$ \n@$ This transformation is important as rapidly quenched austenite\n@$ can transform to martensite and various forms of eutectoid\n@$ structures like perlite and bainite with high strength\n@$\n@&\n@$===============================================================\n@$ \n\nset echo\n\n\nr t ./steel1\nc cr fe si\n\nset c t=1173 p=1e5 n=1 w%(c)=.3 w%(cr)=5 w%(si)=1\n\nc e\n\nl , 4\n\n\n@$ At 1173 K (900 degree C) we have only austenite (FCC)\n@&\n\nset ref fe bcc * 1e5\n\n@$ set the reference state for Fe as BCC\n\n@&\n@$\n@$ Use CALCULATE TRANSITION to find the T when BCC is formed\n@$\nc tran\nBCC\n\n\nl,,,,\n\n\n@$ We release condition 1 (T) and at 1106 K we form BCC\n@$ but also M7C3\n@$ Note the condition for T is set to the new T (1106.18 K)\n@&\n@$ At present ignore carbide formation, thus suspend all phases but FCC and BCC\nset status ph *=sus\nset status ph fcc bcc=ent 1\n\n@$ Calculate without the grid minimizer to avoid creating new composition sets\n\nc n\n\nl,,,,\n\n@$ We have now just fcc at 1106 because we have higher C content in FCC\n@&\n@$ Calculate again when BCC is formed\n\nc tran\nbcc\n\n\nl,,,,\n\n@$ The BCC is formed at 1079 when M7C3 is ignored\n@&\n@$ The T-zero line is at a carbon content in between BCC and FCC\n@$ Thus at a lower T\n\nc tzero\nFCC\nBCC\n1\n\nl,,,,\n\n\ndebug symbol T 946.4939\n\n@$ The tzero T is 946 K (673 degree C).\n@$=====================================================================\n@$ This is not an equilibrium but the limit for diffusionless transformation\n@$ from FCC to BCC\n@$=====================================================================\n@$ At this T FCC and BCC have the same Gibbs energy\n@$ at the same alloy composition.\n@&\n@$ Calculate how the TZERO temperature varies with the carbon content\n\n@$ Set the carbon content as axis\n\nset ax 1 w%(c) 0 1 .01\n\n@$ During this STEP command the C content is varied\n@$ to find the T (condition 1)\n@$ when FCC and BCC have the same Gibbs energy for the same alloy content\nstep tzero\ny\nFCC\nBCC\n1\n\n\n@&\n\nplot\nw%(c)\nT\nTitle step-tzero Fig 1\nout ./tzero-noG-nucleation\nY\n\n@&\n@$ To nucleate the BCC phase there an additional energy is needed and\n@$ we can add an estimated nucleation energy to the BCC phase\n@$\n@$ This can be achieved by adding an energy independent on composition and T\n\nenter para g(bcc,*:*) 298.15 100; 6000 N nucleation\n\n@&\n\nl phase bcc data\n\n\n@$ The parameter G(BCC,*:*) give a shift of the BCC Gibbs energy\n@$ which is independent of the composition and T\n\n@&\n@$ Now calculate the tzero T again, previous value was 946 K:\n\nl eq\n\n\nc tz\nfcc\nbcc\n1\n\n\n@$ With a 300 J/mol nucleation barrier the Tzero temperature is 873 K\n@$ lowered by about 70 degrees at this carbon content.\n\n@&\n@$ And calculate the new T-zero curve\n\nstep tz\ny\nY\nfcc\nbcc\n1\n\n\nplot\nw%(c)\nT\nTitle step-tzero Fig 2\nappend ./tzero-noG-nucleation\nscale Y N\n700\n1200\n\n\n\n@$ The second Tzero curve is lower than the first as expected\n@$ The largest difference is when the carbon content is zero.\n\n@&\n\n\nplot\nw%(c)\nT\nTitle step-tzero Fig 3\ntext .4 930 1 -30 T-zero\ntext n .4 870 1 -27 T-zero plus nucleation barrier\n\n\n@$ In this figure the curves are labelled\n@&\n@$ Finally let us verify that the Gibbs energy curves at 950 K\n@$ actually cross at at some C content.\n@$ First suspend again all other phases\n\nset status ph *=sus\n\nset st ph fcc bcc=ent 0\n\nl c\n\n@&\n\nc n\n\nl,,,,,\n\n\n@&\n\nstep sep\nY\n\n\n\n@&\n\nplot\nw%(C)\nGM(*)\nscale\nY\nN\n-6500\n-5000\nTitle step-tzero Fig 4\ntext .1 -5200 2 0 NOTE: No tie-line in the plane of the diagram!\n\n@$ We can see the Gibbs energy curves cross around w%(C)=0.3\n@$ inside the two-phase region FCC and BCC.\n\n@$ The equilibrium tie-line is not in the plane\n@$ because the alloy also has Cr and Si\n@&\n\nc e\n\nl,,,,,\n\n\n@&\n\n\n@$==========================================================================\n@$ end of step-tzero macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/step1.OCM", "content": "\nnew Y\n\nset echo Y\n\n@$ ==========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step1.OCM\n@$ Calculating property diagrams for a High Speed Steel (HSS)\n@$ ==========================================================\n@$\n@&\n\nset echo\n\nr t ./steel1\n\nset c t=1200 p=1e5 n=1 w(c)=.009 w(cr)=.045, w(mo)=.1,w(si)=.001 w(v)=.009\n\n@$ Enter a composition set for the MC carbide (FCC)\n@$ This is convenient to specify an additional pre/suffix \namend phase fcc comp_set y\nMC\n\nNONE\n<.1\nNONE\n<.1\nNONE\n>.5\n<.2\n\n@$ Set the default constitution for the FCC to be austenite\namend phase fcc default\n<.2\nNONE\n<.2\n<.1\n<.2\n<.2\n>.5\n\n@$ Enter a composition set for the M2C carbide (HCP)\namend phase hcp comp_set y M2C ,\nNONE\nNONE\nNONE\nNONE\nNONE\n>.5\n<.2\n\n@$ We will later plot the heat capacity, enter this as a\n@$ \"dot derivative\"\nent sym cp=hm.t;\n\n@&\n@$--------------------------------------------------------\n\nc e\n\nl r 1\n\n@$ Note that there are two FCC phases and the second, \n@$ with prefix MC, is a cubic carbide with mainly VC\n@&\n@$--------------------------------------------------------------\n\nl r 4\n\n@$ list the results using mass fractions\n@&\n@$ The next command will make several additional equilibrium\n@$ calculation and with +/-5% variation of the contitiona\n@$ to give an estimate the uncertainties of the result\n\nl est-acc\n\n@$ First a list of phases which are close to beoome stebl\n@$ The a list of phases if the condition is changed\n@$ Then a list of the variation of chemical potentials/RT\n@$ and the max/min values of the Gibbs energy and entropy\n@$ Finall the min/max values of the amount of each phase.\n@$ A negative value means the phase may not be stable\n\n@&\n\n@$ Now we calculate how the system changes with T\n\nset axis 1 T 800 1800 10\n\nl ax\n\n@&\n\nstep\n\n\n\n\n@$ The step command indicates whenever there is a phase change\n@&\n@$---------------------------------------------------------\n\nl line\n\n@$ Listing of all equilibria calculated by step\n@&\n\nl eq\n\n@$ list of all node points with phase changes\n@&\n@$ Plot the phase amounts\nplot\nT\nNP(*)\ntitle\nstep 1 fig 1\nrender\n\n\n@&\n@$ move the line identification (keys) outside the plot\nplot\n\n\n?\nposition outside right\n\ntext\n1200 0.6 2 0 High Speed Steel\ntitle step 1 fig 2\n@$ Change the font!\nfont\ngaramond\n16\n@$ Add symbols on lines, 1o means a symbol plotted at every 9th calculation\nextra line\n10\nrender\n\n\n@&\n@$ Plot the Cr content in all stable phases\nplot\nT\nw(*,cr)\ntitle step 1 fig 3\n@$ restore font to default\nfont\narial\n16\nrender\n\n@&\n@$ Plot the fractions in the MC_FCC phase\n@$ NOTE fractions plotted only in the stable range!!!\nplot\nT\nw(mc_fcc,*)\ntext 1000 0.2 1 0\nPlotted only in stable range of the MC carbide\ntitle step 1 fig 4\nrender\n\n\n@$ Fractions plotted only in the stable range of the MC carbide\n@&\n\n@$ Plot the fractions in the BCC phase\nplot\nT\nw(bcc,*)\ntext 1000 0.4 1 0\nPlotted in stable ranges of the bcc phase only\npos left\n\ntitle step 1 fig 5\nrender\n\n@$ NOTE fractions plotted only in the stable range!!!\n@$ I will try to add the composition as dashed i metastable range\n@&\n@$ Plot the enthalpy variation\nplot\nT\nH\ntitle step 1 fig 6\nrender\n\n\n@&\n@$ Plot the heat capacity\n@$ There is a problem with the heat capacity calculation\n@$ when there is a phase chage.\nplot\nT\ncp\ntitle step 1 fig 7\nrender\n\n@&\n@$ scaling of y axis and setting larger axis text\nplot\nT\ncp\naxis\ny\nHeat capacity J/mol/K\nscale\ny\nN\n0\n300\ntitle step 1 fig 8\n\n\n\n@$ The plotted cp include latent heat\n@&\n@$ Plotting as PDF or PNG can be done in the gnuplot window\n@$ The list the available graphic devices are redundant\n@$\n@$ enter gnu\n@$\n@$ Finally plot the driving force of all phases. Stable phases has\n@$ driving force zero, those closest to become stable are close to zero\n\nplot\n\ndgm(#)\ntitle step 1 fig 9\n\n\n\n@&\n\nplot\n\n\ntitle step1 fig 10\nscale y n\n-0.3\n0\n\nset inter\n\n\n@$ This is clearly too many phases, only a few are interesting\n@$ However, to select them we have to recalculate the step with just the phases\n@$ we think are interesting, the other set as suspended.\n@$ That means more or less all phases except the different carbides\n@$ and maybe some intermetallic phases.\n\nset stat ph *=sus\n\nset stat ph liq fcc bcc hcp m23c6 m7c3 m6c ksi m3c2 m5c2 mc_eta mc_shp=e 0\n\n@$ Note that FCC is the austenite and FCC#2 is the MC cubic carbide.\n@$ HCP is the M2C hexagonal carbide.\n\n@&\n\nl c\n\nc e\n\nl,,,,\n\n\n\n@&\n\nstep\n\n\n\n@&\n\nplot\n\ndgm(#)\n@$ Move the position of the line keys to bottom left\nposition\nbottom left\n12\n@$ Add symbols on the lines to make them easier to identify\nextra line 10\ntitle step 1 fig 11\n\n\n\n@$ There are some irregularites for the FCC phase at high T\n@$ as it switches between metallic austenite and cubic carbide phase\n\n@&\n@$ Scale up to see those closest to be stable\n\n\nplot\n\n\nscale\nY\nN\n-0.2\n0\ntitle step 1 fig 12\n\n@$ Note the DGM of the BCC phase, it is stable at high T\n@$ and comes back at low T\n\n@&\n@$ We still have the same set of stable phases\n\nplot\n\nnp(*)\ntitle step 1 fig 13\n\n\n@$==========================================================================\n@$ end of step1 macro\n@$==========================================================================\n\n\n\nset inter\n\n" }, { "path": "examples/macros/step2.OCM", "content": "new Y\n\n\nset echo Y\n\n@$ ===================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step2.COM\n@$ Calculating G curves for the phases in Ag-Cu\n@$ ===================================================================\n@&\n\nset echo\n\nr t ./agcu\n\n\n@&\n@$ --------------------------------------------------------\n\nset cond t=1000 p=1e5 n=1 x(cu)=.2\n\nc e\n\nl r 1\n\n@&\n@$ --------------------------------------------------------\n\nset ref ag fcc,,,,,\nset ref cu fcc,,,,,,\n\nset ax 1 x(cu) 0 1 ,,,\n\nl ax\n\nl sh\n\n\n@&\n@$ --------------------------------------------------------\n\n\nstep \nsep\n\n@&\n@$ --------------------------------------------------------\n@$ Plot of the Gibbe energy curves at 1000 K\n\n\nplot\nx(cu)\nG(*)\ntitle step 2 fig 1\nrender\n\n\n@&\n@$ --------------------------------------------------------\n@$ Plot of enthalpy curves for components in each phase at 1000 K\n\n\nplot\nx(cu)\nHM(*)\ntitle step 2 fig 2\nrender\n\n\n@&\n@$ plot the stability function, the lowest eigenvalue \n\nplot\nx(cu)\nQ(*)\ntitle step 2 fig 3\n\n\n\n@$ High positive values at the edges, scale !\n@&\nplot\n\n\ntitle step2 fig 4\nscale y n\n-4\n4\ntext\n.4\n-.2\n1\n0\nNegative Q means phase is unstable\nrender\n\n\n@$==========================================================================\n@$ end of step2 macro\n@$==========================================================================\n\nset inter\n" }, { "path": "examples/macros/step3.OCM", "content": "new Y\n\nset echo Y\n\n@$ ===================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step3.OCM\n@$ Calculating speciation in a gas phase and plot y, H and Cp\n@$ ===================================================================\n@&\n\nset echo\n\nr t ./hogas\n\nl d,,,,,\n\n@$ Listing of the gas data\n@$-------------------------------------------------------\n@&\n@$ Set conditions\nset c t=3000 p=1e5 n(h)=2 n(o)=1\n\nc e\n\nl,,,,,\n\n@$-------------------------------------------------------\n@&\n@$ Set T as axis\nset ax 1 t 1000 6000 25\n\nstep\n\n\n@$-------------------------------------------------------\n@$ Plot the constitution of the gas\nplot\nT\ny(gas,*)\ntitle step 3 fig 1\nrender\n\n@&\n@$-------------------------------------------------------\n@$ Move the position of the identification\nplot\n\n\nposition bottom left\n\ntitle step 3 fig 2\nrender\n\n@&\n@$-------------------------------------------------------\n@$ Plot the enthalpy content, scale the value\nplot\nT\n0.001*H\nset xax Enthalpy kJ\ntitle step 3 fig 3\nrender\n\n@&\n@$-------------------------------------------------------\n@$ Enter symbol for heat capacity and plot the heat capacity\nent symb cp=h.t;\n\nplot\nT\ncp\ntitle step 3 fig 4\nrender\n\n@&\n@$ Note the strong contribution to the heat capacity from the variation\n@$ of the constituent fractions\n@$-------------------------------------------------------\n@&\n\n\n@$==========================================================================\n@$ end of step3 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/step4.OCM", "content": "new Y\n\nset echo Y\n\n@$ ================================================================\n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ \n@$ step4.OCM \n@$ Enter data interactively and\n@$ calculate G curves in the ordered FCC in the Fe-Ni system\n@$ ================================================================\n@$\n@&\n\nset echo\n\n@$ Enter the elements and their reference states\nenter element Fe Iron BCC 55.847 0 0 \n\nenter element Ni Nickel FCC 58.69 0 0\n\n@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3\n@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are:\n@$ Fe3Ni1 -0.071689 eV for 1 atom??\n@$ Fe2Ni2 -0.138536 eV for 1 atom??\n@$ Fe1Ni3 -0.125748 eV for 1 atom??\n@$ To modify to J/mol atoms multiply with 96500\n@$ bond energy multiplied with 3, 4 and 3 respectively.\n\nenter tp-sym evtoj constant 96500\n\nenter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,,\nenter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,,\nenter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,,\n \n@$ We set a positive regular solution parameter\nenter tp-sym L0 fun 1 12000; ,,,,,\n\n@$ this is an approximate SRO contribution to the LRO phase. It is\n@$ set to about a quater of the L1_0 ordering energy, \n@$ equal to the Fe-Ni bond energy\nenter tp-sym GSRO fun 1 -0.034*evtoj;,,,,,\n\n@$ Using the partitioned model the contribition from the ordered parameters\n@$ will cancel when the phase is disordered. If we want them to contribute\n@$ we must add them to the disordered part\nenter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,,\nenter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,,\nenter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,,\n\n@$ ==================================================\n@$ This is an fcc phase with lro but no explicit sro\n@$ described with the sublattice model\nenter phase PARTITIONED_FCC \nCEF\n4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI;\n\n@&\n@$ we must add disordered set before entering parameters\namend phase part dis 4 yes\n\n@$ We do not use the F option which would reduce the number of parameters\n\nenter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test\nenter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test\nenter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test\nenter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test\nenter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test\nenter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test\nenter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test\nenter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test\nenter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test\nenter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test\nenter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test\n\nenter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test\nenter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test\nenter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test\nenter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test\nenter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test\nenter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test\n\namend biblio test VASP calculation by test;\n\n@$ These are possible disordered parameters\nenter param GD(part,Fe,Ni;0),,LD0+L0; 6000 N test\nenter param GD(part,Fe,Ni;1),,LD1; 6000 N test\nenter param GD(part,Fe,Ni;2),,LD2; 6000 N test\n\n@$ enter param GD(part,Fe,Ni;0),,+L0; 6000 N test\n\n\nlist data ,,\n\n@$ we have to create composition sets manually\n\n@$ this is by default Fe3Ni_L12\namend phase part comp-set y , ,\n<.2 >.5\n>.5 <.2\n>.5 <.2\n>.5 <.2\n\n@$ this is by default FeNi_L10\namend phase part comp-set y , ,\n<.2 >.5\n<.2 >.5\n>.5 <.2\n>.5 <.2\n\n@$ this is by default FeNi3_L12\namend phase part comp-set y , ,\n<.2 >.5\n<.2 >.5\n<.2 >.5\n>.5 <.2\n\n\nset c t=400 p=1e5 n=1 x(fe)=.3\n\nc e\n\nl r 2\n\n\n@&\n@$ Calculating the metastable regions are very sensitive to the step increment\n\nset ax 1 x(fe) 0 1 0.02\n\nstep sep\n\n\n\n\n@&\n\n\nplot\nx(ni)\nGM(*)\ntitle step 4 fig 1\n\n\n@&\n@$ the constitution of FeNi3\n\nplot\nx(ni)\ny(part#4,*)\ntitle step 4 fig 2 L1_2\n\n\n@&\nplot\n\n\ntitle step 4 fig 3 L1_2\nposition top left\n\nrender\n\n@&\n@$ The constitution of the L1_0 phase (AlNi)\nplot\n\ny(part#3,*)\ntitle step4 fig 4 L1_0\nposition top left\n\nrender\n\n@&\n@$ The calculation has sometimes failed for compositions\n@$ where the L1_2 or L1_0 ordering is not stable\n@&\n@$ ========================================================\n@$ Now something different\n@$ \n@$ During a phase field simulation one may use mole fractions\n@$ to calculate diffusion also for ordered phases. To find\n@$ how the CONSTITUTION changes in an ordered phase when\n@$ the MOLE FRACTION changes one must minimize the\n@$ Gibbs energy for that phase. \n@$ There is a special command (and subroutine) to calculate \n@$ the constitution of a phase for a given set of mole fractions\n@$ which could be useid when for a gridpoint with just one\n@$ stable phase. This command also gives the chemical potentials.\n@$\n@$ This is a way to avoid a full equilibrium calculation \n@$ but if there are two or more phases stable at the gridpoint\n@$ one must do that in order to determine the phase amounts.\n@$ However, an equilibrium calculation is sometimes needed to \n@$ find the most stable configuration ...\n@&\n@$ We use the current ordered FCC as an example, first\n@$ calculate a full equilibrium at T=400 K and x(fe)=.27\n\nl sh a\n\nset c x(fe)=.27\n\nl c\n\nc e\n\nl,,,,\n\n@$\n@$ At this composition and T we have an L1_2 ordered fcc phase\n@&\n@$ ============================================================\n@$ Now calculate for a single phase with mole fraction Fe 0.26\n\ncalc phase \npart \n1 \ny \ncon\n.26\n\n@$\n@$ Note the chemical potentials/RT above\n@$ they are different the equilibrium listing higher up\n@$ The value of G is also different but as it is divided by RT\n@$ it is not so easy to compare\n@&\n@$ If we list the full equilibrium we get a warning\n\nl,,,\n\n@$\n@$ because the constitution and composition listed is from the \n@$ single phase calculation whereas the conditions on the \n@$ composition and chemical potentials and the Gibbs energy\n@$ has not changed and are inconsistent.\n@&\n@$ If we set the condition of Fe and calculate\n\nset c x(fe)=.26\n\nc e\n\nl,,,,,\n\n@$ then we get the same chemical potentials/RT\n@&\n@$ ============================================================\n@$ Try a calculate phase with a different composition, x(fe)=.49\n@$ \ncalc phase \npart \n1 \ny \ncon\n.49\n\nl,,,\n\n@$\n@$ The phase is still L1_2 ordered as the calculation\n@$ used the previous constitution as start values. \n@$ Note the Gibbs energy/RT= -3.0747\n@&\n@$ ============================================================\n@$ To have the fcc L1_0 ordered we have to give a start constitution\n@$ NOTE it is important to start from extreme ordering\n\ncalc phase \npart \n1 \nn\n.01\n.01\n.99\n.99\ncon\n.49\n\nl,,,\n\n@$\n@$ Now the fcc phase is L1_0 ordered \n@$ and the Gibbs energy/RT is more negative, -3.1546\n@$\n@$ NOTE: If you start from a less ordered state like 0.1/0.9 \n@$ you may find a less stable L1_2 phase.\n@&\n@$ ============================================================\n@$ Calculate also setting start constitution as disordered\n\ncalc phase \npart \n1 \nn\n.5\n.5\n.5\n.5\ncon\n.49\n\nl,,,\n\n\n@$\n@$ The Gibbs energy/RT is -3.1150\n@$ so the L1_0 ordered state is more stable than the\n@$ disordered which is more stable than the L1_2\n@&\n@$ ============================================================\n@$ A full equilibrium calculation is sometimes necessary to\n@$ determine the most stable configuration of a single phase\n@$ using the grid minimizer (or manually set start constitutions)\n@$ We can check what the grid minimizer gives for x(Fe)=0.49\n\nset c x(fe)=.49\n\nc e\n\nl,,,,\n\n\n@$ But again, \n@$ sometimes one may want to use a metastable state...\n@&\n\n\n@$==========================================================================\n@$ end of step4 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/step5.OCM", "content": "new Y\n\n\nset etco Y\n\n@$ ===================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step5.OCM\n@$ Calculate y and Cp as function of T for the ordered FCC FeNi3\n@$ ===================================================================\n@&\n\nset echo\n\n@$ Enter the elements and their reference states\nenter element Fe Iron BCC 55.847 0 0 \n\nenter element Ni Nickel FCC 58.69 0 0\n\n@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3\n@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are:\n@$ Fe3Ni1 -0.071689 eV for 1 atom??\n@$ Fe2Ni2 -0.138536 eV for 1 atom??\n@$ Fe1Ni3 -0.125748 eV for 1 atom??\n@$ To modify to J/mol atoms multiply with 96500\n@$ bond energy multiplied with 3, 4 and 3 respectively.\n\nenter tp-sym evtoj constant 96500\n\nenter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,,\nenter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,,\nenter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,,\n \n@$ We can use a disordered regular solution parameter\nenter tp-sym L0 fun 1 12000; ,,,,,\n\n@$ this is an approximate SRO contribution to the LRO phase. It is\n@$ set to about a quater of the L1_0 ordering energy, \n@$ equal to the Fe-Ni bond energy\nenter tp-sym GSRO fun 1 -0.034*evtoj;,,,,,\n\n@$ Using the partitioned model the contribition from the ordered parameters\n@$ will cancel when the phase is disordered. If we want them to contribute\n@$ we must add them to the disordered part\nenter tp-sym LD0 fun 1 GA3B1+1.5*GA2B2+GA1B3+1.5*GSRO;,,,,,,\nenter tp-sym LD1 fun 1 2*GA3B1-2*GA1B3;,,,,,,\nenter tp-sym LD2 fun 1 GA3B1-1.5*GA2B2+GA1B3-1.5*GSRO;,,,,,,\n\n@$ ==================================================\n@$ This is an fcc phase with lro but no explicit sro\n@$ described with the sublattice model\nenter phase PARTITIONED_FCC \nCEF \n4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI;\n\n@&\n@$ we must add disordered set before entering parameters\namend phase part dis 4 yes\n\nenter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test\nenter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test\nenter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test\nenter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test\nenter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test\nenter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test\nenter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test\nenter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test\nenter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test\nenter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test\nenter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test\nenter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test\n\nenter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test\nenter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test\nenter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test\nenter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test\nenter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test\nenter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test\n\namend biblio test VASP calculation by test;\n\n@$ These are possible disordered parameters\nenter param GD(part,Fe,Ni;0),,LD0+L0; 6000 N test\nenter param GD(part,Fe,Ni;1),,LD1; 6000 N test\nenter param GD(part,Fe,Ni;2),,LD2; 6000 N test\n\n\nlist data ,,\n\n\n@&\n@$ set a slightly off-ideal composition as the griminimiser prefers that ...\nset c t=300 p=1e5 n=1 x(ni)=.751\n\n\n@$ To avoid confusion I do no calculate with 2 composition sets\n@$ I do not want to use the gridminimizer. If I just use \"c n\"\n\nc n\n\nl res 2\n\n\n@$ I get the disordered phase. Its G=-8089 J/mol\n@$ To set the constitution to be ordered I use the calculate phase comamnd\n\ncalc phase\npart\n1\nN\n.1\n.1\n.1\n.9\n\n@$ There should be low fraction Fe in 3 sublattices and high in the 4th\n@$ After this we can use the \"c n\" again which will start from current y\n\nc n\n\nl,,,,,\n\n@$ Now the phase is ordered with a lower G=-9858 J, 1 kJ more negative!\n\n@&\n\n@$ Set a T axis to calculate how the ordering varies wih T\n\nset ax 1 T 10 800 5\n\nstep \n\n\n\n\n@&\n\nplot\nT\ny(part,*)\ntitle step 5 fig 1\nrender\n\n\n@&\n\n@$ Plot also the heat capacity\n\nent sym cp=h.t;\n\nc sym cp\n\n@&\n\nplot\nT\ncp\ntitle step 5 fig 2a\n\n\n@&\n\n@$ We may need scaling ...\n\nplot\nT\ncp\nscale\ny\nN\n0\n10\ntitle step 5 fig 2b\nrender\n\n\n@&\n\n\n@$==========================================================================\n@$ end of step5 macro\n@$==========================================================================\n\nset inter\n\n\n\n" }, { "path": "examples/macros/step6.OCM", "content": "new Y\n\n\nset echo y\n\n@$ ==================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step6.OCM\n@$ Calculate G curves for Fe-Mo at 1400K\n@$ ==================================================================\n@&\n\nset echo\n\nr t ./steel1\nfe mo\n\n\nset c t=1400 p=1e5 n=1 x(mo)=.2\n\nc e\n\nl r 1\n\n@&\n\nset axis 1 x(mo) 0 1 .02\n\n@&\n\nset ref fe bcc ,,,,,,,\nset ref mo bcc ,,,,,,,\n\n@&\n\nstep\nsep\n\n\n\nplot\n\n\ntitle step 6 fig 1\nrender\n\n\n@&\nplot\nx(mo)\ngm(*)\nscale\ny\nN\n-5000\n1000\nposition right bottom\n\ntitle step 6 fig 2\nrender\n\n@&\n@$ Plot with wildcards on x axis and factor\n\nplot\ngm(*)\nx(mo)\ntitle step 6 fig 3\n\n\n@&\n\nplot\nx(mo)\ngm(*)\n@$ This adds a scaling factor\nextra axis\ny\n\naxis y\nGibbs energy kJ/mol\ntitle step 6 fig 4\n\n\n\n@$==========================================================================\n@$ end of step6 macro\n@$==========================================================================\n\nset inter\n\n\n" }, { "path": "examples/macros/step7.OCM", "content": "new Y\n\n\nset echo Y\n\n@$ ===========================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step7.OCM\n@$ Calculate phase fractions and other property diagrams for SAF2507\n@$ ===========================================================\n@&\n\nset echo\n\nr t ./saf2507\n\nset c t=1273.15 p=1e5 n=1 W(cr)=.25 w(ni)=.07, w(mo)=.03 w(mn)=.015 w(n)=.002\n\n@$ set c t=1273 p=1e5 n=1 x(cr)=.266 x(ni)=.066, x(mo)=.017 x(mn)=.015 x(n)=.008\n\nc e\n\nl r 1\n\nset axis 1 T 800 1800 10\n\nl ax\n\n@&\n\nstep\n\n\n\n@&\n\n\nplot\n\n\ntitle step 7 fig 1\nrender\n\n@& save plot\nplot\n\n\nposition top left \n\ntitle step 7 fig 2\nrender\n\n\n@&\n\n@$ enter symbols for the PRE (Pitting Resistance Equivalence)\n\nent sym prefcc=100*w(fcc,cr)+300*w(fcc,mo)+1600*w(fcc,n);\n\nent sym prebcc=100*w(bcc,cr)+300*w(bcc,mo)+1600*w(bcc,n);\n\n\nl sym\n@&\n@$ Sometimes a dense grid is needed here\n\nset adv grid 2\n\nset c t=1350 w(n)=.002\n\nc e\n\nl,,,,,\n\n@&\n\nset ax 1 w(n) 0 .005\n\nstep\n\n\nplot\nw%(n)\nnp(*)\ntitle step 7 fig 3\nrender\n\n@&\nplot\nw%(n)\nprefcc\nposition off\ntitle step 7 fig 4\n\n@&\nplot\nw%(n)\nprebcc\ntitle step 7 fig 5\nrender\n\n@&\n@$ step with 50% ferrite\n\nset stat ph bcc=fix 0.5\n\nset c t=none\nset c w(n)=.0002\nl c\n\n@&\n\nc e\n\nstep\n\n\n@&\n\nplot\nw%(n)\nT\ntitle step 7 fig 6\nrender\n\n@&\n\n\n@$==========================================================================\n@$ end of step7 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/step8.OCM", "content": "new Y\n\n\nset echo Y\n\n@$ =============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ step8.OCM\n@$ Adiabatic flame temperature for propane, C3H8\n@$ Also a P-V diagram for the gas\n@$ and setting various conditions like the constituent fraction in the gas\n@$ =============================================================\n@&\nset echo\n\nr t ./CHO-gas\n\n@&\n@$-------------------------------------------------------------------\n@$ A pure C3H8 gas has enthalpy content -99288 J at 300 K\n@$ adding 7 moles of O at T=300K gives an adiabatic flame T of 3071 K\n@$ remove all other phases except gas\n\nset status phase *=sus\n\nset status phase gas=ent 1\n\n@$ set c t=300 p=1e5 n(c)=3 n(h)=8 n(o)=1e-8\n\n@$ Set that the system has 1 mole C3H8\nset input n(c3h8)=1\n\nset c t=300 p=1e5 n(o)=1e-8\n\n@$ Also set the reference state of O to be gas at current T\n\nset ref O gas\n\n\n@$ We must be careful setting gas as reference state if there are\n@$ several possible species like O, O2 or O3 in this case\n@$ The program will automatically select the species (endmember) that\n@$ has the lowest Gibbs energy at the current T. At very high T\n@$ that may be O and not O2\n\nc e\n\nl,,,,\n\n@$ This is the stable state of a gas with 3 moles C and 8 moles H at 300 K\n@$ but there is no C3H8!\n@&\n@$------------------------------------------------------------\n@$ This is a rather clumsy way to calculate the enthalpy content\n@$ of a pure propane gas at 300 K\n\ncalc phase gas \n1 \nN\n0\n0\n0\n0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 \n0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 \n0 \n0\n0\n1\n,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,\n\n@$ The enthalpy content is -103711 J\n@$ We will use this enthalpy as condition and calculate\n@$ the temperature when reacting C3H8 with 7 moles of O will give\n@$ the same enthalpy content (adiabatic conditions).\n@$ N(O)=7 assumes that the product will be 3 moles C1O1 4 moles and H2O1\n@$ The enthalpy content of O2 gas at 298.15 K is 0 J by definition\n@&\n@$-------------------------------------------------------------------\n@$ We must use HS as we refer the enthalpy to 298.15 K\n\nset c HS\n-103711\n\n\nset c t=none\n\nset c n(o)=7\n\nc e\n\nl,,,,\n\n@$ The adiabatic flame temperature is 3069 K\n@$ Note the reaction to C1O1 and H2O is not complete,\n@$ there are some H2, C1O2 even H gas species\n@&\n\n@$-------------------------------------------------------------------\n@$ Check the temperature with N(O)=8\n\nset cond n(o)=8\n\nc e\n\nl,,,,,,,,\n\n@$ The temperature is now 3098 K, slightly higher.\n@$-------------------------------------------------------------------\n@&\n@$ Check how the temperature varies with N(O)\n\nset ax 1\nn(o)\n5\n15\n\n\n\n@&\n@$-------------------------------------------------------------------\nstep\n\n\nplot\nn(o)\nT\ntitle step 8 fig 1\n\n\n@$ The maximum T is about 8 moles of O\n@&\nplot\nac(o)\nT\ntitle step 8 fig 2\n\n@&\n\n@$ We can see how the T varies with the oxygen potential\n@$ It is rather constant for a large range of activities\n@$--------------------------------------------------------------------\n@$ The next plot is very messy ....\nplot\nn(o)\ny(gas,*)\nextra log\ny\ntitle step 8 fig 3\n\n\n@&\n\n@$ we can only plot the constitution of species one by one (or all)\nplot\nn(o)\ny(gas,h2o1)\ntitle step 8 fig 4\n\n\n\n@&\nplot\nn(o)\ny(gas,c1o1)\ntitle step 8 fig 5\n\n\n@&\nplot\nn(o)\ny(gas,c1o2)\ntitle step 8 fig 6\n\n\n@&\nplot\nn(o)\ny(gas,o2)\ntitle step 8 fig 7\n\n\n@&\nplot\nn(o)\ny(gas,h2)\ntitle step 8 fig 8\n\n\n@&\n@$ How the H2O1 content depend on T\nplot\nT\ny(gas,h2o1)\ntitle step 8 fig 9\n\n\n@$ ------------------------------------------------------\n@$ Finally set the chemical potential of O as condition\n@$ First change the conditions to use the current value of T=3097.67876\n@$ instead of H (open system so amount of O can change)\n\n@$ c e\n\nl,,,,,,\n\n@&\n\n@$ set c t\n\n@$ set c h=none\n\nl c\n\nc e\n\nl,,,,,,,\n\n@&\n@$ Replace N(O) by current value of AC(O)=0.19658\n@$ (referred to O2 at current T) and calculate the same equilibrium\n\nset c ac(o)\n\nset c n(o)=none\n\nl c\n\n@&\n\nc e\n\nl,,,,,,\n\n@$ We have the same equilibrium with AC(O) instead on N(O)\n@&\n@$---------------------------------------------------------\n@$ Change ac(o) to a higher value meaning more oxygen\n\nset c ac(o)=0.3\n\nc e\n\nl,,,,\n\n@$ Higher oxygen activity means more N(O), here 9.7968 moles\n@$ and lower T, 3096 K\n@$ NOTE ALSO DALTON's LAW is valid!!! The constituent fraction of O2 is 0.09\n@$ which is the square of ac(o)\n@&\n@$ Include the calculation of the driving force of graphite\n@$ by setting it as dormant\n\nset st ph gra=d\n\nc e\n\nl sh p\n\n@$ We can see graphite has very negative driving force, it is not stable\n@&\n@$---------------------------------------------------------\n@$ Set the amount of O less than 3\nset c ac(o)=none\n\nset c n(o)=2\n\nc e\n\nl,,,,,\n\n@$ Now graphite has a positive driving force, \n@$ and we have a much lower T 1204 K\n@$ We get soot and a lot of H2 gas burning C3H8 without enough oxygen\n@&\n@$ Calculate minimum O to avoid soot\n\nset st ph gra=fix 0\n\nset c n(o)=none\n\nc e\n\nl,,,,,\n\n@$ As expected we must have at least 3 moles of O (1.5 O2) to avoid soot.\n@$ and we have a low T, 1366 K, as there is a lot of H2 to burn.\n@&\n@$================================================================\n@$ Now something different again\n@$ Testing variable P and using V as condition\n@$ First set condtions using T, P and N\n@$ \nset stat ph gra=e 0\nset c h=none\n\nset c t=3000 n(o)=7\n\n@&\n\nc e\n\nl,,,,,\n\n@&\n@$ Now release P as condition at same V\n\nset c v\n\nset c p=none\n\nc e\n\nl,,,,\n\n@$ Same equilibrium with V as condition, next change V\n@& \n\nset c v=2\n\nc e\n\nl,,,,\n\n@$ With a bigger volume P has decreased to 94963 Pa\n@$ or 0.94963 bar\n@&\n\nset c v=1\n\nc e\n\nl,,,,,\n\n@$ With a smaller volume the pressure increases, P=1.8499 bar\n@$ Check Boyles law: P1V1=P2V2 (N/m2 * m3) = Nm = J\n@$ right hand side: 2*94963=189926 J\n@$ left hand side: 1*184990 Pa\n@$ It is not same because the constitution of the gas has changed!! \n@$ Increasing the pressure increases the fraction of large molecules \n@$\n@&\n@$ We can list the volume separately (unit is m3)\n\nl st v\n\n\n@$ Make a plot how P depend on V\nset ax 1 \nV\n.1\n10\n\nstep\nnormal\nY\n\n\n@&\nplot\nV\nP\ntitle step 8 fig 10\n\n\n@&\n\n@$ A nice hyperbolic curve\n@&\n\n@$ Try using logscale\nplot\nV\n1.0E-5*P\naxis yax\nbar\nextra log\ny\ntitle step 8 fig 11\n\n\n\n@&\n@$ On Linux the scaling of the P axis the automatic rage is bad\nplot\nV\n1.0E-5*P\ntitle step 8 fig 12\nscale y\nn\n0\n20\naxis yax\nbar\n\n\n@$\n@$===============================================================\n@$ Yet another test\n@&\n@$ \n@$ We can use expressions for some state variables like N(C)\n@$ try that but first rearrange the other conditions\n\nset c v=none\nset c p=1e5\n\nc e\n\nl,,,,\n\n@&\n@$\n@$ This condition means there will be a constant ratio between C and H\nset c 8*n(c)-3*n(h)=0\n\nset c n(h)=none\n\nc e\n\nl,,,,,\n\n@$ The equilibrium is the same, N(H)=8/3*N(C) !\n@&\n@$ Now increase C\n\nset c n(c)=4\n\nc e\n\nl,,,,,\n\n@$ The amount of h has also increased to keep the ratio\n@$ 3*n(c)-8*n(h)=0\n\n@&\n@$ A feature added 2019.07.22: \n@$ Setting a constituent fraction of a phase\n@$\n@$ We already have a fairly complicated set of conditions\n\nl c\n\n@&\n@$ But we may for some reason prescribe the amount of H2O molecules in\n@$ the gas (do not ask me why...)\n\nset cond y(gas,h2o1)\n\n\n@$ Note we have to specify H2O1 as there is a H2O2 molecule also!\n@$ At first just calculate with the current value, we have to remove\n@$ another condition, for example the amount of C\n\nset c n(c)=none\n\nl c\n\n@&\n\nc e\n\n@&\n\nl,,,,\n\n@$ We have just recalculated the same equilibrium with another \n@$ set of external conditions.\n@&\n@$ But now we can increase the fraction of H2O1\n\nset c y(gas,h2o1)\n0.3\n\nc e\n\n@&\n\nl,,,,\n\n\n@$ The amount of both C and H has decreased to fullfull the condition\n@$ that the fraction of H2O1 in the gas should be 0.3.\n@&\n\n@$ Playing with condition on the constitution of a phase can easily\n@$ lead to failed calculations because it may be impossible to find\n@$ an equilibrium with a specified fraction of a molecule.\n\nset c y(gas,h2o1)=0.4\n\nc e\n\n\n@$ This fails because it is impossible to have such a high fraction of H2O1\n@$ in the gas at this T\n@&\n@$ We can try with a smaller value\n\nset c y(gas,h2o1)=.01\n\nc e\n\n@&\n\nl,,,,\n\n\n@$ This works.\n@&\n@$ The amounts of both C and H has increased.\nl el\n\n@&\n\n@$ That is all for now !!\n\n@&\n\n\n@$==========================================================================\n@$ end of step8 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/step9.OCM", "content": "@$ ordering in a reciprocal system B2 with z=8 nn\n@$ Adding SRO by a T**(-1) dependent reciprocal parameter\n\nnew Y\n\nset echo Y\n\n@$===============================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$===============================================================\n\n\nenter element A A BCC 10 0 0 0\nenter element B B BCC 10 0 0 0\n\n@$ This is the bond energy. \nenter tp UAB fun 10 -250*R;,,,,,\n@$ UAB=-250*R gives T_o/d at T=1000 K without SRO\n@$ Adding UAB as a constant reciprocal parameter gives T_o/d=935\n@$ But with constant reciprocal parameter there is no SRO contribution\n@$ to Cp in disordered state. Theoretically the parameter should be\n@$ UAB*T_o/d* T**(-1), i.e. 1000*UAB*T**(-1)\n@$ But adding 1000*UAB*T**(-1) gives and a Cp in disordered state\n@$ but the disordered state becomes stable at low T as T**(-1) goes to infinity\n\n@$ To avoid this we can approximate using the T-dependence as 0.2*T_o/d + T\n@$ This decrease the Cp in the disordered state but that is anyway a small\n@$ term and considering all other approximations reasonable.\n@$\n@$ To have the value UAB at T=1000 we must use 0.2*T_o/d instead of just T_o/d\nenter tp TP1 fun 10 200+T;,,,,,\nenter tp USRO fun 10 1200*TP1**(-1);,,,,,,,,\nenter tp LSRO fun 19 UAB*USRO; ,,,,,\n\n@$ We want to plot the heat capacity\nenter symb CP=H.T;\n\n@$--------------------------\n\nenter phase B2 CEF 2 0.5 A B; 0.5 A B\n\nenter parameter G(B2,A:B) 10 4*UAB; 6000 N ref0\n\nenter parameter G(B2,B:A) 10 4*UAB; 6000 N ref0\n\n@$ This is the same as LRSO2 above 200 K, below 150 K it gives negative entropy\n@$ for the disordered phase\n@$ enter parameter G(B2,A,B:A,B) 10 1000*UAB*T**(-1); 6000 N ref0\n\nenter parameter G(B2,A,B:A,B) 10 LSRO; 6000 N ref0\n\n@$ This should give save value at 1000~K\n@$ enter parameter G(B2,A,B:A,B) 10 BAD; 6000 N ref0\n\n@&\n\nl d\n\n\n@&\n@$ First calculate the heat capacity at 50-50\nset c t=300 p=1e5 n=1 x(b)=.5\n\nc e\n\nl , 2\n\n\n\n@$ We have an ordered constitution\n@&\n@$ Set a T axis with very small step\nset ax 1 T 10 1600 2\n\nstep\n\n\nplot\nt\ncp\ntext 1000 1 1 0\nThis tail of Cp is due to SRO\ntext N\n410 3 1 60\nThis Cp comes from disappearing LRO\ntext N\n100 13.8 1 0\nSRO from reciprocal parameter\ntext N\n100 13 1 0\nL(B2,A,B:A,B)=1200*UAB/(T+200)\ntitle Step 9 fig 1\nrender\n\n@$ The tail of Cp in the disordered state comes from the T**(-1) term\n@$ in the reciprocal parameter.\n@&\n@$ Now we try to plot the 2nd order transition line\n@$ At the 2nd order transition the difference of the fractions\n@$ of the same element in the two sublattices vanishes.\n@$ We can approcimate this by having a very small difference\n\n@$ Calculate the equilibrium when we have LRO a bit off the 50-50\n\nset c t=400 x(b)=.2\n\nc e\n\nl,,,\n\n@$ We have LRO. We should decrease the difference between\n@$ the fractions of B in first and second sublattice\n@$ First replace the condition on x(b) by a difference in the\n@$ constituent fractions\n\nset c y(b2,b)-y(b2,b#2)\n\n\nset c x(b)=none\n\nc e\n\nl,,,,\n\n\n@$ We have the same equilibrium but with different conditions\n@&\n@$ Make the difference smaller, i.e. closer to order/diorder transition\n\nl c\n\n@$ set c y(b2,b)-y(b2,b#2)=.01\n@$ This rather crypric command change the value of condition 4\nset c 4:=0.01\n\nl c\n\n\n@&\n\nc e\n\nl,,,,,\n\n@$ In priciple we could also release the condition on T\n@$ but the convergence is then very bad, better to keep T constant.\n@$\n\n@$ use the save values on the T axis to calculate the 2nd order line\n@$ Start at a low value\n\n\nset c t=100\n\nc n\n\n\nstep\n\n\nplot\nx(b)\nT\ntext 0.05 900 1 0\n2nd order transition line\ntitle Step 9 fig 2\n\n\n@&\n@$ Append a 2nd order line calculated with fix USRO\n\nplot\nx(b)\nT\nappend\n./step9UAB\ntitle Step 9 fig 3\n\n\n\n@$==========================================================================\n@$ end of step9 macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "examples/macros/testcond1.OCM", "content": "@$===============================================================\n\nnew Y\n\nset echo Y\n\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ testcond1.OCM\n@$ Testing combining combination of various condition\n@$ for a ternary system C-Cr-Fe\n@$ \n@$ There is a test to calculate T-zero point\n@$\n@$ There is a test to calculate NPLE conditions\n@$\n@$ There are also tests of entering, listing\n@$ and calculating mobility data\n@$ and to calculate the Darken stability matrix \n@$ to convert these to diffusion coefficients.\n@&\n@$===============================================================\n@$ \n\nset echo\n\n\n?\n\n@$ A single ? gives the menue\n@&\n\n??\n\n@$ Two ?? opens the user guide at an approriate place\n\nr t ./steel1\n?\nc fe cr\n\n\n@$ A single ? when asked a guestion also opens the user guide\n@&\n\nset c t=2000 p=1e5 n=1 x(c)=.1 x(cr)=.1\n\nc e\n\nl,,,,,\n\n@$ Just calculate a first equilibrium and check G\ndebug symbol G -128465.6\n@&\n@$ Replace carbon mole fraction with lnac (=mu/RT)\n\nset c lnac(c)\n\nset c x(c)=none\n\nc e\n\nl,,,,\n\n@$ We have the same equilibrium with different conditions,\n@$ lnac(c)=-5.14107979\ndebug symbol lnac(c) -5.14107979\n@&\n@$----------------------------------------------\n@$ Change the value of the lnac condition\n\nset c lnac(c)=-6\n\nc e\n\nl,,,,,\n\n@$ Lower carbon activity decreases carbon content, \n@$ x(c)=.05484\n@&\n@$------------------------------------\n@$ Change to condition on mass of Cr\n\nset c b(cr)\n\nset c x(cr)=none\n\nc e\n\nl,,,,,\n\n@$ Same equilibrium with different condition\n@&\n@$ And then again with the mass fraction condition\nset c w(cr)\n\nset c b(cr)=none\n\nc e\n\nl,,,,,\n\n@$ still the same equilibrium with different conditions, \n@$ w(cr)=0.0979989 and x(cr)=0.1\n@&\n@$ Set the composition of the liquid as condition\n\nset c w(liquid,cr)\n\nset c w(cr)=none\n\nl,,,,\n\nc e\nl,,,,,\n@$ The calculated results should be identical with previous\ndebug symbol w(liquid,cr) 0.0979989293\n@&\n@$-----------------------------------------\n@$ Change the value of the mass fraction\n\nset cond w(liquid,cr)=0.1\n\nc e\n\nl,,,,,\n\n@$ Note the carbon content changes also, x(c)=.05519\n@&\n@$------------------------------------------\n@$ Now change reference state for carbon chemical potential\n\nset ref c gra * ,,,,\n\nl c\n\n@$ Note that the condition on lnac(c) does not change!!\n@&\n\nl,,,,\n\n@$ Change of reference state does not\n@$ change the condition lnac(c)=-6\n@$ but the listed value lnac(c)=-3.2347\n@&\n@$---------------------------------------------\n@$ When we calculate we get another equilibrium!\n\nc e\n\nl,,,,\n\n@$ At the calculation the conditon lnac(c)=-6 is used\n@$ Carbon content much lower as reference state is graphite,\n@$ x(c)=.00432\n@&\n@$-------------------------------------------------------\n@$ We can set back the previous (listed) chemical potential, \n@$ referred to graphite at 2000 K\nset c lnac(c)=-3.2347\n\nc e\n\nl ,,,,\n\n@$ And we get back the previous carbon content x(c)=0.05519\n@&\n@$ -------------------------------------------------------\n@$ Set graphite as fix\n\nset stat ph gra=fix 0\n\nset cond lnac(c)=none\n\nc e\n\nl ,,,,\n\n@$ The carbon activity should be unity, IT IS!!! \n@$ And the Carbon content has increased, x(c)=.26637\n@&\n@$--------------------------------------------------\n\nl r 4\n\n@$ listing also with mass fractions\n@$ Note the activity of Cr is 2.2858E-5 referred to SER\n@$ Next change reference state to BCC at current T\n@&\n@$--------------------------------------------------\n@$ set reference state for Cr\n\nset ref cr bcc * ,,,,\n\nl,,,,,\n\n@$ The new chromium activity listed is\n@$ ac(cr)=1.4341E-2 referred to BCC at 2000 K\n@$ There is a warning that conditions may be inconsistent with listing\n@&\n\nc e\n\nl,,,,,\n\n@$ But nothing changes when we calculate as Cr activity is not a condition\n@&\n@$---------------------------------------------------\n@$ Set activity of Cr as condition\n\nset c ac(cr)\n\nset c w(liquid,cr)=none\n\nl,,,,,,\n\nc e\n\nl,,,,,\n\n@$ The equilibrium is the same but with other conditions\n@$ Note we have now one single extensive condition on N=1.\n@$ All other conditions are potentials. We cannot have\n@$ all conditions as potentials. Why?\n@&\n@$---------------------------------------------------------\n@$ list the (dimensionless) driving force for BCC, \nshow dgm(bcc)\n\n@$ The value is -0.29495337, list the constitution of bcc\ndebug symbol dgm(bcc) -0.29495337\n@$\nl ph bcc\n?\n\n@&\n@$---------------------------------------------------\n@$ Increase the activity of Cr\n\nset c ac(cr)=.1\n\nc e\n\nl r 1\n\n@$ The Cr content is now x(cr)=.51629\n\nl st dgm(bcc)\n\n@$ The bcc has become less stable, -0.99442471 Why? \nl ph bcc,,,,\n\n@$ The Cr content of metastable bcc has increased !!\n@&\n@$-----------------------------------------------------------------\n@$ Now insulate the system for heat exchange\n@$ that is done by changing the condition on T to enthalpy\nset c h\n\n@$ This walue of H is referred to current reference states\n@$ but for enthalpies it is better to use SER as is result listing\n@$ That is called HS with the suffix S for SER\n\nset c hs\n\nset c t=none\n\nc e\n\nl,,,,\n\n@$ The calculated equilibrium is same as before\n@$ It is a BUG that OC does not add the suffix S for the condition on H.\n@$ That will be fixed in the future ...\n@&\n@$-----------------------------------------------------------\n@$ Increase the enthalpy, that should increase T\nset c hs\n90000\n\nc e\n\nl,,,,\n\n@$ Temperature becomes 2139.23 with this addition of heat\ndebug symbol T 2139.2273\n@&\n@$\n@$ ==============================================================\n@$\n@$ Something different\n@$ Calculate a T-zero point\n@$ where 2 phases has the same Gibbs energy\n@$\n@$ ==============================================================\n@&\n@$ First clean up the last set of conditions\n@$ Remove all condotions and make sure all phases are entered\n\nset cond *:=none\n\nl c\n\n@&\nset status phase *=ent 0\n\nl sh p\n\n@&\n@$ Set conditions for a two-phase equilibrium fcc+bcc\n\nset c t=1100 p=1e5 n=1 w%(c)=0.05 w%(cr)=5\n\nc e\n\nl,,,,\n\n@$ We have a 2-phase equilibrium between FCC and BCC\n@&\n@$ Calculate the T0 (T zero) point where FCC and BCC have the same\n@$ Gibbs energy. This is a limit for diffusionless transformation\n@$ from FCC to BCC (such as martensite)\n\ncalc ?\n\ncalc tz\n?\nfcc\nbcc\n4\n\n@$ The calculated mass percent of C at equal Gibbs energy is 0.0271\n@$ We selected conditon 4 to be varied, i.e. the mass percent of C\ndebug symbol w(c) 0.000271032666\n@$ We could also have releast condition 1, the T\n@$ But not any of the other conditions. Why?\n@&\n\nc e\n\nl,,,,\n\n@$ The stable equilibrium at the T0 point is 70% BCC and 30% FCC\n@&\n\n@$ We can instead change T to find a T0 point\n@$ First set back the carbon composition\nset c w%(c)=0.05\n\nc tz\nfcc\nbcc\n1\n\n\n@$ The T0 point is at 1077.84 K for the carbon content of 0.05.\ndebug symbol T 1077.84124\n@&\n@$\n@$ ==============================================================\n@$\n@$ Something related\n@$ Calculate NPLE (Negligible Partition Local Equilibrium)\n@$ The limit of fast FCC/BCC transformation when only carbon diffusion\n@$ and other alloying elements fractions same in both phases\n@$\n@$ ==============================================================\n@&\n@$ First clean up the last set of conditions\n@$ and suspend all phases\nset cond *:=none\nset status phase *=sus\n\n@&\n@$ Set conditions for a tie-line between FCC and BCC with\n@$ x(cr)=.2 in BCC\nset status phase fcc_a1 bcc_a2 = ent 1\nset c t=1000 p=1e5 n=1 x(c)=.02 x(bcc_a2,cr)=.2\n\nl c\n\nc e\n\nl r 1\n\n@$ This is the stable tie-line between FCC and BCC\n@$ (Ortho-equilibrium) when BCC has x(cr)=.2. FCC has less Cr \n@$ and its x(c)=.032961. Now we want to find the NPLE\n@$ composition of C in FCC (when FCC has the same Cr content\n@$ as BCC and the current chemical potential for C)\n@& \n@$--------------------------------------------------------------\n@$ To calculate this remove the bcc phase and calculate with just\n@$ the FCC with the same Cr content as bcc, x(fcc,cr)=.2 for the\n@$ same carbon activity. That is NPLE conditions for growing FCC\n\nset status phase bcc_a2=d\nset status phase fcc_a1=ent 1\nset c ac(c)\n\nset c x(c)=none x(bcc_a2,cr)=none\nset c x(fcc,cr)=.2\n\nl c \n@&\n\nc n\n\nl,,,,\n\n@$ This is the content of C in an FCC with same Cr fraction\n@$ as BCC and with the same carbon activity as the tie-line.\n@$ The carbon content in FCC is now x(c)=.030725\n@$ We are inside the two-phase region as BCC would like to be\n@$ stable (it has a small positive driving force, +4.90E-4) but\n@$ it is dormant and cannot be included in the stable phase set.\n@$ \ndebug symbol dgm(bcc) 4.8934988E-4\n@$\n@$ The calculation kindly provided by Shaojie Song\n@$ who discovered a bug!\n@$ Report one yourself and get cited!\n\n@&\n\nset inter\n\n@$ ==============================================================\n@$ \n@$ The example below does not work at present\n@$\n@$ ==============================================================\n@$ \n@$ Testing entering mobility data, list and calculate\n@$ First list all model_parameter_identifires\nl m-p-i\n\n@&\n@$ Use MQ, the values are just made up\n@$ You must specify the sublattice with the diffusing constituent\n\nenter parameter mq&c#2(fcc,fe:c) 298.15 -1000+5*T; 6000 N me\n\n@$ It is correct that you get a warning that\n@$ there is no addition handling these parameters\n@&\n\nenter parameter mq&c#2(fcc,cr:c) 298.15 -2000+7*T; 6000 N me\nenter parameter mq&c#2(fcc,fe:va) 298.15 -10000+3*T; 6000 N me\nenter parameter mq&c#2(fcc,cr:va) 298.15 -5000; 6000 N me\n\nlist ph fcc data\n\n@$\n@$ Note there are 4 parameters called MQ&C\n@&\n \nenter symbol mobc = exp(mq&c#2(fcc)/rt);\n\nl sym\n\ncal sym *\n\n@$ We cannot calculate the MOBC symbol unless the phase\n@$ has been calculated with the mobility parameters.\n@&\nl c\n\n@$ The current conditions are a bit odd, set an overall Cr and C content\n@$ and increase T\n\nset cond ac(c)=none x(fcc,cr)=none\n\nset c x(c)=.03 x(cr)=.1 t=1200\n\nc e\n\nl,,,,\n\n@&\n@$ Now we can calculate all symbols\n\ncal ph fcc ,,,,,\n\nl sym\n\ncal sym *\n\n\n@$ the value of a parameter identifier can also be obtained directly\n@$ DO NOT FORGET THE PHASE!\n\nlist model-para-val\nmq&c#2(fcc)\n\ndebug symbol mq&c#2(fcc) -5.9030928E3\n@$ The value should be -5903.0928. NOTE this is not an assessed value.\n@&\n@$ There is a command to calculate the equilibrium state of a single\n@$ adjusted to a specified compostion. This will adjust the fractions on\n@$ all sublattices to minimize the Gibbs energy for that phase.\n\ncal ph fcc\n\nY\nconst-adj\n\n\n@& \n@$ There is also a command to calculate the potential derivative\n@$ matrix (note it is symmetrical) which is needed to convert\n@$ the mobilities to diffusion coefficients. \n\ncal ph fcc\n\nY\ndiff\n\n\n\n\n@$ This command is quite powerful as it calculates the equilibrium for a\n@$ single phase (which may have the same component in several sublattices)\n@$ for a given composition and then returns\n@$ 1) The chemical potentials for the endmembers (Cr:C) (Cr:Va) (Fe:C) (Fe:VA)\n@$ (in that order)\n@$ 2) The Darken matrix for the endmembers\n@$ 3) The current mobiliy values for the components (in alphabetical order)\n@&\n@$ Just calculate the normal equilibrium\n\nc e\n\nl,,,,\n\n@$ Note that MU/RT for the 4th endmember, -5.7912, is the same as MU/RT for Fe\n@$ but not for the second (Cr) as we have defined a different reference state\n@$ The difference between the first and second is MU/RT for C\n@$\ndebug symbol mu(fe) -5.7780791E4\n@&\n@$ That is all for now\n@&\n@$==========================================================================\n@$ end of testcond1 macro\n@$==========================================================================\nset inter\n\n" }, { "path": "examples/macros/unary.OCM", "content": "@$==========================================================================\nnew Y\n\nset echo Y\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ unary.OCM\n@$ This is calculation for a single element, pure Fe\n@$ Just to check it can change stable phase \n@$ step in T and P-T diagram does not work\n@&\n@$==========================================================================\n\nr t ./steel1\nfe\n\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ list the data\nl data\n\n@$ Listing of all data above\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ Set condition to calculate an equilibrium\n\nset c t=1000 p=1e5 n=1\n\nc e\n\nl,,,,\n\n@$ At T=1000 and 1 bar BCC is stable and G=-42.2718 kJ\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\ndebug symbol G -42271.753\n@&\n\nl sh\n\n@$ A short list\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ Change condition to total mass, B, corresponding to 1 mole\n\nset c b\n\n@$ remove condition on N\nset c n=none\n\nc e\n\nl,,,,\n\n@$ Same equilibrium with B instead of N as condition\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ Change T to ensure we can change stable phase\n\nset c t=2000\nc e\nl,,,,\n\n@$ Now liquid is stable and G=-127.518 kJ\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ set condition on H and remove condition on T\n\nset c h\n\nset c t=none\n\nl c\n\nc e\n\nl,,,,\n@$ Same equilibrium with condition on H instead of T\n@$ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-\n@&\n@$ Problem combining condition on H amd B, restore condition on N\nset c N=1\nset c B=none\n\nc e\n\nl,,,\n\n@&\n@$ Change value of H and calculate the equilibrium\n\nset c h\n50000\n\nc e\n\nl,,,,\n\n@$ With this value of H we have FCC stable at 1615.28 K \ndebug symbol T 1615.2788\n@&\n@$==========================================================================\n@$ end of unary macro\n@$==========================================================================\nset inter\n" }, { "path": "examples/macros/uniquac.OCM", "content": "\nnew Y\n\nset echo Y\n\n@$==================================================================\n@$\n@$\n@$\n@&\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$ Testing the implementation of the UNIQUAC model\n@$\n@$==============================================================\n@$\n@$ UNIQUAC model based on the 1975 paper by Abrams and Prausnitz\n@$ It has a particular liquid configurational entropy term to\n@$ account for the different sizes of the aonstituents.\n@$\n@$ DATA is from 1978 Andersson and Prausnitz, part 1 and 2\n@$ Ind Eng Chem Process Des Dev Vol 17, No 4, 1978, 552-567\n@$\n@$ First part binary system acenonitrile - n_heptane\n@$\n@&\n\n@$ The molecules are entered as elements to simplify\n@$ The \"mass\" is irrelevant as no mass fraction plots\nenter element A A liquid 100 ,,,,,\n\nenter element B B liquid 100 ,,,,,\n\nenter species acetonitrile A\n\nenter species n_heptane B\n\n@$ enter species benzene C\n\n@&\n@$ The values of area \"q\" and segments \"r\" associated with the molecule\n@$ are entered as species properties\n@$ A is ACETONITRILE from 78And-part1\n@$ First value is q, second is r, values from Table 1 in 78And\namend species ACETONITRILE\n1.72\n1.87\n\n@$ B is N_HEPTANE\namend species N_HEPTANE 4.40 5.17\n\nl d\n\n@&\n@$ Thus the values below are the negative from Table 1 in 78And-part2\n@$ system 5 (Palmer 1972)\nenter tp tauAB fun 200 exp(-23.71*T**(-1)); 1000 N test\nenter tp tauBA fun 200 exp(-545.71*T**(-1)); 1000 N test\n\n@&\n@$ enter the liquid and set model to uniquac\nenter phase liquid\nuniquac\n1\n1\nacetonitrile n_heptane\n\n\n@&\n\n@$ For the residual parameters denoted tau_ji or a_ij\n@$ the constitient representing the second index \"j\"\n@$ muset be part of the parameter identifier in UQT\n\nenter param UQT&ACETONITRILE(liquid,N_HEPTANE) 200 tauAB; 700 N bosse\nenter param UQT&N_HEPTANE(liquid,ACETONITRILE) 200 tauBA; 700 N bosse\n\nset cond t=320 p=1e5 n=1 x(b)=.5\n\nc e\n\nl,,,,\n\n@&\n\n@$ enter symbols for the activity coefficients. Do not forget = !!\n\nenter symb gamma1=ac(a)/x(a);\n\nenter symb gamma2=ac(b)/x(b);\n\nshow gamma1 gamma2\n\n@&\n@$ Calculate Gibbs energy curves and other properties\n\nset ax 1 x(b)\n0\n1\n.01\n\n@$ use \"step separate\" as we have two liquids\nstep sep\n\nplot\n\ngm(*)\ntitle uniquac fig 1\n\n@$ The two minima is typical of a miscibility gasp\n@&\n\nplot\n\nmu(*)\nscale y\nn\n-10000\n600\ntitle uniquac fig 2\n\n\n@&\n@$ lnac(*) is same as mu(*)/RT\n\nplot\n\nlnac(*)\nscale y\nn\n-5\n1\ntitle uniquac fig 3\n\n\n@&\n\nplot\n\nac(*)\ntitle uniquac fig 4\n\n@&\n@$ Activity plots are nicest if one has a square diagram as all values\n@$ normally are between 0 1. We can obtain a square diagram on the screen\n@$ by changing the ratio_xy\n@$ But to have a square diagram on a PDF plot we have to modify the\n@$ GNUPLOT terminals\n\nenter gnu\n@$ There ate 5 predefined terminals, we can add one\nsquare\nY\npdf color solid size 4,4 enhanced font \"arial,16\"\npdf\n\n@$ Check the terminal you defined is there\nenter gnu\nquit\ny\n\nplot\n\n\ntitle uniquac fig 5\ngra\n6\nsquare\nY\n\n\n@$ Check that you have a pdf file \"square.pdf\" with the square diagram!\n@$ It is not exactly a square but reasonably so.\n@$ The OC logo is also a bit distorded but you can edit the square.plt file\n@&\n\n@$ Activity coefficients\nplot\n\ngamma1\ntitle uniquac fig 6\n\n@&\n\nplot\n\ngamma2\ntitle uniquac fig 7\n\n\n@&\n@$\n@$ Now calculate a binary phase diagram with the miscibility gap\n@$\n\nset ax 2 t\n270\n500\n5\n\n\nlist ax\n\n@&\n\nset c t=400\n\nc e\n\nl,,,,\n\n@&\n\nmap\n\n\nplot\n\n\ntitle uniquac fig 8\n\n@&\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$=================================================================\n@$ Now calculate a ternary\n@$\nNEW Y\n@$\n@$ We must enter the parameters again\n@$\n@$ Calculate 78And part 2: fig 4: acenonitrile - n_heptane - benzene\n@$\n@$==========================================================================\n@$ problems with the calculation of this diagram, maybe NEW is not sufficient\n@$\n\nset inter\n\n@$\n@$=================================================================\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n@$\n\nenter element A A liquid 100 ,,,,,\n\nenter element B B liquid 100 ,,,,,\n\nenter element C C liquid 100 ,,,,,\n\nenter species acetonitrile A\n\nenter species n_heptane B\n\nenter species benzene C\n\n@$ A is ACETONITRILE from 78And-part1\namend species ACETONITRILE 1.72 1.87\n\n@$ B is N_HEPTANE from 78And-part1\namend species N_HEPTANE 4.40 5.17\n\n@$ C is BENZENE from 75Abr\namend species BENZENE 2.40 3.18\n\nl d\n\n\n@&\n@$ Thus the values below are the negative from Table 1 in 78And-part2\n@$ system 5 (Palmer 1972)\nenter tp tauAB fun 200 exp(-23.71*T**(-1)); 1000 N test\nenter tp tauBA fun 200 exp(-545.71*T**(-1)); 1000 N test\nenter tp tauAC fun 200 exp(-60.28*T**(-1)); 1000 N test\nenter tp tauCA fun 200 exp(-89.57*T**(-1)); 1000 N test\nenter tp tauBC fun 200 exp(-245.42*T**(-1)); 1000 N test\nenter tp tauCB fun 200 exp(+135.93*T**(-1)); 1000 N test\n\n@&\n@$ enter the liquid phase, now with 3 constituents\nenter phase liquid\nuniquac\n1\n1\nacetonitrile n_heptane benzene\n\n\n@&\n\nl d\n\n\n@&\n\n@$ NOTE second index in tau_ji is used in parameter identifier\n@$ thus UQT&UA(LIQUID,UB) is tau_(ub,ua)\n\nenter param UQT&ACETONITRILE(liquid,N_HEPTANE) 200 tauAB; 700 N bosse\nenter param UQT&N_HEPTANE(liquid,ACETONITRILE) 200 tauBA; 700 N bosse\n\nenter param UQT&ACETONITRILE(liquid,BENZENE) 200 tauAC; 700 N bosse\nenter param UQT&BENZENE(liquid,ACETONITRILE) 200 tauCA; 700 N bosse\n\nenter param UQT&N_HEPTANE(liquid,BENZENE) 200 tauBC; 700 N bosse\nenter param UQT&BENZENE(liquid,N_HEPTANE) 200 tauCB; 700 N bosse\n\n\n@&\n\n\nl data\n\n\n@$ Check parameters OK\n@&\n@$ Set a ternary composition\n\n@$ NOTE Mapping is very sensitive to start point\nset c t=320 p=1e5 n=1 x(b)=.5 x(c)=.1\n\nc e\n\nl,,,,\n\n@$ Sometimes there are problems, if so try again ...\n\nc e\n\nl,,,,\n\n\n@$ Check result\n@$ debug symbol g -9.4475313E2\n@&\nshow g\n\n@$ set the axis for an isothermal phase diagram ...\nset ax 1 x(b) 0 1 .01\nset ax 2 x(c) 0 1 .01\n\n\nl ax\n\n@&\nmap\n\n\nplot\n\n\nextra gib y\nextra tie 5\ntitle uniquac fig 9\n\n\n@$ All well done ...\n\n\n@$==========================================================================\n@$ end of uniquac macro\n@$==========================================================================\n\nset inter\n\n" }, { "path": "linkmake", "content": "REM This file must be given the extension .cmd to be run on Windows\nREM It compiles OC with openMP amd the popup window for opening files.\n\nREM *******************************************\nREM ** OC graphics require GNUPLOT 5.2 or later\nREM *******************************************\n\ndel *.o\ndel *.mod\n\nREM tinyfiledialog files and interface\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyopen.c .\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyfiledialogs.c .\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyfiledialogs.h .\ncopy src\\utilities\\TINYFILEDIALOGS\\ftinyopen.F90 .\ngcc -c tinyopen.c\ngcc -c tinyfiledialogs.c\ngfortran -c ftinyopen.F90\ndel tinyopen.c\ndel tinyfiledialogs.c\ndel tinyfiledialogs.h\ndel ftinyopen.F90\n\nREM NEW global constants mm\ncopy src\\models\\ocparam.F90 .\ngfortran -c -O2 ocparam.F90\ndel ocparam.F90\n\nREM some utilites and the command line interface\nREM Changed to utiliy package metlib4\ncopy src\\utilities\\metlib4.F90 .\ngfortran -c -O2 -Dtinyfd metlib4.F90\ndel metlib4.F90\n\nREM some routines from LAPACK and BLAS\ncopy src\\numlib\\oclablas.F90 .\ngfortran -c -O2 oclablas.F90\ndel oclablas.F90\n\nREM some more numerical routines\nREM NEW if no external LAPACK -DNOLAPACK needed\ncopy src\\numlib\\ocnum.F90 .\ngfortran -c -DNOLAPACK -O2 ocnum.F90\ndel ocnum.F90\n\nREM the MINPACK package for least square fitting and solving nonlinear eqs.\ncopy src\\numlib\\minpack1.F90\ngfortran -c -O2 minpack1.F90\ndel minpack1.F90\n\nREM the model routines\ncopy src\\models\\gtp3*.F90 .\ngfortran -c -O2 gtp3.F90\ndel gtp3*.F90\n\nREM the equilibrium calculation routines\ncopy src\\minimizer\\matsmin.F90 .\ngfortran -c -O2 matsmin.F90\ndel matsmin.F90\n\nREM the routines diagrams using STEP or MAP\ncopy src\\stepmapplot\\smp2*.F90 .\ngfortran -c -O2 smp2.F90\ndel smp2*.F90\n\nREM the user interface\nREM set -Dqtplt to use the Qt terminal driver for screen\nREM -Dwinhlp needed for online help on Windows\ncopy src\\userif\\pmon6.F90 .\ngfortran -c -Dwinhlp pmon6.F90\ndel pmon6.F90\n\nREM First installation create the libs directory\nmkdir libs\ndel libs\\liboceq.a\n\nREM generating the library (needed also for TQ library)\nar sq libs\\liboceq.a metlib4.o oclablas.o gtp3.o matsmin.o minpack1.o ocnum.o\n\nREM What about the mod file liboceqplus.mod ?\n\nREM Add linkdate to main program\nREM New copy pmain1.F90 to pmain1-save.90 to modify linkdat, then delete it\ncopy src\\pmain1.F90 src\\pmain1-save.F90\ngfortran -o linkocdate src/linkocdate.F90\nlinkocdate\ndel src\\pmain1-save.F90\n\nREM Finally linking all together\ngfortran -o oc6A src\\pmain1.F90 pmon6.o smp2.o ftinyopen.o tinyopen.o tinyfiledialogs.o libs\\liboceq.a -lcomdlg32 -lole32\n\ncopy oc6A.exe bin\\\n\nREM *******************************************\nREM ** OC graphics require GNUPLOT 5.2 or later\nREM *******************************************\n\n" }, { "path": "linkpara", "content": "REM This file must be given the extension .cmd to be run on Windows\nREM It compiles OC with openMP amd the popup window for opening files.\n\nREM *******************************************\nREM ** OC graphics require GNUPLOT 5.2 or later\nREM *******************************************\n\ndel *.o\ndel *.mod\n\nREM tinyfiledialog files and interface\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyopen.c .\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyfiledialogs.c .\ncopy src\\utilities\\TINYFILEDIALOGS\\tinyfiledialogs.h .\ncopy src\\utilities\\TINYFILEDIALOGS\\ftinyopen.F90 .\ngcc -c tinyopen.c\ngcc -c tinyfiledialogs.c\ngfortran -c ftinyopen.F90\ndel tinyopen.c\ndel tinyfiledialogs.c\ndel tinyfiledialogs.h\ndel ftinyopen.F90\n\nREM NEW global constants mm\ncopy src\\models\\ocparam.F90 .\ngfortran -c -O2 ocparam.F90\ndel ocparam.F90\n\nREM some utilites and the command line interface\nREM Changed to utiliy package metlib4\ncopy src\\utilities\\metlib4.F90 .\ngfortran -c -O2 -Dtinyfd metlib4.F90\ndel metlib4.F90\n\nREM some routines from LAPACK and BLAS\ncopy src\\numlib\\oclablas.F90 .\ngfortran -c -fopenmp -O2 oclablas.F90\ndel oclablas.F90\n\nREM some more numerical routines\nREM NEW if no external LAPACK -DNOLAPACK neededs\ncopy src\\numlib\\ocnum.F90 .\ngfortran -c -DNOLAPACK -fopenmp -O2 ocnum.F90\ndel ocnum.F90\n\nREM the MINPACK package for least square fitting and solving nonlinear eqs.\ncopy src\\numlib\\minpack1.F90\ngfortran -c -fopenmp -O2 minpack1.F90\ndel minpack1.F90\n\nREM the model routines\ncopy src\\models\\gtp3*.F90 .\ngfortran -c -fopenmp -O2 gtp3.F90\ndel gtp3*.F90\n\nREM the equilibrium calculation routines\ncopy src\\minimizer\\matsmin.F90 .\ngfortran -c -fopenmp -O2 matsmin.F90\ndel matsmin.F90\n\nREM the routines diagrams using STEP or MAP\ncopy src\\stepmapplot\\smp2*.F90 .\ngfortran -c -fopenmp -O2 smp2.F90\ndel smp2*.F90\n\nREM the user interface\nREM set -Dqtplt to use the Qt terminal driver for screen\nREM -Dwinhlp needed for online help on Windows\ncopy src\\userif\\pmon6.F90 .\ngfortran -c -fopenmp -Dwinhlp pmon6.F90\ndel pmon6.F90\n\nREM First installation create the libs directory\nmkdir libs\ndel libs\\liboceq.a\n\nREM generating the library (needed also for TQ library)\nar sq libs\\liboceq.a metlib4.o oclablas.o gtp3.o matsmin.o minpack1.o ocnum.o\n\nREM What about the mod file liboceqplus.mod ?\n\nREM Add linkdate to main program\nREM New copy pmain1.F90 to pmain1-save.90 to modify linkdat, then delete it\ncopy src\\pmain1.F90 src\\pmain1-save.F90\ngfortran -o linkocdate src/linkocdate.F90\nlinkocdate\ndel src\\pmain1-save.F90\n\nREM Finally linking all together\ngfortran -o oc6P -fopenmp -O2 src\\pmain1.F90 pmon6.o smp2.o ftinyopen.o tinyopen.o tinyfiledialogs.o libs\\liboceq.a -lcomdlg32 -lole32\n\nREM Copy to AppData (Create first and insert in PaTH in ENVIRONMENT)\nREM copy oc6P.exe C:\\Users\\bosun\\AppData\\Local\\OC\\bin\\\nREM copy changes.txt C:\\Users\\bosun\\Documents\\ochome\\\n\n\nREM *******************************************\nREM ** OC graphics require GNUPLOT 5.2 or later\nREM *******************************************\n\n" }, { "path": "src/linkocdate.F90", "content": "program linkocdate\n! extract current date and inserts it in the source code of the main program\n character date*20,mdate*12,line*60\n call date_and_time(date)\n write(*,*)'Stored linking date: ',date\n mdate=\"'\"//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//\"'\"\n open(21,file='src/pmain1-save.F90',access='sequential',status='old')\n open(22,file='src/pmain1.F90',access='sequential',status='unknown')\n100 continue\n read(21,110,end=200)line\n k=index(line,'linkdate=')\n if(k.gt.0) then\n line(k+9:)=mdate\n endif\n write(22,110)line(1:len_trim(line))\n110 format(a)\n goto 100\n200 continue\n close(21)\n close(22)\nend program linkocdate\n" }, { "path": "src/minimizer/matsmin.F90", "content": "! Hillert's Minimizer as implemented by Sundman (HMS)\n! Based on Mats Hillert paper in Physica 1981 and Bo Janssons thesis 1984\n! Details of this implementation published in Computational Materials Science,\n! vol 101, (2015) pp 127-137\n!\n! MODULE liboceq\n!\nMODULE liboceqplus\n!\n use general_thermodynamic_package\n use minpack\n!\n! Copyright 2012-2021, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n! contact person: bo.sundman@gmail.com\n!\n!---------------------------\n!\n! To be implemented/improved\n! - calculating dot derivatives (Cp, thermal expansion etc) PARTIALLY DONE\n! - stability check (eigenvalues)\n! - conditions for properties H, V, S etc. (partially done)\n! - expressions as conditions (only for x(A) and N(A))\n! - calculate gridminimizer after equilibrium as check DONE \n! - cleanup the use of chemical potentials. DONE\n!\n!\n! For parallellization, also used in gtp3.F90\n!$ use omp_lib\n!\n implicit none\n character*8, parameter :: hmsversion='HMS-3.0'\n!\n!-------------------------------------------------------\n! for single equilibrium\n!\n! BITS in meqrec status word\n! MMQUIET means no output for the equilibrium calculation\n! MMNOSTARTVAL means grid minimizer not called at start\n integer, parameter :: MMQUIET=0, MMNOSTARTVAL=1,MMSTEPINV=2\n! NOTE in calceq7 status word is set to zero if more bits used because\n! it seemed to have an arbitrary value and it created problems in macro map7\n! I have now correceted the main reason (creating linehead records in SMP)\n! but I kept this check\n!\n!\\begin{verbatim}\n TYPE meq_phase\n! parts of the data in this structure should be in the gtp_equilibrium_data\n! it contains phase specific results from various subroutines during\n! equilibrium calculation\n! iph: phase number\n! ics: composition set number\n! idim: the dimension of phase matrix, \n! ncc: the number of constituents (same as idim??)\n! stable: is 1 for a stable phase\n! xdone: set to 1 for stoichiometric phases after calculating xmol first time\n! dormlink: link to next phase that has temporarily been set dormant\n! eec_check for equi-entropy check\n! phtupix phase tuple index\n integer iph,ics,idim,stable,ncc,xdone,dormlink,eeccheck,phtupix\n! value of phase status (-1,0=ent, 1=stable, 2=fix, -2=dorm, -3=sus, -4 hidden)\n integer phasestatus\n! inverted phase matrix\n double precision, dimension(:,:), allocatable :: invmat\n! mole fractions of components and their sum\n double precision, dimension(:), allocatable :: xmol\n double precision :: sumxmol,sumwmol\n! Derivatives of moles of component wrt all constituent fractions of the phase\n double precision, dimension(:,:), allocatable :: dxmol\n! link to phase_varres record\n TYPE(gtp_phase_varres), pointer :: curd\n! value of amount and driving force at previous iteration\n double precision prevam, prevdg\n! iteration when phase was added/removed\n integer itadd, itrem\n! chargebal is 1 if external charge balance needed, ionliq<0 unless \n! ionic liquid when it is equal to nkl(1)=number of cations\n integer chargebal,ionliq,i2sly(2)\n double precision iliqcharge,yva\n! end specific ionic liquids\n end TYPE meq_phase\n!\\end{verbatim}\n!\n!-------------------------------------------------------------------\n! \n!\\begin{verbatim}\n TYPE meq_setup\n! one structure of this type is created when an equilibrium calculation\n! is started and it holds all global data needed for handling the\n! calculation of an equilibrium. The phase specific data is in meq_phase\n! nv: initial guess of number of stable phases\n! nphase: total number of phases and composition sets\n! nstph: current number of stable phases\n! dormlink: is start of list of phases temporarily set dormant\n! noofits current number of iterations\n! status for various things\n! nrel number of elements (components)\n! typesofcond: types of conditions, =1 only massbal, =2 any conditions\n! nfixmu number of fixed chemical potentials\n! nfixph number of conditions representing fix phases\n integer nv,nphase,nstph,dormlink,noofits,status\n integer nrel,typesofcond,maxsph,nfixmu,nfixph\n! component numbers of fixed potentials, reference and value \n integer, dimension(:), allocatable :: mufixel\n integer, dimension(:), allocatable :: mufixref\n! in this array the mu value as calculated from SER is stored\n double precision, dimension(:), allocatable :: mufixval\n! in this array the mu value for user defined reference state is stored\n double precision, dimension(:), allocatable :: mufixvalref\n! fix phases and amounts\n integer, dimension(:,:), allocatable :: fixph\n double precision, dimension(:), allocatable :: fixpham\n! indices of axis conditions that has been inactivated\n! integer, dimension(:), allocatable :: inactiveaxis\n! iphl, icsl: phase and composition sets of intial guess of stable phases\n! aphl: initial guess of amount of each stable phase\n integer iphl(maxel+2),icsl(maxel+2)\n double precision aphl(maxel+2)\n! stphl: current list of stable phases, value is index in phr array\n integer, dimension(maxel+2) :: stphl\n! current values of chemical potentials stored in gtp_equilibrium_data\n! if variable T and P these are TRUE, otherwise FALSE\n logical tpindep(2)\n! these are the maximum allowed changes in T and P during iterations\n double precision tpmaxdelta(2)\n! individual phase information\n type(meq_phase), dimension(:), allocatable :: phr\n! this is used for EEC, pointer to liquid phr record and highest liquid entropy\n type(meq_phase), pointer :: pmiliq\n double precision seecliq\n! information about conditions should be stored here. Note that conditions\n! may change during STEP and MAP\n end TYPE meq_setup\n!\\end{verbatim}\n!\n!------------------------------------------------------------------\n!\n! This is a connection to step/map\n!\\begin{verbatim}\n TYPE map_fixph\n! provides information about phase sets for each line during mapping\n integer nfixph,nstabph,status\n type(gtp_phasetuple), dimension(:), allocatable :: fixph\n type(gtp_phasetuple), dimension(:), allocatable :: stableph\n! most likely some of these variables are redundant stable_phr added 2020.03.05\n integer, dimension(:), allocatable :: stable_phr\n double precision, dimension(:), allocatable :: stablepham\n! new 180814 to have nonzero fix phase amounts ... not yet used\n double precision, dimension(:), allocatable :: fixphamap\n end TYPE map_fixph\n!\\end{verbatim}\n! declared as mapfix in call to calceq7 and some other routines\n!\n! Added for debugging converge problems\n TYPE meqdebug\n integer mconverged,nvs,typ(10)\n integer :: flag=0\n double precision val(10),dif(10)\n end type meqdebug\n type(meqdebug) :: cerr\n!\n!\\begin{verbatim}\n! This is for returning the calculated value of an experimental property\n! as we need an array to store the calculated values of the experimental \n! properties in order to calculate the Relative Standarad Deviation (RSD)\n double precision, allocatable, dimension(:) :: calcexp\n! We cannot have EEC variabler here as it does bot work in parallel\n! this is for EEC test\n! type(meq_phase), pointer :: pmiliq\n! if several liquids check for largest S\n! type(meq_phase), pointer :: pmiliqsave\n! double precision eecliqentropy\n! this is set TRUE when entering meq_onephase and false after one solid checked?\n! it is now check for EEC\n! logical eecextrapol\n! This is an (failed) attempt to limit Delta-T when having condition on y\n logical ycondTlimit\n double precision deltatycond\n! TZERO, EET and PARAEQUIL calculation need these (CANNOT BE USED IN PARALLEL)\n type(gtp_equilibrium_data), pointer :: tzceq\n type(gtp_condition), pointer :: tzcond\n type(gtp_state_variable), target :: musvr,xsvr\n integer tzph1,tzph2\n! To prevent calculating a dot derivative at a given equilibrium\n integer :: special_circumstances=0\n!\\end{verbatim}\n!\n!--------------------------------------------------------------\n!\n! declared as part of phase_varres to be used in parallel\n! integer, dimension (:,:), allocatable :: phaseremoved\n! debug output indicator\n! mmdotder indicate dot derivative calculation, phase set may be different\n! from the static memory\n integer :: mmdebug=0,mmdotder=0\n! warning using B=value as condition\n logical bwarning\n!--------------------------------------------------------------\n!\n! IMPORTANT\n! phase_varres(lokcs)%amfu is the number of formula units of the phase\n! phase_varres(lokcs)%netcharge is the current total charge of the phase\n! phase_varres(lokcs)%abnorm(1) is the number of real atoms per formula unit\n! (may vary with composition like in (Fe,Cr,...)(Va,C,N,...) )\n! phase_varres(lokcs)%abnorm(2) is the mass per formula unit\n! NOTE: abnorm(1) and abnorm(2) are set by call to set_constitution\n!\nCONTAINS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calceq2(mode,ceq)\n!\\begin{verbatim}\n subroutine calceq2(mode,ceq)\n! calculates the equilibrium for the given set of conditions\n! mode=0 means no global minimization\n! ceq is a datastructure with all relevant thermodynamic data\n implicit none\n integer mode\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n TYPE(meq_setup), allocatable, target :: meqrec1\n TYPE(meq_setup), pointer :: meqrec\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n double precision starting,finish2,gtot\n integer starttid,endoftime,ij,addtuple,errall\n character name*16\n!--------------------------------\n allocate(meqrec1,stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 1: ',errall\n gx%bmperr=4370; goto 1000\n endif\n meqrec=>meqrec1\n meqrec%status=0\n if(allocated(mapfix)) deallocate(mapfix)\n call cpu_time(starting)\n call system_clock(count=starttid)\n! we may return here if gridcheck found a gridpoint below\n100 continue\n call calceq7(mode,meqrec,mapfix,ceq)\n call system_clock(count=endoftime)\n call cpu_time(finish2)\n1000 continue\n if(gx%bmperr.eq.0) then\n! Gibbs energy using SER as reference state\n call get_state_var_value('GS ',gtot,name,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n if(.not.btest(globaldata%status,GSSILENT)) then\n if(ceq%eqno.ne.1) then\n write(*,1010)ceq%eqname(1:11),meqrec%noofits,&\n finish2-starting,endoftime-starttid,gtot\n else\n write(*,1010)'Equilibrium',meqrec%noofits,&\n finish2-starting,endoftime-starttid,gtot\n endif\n1010 format(a,' result:',i4,' its, ',&\n 1pe11.4,' s, ',i6,' cc, GS=',1pe15.7,' J/mol')\n endif\n! Here we have now an equilibrium calculated. Do a cleanup of the structure\n! for phases with several compsets the call below shifts the stable one\n! to the lowest compset number unless the default constitution fits another\n! For example to ensure a fcc-carbonitrides is always the same compset.\n ij=1\n! if meqrec%status indicate no initial startvalues set ij<0 to indicate test\n! DO not test if mode=0\n if(mode.ne.0 .and. btest(meqrec%status,MMNOSTARTVAL)) ij=-ij\n! OC went into a loop for a complex alloy calcumation here (once long ago ...)\n! write(*,*)'MM calling todo_after: 2',&\n! btest(meqrec%status,MMNOSTARTVAL),mode\n call todo_after_found_equilibrium(ij,addtuple,ceq)\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4358) then\n! gridpoint below current equilibrium found and set as stable (maybe new\n! composition set). Recalculate\n gx%bmperr=0\n write(*,*)'MM recalculating with this phase as stable 2: ',addtuple\n goto 100\n endif\n endif\n! write(*,*)'MM back in calceq2 after todo_after'\n endif\n!CCI\n! save the number of iterations needed to calculate the equilibrium\n ceq%conv_iter=meqrec%noofits\n! maybe memory leak 2\n! write(*,*)'MM deallocate 2'\n deallocate(meqrec1)\n! write(*,*)'MM deallocated meqrec1'\n return\n end subroutine calceq2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calceq3\n!\\begin{verbatim} %-\n subroutine calceq3(mode,confirm,ceq)\n! calculates the equilibrium for the given set of conditions\n! mode=0 means no global minimization\n! confirm is TRUE if output of CPU time\n! ceq is a datastructure with all relevant thermodynamic data\n implicit none\n integer mode\n logical confirm\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(meq_setup), allocatable, target :: meqrec1\n TYPE(meq_setup), pointer :: meqrec\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n double precision starting,finish2\n integer starttid,endoftime,ij,addtuple,errall\n!--------------------------------\n allocate(meqrec1,stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 2: ',errall\n gx%bmperr=4370; goto 1000\n endif\n meqrec=>meqrec1\n meqrec%status=0\n if(.not.confirm) meqrec%status=ibset(meqrec%status,MMQUIET)\n if(allocated(mapfix)) deallocate(mapfix)\n! nullify(mapfix)\n call cpu_time(starting)\n call system_clock(count=starttid)\n! we may return here if gricheck found a new phase stable\n100 continue\n call calceq7(mode,meqrec,mapfix,ceq)\n call system_clock(count=endoftime)\n call cpu_time(finish2)\n1000 continue\n if(gx%bmperr.eq.0) then\n! Here we have now an equilibrium calculated. Do a cleanup of the structure\n! for phases with several compsets the call below shifts the stable one\n! to the lowest compset number unless the default constitution fits another\n! For example to ensure a fcc-carbonitrides is always the same compset.\n ij=1\n! if meqrec%status indicate no initial startvalues set ij<0 to indicate test\n if(mode.ne.0 .and. btest(meqrec%status,MMNOSTARTVAL)) ij=-ij\n! write(*,*)'MM Calling todo_after calceq3'\n call todo_after_found_equilibrium(ij,addtuple,ceq)\n if(gx%bmperr.eq.4358) then\n! gridcheck after found a new phase stable! recalculate\n gx%bmperr=0\n! write(*,*)'MM recalculate with new phase added as stable 3:',addtuple\n goto 100\n endif\n if(confirm) then\n write(*,1010)meqrec%noofits,finish2-starting,endoftime-starttid\n1010 format('Equilibrium calculation ',i4,', its, ',&\n 1pe12.4,' s and ',i7,' clockcycles')\n endif\n elseif(confirm) then\n write(*,1020)gx%bmperr\n1020 format('Error return from equilibrium calculation ',i5)\n endif\n! CCI save the number of iterations to calculate the equilibrium\n ceq%conv_iter=meqrec%noofits\n! memory leak 2\n! write(*,*)'MM deallocate 3'\n deallocate(meqrec1)\n! write(*,*)'MM deallocated'\n return\n end subroutine calceq3\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calceq7\n!\\begin{verbatim}\n subroutine calceq7(mode,meqrec,mapfix,ceq)\n! calculates the equilibrium for the given set of conditions\n! mode=0 means no global minimization\n! mode=-1 means used during step/map, no gridmin and do not deallocate phr\n! ceq is a datastructure with all relevant thermodynamic data\n! calling this routine instead of calceq2 makes it possible to extract\n! additional information about the equilibrium from meqrec.\n! Meqrec is also used for calculation of derivatives of state vatiables\n implicit none\n integer mode\n TYPE(meq_setup), pointer :: meqrec\n type(map_fixph), allocatable :: mapfix\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_condition), pointer :: condition,lastcond\n! conditions on T and P and mole fractions of components\n double precision, dimension(2) :: tpval\n double precision, dimension(maxel) :: xknown,vmu\n! antot is total number of moles of atoms. Needed to scale results from\n! gridmin which assumes 1 mole of atoms\n double precision xxx,antot,cvalue,ccf(5)\n logical gridtest,formap\n! for global minimization (change maybe to allocate dynamically)\n integer, dimension(maxph) :: nyphl\n double precision, dimension(maxconst) :: yarr\n integer np,iph,ics,jph,lokph,lokcs,mode2,errall\n integer mostcon,mph,nvf,mostconph(2,maxel),icc,jcc\n! max number of potential conditions\n integer, parameter :: mmu=20\n! dimension cmix(22) allows 5 terms: 2+4*5 \n integer mjj,ij,cmix(22),cmode,mufixel(mmu),mufixref(mmu),errout\n integer fixph(2,maxel),oldorder(mmu),kst,jj\n! just for debugging\n! integer idum(1000)\n double precision fixpham(maxel),sumnp,props(5)\n logical ycond\n integer jq,ntup,saverr\n! character statevar*40\n!\n ntup=nooftup()\n! write(*,*)'MM in calceq7',ntup\n ycond=.FALSE.\n! this will be set to false when warning shown once for each calculation\n bwarning=.TRUE.\n if(btest(globaldata%status,GSSILENT)) &\n meqrec%status=ibset(meqrec%status,MMQUIET)\n if(ocv()) write(*,*)\"Entering calceq7\",mode\n errout=0\n! clear bit that start values has not been calculated\n meqrec%status=ibclr(meqrec%status,MMNOSTARTVAL)\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4203 .or. gx%bmperr.eq.4204) then\n! this means system matrix error and too many iterations respectivly\n write(kou,3)gx%bmperr\n3 format('Error code ',i5,' reset before calling global minimizer')\n gx%bmperr=0\n errout=kou\n else\n write(kou,*)'Error code ',gx%bmperr,' prevents using global minimizer'\n goto 1000\n endif\n endif\n if(mode.ge.0) then\n mode2=mode\n formap=.FALSE.\n else\n! formap .TRUE. means that phr will not be deallocated\n! and that phr(jj)%phasestatus will be set from meqrec%fixph ....\n mode2=0\n formap=.TRUE.\n endif\n! skip this if mode=-1, we may not have degrees of freedom equal to zero\n! as the fix phase is not stored as condition ...\n if(mode.ge.0) then\n!---------------------------\n! extract conditions\n call extract_massbalcond(tpval,xknown,antot,ceq)\n! write(*,7)'MM xk: ',gx%bmperr,(xknown(mjj),mjj=1,noel())\n7 format(a,i5,9(F8.4))\n if(gx%bmperr.ne.0) then\n! error 4143 means no conditions, 4144 wrong number of conditions\n if(gx%bmperr.eq.4143 .or. gx%bmperr.eq.4144) then\n! write(*,*)'Degrees of freedom not zero',gx%bmperr\n goto 1000\n endif\n! 4151 not only massbalance conditions\n! if(gx%bmperr.eq.4151) goto 1000\n! these are other errors that makes it impossible to use gridminimizer\n! if(gx%bmperr.eq.4173 .or. &\n! gx%bmperr.eq.4174 .or. &\n! (gx%bmperr.ge.4176 .and. gx%bmperr.le.4185)) goto 1000\n! if mode=0 we should not use grid minimizer\n! if(mode.ne.0 .or. .not.btest(meqrec%status,MMQUIET)) &\n if(mode.ne.0 .and. .not.btest(meqrec%status,MMQUIET)) &\n write(*,9)\n9 format('Warning: global minimizer cannot be used for the current',&\n ' set of conditions')\n gx%bmperr=0\n gridtest=.true.\n meqrec%typesofcond=2\n else\n! meqrec%antot=antot\n! no need for final grid minimizer as we will do one as start\n gridtest=.false.\n meqrec%typesofcond=1\n endif\n! write(*,*)'MM checked massbalance'\n if(ocv()) write(*,*)'MM checked massbalance'\n!------------------------------------\n endif\n! write(*,*)'In Calceq7 2'\n meqrec%nrel=noel()\n! set some initial values\n meqrec%maxsph=noel()+2\n meqrec%nfixph=0\n meqrec%nfixmu=0\n meqrec%tpindep=.TRUE.\n! limit change in T and P. For P it should be a factor ...\n meqrec%tpmaxdelta(1)=2.0D2\n meqrec%tpmaxdelta(2)=1.0D2\n! now we calculate maxsph, nfixmu and maybe other things for later\n lastcond=>ceq%lastcondition\n if(.not.associated(lastcond)) then\n! write(*,*)'No conditions'\n gx%bmperr=4143; goto 1000\n endif\n condition=>lastcond\n cmix=0\n np=0\n mjj=0\n! set default values\n! write(*,69)tpval,ceq%tpval\n!69 format('T&P: ',4(1pe12.4))\n tpval(1)=ceq%tpval(1)\n tpval(2)=ceq%tpval(2)\n ceq%rtn=globaldata%rgas*tpval(1)\n!---------------- loop\n! loop through all conditions, end when the pointer condition is empty\n! loop to investigate conditions, apply_condition:value in gtp3D.F90\n70 continue\n! comode=-1 means just check type of condition\n! NOTE SPECIAL: condition on Y returns cmix(1)=6 to inhibit grid minimizer\n cmode=-1\n condition=>condition%next\n mjj=mjj+1\n if(ocv()) write(*,*)'check condition'\n! a condtion can have several terms, ccf is coefficient for each term, \n! if just one term ccf (is assumed?) to be 1.0\n call apply_condition_value(condition,cmode,cvalue,cmix,ccf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,71)'MM apply 1: ',cmode,cvalue,cmix,ccf(1)\n!71 format(a,i3,1pe14.4,10i4/12i4,1pe12.4)\n!71 format(a,i3,1pe14.4,10i4/5(1pe12.4))\n! cmix(1)=0 for inactive conditions\n! cmix(1)=1 fix T, =2, fix P, =3 fix MU/AC/LNAC, =4 fix phase, =5 anything else\n! if condition on T, P, potential or fix phase reduce maxsph\n select case(cmix(1))\n case default\n if(.not.associated(condition,lastcond)) goto 70\n case(1) ! fix T\n if(cvalue.le.1.0D-2) then\n write(*,*)'Condition on T must be larger than 0.01 K'\n gx%bmperr=4187; goto 1000\n endif\n meqrec%maxsph=meqrec%maxsph-1\n meqrec%tpindep(1)=.FALSE.\n ceq%tpval(1)=cvalue\n case(2) ! fix P\n if(cvalue.le.1.0D-2) then\n write(*,*)'Condition on P must be larger than 0.01 Pa'\n gx%bmperr=4187; goto 1000\n endif\n meqrec%maxsph=meqrec%maxsph-1\n meqrec%tpindep(2)=.FALSE.\n ceq%tpval(2)=cvalue\n!-------------------------\n case(3) ! (MU,AC,LNAC) in cmix(2)=3,4,5\n! The component is in cmix(3) and reference state in cmix(4)\n! Handling of the reference state ignored at present\n np=np+1\n if(np.gt.mmu) then\n write(*,*)'Max conditions on potentials is ',mmu\n gx%bmperr=4189; goto 1000\n endif\n mufixel(np)=cmix(3)\n mufixref(np)=cmix(4)\n! temporarily use yarr for something else\n if(cmix(2).eq.3) then\n! Divide MU by RT\n yarr(np)=cvalue/ceq%rtn\n elseif(cmix(2).eq.4) then\n! AC=exp(MU/RT) converted to chemical potential/RT\n if(cvalue.le.zero) then\n write(*,*)'Conditions on activity must be larger than zero'\n gx%bmperr=4191; goto 1000\n endif\n yarr(np)=LOG(cvalue)\n else\n! LNAC=MU/RT which is the value used during minimization\n yarr(np)=cvalue\n endif\n! write(*,*)'Chemical potential condition: ',yarr(np)\n meqrec%maxsph=meqrec%maxsph-1\n! write(*,72)'MM, chemp: ',cmix(1),cmix(2),cmix(3),cvalue\n!72 format(a,3i3,1pe12.4)\n!-------------------------\n case(4) ! fix phase\n! cmix(2) is phase index; cmix(2) is composition set\n meqrec%nfixph=meqrec%nfixph+1\n fixph(1,meqrec%nfixph)=cmix(2)\n fixph(2,meqrec%nfixph)=cmix(3)\n fixpham(meqrec%nfixph)=cvalue\n! write(*,*)'Fix phase condition: ',cmix(2),cmix(3),cvalue\n! debug output of fix phase composition\n! call calc_phase_mol(cmix(1),yarr,ceq)\n case(5) ! mass balance condition\n! write(*,*)'MM cmix(1..4): ',cmix(1),cmix(2),cmix(3),cmix(4)\n case(6) ! Condition on Y, no grid minimizer\n ycond=.TRUE.\n! write(*,*)'MM condition on Y inhibit grid minimizer!'\n end select !-----------------------------------------------\n if(.not.associated(condition,lastcond)) goto 70\n! end loop of conditions\n!--------------------------------------------------------------\n! write(*,*)'variable potentials, max variable phases: ',&\n! noel()-cmix(2),meqrec%maxphases\n meqrec%nfixmu=np\n if(np.gt.0) then \n! number of fixed chemical potentials\n if(.not.allocated(meqrec%mufixel)) then\n allocate(meqrec%mufixel(np),stat=errall)\n allocate(meqrec%mufixref(np),stat=errall)\n allocate(meqrec%mufixval(np),stat=errall)\n allocate(meqrec%mufixvalref(np),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 3: ',errall\n gx%bmperr=4370; goto 1000\n endif\n else\n! this can happen if activity condition and calculating without gridmin\n! write(*,*)'Warning: meqrec has already mufixel allocated!'\n write(*,'(\"MM Calculate with activity condition\")')\n endif\n if(np.gt.1) then\n! sort components with fix MU in increasing order to simplify below\n call sortin(mufixel,np,oldorder)\n do mjj=1,np\n nvf=mufixel(mjj)\n meqrec%mufixel(mjj)=nvf\n meqrec%mufixref(mjj)=mufixref(oldorder(mjj))\n meqrec%mufixval(mjj)=yarr(oldorder(mjj))\n meqrec%mufixvalref(mjj)=yarr(oldorder(mjj))\n! copy fixed chemical potential (divided by RT) to ceq%cmuval also\n ceq%cmuval(nvf)=yarr(oldorder(mjj))\n! in the component records multiply with RT\n ceq%complist(nvf)%chempot(1)=yarr(oldorder(mjj))*ceq%rtn\n enddo\n else\n nvf=mufixel(1)\n meqrec%mufixel(1)=nvf\n meqrec%mufixref(1)=mufixref(1)\n meqrec%mufixval(1)=yarr(1)\n meqrec%mufixvalref(1)=yarr(1)\n! also copy fixed chemical potential to ceq%cmuval\n ceq%cmuval(nvf)=yarr(1)\n ceq%complist(nvf)%chempot(1)=ceq%cmuval(nvf)*ceq%rtn\n endif\n endif\n if(meqrec%nfixph.gt.0) then\n! allocate 5 extra places for fix phase during mapping ...\n if(.not.allocated(meqrec%fixph)) then\n! write(*,*)'Allocate meqrec%fixph'\n allocate(meqrec%fixph(2,meqrec%nfixph+5),stat=errall)\n allocate(meqrec%fixpham(meqrec%nfixph+5),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 4: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! write(*,*)'Allocated meqrec%fixph'\n endif\n if(np.gt.1) then\n! ?? sort phases in increasing order to simplify below\n write(*,*)'MM Cannot handle two fix phases ... '\n gx%bmperr=4192; goto 1000\n endif\n do mjj=1,meqrec%nfixph\n meqrec%fixph(1,mjj)=fixph(1,mjj)\n meqrec%fixph(2,mjj)=fixph(2,mjj)\n meqrec%fixpham(mjj)=fixpham(mjj)\n enddo\n else\n! allocate 5 places for fix phase during mapping (one per axis)\n if(.not.allocated(meqrec%fixph)) then\n allocate(meqrec%fixph(2,5),stat=errall)\n allocate(meqrec%fixpham(5),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 5: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n endif\n!----------------------------\n! call list_conditions(kou,ceq)\n! skip if mode2=0 or global gridminimizer if bit set\n! write(*,*)'In Calceq7 4'\n if(mode2.eq.0 .or. btest(globaldata%status,GSNOGLOB)) then\n! if errout set then grimin probably called to handel bad start point\n if(errout.eq.0) goto 110\n! write(*,*)'errout 2: ',errout\n endif\n! skip global gridminimizer if only one component but make sure one phase\n! has positive amount\n if(meqrec%nrel.eq.1) then\n goto 110\n endif\n! skip global minimizer if ycond is true\n if(ycond) then\n! write(*,*)'MM condition on y(phase,const), no global minimizer'\n goto 110\n endif\n!---------------------------------------------------------------\n! Try global gridminimization. Returned values are:\n! nv is number of stable phase, iphl, icsl list of stable phases, aphl amounts\n! nyphl(j) is number of constituent fractions in phase j, yarr are the \n! constituent fractions, vmu the chemical potentials\n! THIS CALL MAY CREATE NEW COMPOSITION SETS unless GSNOACS set.\n! loop through all phases and set amount=0 and CSABLE off\n ij=1\n call todo_before(ij,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(meqrec%typesofcond.eq.1) then\n! with only massbalance condition make a global grid minimization\n! call global_gridmin(1,tpval,xknown,meqrec%nv,&\n! meqrec%iphl,meqrec%icsl,meqrec%aphl,nyphl,yarr,vmu,idum,ceq)\n! write(*,*)'MM calling global gridmin'\n call global_gridmin(1,tpval,xknown,meqrec%nv,&\n meqrec%iphl,meqrec%icsl,meqrec%aphl,nyphl,vmu,ceq)\n if(ocv()) write(*,*)'MM back from gridmin'\n! write(*,*)'MM back from gridmin'\n if(gx%bmperr.ne.0) then\n! if global fails reset error code and try a default start set of phases\n! if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n! write(*,102)gx%bmperr,trim(bmperrmess(gx%bmperr))\n!102 format('Error ',i5,': ',a/&\n! 'Minimizer tries using current or default start values')\n! write(kou,102)gx%bmperr,bmperrmess(gx%bmperr)\n! write(kou,102)bmperrmess(gx%bmperr)\n!102 format(a/'Current constitution used as start values.')\n! else\n! write(kou,113)gx%bmperr \n!113 format('Cannot use grid minimazer, error: ',i5/&\n! 'Current constitution used as start values.')\n! endif\n! no initial gridmin, make a gridtest at the end (not implemented ...)\n! else\n! write(*,*)'Grid minimizer cannot be used with these conditions'\n! endif\n! set that grid minimizer is called after the equilibrium calculation\n gridtest=.true.\n! problems using gridmin\n! use current constitution or set default constitution (does not work well)\n gx%bmperr=0; goto 110\n endif\n! multiply phase amounts with antot as global_grimin assumes 1 mole\n if(abs(antot-one).gt.1.0D-8) then\n! write(*,*)'From gridmin: ',meqrec%nv,antot\n do mph=1,meqrec%nv\n call get_phase_compset(meqrec%iphl(mph),meqrec%icsl(mph),&\n lokph,lokcs)\n ceq%phase_varres(lokcs)%amfu=antot*ceq%phase_varres(lokcs)%amfu\n enddo\n endif\n if(ocv() .or. errout.gt.0) &\n write(*,103)(meqrec%iphl(mjj),meqrec%icsl(mjj),meqrec%aphl(mjj),&\n mjj=1,meqrec%nv)\n103 format('Phases: ',12(i3,i2,F5.2))\n goto 200\n endif\n!--------------------\n! no global gridmin or we come here if gridtest finds a new stable phase\n! UNFINISHED: A better start guess should be made!!!\n!\n110 continue\n! write(*,*)'starting without gridmin',errout\n meqrec%nv=0\n! at least one phase must be stable\n mostcon=0\n mostconph=0\n mph=0\n jph=0\n sumnp=zero\n selph1: do iph=1,noph()\n selcs1: do ics=1,noofcs(iph)\n kst=test_phase_status(iph,ics,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! new: -4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\n! skip loop selph1 for phases that are dormant or suspended\n if(kst.le.PHDORM) then\n if(ics.lt. noofcs(iph)) then\n cycle selcs1\n else\n cycle selph1\n endif\n endif\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(ceq%phase_varres(lokcs)%amfu.gt.zero) then\n meqrec%nv=meqrec%nv+1\n meqrec%iphl(meqrec%nv)=iph\n meqrec%icsl(meqrec%nv)=ics\n meqrec%aphl(meqrec%nv)=ceq%phase_varres(lokcs)%amfu\n sumnp=sumnp+ceq%phase_varres(lokcs)%amfu\n endif\n enddo selcs1\n! select the phases with most constituents\n call get_phase_variance(iph,nvf)\n if(mostcon.eq.0) then\n mostcon=mostcon+1\n mostconph(1,1)=nvf\n mostconph(2,1)=iph\n else\n! very very clumsy\n do icc=1,mostcon\n if(nvf.le.mostconph(1,icc)) then\n if(icc.gt.1) then\n! store this phase as a start phase if not in first position\n! otherwise ignore it\n if(mostcon.lt.noel()-meqrec%nfixmu) then\n mostcon=mostcon+1\n do jcc=icc+1,mostcon\n mostconph(1,jcc)=mostconph(1,jcc-1)\n mostconph(2,jcc)=mostconph(2,jcc-1)\n enddo\n mostconph(1,icc)=nvf\n mostconph(2,icc)=iph\n else\n! bug reported by valgrid used by UrbanJost icc-1 = 1 but icc>1 here!\n mostconph(1,icc-1)=nvf\n mostconph(2,icc-1)=iph\n endif\n endif\n endif\n enddo\n endif\n enddo selph1\n if(meqrec%nv.eq.0) then\n! no phase with positive amount, set the noel()-meqrec%nfixmu-1 phases stable\n! starting with those with highest number of constituents\n if(mostcon.eq.0) then\n! write(*,*)'MM no phase to set stable'\n gx%bmperr=4200; goto 1000\n endif\n! write(*,55)'Initial phases set stable: ',mostcon,&\n! (mostconph(1,icc),mostconph(2,icc),icc=1,mostcon)\n!55 format(a,i3,10(2i3,2x))\n meqrec%nv=mostcon\n! write(*,56)(mostconph(1,icc),icc=1,mostcon)\n!56 format('Setting start phases: ',20(i3))\n do icc=1,mostcon\n call get_phase_compset(mostconph(2,icc),1,lokph,lokcs)\n! ceq%phase_varres(lokcs)%amfu=one/mostcon\n ceq%phase_varres(lokcs)%amfu=one\n ceq%phase_varres(lokcs)%phstate=PHENTSTAB\n meqrec%iphl(icc)=mostconph(2,icc)\n meqrec%icsl(icc)=1\n meqrec%aphl(icc)=one\n! this sets a default constitution \n call set_default_constitution(mostconph(2,icc),1,ceq)\n enddo\n else\n! hopefully set_constitution has been called ...\n! normallize the sum of phase amounts assuming N=1 ... this did not help ...\n! if(sumnp.gt.one) then\n! sumnp=one/sumnp\n! do icc=1,meqrec%nv\n! meqrec%aphl(icc)=meqrec%aphl(icc)*sumnp\n! enddo\n! endif\n! write(*,57)(meqrec%iphl(icc),meqrec%icsl(icc),meqrec%aphl(icc),&\n! icc=1,meqrec%nv)\n!57 format('Start phase set: ',10(i3,i2,F6.2))\n if(ocv()) write(*,*)'No global minimization, using current phase set',&\n meqrec%nv\n endif\n! copy ceq%complist%chempot(1) to ceq%cmuval\n do mjj=1,meqrec%nrel\n if(abs(ceq%complist(mjj)%chempot(1)).ge.one) then\n ceq%cmuval(mjj)=ceq%complist(mjj)%chempot(1)/ceq%rtn\n else\n ceq%cmuval(mjj)=zero\n endif\n enddo\n if(ocv()) write(*,68)'MM cmuval: ',meqrec%nrel,&\n (ceq%cmuval(mjj),mjj=1,meqrec%nrel)\n68 format(a,i3,6(1pe12.4))\n!\n! we must make sure the fix phases are in the initial list of stable phases\n! the order does not matter, the phases will be sorted later\n addfixph: do mjj=1,meqrec%nfixph\n jph=1\n do while (jph.le.meqrec%nv)\n if(meqrec%iphl(jph).eq.meqrec%fixph(1,mjj) .and. &\n meqrec%icsl(jph).eq.meqrec%fixph(2,mjj)) then\n! found fix phase as already stable, just store the amount\n meqrec%aphl(jph)=meqrec%fixpham(mjj)\n cycle addfixph\n endif\n jph=jph+1\n enddo\n! add this phase as stable, check that not too many stable phases ...\n! meqrec%nv is the current number of stable phases\n if(meqrec%nv.eq.meqrec%maxsph) then\n write(*,69)'MM Too many stable phases',meqrec%nv,meqrec%maxsph\n69 format(a,2i5)\n gx%bmperr=4193; goto 1000\n endif\n! write(*,*)'Adding fix phase to stable phase set',&\n! meqrec%fixph(1,mjj),meqrec%fixph(2,mjj)\n meqrec%nv=meqrec%nv+1\n meqrec%iphl(meqrec%nv)=meqrec%fixph(1,mjj)\n meqrec%icsl(meqrec%nv)=meqrec%fixph(2,mjj)\n meqrec%aphl(meqrec%nv)=meqrec%fixpham(mjj)\n enddo addfixph\n!------------------------------- special for mapping and STEP\n mapfixdata: if(allocated(mapfix)) then\n! for step only the status word is used to indicate an invarant node\n! if(mapfix%nfixph.eq.0) then\n! if(btest(mapfix,STEPINVARIANT)) then\n! exit mapfixdata\n! endif\n! endif\n! the stable and fix phases copied from mapfix record.\n do ij=1,meqrec%nv\n meqrec%iphl(ij)=0\n meqrec%icsl(ij)=0\n enddo\n meqrec%nfixph=mapfix%nfixph\n meqrec%nv=0\n do ij=1,meqrec%nfixph\n meqrec%fixph(1,ij)=mapfix%fixph(ij)%ixphase\n meqrec%fixph(2,ij)=mapfix%fixph(ij)%compset\n meqrec%fixpham(ij)=zero\n if(allocated(mapfix%fixphamap)) then\n! attempt 180814 to let fix phases have nonzero amount to improve mapping\n meqrec%fixpham(ij)=mapfix%fixphamap(ij)\n write(*,65)'MM fix mapphase: ',mapfix%fixph(ij)%ixphase,&\n mapfix%fixph(ij)%compset,mapfix%fixphamap(ij)\n65 format(a,2i5,1pe12.4)\n! else\n! write(*,65)'MM mapfix phase: ',mapfix%fixph(ij)%ixphase,&\n! mapfix%fixph(ij)%compset\n endif\n meqrec%nv=meqrec%nv+1\n meqrec%iphl(meqrec%nv)=mapfix%fixph(ij)%ixphase\n meqrec%icsl(meqrec%nv)=mapfix%fixph(ij)%compset\n! 180814 not sufficient to set aphl \n! because around line 1010 amfu is set to zero fix mapfix ... removed that!!\n! meqrec%aphl(meqrec%nv)=mapfix%fixpham(ij)\n! I am not sure what value for mph here\n! meqrec%phr(mph)%curd%amfu=zero\n enddo\n do ij=1,mapfix%nstabph\n meqrec%nv=meqrec%nv+1\n meqrec%iphl(meqrec%nv)=mapfix%stableph(ij)%ixphase\n meqrec%icsl(meqrec%nv)=mapfix%stableph(ij)%compset\n meqrec%aphl(meqrec%nv)=mapfix%stablepham(ij)\n enddo\n! write(*,64)'MM Stable mapphase: ',mapfix%nstabph,&\n! mapfix%stableph(1)%ixphase,mapfix%stableph(1)%compset,&\n! mapfix%stablepham(1)\n64 format(a,i3,2i5,1pe12.4)\n! elseif(formap) then\n! mapfixrecord not allocated for STEP calculations\n! this dis not work for handling invariant nodes for STEP\n! write(*,*)'MM calceq7 formap MMSTEPINV:',btest(meqrec%status,MMSTEPINV)\n! if(btest(meqrec%status,MMSTEPINV)) then\n! The line start at an invariant node for a STEP calculation, \n! write(*,*)'MM invariant node with phases: ',meqrec%nstph\n! do jj=1,meqrec%nstph\n! jq=meqrec%stphl(jj)\n! write(*,*)'MM stable: ',jj,jq,meqrec%phr(jq)%curd%amfu\n! enddo\n! endif\n endif mapfixdata\n!------------------------------- \n! zero start of link to phases set temporarily dormant ....\n meqrec%dormlink=0\n!\n!-------------------------------\n! Now we (try to) calculate the equilibrium\n200 continue\n! allocate phaseremoved to avoid same phase stable again and again\n! write(*,*)'MM start interative minimizer',ceq%eqno\n if(allocated(ceq%phaseremoved)) deallocate(ceq%phaseremoved)\n ntup=nooftup()\n allocate(ceq%phaseremoved(2,ntup),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 6: ',errall\n gx%bmperr=4370; goto 1000\n endif\n ceq%phaseremoved=0\n!\n! this routine varies the set of phases and the phase constitutions\n! until the stable set is found for the given set of conditions.\n if(ocv()) write(*,*)'MM calling meq_phaseset'\n call meq_phaseset(meqrec,formap,mapfix,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! gridtest=.false.\n!------------------------------------------------------\n!\n! When we come here the equilibrium is calculated or calculation failed\n! if failed or called from step/map (formap TRUE) just exit\n if(gx%bmperr.ne.0 .or. formap) goto 1000\n! write(*,*)'End of calceq7 ',gridtest\n if(gridtest) then\n! gridtest value is set to .TRUE. if no gridmin done initially\n meqrec%status=ibset(meqrec%status,MMNOSTARTVAL)\n endif\n!--------------------------------------------------\n1000 continue\n! extract configurational entropy for mqmqa\n! write(*,'(\"MM mqmqa entropy: \",1pe14.4)')sconfmqmqa\n! write(*,*)'MM back from meq_phaseset'\n if(gx%bmperr.ne.0) then\n! test if total number of models > 10; that can create converge problems\n saverr=gx%bmperr; gx%bmperr=0\n! This routine returns total G, S, V, N and B\n call sumprops(props,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Convergence error, check your conditions are reasonable'\n elseif(props(4).gt.1.0D1 .and. &\n .not.(saverr.eq.4210 .or. saverr.eq.4364)) then\n write(*,'(a,a,i5,1pe12.4)')'Convergence error, maybe reduce ',&\n 'the size of your system!',saverr,props(4)\n endif\n gx%bmperr=saverr\n endif\n! This error means T or P is less than 0.1\n if(gx%bmperr.eq.4187) write(*,*)'Exit calceq7 with error ',gx%bmperr\n return\n end subroutine calceq7\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_phaseset\n!\\begin{verbatim}\n subroutine meq_phaseset(meqrec,formap,mapfix,ceq)\n! this subroutine can change the set of stable phase and their amounts\n! and constitutions until equilibrium is found for the current conditions.\n implicit none\n TYPE(meq_setup) :: meqrec\n type(map_fixph), allocatable :: mapfix\n TYPE(gtp_equilibrium_data), pointer :: ceq\n logical formap\n!\\end{verbatim}\n! should one use meqrec as pointer here???\n integer ok,iadd,iph,ics,irem,jj,jph,kk,lastchange,lokph,lokcs,minadd\n integer kph,mph,nip,zap,toomanystable,jrem,krem,inmap\n double precision, parameter :: addedphase_amount=1.0D-2\n double precision xxx,tpvalsave(2)\n integer iremsave,zz,tupadd,tuprem,samephase,phloopaddrem1,phloopaddrem2\n! mapx is special for using meq_sameset for mapping\n integer phloopv,findtupix,saverr,mapx,errall\n character phnames*50,phname2*24\n! prevent loop that a phase is added/removed more than 10 times\n integer, allocatable, dimension(:,:) :: addremloop\n! replace always FALSE except when we must replace a phase as we have max stable\n logical replace,force\n! number of iterations without adding or removing a phase\n replace=.FALSE.\n samephase=0\n lastchange=0\n!\n if(ocv()) write(*,*)'entering meq_phaseset: '\n! write(*,*)'MM entering meq_phaseset: '\n meqrec%dormlink=0\n! nphase is set to total number of phases (phase+compset) to be calculated\n! >>> parallellization ALERT, nphase may change when composition sets created\n! call sumofphcs(meqrec%nphase,ceq)\n! meqrec%nphase=totalphcs(ceq)\n meqrec%nphase=nonsusphcs(ceq)\n if(gx%bmperr.ne.0) goto 1000\n! Nathalie had an error here \"already allocated\"\n if(allocated(meqrec%phr)) deallocate(meqrec%phr)\n allocate(meqrec%phr(meqrec%nphase),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 7: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! order the inital set of stable phases in ascending order\n! VERY CLUMSY SORTING\n15 continue\n ok=0\n! write(*,16)meqrec%nv,meqrec%nphase,size(meqrec%iphl)\n!16 format('sort: ',10i3)\n do iph=2,meqrec%nv\n if(meqrec%iphl(iph-1).gt.meqrec%iphl(iph)) then\n ok=1\n kk=meqrec%iphl(iph-1)\n meqrec%iphl(iph-1)=meqrec%iphl(iph)\n meqrec%iphl(iph)=kk\n kk=meqrec%icsl(iph-1)\n meqrec%icsl(iph-1)=meqrec%icsl(iph)\n meqrec%icsl(iph)=kk\n xxx=meqrec%aphl(iph-1)\n meqrec%aphl(iph-1)=meqrec%aphl(iph)\n meqrec%aphl(iph)=xxx\n endif\n enddo\n if(ok.ne.0) goto 15\n17 continue\n ok=0\n do iph=2,meqrec%nv\n if(meqrec%iphl(iph-1).eq.meqrec%iphl(iph)) then\n if(meqrec%icsl(iph-1).gt.meqrec%icsl(iph)) then\n kk=meqrec%icsl(iph-1)\n meqrec%icsl(iph-1)=meqrec%icsl(iph)\n meqrec%icsl(iph)=kk\n xxx=meqrec%aphl(iph-1)\n meqrec%aphl(iph-1)=meqrec%aphl(iph)\n meqrec%aphl(iph)=xxx\n ok=1\n endif\n endif\n enddo\n if(ok.ne.0) goto 17\n!-----------------------------\n mph=0\n nip=1\n! krem=0\n meqrec%nstph=0\n allphases: do iph=1,noph()\n allcompsets: do ics=1,noofcs(iph)\n! ignore hidden and suspended phases (also ignored above in sumofphcs)\n! entered, fixed and dormat has values 1, 2 and 3, suspended 4, hidden 5\n zap=test_phase_status(iph,ics,xxx,ceq)\n! new: -4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed\n phstatus: if(zap.ge.PHDORM) then\n mph=mph+1\n! this iph is the index in the phlista record\n meqrec%phr(mph)%iph=iph\n meqrec%phr(mph)%ics=ics\n! compare with these the first time a phase wants to be added or removed\n! if zero it means phase can be added/removed at iteration default_minadd/default_minrem\n meqrec%phr(mph)%itadd=0\n meqrec%phr(mph)%itrem=0\n! initiate indicator for phases with fix composition, set to 1 later if so\n meqrec%phr(mph)%xdone=0\n! save phasestatus, zap>-2 here so set all -1,0,1 set to 0\n if(abs(zap).le.1) zap=0\n meqrec%phr(mph)%phasestatus=zap\n! set link to calculated values of G etc.\n call get_phase_compset(iph,ics,lokph,lokcs)\n meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs)\n! save phase tuple index\n findtupix=meqrec%phr(mph)%curd%phtupx\n meqrec%phr(mph)%phtupix=findtupix\n! set %volatile=0 to indicate start of equilibrium calculation\n! used for the cvmsro model (maybe not needed) in ges5X.F90\n ceq%phase_varres(lokcs)%volatile=0\n! write(*,'(a,4i6,5x,3i6)')'MM save tuple index: ',mph,iph,ics,&\n! findtupix,phasetuple(findtupix)%ixphase,&\n! phasetuple(findtupix)%compset,phasetuple(findtupix)%lokph\n! set number of constituents, DO NOT USE size(...curd%size(yfr)!!!\n meqrec%phr(mph)%ncc=noconst(iph,ics,ceq)\n whenmap: if(formap) then\n! when mapping fix phases are used to replace axis conditions. The\n! fix phases are in the meqrec%fixph array\n! They do not return PHFIXED for test_phase_status !!!\n do zz=1,meqrec%nfixph\n if(iph.eq.meqrec%fixph(1,zz) .and. &\n ics.eq.meqrec%fixph(2,zz)) then\n meqrec%phr(mph)%phasestatus=PHFIXED\n if(allocated(mapfix)) then\n if(allocated(mapfix%fixphamap)) then\n meqrec%phr(mph)%curd%amfu=mapfix%fixphamap(1)\n write(*,*)'MM set fixamount: ',&\n mapfix%fixphamap(1)\n endif\n endif\n endif\n enddo\n! inmap=1 turns off converge control of T\n inmap=1\n else\n! inmap=0 means not called from step/map routines\n inmap=0\n endif whenmap\n meqrec%phr(mph)%ionliq=-1\n meqrec%phr(mph)%i2sly=0\n if(test_phase_status_bit(iph,PHIONLIQ)) meqrec%phr(mph)%ionliq=1\n! already done: set link to calculated values of G etc. \n! call get_phase_compset(iph,ics,lokph,lokcs)\n! meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs)\n! causing trouble at line 3175 ???\n compset: if(nip.le.meqrec%nv) then\n if(iph.eq.meqrec%iphl(nip) .and. ics.eq.meqrec%icsl(nip)) then\n! this phase is part of the initial stable set, increment nstph\n meqrec%nstph=meqrec%nstph+1\n meqrec%stphl(meqrec%nstph)=mph\n meqrec%phr(mph)%stable=1\n if(meqrec%phr(mph)%phasestatus.eq.PHFIXED) then\n! Rather confused here ...\n! fixed phases as conditions have an amount in meqrec%fixpham\n! fixed phases during mapping should have zero amount (maybe not ...)\n! krem=krem+1\n! write(*,*)'MM aphl for fix phase: ',krem,mph,&\n! meqrec%fixpham(krem)\n if(meqrec%phr(mph)%curd%phstate.ne.PHFIXED) then\n! this is a phase set fix by mapping, set amount to zero unless mapfix%fixpham \n! but mapfix is not available in this routine ..\n if(allocated(mapfix%fixphamap)) then\n! 180814 tried to remove setting fix phase amount to zero\n write(*,*)'MM nonzero mapfix amount !'\n meqrec%phr(mph)%curd%amfu=mapfix%fixphamap(1)\n else\n meqrec%phr(mph)%curd%amfu=zero\n endif\n endif\n else\n! this is setting non-zero fixed amount of a phase as condition\n! Trying to handle this in mapping ... but here it not the fix phase ...\n if(allocated(mapfix)) then\n if(allocated(mapfix%fixphamap)) &\n write(*,*)'MM phase amount: ',&\n meqrec%phr(mph)%iph,meqrec%aphl(meqrec%nstph)\n endif\n meqrec%phr(mph)%curd%amfu=meqrec%aphl(meqrec%nstph)\n endif\n! set \"previous values\"\n meqrec%phr(mph)%prevam=meqrec%aphl(meqrec%nstph)\n meqrec%phr(mph)%prevdg=zero\n nip=nip+1\n else\n! unstable phase\n meqrec%phr(mph)%stable=0\n meqrec%phr(mph)%prevam=zero\n meqrec%phr(mph)%prevdg=-one\n meqrec%phr(mph)%curd%amfu=zero\n endif\n else\n! unstable phase\n! write(*,312)'MM nip: ',nip,meqrec%nv\n!312 format(a,5i4)\n meqrec%phr(mph)%stable=0\n meqrec%phr(mph)%prevam=zero\n meqrec%phr(mph)%prevdg=-one\n meqrec%phr(mph)%curd%amfu=zero\n endif compset\n! mark that no data arrays allocated for this phase\n meqrec%phr(mph)%idim=0\n! initiate link to another phase temporarily set dormant zero\n meqrec%phr(mph)%dormlink=0\n else\n! we are here for phases that are suspended, test_phase_status return -3\n! make sure stable bit is cleared in phases not included in calculation\n! maybe the whole status word should be zeroed?\n call get_phase_compset(iph,ics,lokph,lokcs)\n ceq%phase_varres(lokcs)%status2=&\n ibclr(ceq%phase_varres(lokcs)%status2,CSABLE)\n! check if suspended phase bits CSSUS set\n!z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then\n! write(*,*)'MM Suspended bit set',lokph,lokcs\n! else\n! This should not be necessary but it fixes the problem using c n with\n! suspended phases. The CSSUS bit should no longer be used???\n! write(*,*)'MM warning, suspended bit NOT set',lokph,lokcs\n!z ceq%phase_varres(lokcs)%status2=&\n!z ibset(ceq%phase_varres(lokcs)%status2,CSSUS)\n!z endif\n endif phstatus\n enddo allcompsets\n enddo allphases\n! problem phases suspended are restored!!\n! write(*,*)'MM at start, nonsuspenden phases: ',mph\n meqrec%noofits=0\n toomanystable=0\n jrem=0\n krem=0\n iremsave=0\n phloopaddrem1=0\n! code above executed only intially\n! write(*,*)'MM allocating addremloop',meqrec%nphase\n allocate(addremloop(meqrec%nphase,3),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 8: ',errall\n gx%bmperr=4370; goto 1000\n endif\n addremloop=0\n!----------------------------------------------------------------\n!\n! meq_sameset calculate the equilibrium for a given set of stable phases\n! if the phase set change we return to this routine to take some action and\n! then call meq_sameset again\n! irem nonzero if phase irem should be removed\n! iadd nonzero if phase iadd should be added\n! meqrec has the general information needed\n! meqrec%phr is the array with phases\n! ceq is the connection to the model package data\n200 continue\n! iadd=-1 ! iadd =-1 turns on verbose in meq_sameset\n iadd=0\n irem=iremsave\n! for debuging convergence\n! call list_stable_phases('MM call:',meqrec%noofits,iadd,irem,meqrec,ceq)\n! write(*,*)'MM calling meq_sameset ',meqrec%noofits\n! write(*,*)'MM calling list conditions'\n! call list_conditions(kou,ceq)\n! meq_sameset varies amounts of stable phases and constitutions of all phases\n! If there is a phase change (iadd or irem nonzeri) or error it exits \n! mapx is needed when using meq_sameset for mapping, irrelevant here\n mapx=0\n call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq)\n if(ocv()) write(*,*)'MM back from sameset ',irem,iadd,meqrec%noofits\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4364) then\n! write(*,*)'MM Two phases with same stoichiometry stable, to be fixed'\n endif\n goto 1000\n endif\n!\n force=.false.\n! call list_stable_phases('MM back:',meqrec%noofits,iadd,irem,meqrec,ceq)\n! write(*,*)'MM line 1114:',irem,iadd\n if(irem.gt.0 .or. iadd.gt.0) then\n if(iremsave.gt.0 .and. iadd.eq.iremsave) then\n! if iadd=iremsave>0 there was a equil matrix error when removing iremsave\n irem=0\n force=.true.\n!CCI\n elseif(meqrec%noofits-lastchange.lt.default_nochange) then\n!CCI\n! write(*,221)' *** Phase set change not allowed: ',&\n! meqrec%noofits,lastchange,default_nochange,irem,iadd\n!221 format(a,10i4)\n goto 200\n endif\n! keep record of adding and removing phases\n if(iadd.gt.0) then\n addremloop(iadd,1)=meqrec%noofits\n if(irem.eq.0) then\n addremloop(iadd,2)=addremloop(iadd,2)+1\n! write(*,'(a,4i5)')'MM adding: ',addremloop(iadd,1),iadd,&\n! addremloop(iadd,2),addremloop(iadd,3)\n endif\n if(addremloop(iadd,2).gt.5) then\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,'(a,2i4,\"#\",i1)')'MM Removing phase: ',iadd,&\n meqrec%phr(iadd)%iph,meqrec%phr(iadd)%ics\n meqrec%phr(iadd)%phasestatus=PHDORM\n meqrec%phr(iadd)%curd%phstate=PHDORM\n meqrec%phr(iadd)%dormlink=meqrec%dormlink\n meqrec%dormlink=iadd\n! iremsave keeps track of last removed phase, if equal to iadd set it to 0\n if(iremsave.eq.iadd) iremsave=0\n iadd=0\n goto 200\n endif\n else\n addremloop(irem,3)=addremloop(irem,3)+1\n! write(*,'(a,3i5)')'MM removing: ',addremloop(irem,1),irem,&\n! addremloop(iadd,2),addremloop(iadd,3)\n! if(addremloop(irem,3).gt.5) then\n! write(*,'(a,3i5)')'MM Suspend ',addremloop(irem,1),irem,&\n! meqrec%dormlink\n! meqrec%phr(irem)%phasestatus=PHDORM\n! meqrec%phr(irem)%curd%phstate=PHDORM\n! meqrec%phr(irem)%dormlink=meqrec%dormlink\n! meqrec%dormlink=irem\n! irem=0\n! goto 200\n! endif\n endif\n! What is iadd here? Not phasetuple index!!\n if(iadd.gt.0) then\n! check if phase to be added is already stable as another composition set\n! This check should maybe be above as maybe another phase want to be stable??\n! The last argument is not used\n if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then\n! write(*,*)'MM ignoring the same phase twice: ',iadd\n goto 200\n endif\n! do not add phases with net charge\n!CCI\n if(meqrec%phr(iadd)%curd%netcharge.gt.default_addchargedphase) then\n!CCI\n if(iadd.ne.samephase) then\n! call get_phasetup_name(iadd,phname2)\n call get_phasetup_name(meqrec%phr(iadd)%curd%phtupx,phname2)\n write(*,'(a,a,2i4,a,1pe12.4)')'MM ignoring phase: ',&\n trim(phname2),iadd,meqrec%phr(iadd)%curd%phtupx,&\n ' with charge:',meqrec%phr(iadd)%curd%netcharge\n! meqrec%phr(iadd)%curd%phtupx,meqrec%phr(iadd)%curd%netcharge\n218 format(a,2i5,1pe14.6)\n! change 2021.08.19 when a phase with no ions has net charge .... why\n! samephase=iadd\n iadd=0\n endif\n goto 200\n elseif(phloopaddrem1.gt.4) then\n! reset this phase to a default constitution\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,*)'MM phloopaddrem: ',phloopaddrem2\n iadd=phloopaddrem2\n phloopv=phasetuple(iadd)%lokph\n! if(ceq%phlista(phloopv)%tnooffr-ceq%phlista(phloopv)%noofsubl &\n! .gt. 0) then\n! reset troublesome phase constitution if it can vary\n call set_default_constitution(phasetuple(iadd)%ixphase,&\n phasetuple(iadd)%compset,ceq)\n! else\n! set phase dormant ... Hm I do not understand meqrec%phr any longer ...\n! phloopv=phasetuple(iadd)%lokvares\n! ceq%phase_varres(phloopv)%phstate=PHDORM\n! endif\n iadd=0\n phloopaddrem1=0\n phloopaddrem2=0\n goto 200\n! elseif(meqrec%phr(iadd)%curd%netcharge.gt.1.0D-8) then\n! write(*,231)'MM adding phase with net charge: ',iadd,&\n! meqrec%phr(iadd)%curd%phtupx,meqrec%phr(iadd)%curd%netcharge\n!231 format(a,2i5,1pe14.6)\n endif\n endif\n tupadd=0\n tuprem=0\n xxx=0.0D0\n! if(iadd.gt.0) tupadd=meqrec%phr(iadd)%curd%phtupx\n! if(irem.gt.0) tuprem=meqrec%phr(irem)%curd%phtupx\n if(iadd.gt.0) tupadd=meqrec%phr(iadd)%phtupix\n if(irem.gt.0) tuprem=meqrec%phr(irem)%phtupix\n if(.not.btest(meqrec%status,MMQUIET)) then\n if(iadd.gt.0) then\n phnames='+'\n call get_phasetup_name(tupadd,phnames(2:))\n if(irem.gt.0) then\n kk=len_trim(phnames)+3\n phnames(kk-1:kk-1)='-'\n call get_phasetup_name(tuprem,phnames(kk:))\n endif\n else\n phnames='-'\n call get_phasetup_name(tuprem,phnames(2:))\n endif\n addph: if(formap) then\n! if(btest(meqrec%status,MMSTEPINV)) then\n! This did not work to handle invariants during STEP\n! we are exiting an invariant node for a STEP calculation, allow phase change\n! meq_sameset wants to ADD a phase, instead remove the last stable phase\n! write(*,*)'MM meq_phaseset invariant node',meqrec%noofits,iadd\n! do jj=1,meqrec%nstph\n! irem=meqrec%stphl(jj)\n! if(iadd.eq.0 .and. &\n! meqrec%phr(irem)%curd%amfu.eq.zero) then\n! meqrec%phr(irem)%curd%amfu=1.0D-1\n! endif\n! write(*,*)'MM stable: ',jj,irem,meqrec%phr(irem)%curd%amfu\n! enddo\n! if(iadd.gt.0 .and. meqrec%nstph.gt.1) then\n! meqrec%nstph=meqrec%nstph-1\n! meqrec%phr(irem)%curd%amfu=zero\n! write(*,*)'MM ignore adding ',iadd,' but remove ',irem\n! iadd=0\n! goto 200\n! endif\n! exit addph\n! endif\n! This can be too strong, we can have a tie-line betwen two stoichiometric\n! phases, i.e. a new phase appears at first attempt to step in two-phase region.\n! UNFINISHED handling of many exceptions during mapping \n write(*,'(a,a)')'MM Phase change not allowed: ',trim(phnames)\n gx%bmperr=4210; goto 1000\n#ifdef silent\n#else\n elseif(ceq%eqno.ne.1) then\n! write(*,219)meqrec%noofits,iadd,irem,' at equil: ',ceq%eqno\n!219 format('Phase change: its/add/remove: ',3i5,a,i5)\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,219)ceq%eqno,meqrec%noofits,trim(phnames)\n219 format('Phase change (equil: ',i3,') iteration: ',i5,', phase: ',a)\n#endif\n else\n if(iadd.gt.0) then\n phnames='+'\n call get_phasetup_name(tupadd,phnames(2:))\n if(irem.gt.0) then\n kk=len_trim(phnames)+3\n phnames(kk-1:kk-1)='-'\n call get_phasetup_name(tuprem,phnames(kk:))\n endif\n else\n phnames='-'\n call get_phasetup_name(tuprem,phnames(2:))\n endif\n#ifdef silent\n#else \n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,281)meqrec%noofits,trim(phnames)\n281 format('Phase change iteration: ',i5,2x,a)\n#endif\n endif addph\n endif\n endif\n222 continue\n remove: if(irem.gt.0) then\n! remove a phase ---------------------------\n if(ocv()) write(*,223)'Phase to be removed: ',meqrec%phr(irem)%iph,&\n meqrec%phr(irem)%ics,meqrec%phr(irem)%curd%amfu,meqrec%noofits\n if(meqrec%nstph.eq.1) then\n if(.not.REPLACE) then\n! we must be able to REPLACE the only stable phase for a unary system\n write(*,*)'Attempt to remove the only stable phase!!!'\n goto 200\n endif\n! write(*,*)'MM replacing one stable phase with another',irem,iadd\n else\n! make sure replace is false unless explitly set below\n replace=.FALSE.\n endif\n!CCI\n if(meqrec%noofits-meqrec%phr(irem)%itadd.lt.default_minrem) then\n!CCI\n! if phase was just added do not remove before default_minrem iterations\n if(ocv()) write(*,*)'Too soon to remove phase',&\n meqrec%phr(irem)%curd%phtupx,meqrec%noofits,&\n meqrec%phr(irem)%itadd\n if(phloopaddrem1.gt.0) then\n if(phloopaddrem2.eq.meqrec%phr(irem)%curd%phtupx) then\n phloopaddrem1=phloopaddrem1+1\n else\n phloopaddrem2=0\n phloopaddrem1=0\n endif\n else\n phloopaddrem2=meqrec%phr(irem)%curd%phtupx\n phloopaddrem1=1\n endif\n goto 200\n endif\n! shift phases after irem down in meqrec%stphl\n! irem is index to meqrec%phr(), meqrec%stphl(jph) is index to meqrec%phr\n meqrec%nstph=meqrec%nstph-1\n do iph=1,meqrec%nstph\n jj=meqrec%stphl(iph)\n if(jj.ge.irem) then\n meqrec%stphl(iph)=meqrec%stphl(iph+1)\n endif\n enddo\n! we must zero the last phase !!\n meqrec%stphl(meqrec%nstph+1)=0\n!\n meqrec%phr(irem)%itrem=meqrec%noofits\n meqrec%phr(irem)%prevam=zero\n meqrec%phr(irem)%stable=0\n meqrec%phr(irem)%curd%amfu=zero\n! save irem as it is used to restore a phase if massbalance problem\n iremsave=irem\n irem=0\n lastchange=meqrec%noofits\n! one can remove and add a phase at the same time !!!\n if(iadd.eq.0) then\n toomanystable=0\n jrem=0\n goto 200\n endif\n endif remove\n!------------------------------------------- \n add: if(iadd.gt.0) then\n! add a phase. This can be tricky\n! NOTE it must be added so meqrec%stphl in ascending order\n if(ocv()) write(*,223)'Phase to be added: ',meqrec%phr(iadd)%iph,&\n meqrec%phr(iadd)%ics,meqrec%phr(iadd)%curd%dgm,meqrec%noofits\n223 format(a,2x,2i4,1pe15.4,i7)\n!CCI\n if(meqrec%noofits-meqrec%phr(iadd)%itrem.lt.default_minadd .and. .not.force) then\n!CCI\n! if phase was just removed, do not add it before default_minadd iterations\n! if(.not.btest(meqrec%status,MMQUIET))write(*,224)\n if(ocv()) write(*,224)meqrec%phr(iadd)%curd%phtupx,&\n meqrec%noofits,meqrec%phr(iadd)%itrem,phloopaddrem1,&\n phloopaddrem2,default_minadd\n224 format('Too soon to add phase: ',i3,2x,i4,2x,5i5)\n if(phloopaddrem1.gt.0) then\n if(phloopaddrem2.eq.meqrec%phr(iadd)%curd%phtupx) then\n phloopaddrem1=phloopaddrem1+1\n else\n phloopaddrem2=0\n phloopaddrem1=0\n endif\n else\n phloopaddrem2=meqrec%phr(iadd)%curd%phtupx\n phloopaddrem1=1\n endif\n goto 200\n endif\n! if(iadd.eq.abs(iremsave)) then\n! write(*,*)'Phase just removed, do not add: ',iadd\n! iremsave=0\n! goto 200\n! endif\n! make sure iremsave is zero\n iremsave=0\n if(meqrec%nstph.eq.meqrec%maxsph) then\n! No more phases allowed, we must see if some other phase may be removed\n if(toomanystable.ge.3) then\n! write(*,*)'Attempt to set too many phases stable',meqrec%maxsph\n! gx%bmperr=4201; goto 1000\n! During mapping do not replace phases ...\n if(formap) then\n gx%bmperr=4201; goto 1000\n endif\n! UNFINISHED code below\n if(jrem.eq.0) then\n! try to remove a stable phase ... which? Replace the one that does not\n! disturb the order of phases in meqrec%stphl by adding iadd\n do iph=1,meqrec%nstph\n if(iadd.gt.meqrec%stphl(iph)) cycle\n jrem=meqrec%stphl(iph); exit\n enddo\n! if jrem zero here replace the last\n if(jrem.eq.0) jrem=meqrec%stphl(meqrec%nstph)\n krem=jrem\n irem=jrem\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,241)meqrec%noofits,irem,iadd,ceq%tpval(1)\n241 format('MM Too many stable phases at iter ',i3,', phase ',i3,&\n ' replaced by ',i3,', T= ',F8.2)\n! write(*,240)meqrec%noofits,irem,iadd,ceq%tpval(1),&\n! (meqrec%stphl(iph),iph=1,meqrec%nstph)\n!240 format('Too many stable phases at iter ',i3,', phase ',i3,&\n! ' replaced by ',i3,', T= ',F8.2/3x,15(i3))\n replace=.TRUE.\n goto 222 \n else\n write(*,*)'MM setting too many phases stable',meqrec%maxsph\n gx%bmperr=4201; goto 1000\n endif\n else\n! try ignore adding 3 times\n! write(*,*)'Ignoring attempt to set too many phases stable',&\n! meqrec%maxsph,toomanystable\n toomanystable=toomanystable+1\n goto 200\n endif\n endif\n! the phase must be added in sequential order of phase and composition set no\n findplace: do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(iadd)%iph.gt.meqrec%phr(jj)%iph) then\n cycle\n endif\n if(meqrec%phr(iadd)%iph.lt.meqrec%phr(jj)%iph) then\n exit\n endif\n! if same phase number compare composition set numbers\n if(meqrec%phr(iadd)%iph.eq.meqrec%phr(jj)%iph) then\n if(meqrec%phr(iadd)%ics.gt.meqrec%phr(jj)%ics) then\n cycle\n else\n exit\n endif\n endif\n enddo findplace\n! one should come here at exit, iadd should be inserted before \n! meqrec%stphl(jph), jph can be nstph+1 if added phase should be the last\n! otherwise shift previous phases one step up.\n do kph=meqrec%nstph,jph,-1\n meqrec%stphl(kph+1)=meqrec%stphl(kph)\n enddo\n! write(*,*)'Phase added: ',jph,meqrec%nstph,meqrec%maxsph\n! phase added at jph, (note jph may be equal to nstph+1)\n meqrec%stphl(jph)=iadd\n meqrec%nstph=meqrec%nstph+1\n meqrec%phr(iadd)%itadd=meqrec%noofits\n meqrec%phr(iadd)%curd%dgm=zero\n lastchange=meqrec%noofits\n! maybe some more variables should be set?\n meqrec%phr(iadd)%curd%amfu=addedphase_amount\n meqrec%phr(iadd)%stable=1\n iadd=0\n toomanystable=0\n jrem=0\n goto 200\n endif add\n!---------------------------------------------------\n! found stable phase set or error\n1000 continue\n if(gx%bmperr.eq.0) then\n! equilibrium calculation converged, one should add check on stability\n!\n! >> add calculate eigenvalues of phase matrix to check stability, \n! >> a negative eigenvalue means inside spinodal\n! >> Note charge problems for metastable phases, phase must be neutral ...\n!\n!------------------------------------------------------------\n! clear bits: no equilibrium calculated/ inconsistent conditions and result/\n! equilibrium calculation failed/ only gridcal\n ceq%status=ibclr(ceq%status,EQNOEQCAL)\n ceq%status=ibclr(ceq%status,EQINCON)\n ceq%status=ibclr(ceq%status,EQFAIL)\n ceq%status=ibclr(ceq%status,EQGRIDCAL)\n! set stable bit in stable phases and clear it in all others\n kk=1\n do jj=1,mph\n if(jj.eq.meqrec%stphl(kk)) then\n meqrec%phr(jj)%curd%status2=&\n ibset(meqrec%phr(jj)%curd%status2,CSABLE)\n! the stable phase list should be ordered in increasing phase number\n kk=min(kk+1,meqrec%nstph)\n! write(*,*)'mm max kk: ',kk,meqrec%nstph\n else\n meqrec%phr(jj)%curd%status2=&\n ibclr(meqrec%phr(jj)%curd%status2,CSABLE)\n endif\n enddo\n!-----------------------\n! loop through all phases and if their status is entered set it as PHENTUNST\n! unless stablestable phases and set the PHENTST for phases in stable set\n! That is important for extracting values later ...\n do jph=1,meqrec%nphase\n if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. &\n meqrec%phr(jph)%curd%phstate.le.PHENTSTAB) then\n meqrec%phr(jph)%curd%phstate=PHENTUNST\n endif\n enddo\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(jj)%curd%phstate.lt.PHFIXED) then\n meqrec%phr(jj)%curd%phstate=PHENTSTAB\n endif\n enddo\n!-----------------------------------------\n else\n! write(*,*)'MM cleaning up due to error'\n! set some failure bits\n ceq%status=ibset(ceq%status,EQINCON)\n ceq%status=ibset(ceq%status,EQFAIL)\n ceq%status=ibclr(ceq%status,EQGRIDCAL)\n! even when not converged save the current chemical potentials\n do jj=1,meqrec%nrel\n ceq%complist(jj)%chempot(1)=ceq%cmuval(jj)*ceq%rtn\n enddo\n endif\n! restore phases set dormant\n jph=0\n if(gx%bmperr.ne.0) then\n! save any error already set and clear error code\n saverr=gx%bmperr; gx%bmperr=0\n else\n saverr=0\n endif\n jj=meqrec%dormlink\n1200 continue\n if(jj.ne.0) then\n! if(.not.btest(meqrec%status,MMQUIET)) &\n! write(*,*)'Restore from dormant: ',jj,meqrec%phr(jj)%iph,&\n! meqrec%phr(jj)%ics\n kk=meqrec%phr(jj)%phtupix\n phnames=' '\n call get_phasetup_name(kk,phnames)\n if(gx%bmperr.ne.0) then\n write(*,*)'MM cannot find phasetup name: ',jj,kk,gx%bmperr\n gx%bmperr=0\n endif\n if(.not.btest(meqrec%status,MMQUIET)) then\n if(meqrec%phr(jj)%curd%dgm.gt.zero) then\n write(*,1220)jj,kk,trim(phnames),meqrec%phr(jj)%curd%dgm\n1220 format('MM Restoring phase: ',2i5,2x,a,5x,1pe12.4)\n else\n write(*,1220)jj,kk,trim(phnames)\n endif\n endif\n if(meqrec%phr(jj)%curd%dgm.gt.1.0D-2) jph=jj\n! do I have two places for suspendeded ?? YES!!\n meqrec%phr(jj)%phasestatus=PHENTUNST\n! below is in the phase_varres record, previous is temporary equilibrium data\n meqrec%phr(jj)%curd%phstate=PHENTUNST\n jj=meqrec%phr(jj)%dormlink\n goto 1200\n endif\n if(jph.gt.0) then\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,*)'MM warning, a restored phase wants to be stable:',jph\n gx%bmperr=4363\n endif\n! we may already have had an error ...\n if(saverr.ne.0) gx%bmperr=saverr\n! try to find problem with listed chemical potential \n! chempot(2) should be value with user defined reference state,\n if(gx%bmperr.eq.0) then\n do jj=1,meqrec%nrel\n xxx=zero\n lokph=ceq%complist(jj)%phlink\n if(lokph.gt.0) then\n! we must also handle reference state at fix T !!\n! lokph is index of phase in phlista, calcg_endmember want index in phases ....\n! write(*,*)'Component has defined reference state: ',jj,lokph\n tpvalsave=ceq%tpval\n! modified calcg_endmember to convert negative phase index to phase number ...\n! write(*,*)'MM calling calcg_endmember 1: ',-lokph\n! MUS same as TC MU\n call calcg_endmember(-lokph,ceq%complist(jj)%endmember,xxx,ceq)\n if(gx%bmperr.ne.0) then\n write(*,68)'MM error calculating reference state',gx%bmperr,&\n -lokph,jj,xxx,tpvalsave(1),ceq%complist(jj)%endmember\n68 format(a,3i5,2(1pe12.4),2x,10i3)\n ceq%tpval=tpvalsave\n! stop\n goto 998\n endif\n endif\n! MU same as TC MUR\n ceq%complist(jj)%chempot(2)=ceq%complist(jj)%chempot(1)+xxx*ceq%rtn\n enddo\n! else\n! write(*,69)'Unable to calculate reference states due to errors'\n!69 format(a)\n endif\n! write(*,37)'mu1: ',(ceq%complist(jj)%chempot(1),jj=1,meqrec%nrel)\n! write(*,37)'mu2: ',(ceq%complist(jj)%chempot(2),jj=1,meqrec%nrel)\n!37 format(a,6(1pe12.4))\n!-------------\n998 continue \n if(.not.formap) then\n! if called during mapping keep phr\n deallocate(meqrec%phr)\n endif\n! >>>> here one can allow new composition set in parallelization\n return\n end subroutine meq_phaseset\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_sameset\n!\\begin{verbatim}\n recursive subroutine meq_sameset(irem,iadd,mapx,meqrec,phr,inmap,ceq)\n! iterate until phase set change, converged or error (incl too many its)\n! iadd = -1 indicates called from calculating a sequence of equilibria\n! mapx is used when calling meq_sameset from step/map\n implicit none\n integer irem,iadd,inmap,mapx\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n if(globaldata%mqmqa1.eq.1.0d0) then\n call meq_sameset_okmap4(irem,iadd,mapx,meqrec,phr,inmap,ceq)\n else\n call meq_sameset_okmqmqa(irem,iadd,mapx,meqrec,phr,inmap,ceq)\n endif\n return\n end subroutine meq_sameset\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_sameset_okmap4\n!\\begin{verbatim}\n recursive subroutine meq_sameset_okmap4(irem,iadd,mapx,meqrec,phr,inmap,ceq)\n! iterate until phase set change, converged or error (incl too many its)\n! iadd = -1 indicates called from calculating a sequence of equilibria\n! mapx is used when calling meq_sameset from step/map\n implicit none\n integer irem,iadd,inmap,mapx\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer increase,ioff,ik,jj,jph,ie,ierr,jmaxy\n integer kk,kkz,level3,mph,negam,negamph,nj,nk,nl\n integer nz1,nz2\n TYPE(meq_phase), pointer :: pmi\n! Using SAVE not possible for parallel calculations here once is just warning\n logical, save :: once=.true.\n double precision, dimension(5) :: qq\n double precision, dimension(maxconst) :: ycormax\n double precision, dimension(:,:), allocatable :: smat\n double precision, dimension(:), allocatable :: svar\n! these arrays should maybe be allocated ....\n double precision, dimension(maxconst) :: ycorr,yarr\n integer converged,jz\n double precision chargefact,chargerr\n double precision dgm,summ,dgmmax,gsurf,phf,phs\n double precision prevmaxycorr,pv,signerr\n double precision xxx,ycormax2,yprev,ys,ysmm,ysmt,yss,yst\n double precision yvar1,yvar2\n double precision maxphch\n double precision sum\n double precision, dimension(:), allocatable :: cit\n double precision deltat,deltap,deltaam,yfact\n\n! to check if we are calculating a single almost stoichiometric phase ...\n integer iz,tcol,pcol,nophasechange,notagain\n double precision maxphasechange,molesofatoms,factconv\n double precision lastdeltat,deltatycond,phfmin,value\n integer notf,dncol,iy,jy,iremsave,phasechangeok,nextch,iremax,srem,errall\n character phnames*50\n double precision, dimension(:), allocatable :: lastdeltaam\n logical vbug,stoikph,badmat\n!CCI\n integer cmix(22), cmode\n double precision cvalue, maxprescribed, sumprescribed, ccf(5)\n TYPE(gtp_condition), pointer :: conditionScale, lastcondScale\n!CCI\n! NOTE using save cannot be reconciled with parallel calculations\n save notagain\n!\n! do not allow return unless meqrec%noofits greater or equal to nextch\n mapx=0\n nextch=meqrec%noofits+4\n stoikph=.true.\n nophasechange=0\n maxphasechange=zero\n! this is set each time the set of phases changes, controls change in T\n! when there is a condition on y\n!CCI\n deltaTycond=default_deltaTycond\n!CCI\n if(iadd.eq.-1 .or. ocv()) then\n write(*,*)'Debug output in meq_sameset'\n vbug=.TRUE.; iadd=0\n else\n vbug=.FALSE.\n endif\n! vbug=.TRUE.\n if(vbug)write(*,*)'entering meq_sameset',meqrec%nphase,irem\n! write(*,*)'MM entering meq_sameset',meqrec%nphase,irem\n iremsave=irem\n! this is max correction of constituent fraction for each phases\n ycormax=zero\n! magic trying to force decreasing step in fractions\n! ymagic=one\n! nmagic=0\n! this is an attempt to decrease variation in phase amount corrections\n allocate(lastdeltaam(meqrec%nstph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 9: ',errall\n gx%bmperr=4370; goto 1000\n endif\n lastdeltaam=zero\n! dimension matrix for conditions, components+stable phases\n nz1=meqrec%nrel-meqrec%nfixmu+meqrec%nstph-meqrec%nfixph\n if(meqrec%tpindep(1)) nz1=nz1+1\n if(meqrec%tpindep(2)) nz1=nz1+1\n if(ocv()) write(*,11)meqrec%nrel,meqrec%nfixmu,meqrec%nstph,&\n meqrec%nfixph,meqrec%tpindep,nz1,ceq%tpval(1)\n11 format('In meq_sameset, sysmat: ',4i7,2l2,i5,1pe12.4)\n nz2=nz1+1\n if(vbug) write(*,*)'Allocating smat: ',nz1\n allocate(smat(nz1,nz2),stat=errall)\n allocate(svar(nz1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 10: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! check if constituent fraction correction in stable phases increases\n! for each iteration. Needed for the Re-V case ....\n prevmaxycorr=zero\n increase=0\n level3=0\n! this is set TRUE after 3 iterations\n phasechangeok=meqrec%noofits\n if(phasechangeok.eq.1) then\n notagain=0\n endif\n! debugging problem with changing axis in mapping\n if(ocv() .and. meqrec%tpindep(1)) write(*,*)'variable T: ',ceq%tpval(1)\n!-------------------------------------------------------------\n! return here until converged or phase set change\n100 continue\n meqrec%noofits=meqrec%noofits+1\n cerr%flag=0\n! nonzero flag means error output below\n! cerr%flag=1\n!CCI\n if(nophasechange.gt.default_nophasechange) then\n if(maxphasechange.lt.default_maxphaseamountchange) then\n!CCI\n! if we have not changed the set of stable phases for many iterations\n! and the changes in phase amounts is small maybe we are calculationg an\n! almost stoichiometric phase? Changes in MU can be large!\n if(stoikph .and. meqrec%nphase.gt.1) then\n! write this message if VERBOSE is set\n if(btest(globaldata%status,GSVERBOSE)) write(*,30)nophasechange,&\n converged,cerr%nvs,ceq%tpval(1)\n30 format('Slow converge at ',3i3,F10.2)\n if(cerr%flag.ne.0) then\n write(*,31)(cerr%typ(iz),cerr%val(iz),cerr%dif(iz),&\n iz=1,cerr%nvs)\n31 format('MM 31: ',3(i3,1pe12.4,e10.2))\n endif\n! write message only (once for each minimization)\n stoikph=.false.\n! if this happends during step/map give error message to force smaller steps\n if(inmap.eq.1 .and. meqrec%noofits.eq.ceq%maxiter) then\n gx%bmperr=4359; goto 1000\n endif\n endif\n!+ converged=0\n!+ goto 1000\n! else\n! maybe use this to improve concergence??\n! if(.not.allocated(loopfact)) then\n! allocate(loopfact(meqrec%nrel))\n! endif\n endif\n endif\n nophasechange=nophasechange+1\n cerr%nvs=0\n cerr%mconverged=0\n! this is magic ....\n! nmagic=nmagic+1\n! if(mod(nmagic,5).eq.0) ymagic=0.5*ymagic\n! if(mod(nmagic,25).eq.0) ymagic=one\n! end of magic\n!101 format(a)\n! write(*,*)'Iteration: ',meqrec%noofits,' ----------------------------- '\n if(ocv()) write(*,199)meqrec%noofits,ceq%tpval(1),meqrec%nstph,&\n (meqrec%stphl(jz),jz=1,meqrec%nstph)\n!199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,10i3)\n199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,100i3)\n if(meqrec%noofits.gt.ceq%maxiter) goto 1200\n converged=0\n if(vbug) write(*,*)'Iteration: ',meqrec%noofits,converged\n! loop for all phases and composition sets, loop over phr\n! if(meqrec%tpindep(1)) write(*,*)'variable T: ',meqrec%noofits,ceq%tpval(1)\n!\n! >>>>>>>>>>>> here we can parallelize \n!\n!-$omp parallel do private(pmi) shared(meqrec)\n! nullify liquid pointer\n nullify(meqrec%pmiliq)\n! write(*,*)'MM meq_sameset: begin loop for all phases'\n parallel: do mph=1,meqrec%nphase\n pmi=>phr(mph)\n! this routine calculates G and derivatives, the phase matrix and inverts it.\n! it also calculates the amounts of moles of components in the phase\n!-$ write(*,*)'Phase and tread: ',mph,omp_get_thread_num()\n! to set correct pmiliq we must calculate all liquids first!!\n! write(*,*)'MM call onephase: ',pmi%iph,pmi%ics\n call meq_onephase(meqrec,pmi,ceq)\n! write(*,*)'MM back from onephase: ',gx%bmperr\n if(gx%bmperr.ne.0) then\n! using LAPCK gives severe problems if we do not stop\n goto 1000\n if(pmi%stable.eq.0) then\n! if this happends for an unstable phase just continue but ensure it will\n! not be stable (in a very crude way)\n! write(*,*)'Matrix inversion error for unstable phase',pmi%iph\n pmi%curd%gval(1,1)=one\n gx%bmperr=0\n else\n! Inversion error for stable phase is fatal, error code already set\n if(once) then\n write(*,*)'Warning, matrix inversion problem: ',pmi%iph\n once=.false.\n else\n goto 1000\n endif\n gx%bmperr=0\n endif\n endif\n!107 format(a,6(1pe12.3))\n! end of pmi% scope\n enddo parallel\n! hejhopp\n! write(*,*)'MM meq_sameset: end loop for all phases'\n!-$omp end parallel do\n!\n!=======================================================================\n! step 2: calculation of equil matrix\n! Solve for chemical potentials and conditions using all stable phases\n! The EQUIL MATRIX (smat) has one row for each stable phase and\n! one row for each component representing a condition\n! (If a fix phase condition or chem.pot. condition slightly different??)\n!----------------------------------------\n300 continue\n! if(vbug) write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,&\n! write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,&\n! meqrec%nfixph,meqrec%tpindep,meqrec%noofits\n301 format(a,2i2,2l2,i5)\n! some arguments here are redundant but kept for some\n call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,&\n dncol,converged,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM Back from setup_equilmatrix',tcol\n!=====================================================================\n! debug output of equil matrix, last column is right hand side\n!380 continue\n! open(33,file='eqmat.dat ',access='sequential',status='unknown')\n! write(33,*)'Equilibrium matrix',nz1\n! do iz=1,nz1\n! write(33,112)iz,(smat(iz,jz),jz=1,nz2)\n!112 format('>',i4,1x,4(1pe15.6))\n! enddo\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> debug\n! debug output to follow the minimization: all mu_i, and \n! for all stable phases np^alpha, G^alpha, and x^alpha_i\n! call calc_molmass(xdum,wdum,tmdum,wmdum,ceq)\n! write(*,116)'MM mu:',meqrec%nstph,(ceq%cmuval(iz),iz=1,meqrec%nrel),&\n! (xdum(iz),iz=1,meqrec%nrel)\n!116 format(a,i3,6(1pe12.4))\n! do iz=1,meqrec%nstph\n! jj=meqrec%stphl(iz)\n! call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,&\n! xdum,wdum,tmdum,wmdum,dumdum,ceq)\n! if(gx%bmperr.ne.0) stop 'debug'\n! amount of phase, G of phase, x_i of phase\n! write(*,116)'MM ph:',jj,phr(jj)%curd%amfu,smat(iz,nz2),&\n! (xdum(ioff),ioff=1,meqrec%nrel)\n! enddo\n! end debug output\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n if(vbug) then\n! when convergence problem list smat here and (and svar below) and study!!!\n call list_conditions(kou,ceq)\n do iz=1,nz1\n write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2)\n enddo\n endif\n228 format(a,6(1pe12.4),(8x,6e12.4))\n! This is an emergecy check that the smat matrix does not contain\n! values >default_bigvalues. We should test for Infinity and NaN but how??\n do iz=1,nz1\n do jz=1,nz2\n!CCI\n if(abs(smat(iz,jz)).gt.default_bigvalues) then\n!CCI\n write(*,118)iz,jz\n118 format('meq_sameset has illegal values in equilibrium matrix',2i4)\n gx%bmperr=4354; goto 990\n endif\n enddo\n enddo\n! HERE new values of chemical potentials and and amount of phases\n! call lingld(nz1,nz2,smat,svar,nz1,ierr)\n! goto 119\n\n! Rearranged the IF statements/BoS\n! if(inmap.eq.0 and ceq%splitsolver .eq. 1) then\n!CCI\n!-----------------------------------------------------------------------\n!-----------------------------------------------------------------------\n! Development based on the work of Joao Pedro Carvalho Teuber 12/2020\n! Jacobi preconditioning if allowed\n!BS if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.&\n!BS (meqrec%nrel.eq.meqrec%nstph)) then\n!BS call precond(nz1,nz2,smat,badmat)\n! added due to problems with parallel1 and parallel2, 20200220/BoS\n! PRECOND has found a zero diagonal element but just use lingld and skip split\n! if(badmat) then\n! write(*,112)nz1,nz2\n112 format('MEQ_SAMESET: phase matrix illconditioned',2i3)\n! debug output\n! do iz=1,nz1\n! write(*,113)iz,(smat(iz,jz),jz=1,nz1)\n! enddo\n113 format(i3,20(1pe11.3))\n! call lingld(nz1,nz2,smat,svar,nz1,ierr)\n! goto 119\n! end if\n! endif\n! if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.&\n! .not.badmat .and. (meqrec%nrel.eq.meqrec%nstph)) then\n! Splitting is possible for given T, P, composition and\n! when the number of component is equal to the number of stable phases\n! (conditions giving square mass matric)\n! ís this OK if BADNAT is TRUE??\n!BS if(badmat) write(*,*)'MEQ_SAMESET: matrix has a diagonal element zero'\n!BS call lingldSplit(nz1,nz2,smat,svar,nz1,ierr,meqrec%nrel,meqrec%nstph)\n!BS else\n! this used when equilibrium is NOT invariant\n call lingld(nz1,nz2,smat,svar,nz1,ierr)\n!BS endif\n!-----------------------------------------------------------------------\n! write(*,*)'MM meq_sameset: back from lingld'\n!\n119 continue\n if(ierr.ne.0) then\n if(vbug) write(*,*)'Error solving equil matrix 1',meqrec%noofits,ierr,&\n iremsave\n if(iremsave.gt.0) then\n! parallel2 goes into a loop here when phase iremsave has been suspended\n! after at has been set suspended .... fixed by not returning nonzero irem \n! equil matrix wrong at first iteration after removing a phase\n! This can be caused by having no phase with solubility of an element\n! (happened in Fe-O-U-Zr calculation with just C1_MO2 stable and C1 does not\n! dissolve Fe). Try to set back the last phase removed!!\n if(.not.btest(meqrec%status,MMQUIET)) then\n kk=meqrec%phr(iremsave)%phtupix\n phnames=' '\n call get_phasetup_name(kk,phnames)\n write(*,*)'Error, restoring previously removed phase: ',&\n trim(phnames)\n endif\n! NOTE: it should also be removed from the dormant list!!\n iadd=iremsave\n notagain=iremsave\n goto 1100\n endif\n if(vbug) then\n do iz=1,nz1\n write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2)\n enddo\n endif\n! debug output ...\n! write(*,229)'ce:',meqrec%noofits\n! call list_conditions(kou,ceq)\n! do iz=1,nz1\n! write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2)\n! enddo\n! gx%bmperr=4203; goto 1000\n endif\n! when problems output svar here !! (and smat1: above)\n! write(33,*)'Solution'\n! write(*,228)'PHMAT: ',(svar(jz),jz=1,nz1)\n! close(33)\n! write(*,228)'svar1:',(svar(jz),jz=1,nz1)\n if(vbug) write(*,228)'svar1:',(svar(jz),jz=1,nz1)\n!\n! if no error at first calculation after phase set change iremsave=0\n iremsave=0\n if(vbug) write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1)\n! write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1)\n229 format(a,i3,6(1pe12.4))\n!---------\n! copy the chemical potentials, take care of fixed values ....\n! new potentials are in svar(1..meqrec%nrel-meqrec%nfixmu)\n iz=1\n notf=1\n setmu: do ik=1,meqrec%nrel\n if(notf.le.meqrec%nfixmu) then\n if(ik.eq.meqrec%mufixel(notf)) then\n! this potential is fixed, no incrementing \"iz\", ceq%cmuval(ik) is a condition\n ceq%complist(ik)%chempot(1)=meqrec%mufixval(1)*ceq%rtn\n notf=notf+1\n cycle setmu\n endif\n endif\n! if(abs(svar(iz)-ceq%cmuval(ik)).gt.ceq%xconv) then\n! attempt to handle problem with MQMQA phase convergence\n! if(abs(svar(iz)-ceq%cmuval(ik)).gt.abs(ceq%xconv*ceq%cmuval(ik))) then\n if(abs(svar(iz)-ceq%cmuval(ik)).gt.&\n abs(globaldata%mqmqa1*ceq%xconv*ceq%cmuval(ik))) then\n! when MQMQA phase is involved globaldata%mqmqa1 is 1.0D4, otherwise 1.0D0\n! write(*,*)'MM mqmqa1:',globaldata%mqmqa1\n!\n! if(vbug) write(*,387)'Unconverged pot: ',iz,ik,&\n if(nophasechange.gt.100) then\n! Attempt to improve convergence for a 15 component system ... failed\n! xxx=0.25D0*(3.0D0*svar(iz)+1.0D0*ceq%cmuval(ik))\n! write(*,387)'Uncnv pot: ',iz,ik,&\n! svar(iz),ceq%cmuval(ik),xxx,abs(svar(iz)-ceq%cmuval(ik)),&\n! abs(ceq%xconv*ceq%cmuval(ik))\n!387 format(a,2i3,3(1pe14.5),2(1pe10.2))\n! take mean value ... DO NOT TRY THIS IF IT IS NOT ALMOST CONVERGED!!!\n! svar(iz)=xxx\n endif\n converged=7\n cerr%mconverged=converged\n endif\n ceq%cmuval(ik)=svar(iz)\n! svar(iz) is mu/RT, chemput is mu\n ceq%complist(ik)%chempot(1)=svar(iz)*ceq%rtn\n iz=iz+1\n enddo setmu\n ioff=meqrec%nrel-meqrec%nfixmu+1\n!------------\n! update T and P if variable\n if(meqrec%tpindep(1)) then\n xxx=ceq%tpval(1)\n! check convergence\n! write(*,*)'Delta T: ',svar(ioff),1.0D2*ceq%xconv\n! if(abs(svar(ioff)).gt.1.0D2*ceq%xconv) then\n! this convergece criteria needed for the CHO-gas calculation!!!\n! but causes problem calculating phase diagrams ... inmap=1 for step/map\n! OBS svar(ioff) is Delta T, not absolute value\n!CCI\n if(inmap.eq.0 .and. abs(svar(ioff)).gt.default_deltaT*ceq%xconv) then\n!CCI\n converged=8\n cerr%mconverged=converged\n endif\n!CCI\n! limit changes in T to +/- 20% of current value (see default_limitchangesT)\n if(abs(svar(ioff)/ceq%tpval(1)).gt.default_limitchangesT) then\n svar(ioff)=sign(default_limitchangesT*ceq%tpval(1),svar(ioff))\n endif\n!CCI\n! limit change in T when there is condition on y\n if(ycondTlimit) then\n deltat=svar(ioff)\n! Suck it happend that svar(ioff) changed sign each iteration ....\n if(lastdeltat*deltat.lt.zero) then\n deltatycond=max(deltatycond-one,one)\n! never increase during one minimization ...\n! else\n! deltatycond=2.5D1\n endif\n if(abs(svar(ioff)).gt.deltatycond) then\n if(svar(ioff).gt.zero) then\n svar(ioff)=deltatycond\n else\n svar(ioff)=-deltatycond\n endif\n write(*,*)'MM ycondTlimit: ',deltat,svar(ioff)\n lastdeltat=svar(ioff)\n endif\n endif\n deltat=svar(ioff)\n! limit maximum change in deltat\n if(abs(deltat).gt.meqrec%tpmaxdelta(1)) then\n deltat=sign(meqrec%tpmaxdelta(1),deltat)\n if(ocv()) write(*,386)'limit the change in T: ',&\n ceq%tpval(1),deltat,svar(ioff)\n386 format(a,3(1pe12.4))\n endif\n ceq%tpval(1)=ceq%tpval(1)+deltat\n! problems here when -finit-local-zero is removed\n if(vbug) write(*,*)'T and deltaT:',ceq%tpval(1),deltat\n!CCI\n if(ceq%tpval(1).le.default_minimalchangesT) then\n write(*,*)'Attempt to set a temperature less than ',default_minimalchangesT,' K !!!'\n!CCI\n gx%bmperr=4187; goto 1000\n endif\n ioff=ioff+1\n endif\n if(meqrec%tpindep(2)) then\n! if pressure variable\n xxx=ceq%tpval(2)\n! check convergence\n! ??? svar(ioff) much too small!! why? add a factor ...\n! svar(ioff)=1.0D2*svar(ioff)\n!CCI\n if(abs(svar(ioff)).gt.default_deltaP*ceq%xconv) then\n!CCI\n converged=8\n cerr%mconverged=converged\n endif\n! write(*,389)'HMS pv: ',ioff,converged,svar(ioff),ceq%tpval(2)\n!389 format(a,2i3,4(1pe12.4))\n!CCI\n if(abs(svar(ioff)/ceq%tpval(2)).gt.default_limitchangesP) then\n svar(ioff)=sign(default_limitchangesP*ceq%tpval(2),svar(ioff))\n endif\n!CCI\n deltap=svar(ioff)\n! limit the changes in P\n if(abs(deltap).gt.meqrec%tpmaxdelta(2)) then\n deltap=sign(meqrec%tpmaxdelta(2),deltap)\n if(ocv()) write(*,386)'limit the change in P: ',&\n ceq%tpval(2),deltap,svar(ioff)\n endif\n ceq%tpval(2)=ceq%tpval(2)+svar(ioff)\n!CCI\n if(ceq%tpval(2).le.default_minimalchangesP) then\n!CCI\n write(*,*)'Attempt to set pressure lower than ',default_minimalchangesP,' Pa!!!'\n gx%bmperr=4187; goto 1000\n endif\n ioff=ioff+1\n endif\n!------------\n! update phase amounts, take care of fixed phases ....\n! the change in amounts are in svar(ioff+...)\n negamph=0\n negam=0\n irem=0\n iremax=0\n phfmin=zero\n! dncol+1 should be the first Delta_phase-amount\n ioff=dncol+1\n! scale all changes in phase amount with total number of atoms. At present\n! assume this is unity. Without scaling phase changes can be +/-1E+11 or more\n! which creates instabilities\n maxphch=zero\n! normphchange: do jph=1,meqrec%nstph\n normphchange: do jph=1,meqrec%nstph-meqrec%nfixph\n if(abs(svar(ioff+jph-1)).gt.maxphch) maxphch=abs(svar(ioff+jph-1))\n enddo normphchange\n\n!CCI\n! By default, ceq%scale_change_phase_amount equals to one.\n! Such a value is changed by the user in\n!-------------------------------------------------------\n!-------------------------------------------------------\nif(meqrec%noofits.eq.1) then \n if(ceq%type_change_phase_amount.gt.0) then\n ! whenever prescribed values are too big or differ greatly in order of magnitude\n ! Only cmix(1)=5 is interesting here. potentials already cared for\n ! loop if not the last condition\n ! This is the condition, cvalue is the prescibed value\n ! cmode and cmix contain information how to calculate its current value\n lastcondScale=>ceq%lastcondition\n conditionScale=>lastcondScale\n conditionScale=>conditionScale%next\n !---\n ! loop over all conditions and stops when the pointer condition is empty\n ! (use of apply_condition_value subroutine in gtp3D.F90)\n !---\n cmode=-1\n cmix=0\n maxprescribed = one\n sumprescribed = zero\n do while(.not.associated(conditionScale,lastcondScale))\n call apply_condition_value(conditionScale,cmode,cvalue,cmix,ccf,ceq)\n if (cmix(1).eq.5) then\n cvalue = conditionScale%prescribed\n if (cvalue.gt. maxprescribed ) then\n maxprescribed = cvalue\n endif\n sumprescribed = sumprescribed + cvalue\n endif\n conditionScale=>conditionScale%next\n enddo\n sumprescribed = sumprescribed - one\n sumprescribed = abs(sumprescribed)\n if(sumprescribed.lt.one) then\n sumprescribed = sumprescribed + one\n endif\n if(ceq%type_change_phase_amount.eq.1) ceq%scale_change_phase_amount=sumprescribed\n if(ceq%type_change_phase_amount.eq.2) ceq%scale_change_phase_amount=maxprescribed\n else \n ceq%scale_change_phase_amount=default_scalechangephaseamount\n endif\n endif\n!-------------------------------------------------------\n!-------------------------------------------------------\n if(maxphch.gt.ceq%scale_change_phase_amount) then\n ioff=dncol+1\n do jph=1,meqrec%nstph-meqrec%nfixph\n svar(ioff+jph-1)=svar(ioff+jph-1)*ceq%scale_change_phase_amount/maxphch\n enddo\n endif\n!CCI\n!\n ioff=dncol+1\n! do not change phase amounts the first iteration\n! write(*,554)svar\n!554 format('MM svar: ',6(1pe12.4))\n! if(meqrec%noofits.eq.1) then\n! goto 555\n! endif\n phamount2: do jph=1,meqrec%nstph\n! loop for all stable phases\n jj=meqrec%stphl(jph)\n! phr(jj)%curd%damount=zero\n! kkz=test_phase_status(phr(jj)%iph,phr(jj)%ics,xxx,ceq)\n kkz=phr(jj)%phasestatus\n! new -4=hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed\n if(kkz.ge.PHENTUNST .and. kkz.le.PHENTSTAB) then\n! phase is entered so its amount can change, -svar(ioff) is the change\n phs=phr(jj)%curd%amfu\n if(ioff.gt.size(svar)) then\n! error here calculating Fe-Si-C with 2 phases set fix zero\n! setting w(si)=w(c)=none and fix T; should have w(si) fix and T=none\n write(*,42)'MM Too many phases with variable amount',ioff,&\n size(svar),meqrec%nstph,phr(jj)%iph\n42 format(a,10i4)\n gx%bmperr=4193; goto 1000\n endif\n deltaam=svar(ioff)\n! Sigli convergence problem, bad guess of start amount of phases??\n! NOTE sign! -deltaam is the change in amount of phase, \n! write(*,43)'Deltaam: ',meqrec%noofits,jj,deltaam,lastdeltaam(jph),&\n! phr(jj)%curd%amfu,phr(jj)%curd%amfu-deltaam\n!43 format(a,2i3,6(1pe12.4))\n! tried to avoid too large changes in phase amount, just made things worse\n! if(meqrec%noofits.lt.3 .and. &\n! abs(deltaam).gt.0.5D0*phr(jj)%curd%amfu) then\n! deltaam=sign(0.1D0*phr(jj)%curd%amfu,deltaam)\n! write(*,43)'Modified: ',meqrec%noofits,jj,deltaam\n! endif\n! limit change in amount of phase\n if(abs(deltaam).gt.ceq%xconv) then\n! For the equil O-U with conditions on N(O) and N(U) there is no problem\n! with the amount of C1 but with N= and x(O)= the phase amount change varies\n! with sign and converges very slowly. Probably an interference with the\n! charge balance criteria.\n if(lastdeltaam(jph)*deltaam.lt.zero) then\n! wow, this seems to work ... other attmepts interfere directly with the\n! charge balance so one should carefully check how they are connected...\n! deltaam=5.0D-1*deltaam\n! The half worked to C1+tetragonal, it did not work for ionic liquid misc. gap\n! and in that case there is no charge balance criteria ... suck\n! deltaam=5.0D-1*deltaam\n! Dubbelt wow ... 0.2 works for both cases ... why?? More iterations though .. \n deltaam=2.0D-1*deltaam\n if(ocv()) write(*,3)'Phase amount sign change: ',&\n meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam\n! write(*,3)'Phase amount sign change: ',&\n! meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam\n3 format(a,3i3,6(1pe12.4))\n endif\n if(converged.lt.6) then\n converged=6\n cerr%mconverged=converged\n endif\n if(vbug) write(*,381)'Phase amount change: ',meqrec%noofits,jj,&\n phs,deltaam\n381 format(a,2i3,4(1pe12.4))\n endif\n lastdeltaam(jph)=deltaam\n if(phr(jj)%curd%amfu-deltaam.le.zero) then\n if(meqrec%nstph.eq.1) then\n! this is the only stable phase! cannot have negative or zero amount!\n deltaam=phr(jj)%curd%amfu-1.0D-2\n endif\n endif\n! if(-deltaam.gt.one) then\n!CCI Useless if type_change_phase_amount>0 (0 also??)\n! if(abs(deltaam).gt.one) then\n if(abs(deltaam).gt.one .and. ceq%type_change_phase_amount.eq.0) then\n!CCI Useless if type_change_phase_amount>0 (0 also??) ) then\n! try to prevent too large increase/decrease in phase amounts.\n! Should be related to total amount of components.\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,*)'Large change in phase amount: ',deltaam\n! deltaam=-one\n deltaam=sign(0.5D0,deltaam)\n endif\n!CCI\n if(abs(deltaam).gt.maxphasechange) then\n! to allow checks when phase set does not change and amount changes are small\n! like when calculating an almost stoichiometric composition like UO2 with\n! n(o)=2 and n(u)=1 at low T\n maxphasechange=abs(deltaam)\n endif\n! special test for Al-Ni fcc/fcc#2 two-phase\n! Calculations with Al-Ni T=1000, x(al)=.2 gives just a single FCC phase\n! possible problems that we change the amounts of the wrong composition set?\n! HOWEVER, I found the error is the second derivatives are wrong!!\n! if(meqrec%noofits.lt.10) deltaam=0.1*deltaam\n! write(*,383)'MM phase change: ',meqrec%noofits,jj,&\n! phr(jj)%iph,phr(jj)%ics,phr(jj)%curd%amfu,deltaam,svar(ioff)\n!383 format(a,2i3,2x,2i3,3(1pe12.4))\n phf=phr(jj)%curd%amfu-deltaam\n if(phs.gt.0.2D0 .and. phf.le.zero) then\n! violent change of phase fractions in Siglis case, liquid change from 1 to 0\n! Prevent changes larger than 0.1 if value larger than 0.5\n! old value of amfu in phs\n phf=0.1D0\n endif\n! write(*,363)' >>>> Stable phase: ',jj,phr(jj)%iph,&\n! phr(jj)%ics,phf,phs,deltaam,sum\n363 format(a,3i3,6(1pe12.4))\n! phr(jj)%curd%damount=deltaam\n ioff=ioff+1\n elseif(kkz.eq.PHFIXED) then\n! phase is fix, there is no change in its amounts\n phf=phr(jj)%curd%amfu\n! write(*,*)'Fixed phase: ',jj,phf\n else\n! phase is dormant or suspended, must not be stable!!!!\n call get_phase_name(phr(jj)%iph,phr(jj)%ics,phnames)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,373)phr(jj)%iph,phr(jj)%ics,kkz\n! write(*,373)trim(phnames),kkz\n373 format('MM The phase ',a,' cannot vary its amount:',3i7)\n gx%bmperr=4194; goto 1000\n endif\n! problem with Fe-O-U-Zr convergence, all phases disappear ??\n! write(*,364)'Stable phase: ',meqrec%noofits,jj,phr(jj)%iph,&\n! phr(jj)%ics,phf,phs,phr(jj)%prevam\n!364 format(a,4i3,6(1pe12.4))\n! make sure the driving force of stable phases to zero\n phr(jj)%curd%dgm=zero\n if(phf.lt.zero) then\n! phase has negative amount, NOT ALLOWED if it is the only stable phase \n if(meqrec%nstph-meqrec%nfixph.eq.1) then\n! write(*,367)'Trying to remove the only stable phase ',jj,&\n! phr(jj)%curd%amfu\n367 format(a,i3,1pe14.6)\n phf=0.5D0*phr(jj)%curd%amfu\n gx%bmperr=4195; goto 1000\n else\n! select phase with most negative amount\n if(phf.lt.phfmin) then\n phfmin=phf\n iremax=jj\n endif\n! trying to improve convergence by allowing phases to be removed quicker\n! write(*,363)'Phase with negative amount: ',jj,meqrec%noofits,0,&\n! phf,phs,phr(jj)%prevam\n! if(phf.lt.-1.0D-2) phf=zero\n if(jj.ne.notagain .and. phr(jj)%prevam.lt.zero) then\n! remove this phase if negative amount previous iteration also\n irem=jj\n! write(*,376)'meq_sameset remove: ',meqrec%noofits,nextch,&\n! jj,notagain\n376 format(a,4i4)\n! jumping to 1000 here means constitutions not changed in this iteration\n goto 1000\n else\n! mark this phase had negative amount this iteration\n! PROBLEM removing one of two composition sets of the same phase,\n! (miscibility gap), they may change which have negative amount each iteration\n phr(jj)%prevam=-one\n phf=zero\n endif\n endif\n else ! phase has positive amount, mark in prevam\n phr(jj)%prevam=one\n endif\n! store the new phase fraction (moles formula units)\n phr(jj)%curd%amfu=phf\n enddo phamount2 ! end of loop for jph=1,meqrec%nstph\n!555 continue\n!\n! if(iremax.gt.0) then\n! write(*,*)'meq_sameset remove?',meqrec%noofits,iremax,phfmin\n! endif\n if(vbug) write(*,*)'finished updating phase amounts: ',&\n meqrec%noofits,phasechangeok,irem\n! if(meqrec%nfixmu.gt.0) then\n! write(*,33)'mu1: ',(ceq%cmuval(nj),nj=1,meqrec%nrel)\n! write(*,33)'mu2: ',(ceq%complist(nj)%chempot(1),nj=1,meqrec%nrel)\n! write(*,33)'mu3: ',(ceq%complist(nj)%chempot(2),nj=1,meqrec%nrel)\n! write(*,33)'mu4: ',(svar(nj),nj=1,meqrec%nrel)\n!33 format(a,6(1pe12.4))\n! endif\n!-------------------------------------------------------\n! After solving the equil matrix and updating the chemical potentials,\n! the phase amounts and possibly T and P we correct constitions of all phases\n! - Now calculate correction of constituent fractions for all phases\n! See BoJ thesis eq. 30 (also in metastable phases) (paper I)\n! At the same time calculate the driving force for metastable phases\n ycorr=zero\n ycormax2=zero\n! to handle charge balance correction of constituent fractions\n chargerr=zero\n! chargerr fitted to fastest convergence using the ou test case\n! chargefact=1.0D-1 requires more than 100 iterations\n! chargefact=one requires more than 100 iterations\n! this value requires about 40 iteration\n!CCI\n chargefact=0.5*default_chargefact\n!CCI\n! chargefact=1.0D-1\n! kk is used to check if a charged phase is stable,\n! it is incremented for each stable phase\n kk=1\n! iadd is set to the unstable phase with largest positive driving force\n! dgmmax is the largest psoitive driving force\n iadd=0\n dgmmax=zero\n ysmm=zero\n!-----------------------------------------------------\n!CCI\n! Update the constitutions. If irem>0 remove this phase unless\n! we have made at least 'default_noremove' (see ocparam.F90) iterations with the current phase set\n if(irem.gt.0 .and. meqrec%noofits-phasechangeok.gt.default_noremove) goto 1000\n!CCI\n!--------------------------\n! These are needed to avoid several phases have exactly the same fracions\n! if the start guess is very bad and limitations are used\n yvar1=default_yvar1\n yvar2=default_yvar2\n!-----------------------------------------\n lap: do jj=1,meqrec%nphase\n! The current chemical potentials are in ceq%cmuval(i)\n! if(vbug) write(*,*)'Phase: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n if(jj.eq.meqrec%stphl(kk)) then\n! jj is stable, increment kk but do not make it larger than meqrec%nstph\n! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!!\n jph=kk\n kk=min(kk+1,meqrec%nstph)\n! if(meqrec%noofits.le.2) write(*,83)'dy1: ',jj,jph,kk\n!83 format(a,3i3,6(1pe12.4))\n else ! phase is not stable\n! calculate driving force for unstable phases. First calculate the sum\n! of the current phase composition and the calculated chemical potentials\n jph=0\n gsurf=zero; summ=zero\n do ie=1,meqrec%nrel\n! fatal parallel execution error once here\n! index '1' of dimension 1 of array 'phr' above upper bound of 0\n gsurf=gsurf+phr(jj)%xmol(ie)*ceq%cmuval(ie)\n summ=summ+phr(jj)%xmol(ie)\n enddo\n gsurf=gsurf/summ\n! calculate G_m plus any deltat and deltap terms\n dgm=phr(jj)%curd%gval(1,1)\n if(meqrec%tpindep(1)) then\n dgm=dgm+phr(jj)%curd%gval(2,1)*deltat\n endif\n if(meqrec%tpindep(2)) then\n dgm=dgm+phr(jj)%curd%gval(3,1)*deltap\n endif\n! scale dgm per mole atoms\n molesofatoms=phr(jj)%curd%abnorm(1)\n if(molesofatoms.lt.0.3D0) then\n! problem when a phase is stable with just vacancies !!!!!!!!!!!!\n if(phr(jj)%phasestatus.gt.0) then\n write(*,'(a,i3,a,F8.4)')'MM Phase: ',jj,&\n ' moles of atoms: ',molesofatoms\n endif\n endif\n! dgm=gsurf-dgm/phr(jj)%curd%abnorm(1)\n dgm=gsurf-dgm/molesofatoms\n if(phr(jj)%phasestatus.gt.0) then\n! we should be here only for UNSTABLE phases, phr(jj)%phasestatus<=0\n! For some reason a phase has entered/fixed status (>0) THAT IS AN ERROR\n! It happened in SMP2A when mapping Al-Ni and correcting too long step in T\n write(*,'(a,i4,i3)')'MM phase status reset:',jj,phr(jj)%phasestatus\n phr(jj)%phasestatus=0\n endif\n if(dgm.gt.dgmmax) then\n if(phr(jj)%phasestatus.ge.PHENTUNST .and. &\n phr(jj)%phasestatus.le.PHENTERED) then\n! phase is entered, can have status changed\n! if this is another constitution set of an already stable phase then check\n! below if the constitution of this phase is very similar to the stable one\n iadd=jj\n dgmmax=dgm\n! write(*,379)'meq_sameset add: ',meqrec%noofits,nextch,&\n! iadd,dgmmax\n379 format(a,3i4,4(1pe12.4))\n endif\n endif\n! The difference between previous and current DGM is used to check for\n! convergence below. Very important to check if continue iterating!!\n phr(jj)%prevdg=phr(jj)%curd%dgm\n phr(jj)%curd%dgm=dgm\n endif\n! Update constituent fractions for ALL phases, stable or not\n! if phr(jj)%xdone=1 then phase has no composition variation\n if(phr(jj)%xdone.eq.1) cycle\n!----------------------------------------------------\n allocate(cit(phr(jj)%idim),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 11: ',errall\n gx%bmperr=4370; goto 1000\n endif\n cit=zero\n if(meqrec%tpindep(1)) then\n! variable T, code copied from calc_dgdyterms, cit(nj) used below\n! write(*,44)'index 1: ',jj,phr(jj)%ncc,phr(jj)%idim,&\n! size(phr(jj)%invmat)\n do jy=1,phr(jj)%ncc\n sum=zero\n do iy=1,phr(jj)%ncc\n sum=sum+phr(jj)%invmat(iy,jy)*&\n phr(jj)%curd%dgval(2,iy,1)\n enddo\n cit(iy)=sum*deltat\n! write(*,44)'index 2: ',jj,jy,iy,0,sum\n!44 format(a,4i3,6(1pe12.4))\n enddo\n!! end copy\n! write(*,*)'Adding contribution from variable T to delta-y',&\n! phr(jj)%ncc\n! missing code for correction due to variable P?????\n endif\n! These are used to introduce some variation in fractions when the values\n! exceed limits. Otherwise one can as Sigli found have two stable phases\n! with exactly the same fractions and have a crash\n!\n moody: do nj=1,phr(jj)%ncc\n ys=zero\n do nk=1,phr(jj)%ncc\n pv=zero\n do nl=1,meqrec%nrel\n! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT)\n! phr(jj)%dxmol(nl,nk) is the derivative of component nl\n! wrt constituent nk\n! write(*,*)'ycorr: ',nl,ceq%complist(nl)%chempot(1)/ceq%rtn\n! write(*,612)'MM y1: ',nk,nl,&\n! ceq%complist(nl)%chempot(1)/ceq%rtn,ceq%cmuval(nl)\n!612 format(a,2i4,6(1pe12.4))\n pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk)\n! write(*,111)'pvx: ',nj,pv,ceq%complist(nl)%chempot(1),&\n! ceq%rtn,phr(jj)%dxmol(nl,nk)\n! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk)\n! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk)\n enddo\n pv=pv-phr(jj)%curd%dgval(1,nk,1)\n ys=ys+phr(jj)%invmat(nj,nk)*pv\n! write(*,111)'pvx: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),&\n! phr(1)%invmat(nj,nk)\n!111 format(a,i2,6(1pe12.4))\n enddo\n if(phr(jj)%chargebal.eq.1) then\n! For charged phases add a term \n! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q\n ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n phr(jj)%curd%netcharge\n! ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n! phr(jj)%charge\n! jph is nonzero only for stable phases\n if(jph.gt.0 .and. &\n! if(jj.eq.meqrec%stphl(kk) .and. &\n! Hm, is this check correct? kk is updated above to be the next stable phase..\n! abs(phr(jj)%charge).gt.chargerr) then\n! chargerr=abs(phr(jj)%charge)\n! signerr=phr(jj)%charge\n abs(phr(jj)%curd%netcharge).gt.chargerr) then\n chargerr=abs(phr(jj)%curd%netcharge)\n signerr=phr(jj)%curd%netcharge\n endif\n! write(*,*)'Charge: ',jj,phr(jj)%netcharge\n else\n! enshure charge is zero!! \n if(phr(jj)%curd%netcharge.ne.zero) &\n write(*,*)'MM neutral phase with charge: ',&\n phr(jj)%curd%phlink,phr(jj)%curd%netcharge\n phr(jj)%curd%netcharge=zero\n endif\n! when T is variable\n ycorr(nj)=ys+cit(nj)\n if(abs(ycorr(nj)).gt.ycormax2) then\n ycormax2=ycorr(nj)\n endif\n! Sigli converge problem, fixed by changing stable phases in different order\n! write(*,111)converged,jj,nj,ys\n!111 format('Y corr: cc/ph/cons/y: ',i2,2i4,1pe12.4)\n! should possibly be ycorr(nj) instead of ys (ycorrmax)\n if(abs(ys).gt.ceq%xconv) then\n! if the change in any constituent fraction larger than xconv continue iterate\n! write(*,*)'Convergence criteria, phase/const: ',jj,nk\n if(phr(jj)%stable.eq.0) then\n! Phase is not stable\n! Handle convergence criteria different if inmap=1 or not\n mapping7: if(inmap.eq.0) then\n! we are NOT in STEP/MAP, increase convergence criteria to handle\n! the Mo-Ni-Re 3 phase equilibria\n!CCI\n if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then\n!CCI\n! for unstable phases the corrections must be smaller than ...????\n if(converged.lt.3) then\n converged=3\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n!CCI\n elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then\n!CCI\n!212 format(a,3i3,i4,4(1pe12.4))\n if(converged.lt.4) then\n!CCI\n factconv=default_correctionfactorDGM\n if(phr(jj)%ncc.gt.10) then\n! Calculation with the COST507 database and 20 elements too many iterations\n! ... allow larger gdconv(1) \n factconv=10.0*factconv\n endif\n!CCI\n if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.&\n factconv*ceq%gdconv(1)) then\n! Must be less than this if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.5.0E-3) then\n converged=4\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n else\n if(converged.eq.0) then\n converged=1\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n else\n! we are doing step/map NO CHANGE, use old convergence criteria\n! otherwise step1 and mmap4 are uncomplete with those above ...\n!CCI\n if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then\n! for unstable phases the corrections must be smaller than ...????\n if(converged.lt.3) then\n converged=3\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then\n!CCI\n! maybe accept 100 times larger correction than for stable phases\n! write(*,107)'metast ph ycorr: ',ys,&\n! phr(jj)%curd%yfr(nj)\n if(converged.lt.2) then\n converged=2\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n else\n if(converged.eq.0) then\n converged=1\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n endif mapping7\n elseif(converged.lt.4) then\n! large correction in fraction of constituent fraction of stable phase\n! Problem here with CVMSRO model, ys=0.00272 when x(b)=.5\n! write(*,*)'MM converged 4A: ',jj,nj,ys\n converged=4\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n elseif(phr(jj)%stable.eq.1) then\n! check to find good convergence criteria in Re-V test case\n if(abs(ycorr(nj)).gt.ysmm) then\n jmaxy=jj\n ysmm=abs(ycorr(nj))\n ysmt=phr(jj)%curd%yfr(nj)\n endif\n! check if the change in any fraction is larger than the fraction ...\n if(ycorr(nj).gt.phr(jj)%curd%yfr(nj)) then\n! write(*,612)'MM y2: ',jj,nj,ycorr(nj),phr(jj)%curd%yfr(nj)\n if(converged.lt.4) then\n converged=4\n cerr%mconverged=converged\n endif\n endif\n endif\n enddo moody\n! end of correction of y fractions\n!---------------------------------\n! Limit change in fractions .... all ycorr(nj) multiplied with same factor\n! keeping the sum of corrections in all sublattices as zero\n! if(converged.ge.4) then\n! Added to underetand convergence problem with CVMSRO\n! write(*,*)'MM CVMSRO convergence: ',meqrec%noofits,jj,converged\n! converged=1 or 2 means constituent fraction in metastable phase not converged\n! converged 3 means large change constituent fraction of unstable phase\n! converged 4 means a constituent fraction of a stable phase change a lot\n! converged=5 means a condition not fullfilled\n! converged=6 means charge balance not converged or large phase fraction change\n! converged=7 means large change in chemical potentials\n! converged=8 means large change T or P\n! endif\n if(vbug) write(*,74)'maximum corr: ',&\n meqrec%noofits,jj,ycormax2,ycormax(jj)\n74 format(a,2i3,2(1pe12.4))\n if(ycormax(jj)*ycormax2.le.zero) then\n! the condition is zero at first step, limit that\n yfact=one/(2.0D0+abs(ycormax2))\n ycormax2=yfact*ycormax2\n!CCI\n elseif(phr(jj)%ionliq.gt.0 .and. ycormax2.lt.default_upperycormax2) then\n!CCI\n! step seems to be very small ... try to decrease number of iteration\n yfact=2.0d0\n else\n yfact=one\n endif\n moody2: do nj=1,phr(jj)%ncc\n! all corrections of constituent fractions in ycorr(1..phr(jj)%ncc)\n! ymagic is halfed every 5th iteration when same phase set, after 5 times reset\n yprev=phr(jj)%curd%yfr(nj)\n! yarr(nj)=yprev+ycorr(nj)\n if(phr(jj)%ionliq.gt.0) then\n! For ionic liquids, an even smaller step is allowed ...\n! The O-Pu-U test case converged up to 2800 without any particular factor\n! with a factor 0.4 it converged up to 3000K (~150 its), yfact does not\n! has any significant influence. \n! yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact\n! tafidbug, 0.2 created problems\n! yarr(nj)=yprev+2.0D-1*ycorr(nj)*yfact\n! yarr(nj)=yprev+3.0D-1*ycorr(nj)*yfact\n!CCI\n yarr(nj)=yprev+default_ionliqyfact*ycorr(nj)*yfact\n!CCI\n! yarr(nj)=yprev+ycorr(nj)*yfact\n! write(*,281)'ycorr: ',nj,yfact,yprev,yarr(nj)\n!281 format(a,i3,6(1pe12.4))\n else\n yarr(nj)=yprev+ycorr(nj)*yfact\n endif\n! if(vbug) then\n! output to check reasons for bad convergence\n! write(*,57)'MM y&dy ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%stable,nj,&\n! ys,cit(nj),phr(jj)%curd%yfr(nj),yarr(nj),ycorr(nj)\n!57 format(a,3i2,i3,5(1pe12.4))\n! endif\n!CCI\n if(yarr(nj).lt.default_ymin) then\n!CCI\n! this added to avoid too drastic jumps in small fractions\n! The test case ccrfe1.OCM needs this\n!CCI\n if(yprev.gt.default_ylow) then\n!CCI\n! write(*,*)'Applying fraction change limitation 4 ',jj\n!CCI\n yarr(nj)=0.9*default_ylow\n!CCI\n elseif(test_phase_status_bit(phr(jj)%iph,PHGAS)) then\n! for gas phase one must allow smaller constituent fractions\n!CCI\n if(yarr(nj).lt.default_ymingas) then\n yarr(nj)=default_ymingas\n endif\n!CCI\n else\n! write(*,*)'Applying fraction change limitation 5 ',jj\n!CCI\n yarr(nj)=default_ymin+yvar2\n!CCI\n yvar2=2.0D0*yvar2\n if(yvar2.gt.default_upperyvar2) yvar2=default_yvar2\n!CCI\n endif\n endif\n if(yarr(nj).gt.one) then\n! write(*,*)'Applying fraction change limitation 6 ',jj\n yarr(nj)=one-yvar1\n yvar1=2.0D0*yvar1\n!CCI\n if(yvar1.gt.default_upperyvar1) yvar1=default_yvar1\n!CCI\n endif\n enddo moody2 ! end loop for all constituents nj in phase jj\n!\n ycormax(jj)=ycormax2\n! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<<\n! if(meqrec%noofits.le.2) write(*,83)'dy2: ',jj,phr(jj)%iph,kk,&\n! (yarr(nj),nj=1,phr(jj)%ncc)\n! write(*,114)'YARR: ',jj,phr(jj)%ics,(yarr(nj),nj=1,phr(jj)%ncc)\n!114 format(a,2i3,8(F7.4))\n! write(*,*)'MM calling set_constitution 1:',phr(jj)%iph,phr(jj)%ics\n call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n deallocate(cit)\n enddo lap\n! finished correction of all constituent fractions in all phases\n!-------------------------------------------------------\n! do jph=1,meqrec%nstph\n! jj=meqrec%stphl(jph)\n! write(*,393)'Stable phase: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n! enddo\n!393 format(a,2i4,6(1pe12.4))\n! check if fraction corrections in stable phases increases\n! it solved a problem in ReV when fractions initially changed very little\n! but the change increased each iteration\n if(meqrec%noofits.gt.8) then\n! this means minimum 8 iterations!!\n increase=0\n elseif(abs(ysmm).gt.prevmaxycorr) then\n! do this check only for the first 8 iterations\n increase=1\n! write(*,265)increase,ysmm,prevmaxycorr\n!265 format('*** max stable phase ycorr: ',i3,2(1pe12.4))\n endif\n prevmaxycorr=abs(ysmm)\n!-------------------------------------------------------\n! check charge balance, must be 100 times better than fractions\n! otherwise strange chemical potentials, why??\n! The request for 100 times better than ceq%xconv is OK with conditions \n! N(U)= N(O)= but not with N= x(O)=\n! if(chargerr.gt.1.0D-2*ceq%xconv) then\n! strengthen charge balance convergence criteria\n if(chargerr.gt.ceq%xconv) then\n if(ocv()) write(*,654)'Charge error: ',signerr,chargerr,ceq%xconv\n654 format(a,6(1pe12.4))\n if(converged.lt.6) then\n converged=6\n cerr%mconverged=converged\n endif\n endif\n!-------------------------------------------------------\n if(converged.eq.3) then\n! force one extra iterations with large fraction variations in unstable phases\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,&\n! increase,yss,yst\n level3=level3+1\n elseif(converged.eq.4) then\n! this means large fraction variations in stable phases\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,&\n! increase,yss,yst\n!267 format(a,3i4,2(1pe12.4))\n level3=0\n else\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,increase\n level3=0\n endif\n!----------------------------------------------\n! continue iterate if phase change or not converged\n! call get_state_var_value('X(O) ',value,phnames,ceq)\n! trying to understand how STEP/MAP sets fix phases ....\n! write(*,*)'MM Fraction of O: ',value\n if(iadd.gt.0) then\n! check if phase to be added is already stable as another composition set\n! This check should maybe be above as maybe another phase want to be stable??\n if(same_composition(iadd,phr,meqrec,ceq,dgm)) iadd=0\n endif\n! check if phase iadd is stoichiometric and if so check of any stable phase\n! phase that is stoichiometric has the same composition!! IF SO\n! remove that phase at the same time ...\n srem=0\n if(meqrec%nrel.gt.1 .and. iadd.gt.0) then\n! skip this for unary system!!!\n jy=meqrec%phr(iadd)%phtupix\n samestoi: do nj=1,meqrec%nstph\n! loop through all stable phases for other phase with same stoichiometry\n jj=meqrec%stphl(nj)\n if(jj.ne.iadd) then\n iy=meqrec%phr(jj)%phtupix\n! check if same composition ... how? same_stoik in gtp3Y.F90\n if(same_stoik(jy,iy)) then\n srem=jj\n exit samestoi\n endif\n endif\n enddo samestoi\n endif\n if(srem.gt.0) then\n jy=meqrec%phr(iadd)%phtupix\n call get_phasetup_name(jy,phnames)\n iz=len_trim(phnames)+2\n call get_phasetup_name(iy,phnames(iz:))\n! write(*,*)'MM Same stoichiometry: ',trim(phnames),inmap,value\n! try to handle this by calculating the T when the two stochiometric phases\n! has the same Gibbs energy. Use this only if maping and T is not a condition\n if(inmap.ne.0) then\n! inmap=0 if we are not in a step/map calculation\n! I do not understand why iy and jy here ?? I think iadd and srem ...\n call two_stoich_same_comp(iy,jy,mapx,meqrec,inmap,ceq)\n endif\n iadd=iy; irem=jy\n! write(*,*)'Phases: ',iadd,irem\n! after this routine set the error code to return to mapping\n! stop 'same stoichimetries'\n\n! to be handelled either by map/step routines or meq_phaseset\n gx%bmperr=4364; goto 1000\n endif\n! if(meqrec%noofits.gt.2 .and. (irem.gt.0 .or. iadd.gt.0)) then\n if(irem.ne.0 .or. iadd.ne.0) then\n goto 1100\n endif\n!--------------------------------------------------------------------\n! write(*,*)'Iterations and convergence: ',meqrec%noofits,converged\n!--------------------------------------------------------------------\n! check convergence\n! if(meqrec%noofits.gt.400) then\n! write(*,778)'Test converged: ',meqrec%noofits,converged\n!778 format(a,2i4)\n! endif\n!------------------------------------------------------------\n! This output gives a good indication for convergence problem\n if(vbug) write(*,*)'Convergence criteria: ',converged,level3\n! converged=1 or 2 means constituent fraction in metastable phase not converged\n if(converged.gt.3) goto 100\n! converged 3 means large change conts. fraction of unstable phase change a lot\n! level3 is nuber of previous iteration with converged=3\n! with allcost I had the correct equilibrium but occational converged=4\n! probably because a metastable liquid with almost identical composition\n! as the stable interfeared. Accept converged=3 twice in a row as correct!!\n! if(converged.eq.3 .and. level3.lt.4) goto 100\n if(converged.eq.3 .and. level3.lt.2) goto 100\n! converged 4 means a constituent fraction of a stable phase change a lot\n! converged=5 means a condition not fullfilled\n! converged=6 means charge balance not converged or large phase fraction change\n! converged=7 means large change in chemical potentials\n! converged=8 means large change T or P\n! always force 4 iterations, there is a minimum above forcing 9 iterations.\n!CCI\n if(meqrec%noofits.lt.default_minimaliterations) goto 100\n!CCI\n if(increase.ne.0) then\n! continue if corrections in constituent fractions in stable phases increases\n! This is needed to change fractions in a gas from 1E-20 to some significant\n! value\n goto 100\n endif\n!------------------------\n! equilibrium calculation converged, do some common thing\n! write(*,*)'Converged: ',converged\n goto 800\n!\n!==============================================================\n! equilibrium calculation converged, save chemical potentials (svar*RT)\n800 continue\n!------------------------------------------------------\n! do not save system matrix but save -dimension for use with derivatives\n ceq%sysmatdim=-nz1\n! but save components with fix mu and fix phases\n ceq%nfixmu=meqrec%nfixmu\n if(allocated(ceq%fixmu)) deallocate(ceq%fixmu)\n if(ceq%nfixmu.gt.0) then\n allocate(ceq%fixmu(ceq%nfixmu),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 12: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do ie=1,ceq%nfixmu\n ceq%fixmu(ie)=meqrec%mufixel(ie)\n enddo\n endif\n ceq%nfixph=meqrec%nfixph\n if(allocated(ceq%fixph)) deallocate(ceq%fixph)\n if(ceq%nfixph.gt.0) then\n allocate(ceq%fixph(2,ceq%nfixph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 13: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do ie=1,ceq%nfixph\n! phase and composition set numbers\n ceq%fixph(1,ie)=meqrec%fixph(1,ie)\n ceq%fixph(2,ie)=meqrec%fixph(2,ie)\n enddo\n endif\n!-------------------------------------\n if(vbug) write(*,*)'At 800 in meq_sameset: ',meqrec%nrel\n ceq%rtn=globaldata%rgas*ceq%tpval(1)\n do ie=1,meqrec%nrel\n ceq%complist(ie)%chempot(1)=ceq%cmuval(ie)*ceq%rtn\n! write(*,*)'Chempot/RT: ',cea%cmuval(ie),svar(ie)\n enddo\n! list stable phases on exit\n! do jph=1,meqrec%nstph\n! jj=meqrec%stphl(jph)\n! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n! enddo\n! set status of the stable phases on exit\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n call mark_stable_phase(phr(jj)%iph,phr(jj)%ics,ceq)\n! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n enddo\n!----------------------\n! save inverted phase matrix and more for future use when calculating H.T etc\n! If already allocated then dealloc/alloc as number of constituents can change\n! if(vbug) write(*,*)'allocate/deallocate in meq_sameset: ',meqrec%nphase\n do jj=1,meqrec%nphase\n if(allocated(phr(jj)%curd%cinvy)) then\n deallocate(phr(jj)%curd%cinvy)\n deallocate(phr(jj)%curd%cxmol)\n deallocate(phr(jj)%curd%cdxmol)\n endif\n! why is the dimension if invmat so different???\n ie=phr(jj)%idim\n if(vbug) write(*,*)'Save inverted phase matrix in meq_sameset: ',jj,ie\n! ie=int(sqrt(real(size(phr(jj)%invmat)))+0.1)\n! write(*,*)'Size: ',ie,phr(jj)%ncc\n allocate(phr(jj)%curd%cinvy(ie,ie),stat=errall)\n allocate(phr(jj)%curd%cxmol(meqrec%nrel),stat=errall)\n allocate(phr(jj)%curd%cdxmol(meqrec%nrel,phr(jj)%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 14: ',errall\n gx%bmperr=4370; goto 1000\n endif\n phr(jj)%curd%cinvy=phr(jj)%invmat\n phr(jj)%curd%cxmol=phr(jj)%xmol\n phr(jj)%curd%cdxmol=phr(jj)%dxmol\n!----------------------\n enddo\n goto 1000\n! output of equilibrium matrix when error return\n990 continue\n do iz=1,nz1\n write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2)\n enddo\n!\n1000 continue\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n! write(*,*)'minimization error: ',gx%bmperr\n! elseif(irem.eq.0 .and. iadd.eq.0) then\n endif\n! jump here if phase change\n1100 continue\n! trying to extract the configuratinal entropy of MQMQA\n! write(*,'(\"MM leaving meq_sameset\",1pe14.4)')sconfmqmqa\n! DEBUG output for testing when phase change, Christines probkem\n! write(*,*)'MM iadd and irem: ',iadd,irem\n! if(iadd.gt.0) then\n! jy=meqrec%phr(iadd)%phtupix\n! call get_phasetup_name(jy,phnames)\n! write(*,'(a,i4,2x,a,1pe12.4)')'MM found new stable phase: ',jy,&\n! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm\n! call list_conditions(kou,ceq)\n! elseif(irem.ne.0) then\n! jy=meqrec%phr(abs(irem))%phtupix\n! call get_phasetup_name(jy,phnames)\n! write(*,*)'MM found unstable phase: ',trim(phnames),jy,&\n! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm\n! call list_conditions(kou,ceq)\n! endif\n if(vbug) write(*,*)'Deallocating smat and svar'\n deallocate(smat)\n deallocate(svar)\n if(vbug) write(*,*)'Final return from meq_sameset'\n! if(gx%bmperr.ne.0) write(*,*)'Error return from meq_sameset',gx%bmperr\n! if(irem*iadd.gt.0) write(*,*)'Leaving meq_sameset: ',irem,iadd\n! write(*,*)'Exit meq_sameset'\n return\n! too many iterations\n1200 continue\n! write(*,*)'Too many iterations: ',meqrec%noofits,ceq%maxiter\n gx%bmperr=4204\n goto 1000\n end subroutine meq_sameset_okmap4\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_sameset_okmqmqa\n!\\begin{verbatim}\n recursive subroutine meq_sameset_okmqmqa(irem,iadd,mapx,meqrec,phr,inmap,ceq)\n! iterate until phase set change, converged or error (incl too many its)\n! iadd = -1 indicates called from calculating a sequence of equilibria\n! mapx is used when calling meq_sameset from step/map\n!\n! used for mqmqa\n!\n implicit none\n integer irem,iadd,inmap,mapx\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer increase,ioff,ik,jj,jph,ie,ierr,jmaxy\n integer kk,kkz,level3,mph,negam,negamph,nj,nk,nl\n integer nz1,nz2\n TYPE(meq_phase), pointer :: pmi\n! Using SAVE not possible for parallel calculations here once is just warning\n logical, save :: once=.true.\n double precision, dimension(5) :: qq\n double precision, dimension(maxconst) :: ycormax\n double precision, dimension(:,:), allocatable :: smat\n double precision, dimension(:), allocatable :: svar\n! these arrays should maybe be allocated ....\n double precision, dimension(maxconst) :: ycorr,yarr\n integer converged,jz\n double precision chargefact,chargerr\n double precision dgm,summ,dgmmax,gsurf,phf,phs\n double precision prevmaxycorr,pv,signerr\n double precision xxx,ycormax2,yprev,ys,ysmm,ysmt,yss,yst\n double precision yvar1,yvar2\n double precision maxphch\n double precision sum\n double precision, dimension(:), allocatable :: cit\n double precision deltat,deltap,deltaam,yfact\n\n! to check if we are calculating a single almost stoichiometric phase ...\n integer iz,tcol,pcol,nophasechange,notagain\n double precision maxphasechange,molesofatoms,factconv\n double precision lastdeltat,deltatycond,phfmin,value\n integer notf,dncol,iy,jy,iremsave,phasechangeok,nextch,iremax,srem,errall\n character phnames*50\n double precision, dimension(:), allocatable :: lastdeltaam\n logical vbug,stoikph,badmat\n!CCI\n integer cmix(22), cmode\n double precision cvalue, maxprescribed, sumprescribed, ccf(5)\n TYPE(gtp_condition), pointer :: conditionScale, lastcondScale\n!CCI\n! NOTE using save cannot be reconciled with parallel calculations\n save notagain\n!\n! do not allow return unless meqrec%noofits greater or equal to nextch\n mapx=0\n nextch=meqrec%noofits+4\n stoikph=.true.\n nophasechange=0\n maxphasechange=zero\n! this is set each time the set of phases changes, controls change in T\n! when there is a condition on y\n!CCI\n deltaTycond=default_deltaTycond\n!CCI\n if(iadd.eq.-1 .or. ocv()) then\n write(*,*)'Debug output in meq_sameset'\n vbug=.TRUE.; iadd=0\n else\n vbug=.FALSE.\n endif\n! vbug=.TRUE.\n if(vbug)write(*,*)'entering meq_sameset',meqrec%nphase,irem\n! write(*,*)'MM entering meq_sameset',meqrec%nphase,irem\n iremsave=irem\n! this is max correction of constituent fraction for each phases\n ycormax=zero\n! magic trying to force decreasing step in fractions\n! ymagic=one\n! nmagic=0\n! this is an attempt to decrease variation in phase amount corrections\n allocate(lastdeltaam(meqrec%nstph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 9: ',errall\n gx%bmperr=4370; goto 1000\n endif\n lastdeltaam=zero\n! dimension matrix for conditions, components+stable phases\n nz1=meqrec%nrel-meqrec%nfixmu+meqrec%nstph-meqrec%nfixph\n if(meqrec%tpindep(1)) nz1=nz1+1\n if(meqrec%tpindep(2)) nz1=nz1+1\n if(ocv()) write(*,11)meqrec%nrel,meqrec%nfixmu,meqrec%nstph,&\n meqrec%nfixph,meqrec%tpindep,nz1,ceq%tpval(1)\n11 format('In meq_sameset, sysmat: ',4i7,2l2,i5,1pe12.4)\n nz2=nz1+1\n if(vbug) write(*,*)'Allocating smat: ',nz1\n allocate(smat(nz1,nz2),stat=errall)\n allocate(svar(nz1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 10: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! check if constituent fraction correction in stable phases increases\n! for each iteration. Needed for the Re-V case ....\n prevmaxycorr=zero\n increase=0\n level3=0\n! this is set TRUE after 3 iterations\n phasechangeok=meqrec%noofits\n if(phasechangeok.eq.1) then\n notagain=0\n endif\n! debugging problem with changing axis in mapping\n if(ocv() .and. meqrec%tpindep(1)) write(*,*)'variable T: ',ceq%tpval(1)\n!-------------------------------------------------------------\n! return here until converged or phase set change\n100 continue\n meqrec%noofits=meqrec%noofits+1\n cerr%flag=0\n! nonzero flag means error output below\n! cerr%flag=1\n!CCI\n if(nophasechange.gt.default_nophasechange) then\n if(maxphasechange.lt.default_maxphaseamountchange) then\n!CCI\n! if we have not changed the set of stable phases for many iterations\n! and the changes in phase amounts is small maybe we are calculationg an\n! almost stoichiometric phase? Changes in MU can be large!\n if(stoikph .and. meqrec%nphase.gt.1) then\n! write this message if VERBOSE is set\n if(btest(globaldata%status,GSVERBOSE)) write(*,30)nophasechange,&\n converged,cerr%nvs,ceq%tpval(1)\n30 format('Slow converge at ',3i3,F10.2)\n if(cerr%flag.ne.0) then\n write(*,31)(cerr%typ(iz),cerr%val(iz),cerr%dif(iz),&\n iz=1,cerr%nvs)\n31 format('MM 31: ',3(i3,1pe12.4,e10.2))\n endif\n! write message only (once for each minimization)\n stoikph=.false.\n! if this happends during step/map give error message to force smaller steps\n if(inmap.eq.1 .and. meqrec%noofits.eq.ceq%maxiter) then\n gx%bmperr=4359; goto 1000\n endif\n endif\n!+ converged=0\n!+ goto 1000\n! else\n! maybe use this to improve concergence??\n! if(.not.allocated(loopfact)) then\n! allocate(loopfact(meqrec%nrel))\n! endif\n endif\n endif\n nophasechange=nophasechange+1\n cerr%nvs=0\n cerr%mconverged=0\n! this is magic ....\n! nmagic=nmagic+1\n! if(mod(nmagic,5).eq.0) ymagic=0.5*ymagic\n! if(mod(nmagic,25).eq.0) ymagic=one\n! end of magic\n!101 format(a)\n! write(*,*)'Iteration: ',meqrec%noofits,' ----------------------------- '\n if(ocv()) write(*,199)meqrec%noofits,ceq%tpval(1),meqrec%nstph,&\n (meqrec%stphl(jz),jz=1,meqrec%nstph)\n!199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,10i3)\n199 format(/'Equil iter: ',i3,f8.2,', stable phases: ',i3,2x,100i3)\n if(meqrec%noofits.gt.ceq%maxiter) then\n! try to extract some more information when too many iterations\n write(*,1190)meqrec%noofits,ceq%maxiter,converged\n! btest(globaldata%status,GSSILENT),&\n! btest(globaldata%status,GSVERBOSE)\n1190 format('MM Iteration: ',3i5)\n! converged means\n! converged=1 or 2 means constituent fraction in metastable phase not converged\n! converged 3 means large change constituent fraction of unstable phase\n! converged 4 means a constituent fraction of a stable phase change a lot\n! converged=5 means a condition not fullfilled\n! converged=6 means charge balance not converged or large phase fraction change\n! converged=7 means large change in chemical potentials\n! converged=8 means large change T or P\n! if(btest(globaldata%status,GSSILENT)) then\n! endif\n goto 1200\n endif\n converged=0\n if(vbug) write(*,*)'Iteration: ',meqrec%noofits,converged\n! loop for all phases and composition sets, loop over phr\n! if(meqrec%tpindep(1)) write(*,*)'variable T: ',meqrec%noofits,ceq%tpval(1)\n!\n! >>>>>>>>>>>> here we can parallelize \n!\n!-$omp parallel do private(pmi) shared(meqrec)\n! nullify liquid pointer\n nullify(meqrec%pmiliq)\n! write(*,*)'MM meq_sameset: begin loop for all phases'\n parallel: do mph=1,meqrec%nphase\n pmi=>phr(mph)\n! this routine calculates G and derivatives, the phase matrix and inverts it.\n! it also calculates the amounts of moles of components in the phase\n!-$ write(*,*)'Phase and tread: ',mph,omp_get_thread_num()\n! to set correct pmiliq we must calculate all liquids first!!\n! write(*,*)'MM call onephase: ',pmi%iph,pmi%ics\n call meq_onephase(meqrec,pmi,ceq)\n! write(*,*)'MM back from onephase: ',gx%bmperr\n if(gx%bmperr.ne.0) then\n! using LAPCK gives severe problems if we do not stop\n goto 1000\n if(pmi%stable.eq.0) then\n! if this happends for an unstable phase just continue but ensure it will\n! not be stable (in a very crude way)\n! write(*,*)'Matrix inversion error for unstable phase',pmi%iph\n pmi%curd%gval(1,1)=one\n gx%bmperr=0\n else\n! Inversion error for stable phase is fatal, error code already set\n if(once) then\n write(*,*)'Warning, matrix inversion problem: ',pmi%iph\n once=.false.\n else\n goto 1000\n endif\n gx%bmperr=0\n endif\n endif\n!107 format(a,6(1pe12.3))\n! end of pmi% scope\n enddo parallel\n! hejhopp\n! write(*,*)'MM meq_sameset: end loop for all phases'\n!-$omp end parallel do\n!\n!=======================================================================\n! step 2: calculation of equil matrix\n! Solve for chemical potentials and conditions using all stable phases\n! The EQUIL MATRIX (smat) has one row for each stable phase and\n! one row for each component representing a condition\n! (If a fix phase condition or chem.pot. condition slightly different??)\n!----------------------------------------\n300 continue\n! if(vbug) write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,&\n! write(*,301)'MM Calculating general equil matrix',meqrec%nfixmu,&\n! meqrec%nfixph,meqrec%tpindep,meqrec%noofits\n301 format(a,2i2,2l2,i5)\n! some arguments here are redundant but kept for some\n call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,&\n dncol,converged,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM Back from setup_equilmatrix',tcol\n!=====================================================================\n! debug output of equil matrix, last column is right hand side\n!380 continue\n! open(33,file='eqmat.dat ',access='sequential',status='unknown')\n! write(33,*)'Equilibrium matrix',nz1\n! do iz=1,nz1\n! write(33,112)iz,(smat(iz,jz),jz=1,nz2)\n!112 format('>',i4,1x,4(1pe15.6))\n! enddo\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> debug\n! debug output to follow the minimization: all mu_i, and \n! for all stable phases np^alpha, G^alpha, and x^alpha_i\n! call calc_molmass(xdum,wdum,tmdum,wmdum,ceq)\n! write(*,116)'MM mu:',meqrec%nstph,(ceq%cmuval(iz),iz=1,meqrec%nrel),&\n! (xdum(iz),iz=1,meqrec%nrel)\n!116 format(a,i3,6(1pe12.4))\n! do iz=1,meqrec%nstph\n! jj=meqrec%stphl(iz)\n! call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,&\n! xdum,wdum,tmdum,wmdum,dumdum,ceq)\n! if(gx%bmperr.ne.0) stop 'debug'\n! amount of phase, G of phase, x_i of phase\n! write(*,116)'MM ph:',jj,phr(jj)%curd%amfu,smat(iz,nz2),&\n! (xdum(ioff),ioff=1,meqrec%nrel)\n! enddo\n! end debug output\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n if(vbug) then\n! when convergence problem list smat here and (and svar below) and study!!!\n call list_conditions(kou,ceq)\n do iz=1,nz1\n write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2)\n enddo\n endif\n228 format(a,6(1pe12.4),(8x,6e12.4))\n! This is an emergecy check that the smat matrix does not contain\n! values >default_bigvalues. We should test for Infinity and NaN but how??\n do iz=1,nz1\n do jz=1,nz2\n!CCI\n if(abs(smat(iz,jz)).gt.default_bigvalues) then\n!CCI\n write(*,118)iz,jz\n118 format('meq_sameset has illegal values in equilibrium matrix',2i4)\n gx%bmperr=4354; goto 990\n endif\n enddo\n enddo\n! HERE new values of chemical potentials and and amount of phases\n! call lingld(nz1,nz2,smat,svar,nz1,ierr)\n! goto 119\n\n! Rearranged the IF statements/BoS\n! if(inmap.eq.0 and ceq%splitsolver .eq. 1) then\n!CCI\n!-----------------------------------------------------------------------\n!-----------------------------------------------------------------------\n! Development based on the work of Joao Pedro Carvalho Teuber 12/2020\n! Jacobi preconditioning if allowed\n!BS if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.&\n!BS (meqrec%nrel.eq.meqrec%nstph)) then\n!BS call precond(nz1,nz2,smat,badmat)\n! added due to problems with parallel1 and parallel2, 20200220/BoS\n! PRECOND has found a zero diagonal element but just use lingld and skip split\n! if(badmat) then\n! write(*,112)nz1,nz2\n112 format('MEQ_SAMESET: phase matrix illconditioned',2i3)\n! debug output\n! do iz=1,nz1\n! write(*,113)iz,(smat(iz,jz),jz=1,nz1)\n! enddo\n113 format(i3,20(1pe11.3))\n! call lingld(nz1,nz2,smat,svar,nz1,ierr)\n! goto 119\n! end if\n! endif\n! if((inmap.eq.0).and.(ceq%splitsolver.gt.0).and.&\n! .not.badmat .and. (meqrec%nrel.eq.meqrec%nstph)) then\n! Splitting is possible for given T, P, composition and\n! when the number of component is equal to the number of stable phases\n! (conditions giving square mass matric)\n! ís this OK if BADNAT is TRUE??\n!BS if(badmat) write(*,*)'MEQ_SAMESET: matrix has a diagonal element zero'\n!BS call lingldSplit(nz1,nz2,smat,svar,nz1,ierr,meqrec%nrel,meqrec%nstph)\n!BS else\n! this used when equilibrium is NOT invariant\n call lingld(nz1,nz2,smat,svar,nz1,ierr)\n!BS endif\n!-----------------------------------------------------------------------\n! write(*,*)'MM meq_sameset: back from lingld'\n!\n119 continue\n if(ierr.ne.0) then\n if(vbug) write(*,*)'Error solving equil matrix 1',meqrec%noofits,ierr,&\n iremsave\n if(iremsave.gt.0) then\n! parallel2 goes into a loop here when phase iremsave has been suspended\n! after at has been set suspended .... fixed by not returning nonzero irem \n! equil matrix wrong at first iteration after removing a phase\n! This can be caused by having no phase with solubility of an element\n! (happened in Fe-O-U-Zr calculation with just C1_MO2 stable and C1 does not\n! dissolve Fe). Try to set back the last phase removed!!\n if(.not.btest(meqrec%status,MMQUIET)) then\n kk=meqrec%phr(iremsave)%phtupix\n phnames=' '\n call get_phasetup_name(kk,phnames)\n write(*,*)'Error, restoring previously removed phase: ',&\n trim(phnames)\n endif\n! NOTE: it should also be removed from the dormant list!!\n iadd=iremsave\n notagain=iremsave\n goto 1100\n endif\n if(vbug) then\n do iz=1,nz1\n write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2)\n enddo\n endif\n! debug output ...\n! write(*,229)'ce:',meqrec%noofits\n! call list_conditions(kou,ceq)\n! do iz=1,nz1\n! write(*,228)'smat2:',(smat(iz,jz),jz=1,nz2)\n! enddo\n! gx%bmperr=4203; goto 1000\n endif\n! when problems output svar here !! (and smat1: above)\n! write(33,*)'Solution'\n! write(*,228)'PHMAT: ',(svar(jz),jz=1,nz1)\n! close(33)\n! write(*,228)'svar1:',(svar(jz),jz=1,nz1)\n if(vbug) write(*,228)'svar1:',(svar(jz),jz=1,nz1)\n!\n! if no error at first calculation after phase set change iremsave=0\n iremsave=0\n if(vbug) write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1)\n! write(*,229)'pm: ',meqrec%noofits,(svar(iz),iz=1,nz1)\n229 format(a,i3,6(1pe12.4))\n!---------\n! copy the chemical potentials, take care of fixed values ....\n! new potentials are in svar(1..meqrec%nrel-meqrec%nfixmu)\n iz=1\n notf=1\n setmu: do ik=1,meqrec%nrel\n if(notf.le.meqrec%nfixmu) then\n if(ik.eq.meqrec%mufixel(notf)) then\n! this potential is fixed, no incrementing \"iz\", ceq%cmuval(ik) is a condition\n ceq%complist(ik)%chempot(1)=meqrec%mufixval(1)*ceq%rtn\n notf=notf+1\n cycle setmu\n endif\n endif\n!--------------------------------------------------------------------------\n! if(abs(svar(iz)-ceq%cmuval(ik)).gt.ceq%xconv) then\n! MQMQA convergence problem fix ?\n! Here ceq%xconv normally is 1.0D-6\n if(abs(svar(iz)-ceq%cmuval(ik)).gt.&\n! abs(1.0D4*ceq%xconv*ceq%cmuval(ik))) then\n abs(globaldata%mqmqa1*ceq%xconv*ceq%cmuval(ik))) then\n! convergence problems with MQMQA better with a factor 1.0D4\n! By default mqmqa1 is 1.0D0, when MQMQX phase involved set to 1.0D4\n!\n! MQMQA problem here with K-Li-Na/Cl with KLIN100=-25000 and N(NA)>0.6\n! changing ceq%xconv from 1.0e-6 to 0.01 fixes this problem and seems OK \n! for the MQMQA case it OK over the whole composition range\n! Does it work in general? Defaly ceq$xconv=1.0D-6, try 1.0D4 larger ...\n!\n! Tested all examples/macros/ and they worked except map11 for Cr-Fe\n! modified the start equilibria and then it worked\n! So I will keep this reduced convergence criteria, there are more\n! important below.\n!\n!--------------------------------------------------------------------------\n! if(vbug) write(*,387)'Unconverged pot: ',iz,ik,&\n! if(nophasechange.gt.100) then\n! Attempt to improve convergence for a 15 component system ... failed\n! xxx=0.25D0*(3.0D0*svar(iz)+1.0D0*ceq%cmuval(ik))\n xxx=globaldata%mqmqa1\n! write(*,387)'Uncnv pot: ',iz,ik,&\n! svar(iz),ceq%cmuval(ik),xxx,abs(svar(iz)-ceq%cmuval(ik)),&\n! abs(ceq%xconv*ceq%cmuval(ik))\n387 format(a,2i3,3(1pe14.5),2(1pe10.2))\n! take mean value ... DO NOT TRY THIS IF IT IS NOT ALMOST CONVERGED!!!\n! svar(iz)=xxx\n! endif\n converged=7\n cerr%mconverged=converged\n!----------------------------------------- debug output start\n! write(*,388)iz,ik,svar(iz),1.0D4*ceq%xconv,ceq%cmuval(ik),&\n! abs(svar(iz)-ceq%cmuval(ik)),abs(1.0D4*ceq%xconv*ceq%cmuval(ik))\n388 format('MM conv=7:',2i3,5(1pe11.3))\n!----------------------------------------- debug output end\n elseif(mqmqder) then\n! Setting the mqmqa derivative bug gives this output\n! debug test to discover the ratios, these do not indicate any problem\n write(*,389)meqrec%noofits,svar(iz),ceq%cmuval(ik),ceq%xconv,&\n abs(svar(iz)-ceq%cmuval(ik))/ceq%cmuval(ik)\n389 format('MM convergenge 7 accuracy: ',i3,4(1pe12.4))\n endif\n ceq%cmuval(ik)=svar(iz)\n! svar(iz) is mu/RT, chemput is mu\n ceq%complist(ik)%chempot(1)=svar(iz)*ceq%rtn\n iz=iz+1\n enddo setmu\n ioff=meqrec%nrel-meqrec%nfixmu+1\n!------------\n! update T and P if variable\n if(meqrec%tpindep(1)) then\n xxx=ceq%tpval(1)\n! check convergence\n! write(*,*)'Delta T: ',svar(ioff),1.0D2*ceq%xconv\n! if(abs(svar(ioff)).gt.1.0D2*ceq%xconv) then\n! this convergece criteria needed for the CHO-gas calculation!!!\n! but causes problem calculating phase diagrams ... inmap=1 for step/map\n! OBS svar(ioff) is Delta T, not absolute value\n!CCI\n if(inmap.eq.0 .and. abs(svar(ioff)).gt.default_deltaT*ceq%xconv) then\n!CCI\n converged=8\n cerr%mconverged=converged\n endif\n!CCI\n! limit changes in T to +/- 20% of current value (see default_limitchangesT)\n if(abs(svar(ioff)/ceq%tpval(1)).gt.default_limitchangesT) then\n svar(ioff)=sign(default_limitchangesT*ceq%tpval(1),svar(ioff))\n endif\n!CCI\n! limit change in T when there is condition on y\n if(ycondTlimit) then\n deltat=svar(ioff)\n! Suck it happend that svar(ioff) changed sign each iteration ....\n if(lastdeltat*deltat.lt.zero) then\n deltatycond=max(deltatycond-one,one)\n! never increase during one minimization ...\n! else\n! deltatycond=2.5D1\n endif\n if(abs(svar(ioff)).gt.deltatycond) then\n if(svar(ioff).gt.zero) then\n svar(ioff)=deltatycond\n else\n svar(ioff)=-deltatycond\n endif\n write(*,*)'MM ycondTlimit: ',deltat,svar(ioff)\n lastdeltat=svar(ioff)\n endif\n endif\n deltat=svar(ioff)\n! limit maximum change in deltat\n if(abs(deltat).gt.meqrec%tpmaxdelta(1)) then\n deltat=sign(meqrec%tpmaxdelta(1),deltat)\n if(ocv()) write(*,386)'limit the change in T: ',&\n ceq%tpval(1),deltat,svar(ioff)\n386 format(a,3(1pe12.4))\n endif\n ceq%tpval(1)=ceq%tpval(1)+deltat\n! problems here when -finit-local-zero is removed\n if(vbug) write(*,*)'T and deltaT:',ceq%tpval(1),deltat\n!CCI\n if(ceq%tpval(1).le.default_minimalchangesT) then\n write(*,*)'Attempt to set a temperature less than ',&\n default_minimalchangesT,' K !!!'\n!CCI\n gx%bmperr=4187; goto 1000\n endif\n ioff=ioff+1\n endif\n if(meqrec%tpindep(2)) then\n! if pressure variable\n xxx=ceq%tpval(2)\n! check convergence\n! ??? svar(ioff) much too small!! why? add a factor ...\n! svar(ioff)=1.0D2*svar(ioff)\n!CCI\n if(abs(svar(ioff)).gt.default_deltaP*ceq%xconv) then\n!CCI\n converged=8\n cerr%mconverged=converged\n endif\n! write(*,389)'HMS pv: ',ioff,converged,svar(ioff),ceq%tpval(2)\n!389 format(a,2i3,4(1pe12.4))\n!CCI\n if(abs(svar(ioff)/ceq%tpval(2)).gt.default_limitchangesP) then\n svar(ioff)=sign(default_limitchangesP*ceq%tpval(2),svar(ioff))\n endif\n!CCI\n deltap=svar(ioff)\n! limit the changes in P\n if(abs(deltap).gt.meqrec%tpmaxdelta(2)) then\n deltap=sign(meqrec%tpmaxdelta(2),deltap)\n if(ocv()) write(*,386)'limit the change in P: ',&\n ceq%tpval(2),deltap,svar(ioff)\n endif\n ceq%tpval(2)=ceq%tpval(2)+svar(ioff)\n!CCI\n if(ceq%tpval(2).le.default_minimalchangesP) then\n!CCI\n write(*,*)'Attempt to set pressure lower than ',default_minimalchangesP,' Pa!!!'\n gx%bmperr=4187; goto 1000\n endif\n ioff=ioff+1\n endif\n!------------\n! update phase amounts, take care of fixed phases ....\n! the change in amounts are in svar(ioff+...)\n negamph=0\n negam=0\n irem=0\n iremax=0\n phfmin=zero\n! dncol+1 should be the first Delta_phase-amount\n ioff=dncol+1\n! scale all changes in phase amount with total number of atoms. At present\n! assume this is unity. Without scaling phase changes can be +/-1E+11 or more\n! which creates instabilities\n maxphch=zero\n! normphchange: do jph=1,meqrec%nstph\n normphchange: do jph=1,meqrec%nstph-meqrec%nfixph\n if(abs(svar(ioff+jph-1)).gt.maxphch) maxphch=abs(svar(ioff+jph-1))\n enddo normphchange\n\n!CCI\n! By default, ceq%scale_change_phase_amount equals to one.\n! Such a value is changed by the user in\n!-------------------------------------------------------\n!-------------------------------------------------------\nif(meqrec%noofits.eq.1) then \n if(ceq%type_change_phase_amount.gt.0) then\n ! whenever prescribed values are too big or differ greatly in order of magnitude\n ! Only cmix(1)=5 is interesting here. potentials already cared for\n ! loop if not the last condition\n ! This is the condition, cvalue is the prescibed value\n ! cmode and cmix contain information how to calculate its current value\n lastcondScale=>ceq%lastcondition\n conditionScale=>lastcondScale\n conditionScale=>conditionScale%next\n !---\n ! loop over all conditions and stops when the pointer condition is empty\n ! (use of apply_condition_value subroutine in gtp3D.F90)\n !---\n cmode=-1\n cmix=0\n maxprescribed = one\n sumprescribed = zero\n do while(.not.associated(conditionScale,lastcondScale))\n call apply_condition_value(conditionScale,cmode,cvalue,cmix,ccf,ceq)\n if (cmix(1).eq.5) then\n cvalue = conditionScale%prescribed\n if (cvalue.gt. maxprescribed ) then\n maxprescribed = cvalue\n endif\n sumprescribed = sumprescribed + cvalue\n endif\n conditionScale=>conditionScale%next\n enddo\n sumprescribed = sumprescribed - one\n sumprescribed = abs(sumprescribed)\n if(sumprescribed.lt.one) then\n sumprescribed = sumprescribed + one\n endif\n if(ceq%type_change_phase_amount.eq.1) ceq%scale_change_phase_amount=sumprescribed\n if(ceq%type_change_phase_amount.eq.2) ceq%scale_change_phase_amount=maxprescribed\n else \n ceq%scale_change_phase_amount=default_scalechangephaseamount\n endif\n endif\n!-------------------------------------------------------\n!-------------------------------------------------------\n if(maxphch.gt.ceq%scale_change_phase_amount) then\n ioff=dncol+1\n do jph=1,meqrec%nstph-meqrec%nfixph\n svar(ioff+jph-1)=svar(ioff+jph-1)*ceq%scale_change_phase_amount/maxphch\n enddo\n endif\n!CCI\n!\n ioff=dncol+1\n! do not change phase amounts the first iteration\n! write(*,554)svar\n!554 format('MM svar: ',6(1pe12.4))\n! if(meqrec%noofits.eq.1) then\n! goto 555\n! endif\n phamount2: do jph=1,meqrec%nstph\n! loop for all stable phases\n jj=meqrec%stphl(jph)\n! phr(jj)%curd%damount=zero\n! kkz=test_phase_status(phr(jj)%iph,phr(jj)%ics,xxx,ceq)\n kkz=phr(jj)%phasestatus\n! new -4=hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed\n if(kkz.ge.PHENTUNST .and. kkz.le.PHENTSTAB) then\n! phase is entered so its amount can change, -svar(ioff) is the change\n phs=phr(jj)%curd%amfu\n if(ioff.gt.size(svar)) then\n! error here calculating Fe-Si-C with 2 phases set fix zero\n! setting w(si)=w(c)=none and fix T; should have w(si) fix and T=none\n write(*,42)'MM Too many phases with variable amount',ioff,&\n size(svar),meqrec%nstph,phr(jj)%iph\n42 format(a,10i4)\n gx%bmperr=4193; goto 1000\n endif\n deltaam=svar(ioff)\n! Sigli convergence problem, bad guess of start amount of phases??\n! NOTE sign! -deltaam is the change in amount of phase, \n! write(*,43)'Deltaam: ',meqrec%noofits,jj,deltaam,lastdeltaam(jph),&\n! phr(jj)%curd%amfu,phr(jj)%curd%amfu-deltaam\n!43 format(a,2i3,6(1pe12.4))\n! tried to avoid too large changes in phase amount, just made things worse\n! if(meqrec%noofits.lt.3 .and. &\n! abs(deltaam).gt.0.5D0*phr(jj)%curd%amfu) then\n! deltaam=sign(0.1D0*phr(jj)%curd%amfu,deltaam)\n! write(*,43)'Modified: ',meqrec%noofits,jj,deltaam\n! endif\n! limit change in amount of phase\n if(abs(deltaam).gt.ceq%xconv) then\n! For the equil O-U with conditions on N(O) and N(U) there is no problem\n! with the amount of C1 but with N= and x(O)= the phase amount change varies\n! with sign and converges very slowly. Probably an interference with the\n! charge balance criteria.\n if(lastdeltaam(jph)*deltaam.lt.zero) then\n! wow, this seems to work ... other attmepts interfere directly with the\n! charge balance so one should carefully check how they are connected...\n! deltaam=5.0D-1*deltaam\n! The half worked to C1+tetragonal, it did not work for ionic liquid misc. gap\n! and in that case there is no charge balance criteria ... suck\n! deltaam=5.0D-1*deltaam\n! Dubbelt wow ... 0.2 works for both cases ... why?? More iterations though .. \n deltaam=2.0D-1*deltaam\n if(ocv()) write(*,3)'Phase amount sign change: ',&\n meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam\n! write(*,3)'Phase amount sign change: ',&\n! meqrec%noofits,jph,jj,phs,lastdeltaam(jph),deltaam\n3 format(a,3i3,6(1pe12.4))\n endif\n if(converged.lt.6) then\n converged=6\n cerr%mconverged=converged\n endif\n if(vbug) write(*,381)'Phase amount change: ',meqrec%noofits,jj,&\n! write(*,381)'MM Phase amount change: ',meqrec%noofits,jj,&\n phs,deltaam\n381 format(a,2i3,4(1pe12.4))\n endif\n lastdeltaam(jph)=deltaam\n if(phr(jj)%curd%amfu-deltaam.le.zero) then\n if(meqrec%nstph.eq.1) then\n! this is the only stable phase! cannot have negative or zero amount!\n deltaam=phr(jj)%curd%amfu-1.0D-2\n endif\n endif\n! if(-deltaam.gt.one) then\n!CCI Useless if type_change_phase_amount>0 (0 also??)\n! if(abs(deltaam).gt.one) then\n if(abs(deltaam).gt.one .and. ceq%type_change_phase_amount.eq.0) then\n!CCI Useless if type_change_phase_amount>0 (0 also??) ) then\n! try to prevent too large increase/decrease in phase amounts.\n! Should be related to total amount of components.\n if(.not.btest(meqrec%status,MMQUIET)) &\n write(*,*)'Large change in phase amount: ',deltaam\n! deltaam=-one\n deltaam=sign(0.5D0,deltaam)\n endif\n!CCI\n if(abs(deltaam).gt.maxphasechange) then\n! to allow checks when phase set does not change and amount changes are small\n! like when calculating an almost stoichiometric composition like UO2 with\n! n(o)=2 and n(u)=1 at low T\n maxphasechange=abs(deltaam)\n endif\n! special test for Al-Ni fcc/fcc#2 two-phase\n! Calculations with Al-Ni T=1000, x(al)=.2 gives just a single FCC phase\n! possible problems that we change the amounts of the wrong composition set?\n! HOWEVER, I found the error is the second derivatives are wrong!!\n! if(meqrec%noofits.lt.10) deltaam=0.1*deltaam\n! write(*,383)'MM phase change: ',meqrec%noofits,jj,&\n! phr(jj)%iph,phr(jj)%ics,phr(jj)%curd%amfu,deltaam,svar(ioff)\n!383 format(a,2i3,2x,2i3,3(1pe12.4))\n phf=phr(jj)%curd%amfu-deltaam\n if(phs.gt.0.2D0 .and. phf.le.zero) then\n! violent change of phase fractions in Siglis case, liquid change from 1 to 0\n! Prevent changes larger than 0.1 if value larger than 0.5\n! old value of amfu in phs\n phf=0.1D0\n endif\n! write(*,363)' >>>> Stable phase: ',jj,phr(jj)%iph,&\n! phr(jj)%ics,phf,phs,deltaam,sum\n363 format(a,3i3,6(1pe12.4))\n! phr(jj)%curd%damount=deltaam\n ioff=ioff+1\n elseif(kkz.eq.PHFIXED) then\n! phase is fix, there is no change in its amounts\n phf=phr(jj)%curd%amfu\n! write(*,*)'Fixed phase: ',jj,phf\n else\n! phase is dormant or suspended, must not be stable!!!!\n call get_phase_name(phr(jj)%iph,phr(jj)%ics,phnames)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,373)phr(jj)%iph,phr(jj)%ics,kkz\n! write(*,373)trim(phnames),kkz\n373 format('MM The phase ',a,' cannot vary its amount:',3i7)\n gx%bmperr=4194; goto 1000\n endif\n! problem with Fe-O-U-Zr convergence, all phases disappear ??\n! write(*,364)'Stable phase: ',meqrec%noofits,jj,phr(jj)%iph,&\n! phr(jj)%ics,phf,phs,phr(jj)%prevam\n!364 format(a,4i3,6(1pe12.4))\n! make sure the driving force of stable phases to zero\n phr(jj)%curd%dgm=zero\n if(phf.lt.zero) then\n! phase has negative amount, NOT ALLOWED if it is the only stable phase \n if(meqrec%nstph-meqrec%nfixph.eq.1) then\n! write(*,367)'Trying to remove the only stable phase ',jj,&\n! phr(jj)%curd%amfu\n367 format(a,i3,1pe14.6)\n phf=0.5D0*phr(jj)%curd%amfu\n gx%bmperr=4195; goto 1000\n else\n! select phase with most negative amount\n if(phf.lt.phfmin) then\n phfmin=phf\n iremax=jj\n endif\n! trying to improve convergence by allowing phases to be removed quicker\n! write(*,363)'Phase with negative amount: ',jj,meqrec%noofits,0,&\n! phf,phs,phr(jj)%prevam\n! if(phf.lt.-1.0D-2) phf=zero\n if(jj.ne.notagain .and. phr(jj)%prevam.lt.zero) then\n! remove this phase if negative amount previous iteration also\n irem=jj\n! write(*,376)'meq_sameset remove: ',meqrec%noofits,nextch,&\n! jj,notagain\n376 format(a,4i4)\n! jumping to 1000 here means constitutions not changed in this iteration\n goto 1000\n else\n! mark this phase had negative amount this iteration\n! PROBLEM removing one of two composition sets of the same phase,\n! (miscibility gap), they may change which have negative amount each iteration\n phr(jj)%prevam=-one\n phf=zero\n endif\n endif\n else ! phase has positive amount, mark in prevam\n phr(jj)%prevam=one\n endif\n! store the new phase fraction (moles formula units)\n phr(jj)%curd%amfu=phf\n enddo phamount2 ! end of loop for jph=1,meqrec%nstph\n!555 continue\n!\n! if(iremax.gt.0) then\n! write(*,*)'meq_sameset remove?',meqrec%noofits,iremax,phfmin\n! endif\n if(vbug) write(*,*)'finished updating phase amounts: ',&\n meqrec%noofits,phasechangeok,irem\n! if(meqrec%nfixmu.gt.0) then\n! write(*,33)'mu1: ',(ceq%cmuval(nj),nj=1,meqrec%nrel)\n! write(*,33)'mu2: ',(ceq%complist(nj)%chempot(1),nj=1,meqrec%nrel)\n! write(*,33)'mu3: ',(ceq%complist(nj)%chempot(2),nj=1,meqrec%nrel)\n! write(*,33)'mu4: ',(svar(nj),nj=1,meqrec%nrel)\n!33 format(a,6(1pe12.4))\n! endif\n!-------------------------------------------------------\n! After solving the equil matrix and updating the chemical potentials,\n! the phase amounts and possibly T and P we correct constitions of all phases\n! - Now calculate correction of constituent fractions for all phases\n! See BoJ thesis eq. 30 (also in metastable phases) (paper I)\n! At the same time calculate the driving force for metastable phases\n ycorr=zero\n ycormax2=zero\n! to handle charge balance correction of constituent fractions\n chargerr=zero\n! chargerr fitted to fastest convergence using the ou test case\n! chargefact=1.0D-1 requires more than 100 iterations\n! chargefact=one requires more than 100 iterations\n! this value requires about 40 iteration\n!CCI\n chargefact=0.5*default_chargefact\n!CCI\n! chargefact=1.0D-1\n! kk is used to check if a charged phase is stable,\n! it is incremented for each stable phase\n kk=1\n! iadd is set to the unstable phase with largest positive driving force\n! dgmmax is the largest psoitive driving force\n iadd=0\n dgmmax=zero\n ysmm=zero\n!-----------------------------------------------------\n!CCI\n! Update the constitutions. If irem>0 remove this phase unless\n! we have made at least 'default_noremove' (see ocparam.F90) iterations\n! with the current phase set\n if(irem.gt.0 .and. meqrec%noofits-phasechangeok.gt.default_noremove) &\n goto 1000\n!CCI\n!--------------------------\n! These are needed to avoid several phases have exactly the same fracions\n! if the start guess is very bad and limitations are used\n yvar1=default_yvar1\n yvar2=default_yvar2\n!-----------------------------------------\n lap: do jj=1,meqrec%nphase\n! The current chemical potentials are in ceq%cmuval(i)\n! if(vbug) write(*,*)'Phase: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n if(jj.eq.meqrec%stphl(kk)) then\n! jj is stable, increment kk but do not make it larger than meqrec%nstph\n! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!!\n jph=kk\n kk=min(kk+1,meqrec%nstph)\n! if(meqrec%noofits.le.2) write(*,83)'dy1: ',jj,jph,kk\n!83 format(a,3i3,6(1pe12.4))\n else ! phase is not stable\n! calculate driving force for unstable phases. First calculate the sum\n! of the current phase composition and the calculated chemical potentials\n jph=0\n gsurf=zero; summ=zero\n do ie=1,meqrec%nrel\n! fatal parallel execution error once here\n! index '1' of dimension 1 of array 'phr' above upper bound of 0\n gsurf=gsurf+phr(jj)%xmol(ie)*ceq%cmuval(ie)\n summ=summ+phr(jj)%xmol(ie)\n enddo\n gsurf=gsurf/summ\n! calculate G_m plus any deltat and deltap terms\n dgm=phr(jj)%curd%gval(1,1)\n if(meqrec%tpindep(1)) then\n dgm=dgm+phr(jj)%curd%gval(2,1)*deltat\n endif\n if(meqrec%tpindep(2)) then\n dgm=dgm+phr(jj)%curd%gval(3,1)*deltap\n endif\n! scale dgm per mole atoms\n molesofatoms=phr(jj)%curd%abnorm(1)\n if(molesofatoms.lt.0.3D0) then\n! problem when a phase is stable with just vacancies !!!!!!!!!!!!\n if(phr(jj)%phasestatus.gt.0) then\n write(*,'(a,i3,a,F8.4)')'MM Phase: ',jj,&\n ' moles of atoms: ',molesofatoms\n endif\n endif\n! dgm=gsurf-dgm/phr(jj)%curd%abnorm(1)\n dgm=gsurf-dgm/molesofatoms\n if(phr(jj)%phasestatus.gt.0) then\n! we should be here only for UNSTABLE phases, phr(jj)%phasestatus<=0\n! For some reason a phase has entered/fixed status (>0) THAT IS AN ERROR\n! It happened in SMP2A when mapping Al-Ni and correcting too long step in T\n write(*,'(a,i4,i3)')'MM phase status reset:',jj,phr(jj)%phasestatus\n phr(jj)%phasestatus=0\n endif\n if(dgm.gt.dgmmax) then\n if(phr(jj)%phasestatus.ge.PHENTUNST .and. &\n phr(jj)%phasestatus.le.PHENTERED) then\n! phase is entered, can have status changed\n! if this is another constitution set of an already stable phase then check\n! below if the constitution of this phase is very similar to the stable one\n iadd=jj\n dgmmax=dgm\n! write(*,379)'meq_sameset add: ',meqrec%noofits,nextch,&\n! iadd,dgmmax\n379 format(a,3i4,4(1pe12.4))\n endif\n endif\n! The difference between previous and current DGM is used to check for\n! convergence below. Very important to check if continue iterating!!\n phr(jj)%prevdg=phr(jj)%curd%dgm\n phr(jj)%curd%dgm=dgm\n endif\n! Update constituent fractions for ALL phases, stable or not\n! if phr(jj)%xdone=1 then phase has no composition variation\n if(phr(jj)%xdone.eq.1) cycle\n!----------------------------------------------------\n allocate(cit(phr(jj)%idim),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 11: ',errall\n gx%bmperr=4370; goto 1000\n endif\n cit=zero\n if(meqrec%tpindep(1)) then\n! variable T, code copied from calc_dgdyterms, cit(nj) used below\n! write(*,44)'index 1: ',jj,phr(jj)%ncc,phr(jj)%idim,&\n! size(phr(jj)%invmat)\n do jy=1,phr(jj)%ncc\n sum=zero\n do iy=1,phr(jj)%ncc\n sum=sum+phr(jj)%invmat(iy,jy)*&\n phr(jj)%curd%dgval(2,iy,1)\n enddo\n cit(iy)=sum*deltat\n! write(*,44)'index 2: ',jj,jy,iy,0,sum\n!44 format(a,4i3,6(1pe12.4))\n enddo\n!! end copy\n! write(*,*)'Adding contribution from variable T to delta-y',&\n! phr(jj)%ncc\n! missing code for correction due to variable P?????\n endif\n! These are used to introduce some variation in fractions when the values\n! exceed limits. Otherwise one can as Sigli found have two stable phases\n! with exactly the same fractions and have a crash\n!\n moody: do nj=1,phr(jj)%ncc\n ys=zero\n do nk=1,phr(jj)%ncc\n pv=zero\n do nl=1,meqrec%nrel\n! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT)\n! phr(jj)%dxmol(nl,nk) is the derivative of component nl\n! wrt constituent nk\n! write(*,*)'ycorr: ',nl,ceq%complist(nl)%chempot(1)/ceq%rtn\n! write(*,612)'MM y1: ',nk,nl,&\n! ceq%complist(nl)%chempot(1)/ceq%rtn,ceq%cmuval(nl)\n!612 format(a,2i4,6(1pe12.4))\n pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk)\n! write(*,111)'pvx: ',nj,pv,ceq%complist(nl)%chempot(1),&\n! ceq%rtn,phr(jj)%dxmol(nl,nk)\n! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk)\n! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk)\n enddo\n pv=pv-phr(jj)%curd%dgval(1,nk,1)\n ys=ys+phr(jj)%invmat(nj,nk)*pv\n! write(*,111)'pvx: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),&\n! phr(1)%invmat(nj,nk)\n!111 format(a,i2,6(1pe12.4))\n enddo\n if(phr(jj)%chargebal.eq.1) then\n! For charged phases add a term \n! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q\n ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n phr(jj)%curd%netcharge\n! ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n! phr(jj)%charge\n! jph is nonzero only for stable phases\n if(jph.gt.0 .and. &\n! if(jj.eq.meqrec%stphl(kk) .and. &\n! Hm, is this check correct? kk is updated above to be the next stable phase..\n! abs(phr(jj)%charge).gt.chargerr) then\n! chargerr=abs(phr(jj)%charge)\n! signerr=phr(jj)%charge\n abs(phr(jj)%curd%netcharge).gt.chargerr) then\n chargerr=abs(phr(jj)%curd%netcharge)\n signerr=phr(jj)%curd%netcharge\n endif\n! write(*,*)'Charge: ',jj,phr(jj)%netcharge\n else\n! enshure charge is zero!! \n if(phr(jj)%curd%netcharge.ne.zero) &\n write(*,*)'MM neutral phase with charge: ',&\n phr(jj)%curd%phlink,phr(jj)%curd%netcharge\n phr(jj)%curd%netcharge=zero\n endif\n! when T is variable\n ycorr(nj)=ys+cit(nj)\n if(abs(ycorr(nj)).gt.ycormax2) then\n ycormax2=ycorr(nj)\n endif\n! Sigli converge problem, fixed by changing stable phases in different order\n! write(*,111)converged,jj,nj,ys\n!111 format('Y corr: cc/ph/cons/y: ',i2,2i4,1pe12.4)\n! should possibly be ycorr(nj) instead of ys (ycorrmax)\n abssys: if(abs(ys).gt.ceq%xconv) then\n! if the change in any constituent fraction larger than xconv continue iterate\n! write(*,*)'Convergence criteria, phase/const: ',jj,nk\n if(phr(jj)%stable.eq.0) then\n! Phase is not stable\n! Handle convergence criteria different if inmap=1 or not\n mapping7: if(inmap.eq.0) then\n!----------------------------------------- reduce indentation\n! we are NOT in STEP/MAP, increase convergence criteria to handle\n! the Mo-Ni-Re 3 phase equilibria\n!CCI\n if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then\n!CCI\n! for unstable phases the corrections must be smaller than ...????\n if(converged.lt.3) then\n converged=3\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n!CCI\n elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then\n!CCI\n!212 format(a,3i3,i4,4(1pe12.4))\n if(converged.lt.4) then\n!CCI\n factconv=default_correctionfactorDGM\n if(phr(jj)%ncc.gt.10) then\n! Calculation with the COST507 database and 20 elements too many iterations\n! ... allow larger gdconv(1) \n factconv=10.0*factconv\n endif\n!CCI\n if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.&\n factconv*ceq%gdconv(1)) then\n! Must be less than this if(phr(jj)%curd%dgm-phr(jj)%prevdg.gt.5.0E-3) then\n converged=4\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n else\n if(converged.eq.0) then\n converged=1\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n!----------------------- else of mapping7\n else\n! we are doing step/map NO CHANGE, use old convergence criteria\n! otherwise step1 and mmap4 are incompatible with those above ...\n!CCI\n if(abs(ys).gt.default_correctionfactorYS*phr(jj)%curd%yfr(nj)) then\n! for unstable phases the corrections must be smaller than ...????\n if(converged.lt.3) then\n converged=3\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n elseif(abs(ys).gt.default_correctionfactorXCONV*ceq%xconv) then\n!CCI\n! maybe accept 100 times larger correction than for stable phases\n! write(*,107)'metast ph ycorr: ',ys,&\n! phr(jj)%curd%yfr(nj)\n if(converged.lt.2) then\n converged=2\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n else\n if(converged.eq.0) then\n converged=1\n cerr%mconverged=converged\n yss=ys\n yst=phr(jj)%curd%yfr(nj)\n endif\n endif\n endif mapping7\n!----------------------------------- return to original indentation\n! elseif of abssy\n elseif(converged.lt.4) then\n! large correction in fraction of constituent fraction of stable phase\n! Problem here with CVMSRO model, ys=0.00272 when x(b)=.5\n! write(*,*)'MM converged 4A: ',jj,nj,ys\n! Problem here also with MQMQA, the KLiNa step calculation with N(Na)>.6\n! write(*,*)'MM problem 1 with MQMQA? line 2904 ignored'\n! just ignoring it works OK\n! converged=4\n! cerr%mconverged=converged\n! yss=ys\n! yst=phr(jj)%curd%yfr(nj)\n endif\n elseif(phr(jj)%stable.eq.1) then\n! check to find good convergence criteria in Re-V test case\n if(abs(ycorr(nj)).gt.ysmm) then\n jmaxy=jj\n ysmm=abs(ycorr(nj))\n ysmt=phr(jj)%curd%yfr(nj)\n endif\n! check if the change in any fraction is larger than the fraction ...\n if(ycorr(nj).gt.phr(jj)%curd%yfr(nj)) then\n! write(*,612)'MM y2: ',jj,nj,ycorr(nj),phr(jj)%curd%yfr(nj)\n if(converged.lt.4) then\n! write(*,*)'MM problem 2 with MQMQA? line 2921'\n converged=4\n cerr%mconverged=converged\n endif\n endif\n endif abssys\n enddo moody\n! end of correction of y fractions\n!---------------------------------\n! Limit change in fractions .... all ycorr(nj) multiplied with same factor\n! keeping the sum of corrections in all sublattices as zero\n! if(converged.ge.4) then\n! Added to underetand convergence problem with CVMSRO\n! write(*,*)'MM CVMSRO convergence: ',meqrec%noofits,jj,converged\n! converged=1 or 2 means constituent fraction in metastable phase not converged\n! converged 3 means large change constituent fraction of unstable phase\n! converged 4 means a constituent fraction of a stable phase change a lot\n! converged=5 means a condition not fullfilled\n! converged=6 means charge balance not converged or large phase fraction change\n! converged=7 means large change in chemical potentials\n! converged=8 means large change T or P\n! endif\n if(vbug) write(*,74)'maximum corr: ',&\n meqrec%noofits,jj,ycormax2,ycormax(jj)\n74 format(a,2i3,2(1pe12.4))\n if(ycormax(jj)*ycormax2.le.zero) then\n! the condition is zero at first step, limit that\n yfact=one/(2.0D0+abs(ycormax2))\n ycormax2=yfact*ycormax2\n!CCI\n elseif(phr(jj)%ionliq.gt.0 .and. ycormax2.lt.default_upperycormax2) then\n!CCI\n! step seems to be very small ... try to decrease number of iteration\n yfact=2.0d0\n else\n yfact=one\n endif\n moody2: do nj=1,phr(jj)%ncc\n! all corrections of constituent fractions in ycorr(1..phr(jj)%ncc)\n! ymagic is halfed every 5th iteration when same phase set, after 5 times reset\n yprev=phr(jj)%curd%yfr(nj)\n! yarr(nj)=yprev+ycorr(nj)\n if(phr(jj)%ionliq.gt.0) then\n! For ionic liquids, an even smaller step is allowed ...\n! The O-Pu-U test case converged up to 2800 without any particular factor\n! with a factor 0.4 it converged up to 3000K (~150 its), yfact does not\n! has any significant influence. \n! yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact\n! tafidbug, 0.2 created problems\n! yarr(nj)=yprev+2.0D-1*ycorr(nj)*yfact\n! yarr(nj)=yprev+3.0D-1*ycorr(nj)*yfact\n!CCI\n yarr(nj)=yprev+default_ionliqyfact*ycorr(nj)*yfact\n!CCI\n! yarr(nj)=yprev+ycorr(nj)*yfact\n! write(*,281)'ycorr: ',nj,yfact,yprev,yarr(nj)\n!281 format(a,i3,6(1pe12.4))\n else\n yarr(nj)=yprev+ycorr(nj)*yfact\n endif\n! if(vbug) then\n! output to check reasons for bad convergence\n! write(*,57)'MM y&dy ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%stable,nj,&\n! ys,cit(nj),phr(jj)%curd%yfr(nj),yarr(nj),ycorr(nj)\n!57 format(a,3i2,i3,5(1pe12.4))\n! endif\n!CCI\n if(yarr(nj).lt.default_ymin) then\n!CCI\n! this added to avoid too drastic jumps in small fractions\n! The test case ccrfe1.OCM needs this\n!CCI\n if(yprev.gt.default_ylow) then\n!CCI\n! write(*,*)'Applying fraction change limitation 4 ',jj\n!CCI\n yarr(nj)=0.9*default_ylow\n!CCI\n elseif(test_phase_status_bit(phr(jj)%iph,PHGAS)) then\n! for gas phase one must allow smaller constituent fractions\n!CCI\n if(yarr(nj).lt.default_ymingas) then\n yarr(nj)=default_ymingas\n endif\n!CCI\n else\n! write(*,*)'Applying fraction change limitation 5 ',jj\n!CCI\n yarr(nj)=default_ymin+yvar2\n!CCI\n yvar2=2.0D0*yvar2\n if(yvar2.gt.default_upperyvar2) yvar2=default_yvar2\n!CCI\n endif\n endif\n if(yarr(nj).gt.one) then\n! write(*,*)'Applying fraction change limitation 6 ',jj\n yarr(nj)=one-yvar1\n yvar1=2.0D0*yvar1\n!CCI\n if(yvar1.gt.default_upperyvar1) yvar1=default_yvar1\n!CCI\n endif\n enddo moody2 ! end loop for all constituents nj in phase jj\n!\n ycormax(jj)=ycormax2\n! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<<\n! if(meqrec%noofits.le.2) write(*,83)'dy2: ',jj,phr(jj)%iph,kk,&\n! (yarr(nj),nj=1,phr(jj)%ncc)\n! write(*,114)'YARR: ',jj,phr(jj)%ics,(yarr(nj),nj=1,phr(jj)%ncc)\n!114 format(a,2i3,8(F7.4))\n! write(*,*)'MM calling set_constitution 1:',phr(jj)%iph,phr(jj)%ics\n call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n deallocate(cit)\n enddo lap\n! finished correction of all constituent fractions in all phases\n!-------------------------------------------------------\n! do jph=1,meqrec%nstph\n! jj=meqrec%stphl(jph)\n! write(*,393)'Stable phase: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n! enddo\n!393 format(a,2i4,6(1pe12.4))\n! check if fraction corrections in stable phases increases\n! it solved a problem in ReV when fractions initially changed very little\n! but the change increased each iteration\n if(meqrec%noofits.gt.8) then\n! this means minimum 8 iterations!!\n increase=0\n elseif(abs(ysmm).gt.prevmaxycorr) then\n! do this check only for the first 8 iterations\n increase=1\n! write(*,265)increase,ysmm,prevmaxycorr\n!265 format('*** max stable phase ycorr: ',i3,2(1pe12.4))\n endif\n prevmaxycorr=abs(ysmm)\n!-------------------------------------------------------\n! check charge balance, must be 100 times better than fractions\n! otherwise strange chemical potentials, why??\n! The request for 100 times better than ceq%xconv is OK with conditions \n! N(U)= N(O)= but not with N= x(O)=\n! if(chargerr.gt.1.0D-2*ceq%xconv) then\n! strengthen charge balance convergence criteria\n if(chargerr.gt.ceq%xconv) then\n! if(ocv()) write(*,654)'Charge error: ',signerr,chargerr,ceq%xconv\n write(*,654)'MM charge error: ',signerr,chargerr,ceq%xconv\n654 format(a,6(1pe12.4))\n if(converged.lt.6) then\n converged=6\n cerr%mconverged=converged\n endif\n endif\n!-------------------------------------------------------\n if(converged.eq.3) then\n! force one extra iterations with large fraction variations in unstable phases\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,&\n! increase,yss,yst\n level3=level3+1\n elseif(converged.eq.4) then\n! this means large fraction variations in stable phases\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,&\n! increase,yss,yst\n!267 format(a,3i4,2(1pe12.4))\n level3=0\n else\n! write(*,267)'End of iteration: ',meqrec%noofits,converged,increase\n level3=0\n endif\n!----------------------------------------------\n! continue iterate if phase change or not converged\n! call get_state_var_value('X(O) ',value,phnames,ceq)\n! trying to understand how STEP/MAP sets fix phases ....\n! write(*,*)'MM Fraction of O: ',value\n if(iadd.gt.0) then\n! check if phase to be added is already stable as another composition set\n! This check should maybe be above as maybe another phase want to be stable??\n if(same_composition(iadd,phr,meqrec,ceq,dgm)) iadd=0\n endif\n! check if phase iadd is stoichiometric and if so check of any stable phase\n! phase that is stoichiometric has the same composition!! IF SO\n! remove that phase at the same time ...\n srem=0\n if(meqrec%nrel.gt.1 .and. iadd.gt.0) then\n! skip this for unary system!!!\n jy=meqrec%phr(iadd)%phtupix\n samestoi: do nj=1,meqrec%nstph\n! loop through all stable phases for other phase with same stoichiometry\n jj=meqrec%stphl(nj)\n if(jj.ne.iadd) then\n iy=meqrec%phr(jj)%phtupix\n! check if same composition ... how? same_stoik in gtp3Y.F90\n if(same_stoik(jy,iy)) then\n srem=jj\n exit samestoi\n endif\n endif\n enddo samestoi\n endif\n if(srem.gt.0) then\n jy=meqrec%phr(iadd)%phtupix\n call get_phasetup_name(jy,phnames)\n iz=len_trim(phnames)+2\n call get_phasetup_name(iy,phnames(iz:))\n! write(*,*)'MM Same stoichiometry: ',trim(phnames),inmap,value\n! try to handle this by calculating the T when the two stochiometric phases\n! has the same Gibbs energy. Use this only if maping and T is not a condition\n if(inmap.ne.0) then\n! inmap=0 if we are not in a step/map calculation\n! I do not understand why iy and jy here ?? I think iadd and srem ...\n call two_stoich_same_comp(iy,jy,mapx,meqrec,inmap,ceq)\n endif\n iadd=iy; irem=jy\n! write(*,*)'Phases: ',iadd,irem\n! after this routine set the error code to return to mapping\n! stop 'same stoichimetries'\n\n! to be handelled either by map/step routines or meq_phaseset\n gx%bmperr=4364; goto 1000\n endif\n! if(meqrec%noofits.gt.2 .and. (irem.gt.0 .or. iadd.gt.0)) then\n if(irem.ne.0 .or. iadd.ne.0) then\n goto 1100\n endif\n!--------------------------------------------------------------------\n! write(*,*)'Iterations and convergence: ',meqrec%noofits,converged\n!--------------------------------------------------------------------\n! check convergence\n! if(meqrec%noofits.gt.400) then\n! write(*,778)'Test converged: ',meqrec%noofits,converged\n!778 format(a,2i4)\n! endif\n!------------------------------------------------------------\n! This output gives a good indication for convergence problem\n if(vbug) write(*,*)'Convergence criteria: ',converged,level3\n! converged=1 or 2 means constituent fraction in metastable phase not converged\n if(converged.gt.3) goto 100\n! converged 3 means large change conts. fraction of unstable phase change a lot\n! level3 is nuber of previous iteration with converged=3\n! with allcost I had the correct equilibrium but occational converged=4\n! probably because a metastable liquid with almost identical composition\n! as the stable interfeared. Accept converged=3 twice in a row as correct!!\n! if(converged.eq.3 .and. level3.lt.4) goto 100\n if(converged.eq.3 .and. level3.lt.2) goto 100\n! converged 4 means a constituent fraction of a stable phase change a lot\n! converged=5 means a condition not fullfilled\n! converged=6 means charge balance not converged or large phase fraction change\n! converged=7 means large change in chemical potentials\n! converged=8 means large change T or P\n! always force 4 iterations, there is a minimum above forcing 9 iterations.\n!CCI\n if(meqrec%noofits.lt.default_minimaliterations) goto 100\n!CCI\n if(increase.ne.0) then\n! continue if corrections in constituent fractions in stable phases increases\n! This is needed to change fractions in a gas from 1E-20 to some significant\n! value\n goto 100\n endif\n!------------------------\n! equilibrium calculation converged, do some common thing\n! write(*,*)'Converged: ',converged\n goto 800\n!\n!==============================================================\n! equilibrium calculation converged, save chemical potentials (svar*RT)\n800 continue\n!------------------------------------------------------\n! do not save system matrix but save -dimension for use with derivatives\n ceq%sysmatdim=-nz1\n! but save components with fix mu and fix phases\n ceq%nfixmu=meqrec%nfixmu\n if(allocated(ceq%fixmu)) deallocate(ceq%fixmu)\n if(ceq%nfixmu.gt.0) then\n allocate(ceq%fixmu(ceq%nfixmu),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 12: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do ie=1,ceq%nfixmu\n ceq%fixmu(ie)=meqrec%mufixel(ie)\n enddo\n endif\n ceq%nfixph=meqrec%nfixph\n if(allocated(ceq%fixph)) deallocate(ceq%fixph)\n if(ceq%nfixph.gt.0) then\n allocate(ceq%fixph(2,ceq%nfixph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 13: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do ie=1,ceq%nfixph\n! phase and composition set numbers\n ceq%fixph(1,ie)=meqrec%fixph(1,ie)\n ceq%fixph(2,ie)=meqrec%fixph(2,ie)\n enddo\n endif\n!-------------------------------------\n if(vbug) write(*,*)'At 800 in meq_sameset: ',meqrec%nrel\n ceq%rtn=globaldata%rgas*ceq%tpval(1)\n do ie=1,meqrec%nrel\n ceq%complist(ie)%chempot(1)=ceq%cmuval(ie)*ceq%rtn\n! write(*,*)'Chempot/RT: ',cea%cmuval(ie),svar(ie)\n enddo\n! list stable phases on exit\n! do jph=1,meqrec%nstph\n! jj=meqrec%stphl(jph)\n! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n! enddo\n! set status of the stable phases on exit\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n call mark_stable_phase(phr(jj)%iph,phr(jj)%ics,ceq)\n! write(*,393)'Stable phase Z: ',phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu\n enddo\n!----------------------\n! save inverted phase matrix and more for future use when calculating H.T etc\n! If already allocated then dealloc/alloc as number of constituents can change\n! if(vbug) write(*,*)'allocate/deallocate in meq_sameset: ',meqrec%nphase\n do jj=1,meqrec%nphase\n if(allocated(phr(jj)%curd%cinvy)) then\n deallocate(phr(jj)%curd%cinvy)\n deallocate(phr(jj)%curd%cxmol)\n deallocate(phr(jj)%curd%cdxmol)\n endif\n! why is the dimension if invmat so different???\n ie=phr(jj)%idim\n if(vbug) write(*,*)'Save inverted phase matrix in meq_sameset: ',jj,ie\n! ie=int(sqrt(real(size(phr(jj)%invmat)))+0.1)\n! write(*,*)'Size: ',ie,phr(jj)%ncc\n allocate(phr(jj)%curd%cinvy(ie,ie),stat=errall)\n allocate(phr(jj)%curd%cxmol(meqrec%nrel),stat=errall)\n allocate(phr(jj)%curd%cdxmol(meqrec%nrel,phr(jj)%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 14: ',errall\n gx%bmperr=4370; goto 1000\n endif\n phr(jj)%curd%cinvy=phr(jj)%invmat\n phr(jj)%curd%cxmol=phr(jj)%xmol\n phr(jj)%curd%cdxmol=phr(jj)%dxmol\n!----------------------\n enddo\n goto 1000\n! output of equilibrium matrix when error return\n990 continue\n do iz=1,nz1\n write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2)\n enddo\n!\n1000 continue\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n! write(*,*)'minimization error: ',gx%bmperr\n! elseif(irem.eq.0 .and. iadd.eq.0) then\n endif\n! jump here if phase change\n1100 continue\n! trying to extract the configuratinal entropy of MQMQA\n! write(*,'(\"MM leaving meq_sameset\",1pe14.4)')sconfmqmqa\n! DEBUG output for testing when phase change, Christines probkem\n! write(*,*)'MM iadd and irem: ',iadd,irem\n! if(iadd.gt.0) then\n! jy=meqrec%phr(iadd)%phtupix\n! call get_phasetup_name(jy,phnames)\n! write(*,'(a,i4,2x,a,1pe12.4)')'MM found new stable phase: ',jy,&\n! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm\n! call list_conditions(kou,ceq)\n! elseif(irem.ne.0) then\n! jy=meqrec%phr(abs(irem))%phtupix\n! call get_phasetup_name(jy,phnames)\n! write(*,*)'MM found unstable phase: ',trim(phnames),jy,&\n! trim(phnames),ceq%phase_varres(phasetuple(jy)%lokvares)%dgm\n! call list_conditions(kou,ceq)\n! endif\n if(vbug) write(*,*)'Deallocating smat and svar'\n deallocate(smat)\n deallocate(svar)\n if(vbug) write(*,*)'Final return from meq_sameset'\n! if(gx%bmperr.ne.0) write(*,*)'Error return from meq_sameset',gx%bmperr\n! if(irem*iadd.gt.0) write(*,*)'Leaving meq_sameset: ',irem,iadd\n! write(*,*)'Exit meq_sameset'\n return\n! too many iterations\n1200 continue\n! write(*,*)'Too many iterations: ',meqrec%noofits,ceq%maxiter\n! if(btest(globaldata%status,GSVERBOSE)) then\n! some extra indication of problem\n! write(*,1210)converged\n1210 format('MM why: ',i5)\n! endif\n gx%bmperr=4204\n goto 1000\n end subroutine meq_sameset_okmqmqa\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine setup_comp2cons\n!\\begin{verbatim}\n subroutine setup_comp2cons(meqrec,phr,nz1,smat,tval,xknown,converged,ceq)\n! calculate internal equilibrium in a phase for given overall composition\n! meqrec and phr contains data for phases, nz1 is dimension of equlibrium\n! matrix, smat is the equilibrium matrix, tval is fixed T and P\n! xknown is the overall composition\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n double precision smat(nz1,*),tval(*),xknown(*)\n integer nz1,converged\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! TYPE(gtp_condition), pointer :: condition,lastcond\n TYPE(meq_phase), pointer :: pmi\n! cmix dimensioned for 2 terms ...\n integer tcol,pcol,dncol\n integer sel,jph,jj,ie,je,ncol\n integer nz2,nrow,errall\n double precision cvalue,totam,pham,mag,mat,map,xxx\n! the next line of values are a desperate search for a solution\n! double precision amount\n! double precision hmval\n double precision, dimension(:), allocatable :: xcol,mamu\n! double precision, allocatable :: xxmm(:),wwnn(:),hval(:)\n! logical :: calcmolmass\n! character encoded*32\n!-------------------------------------------------------------------\n! Formulating the equil equation in general:\n! Variables (one column per variable):\n! - The chemical potentials of the components: MEQREC%NREL\n! minus the number of fixed chemical potentials: -MEQREC%NFIXMU\n! - The variation in T if not fixed +1\n! - The variation in P if not fixed +1\n! - The variation of the amounts of stable phases: MEQREC%NSTPH\n! minus those that have fixed amount: -MEQREC%NFIXPH\n!\n! The variables will be ordered: MU, DeltaT, DeltaP, Delta Phase amounts\n! this is important for the order of columns in the equil matrix\n!\n! Equations (one row per equation):\n! If T or P are variable extra columns and terms are needed\n! - The expression for the Gibbs energy for each stable phase, M_A mu_A = G\n! if a fixed chemical potentials incorporated that incorporated\n! if T or P variable an extra term for these\n! - The user defined conditions like:\n! - Amount of components, N(A)= or B(A)=\n! - The total amount of moles, N=, or mass, B=\n! - Overall mole fractions, x(A)=, or mass fractions, w(A)=\n! - Phase specific mole or mass fractions, x(FCC,C)= or w(LIQUID,B)=\n! - The volume V=; enthalpy H= etc., with phase spec and normallizing\n! - relations between state variables x(C14,Fe)-x(liq,Fe)= 0 etc.\n!\n! The equations will always have the G expressions first. The other will \n! be random (or in order of the user entered them)\n!\n! There must be as many equations as there are variables and the construction\n! of the equations can be rather complex. \n! At present only a limited set has been implemented.\n!\n!-------------------------------------------------------------------\n! write(*,*)'MM: in comp2cons'\n allocate(mamu(meqrec%nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 15: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! goto 1000\n! zero all values in equil matrix, dimension (nz1)x(nz1)\n nz2=nz1+1\n tcol=0\n pcol=0\n dncol=0\n!-----------------------------------------------------------\n! step 2.1 the Gibbs energies for the phases, we have just one !!\n! allstableph: do jph=1,meqrec%nstph\n jph=1\n jj=meqrec%stphl(jph)\n! one column with amount of each component to be multiplied with the\n! chemical potential\n ncol=1\n xxx=zero\n gloop: do je=1,meqrec%nrel\n! I cannot understand how smat changes columns and rows !!!!\n smat(1,ncol)=phr(jj)%xmol(je)\n! smat(ncol,1)=phr(jj)%xmol(je)\n ncol=ncol+1\n enddo gloop\n! column nz2 is the right hand side of the equation, the molar G\n!? smat(jph,nz2)=phr(jj)%curd%gval(1,1)\n smat(1,nz2)=phr(jj)%curd%gval(1,1)\n!? write(*,11)'MM smat1: ',1,(smat(1,ncol),ncol=1,nz2)\n! do nrow=1,nz1\n! write(*,11)'MM smat1: ',nrow,(smat(nrow,ncol),ncol=1,nz2)\n! enddo\n!11 format(a,i2,6(1pe12.4))\n!------------------------------------------------------------\n! insert code to calculate N(A)=fix for all elements in this phase\n!\n! case(11) ! N or X with or without indices and normalization\n!1100 continue\n nrow=1\n! conditions are N(A)=fix for all elements\n elloop1: do sel=1,meqrec%nrel\n! Formulate equation for total amount N:\n! rhs: N-N+\\sum_alpha N^a + \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j\n! \\sum_B \\sum_alpha N^a \\sum_i \\sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B)\n! \\sum_alpha N^a \\sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT\n! \\sum_alpha N^a \\sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP\n! \\sum_A M^a_A *deltaN^a\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 16: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n! totam=zero\n! nallph: do jj=1,meqrec%nphase\n! we have just one phase\n jj=1\n pmi=>phr(jj)\n! moles formula units of phase ??\n pham=one\n! multiply terms with the inverse phase matrix\n ie=sel\n! MAYBE use calc_dgdyterms1X ??\n call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits)\n if(gx%bmperr.ne.0) goto 1000\n! the call above calculates (A is \"ie\", z_ij is the inverted phase matrix): \n! mamu_A(B=1..nrel) = \\sum_i \\sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij\n! mag_A = \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j\n! mat_A = \\sum_i \\sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j\n! map_A = \\sum_i \\sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n ncol=1\n elloop2: do je=1,meqrec%nrel\n! mamu(B) = \\sum_i \\sum_j \\sum_A dM^a_B/dy_i dM^a_A z^a_ij\n xcol(ncol)=xcol(ncol)-pham*mamu(je)\n ncol=ncol+1\n enddo elloop2\n! last columns on lhs are amounts of element ie for all stable non-fix phases\n! dncol should indicate last column with potential, can be different for\n! derivative, notf is set above\n! Amount of component in phase\n! totam=totam+pham*pmi%xmol(sel)\n! pmi%xmol(sel) is the M per formula unit, not mole fraction !!!!\n jj=size(pmi%xmol)\n! write(*,411)'xmol: ',jj,pmi%sumxmol,(pmi%xmol(ncol2),ncol2=1,jj)\n!411 format(a,i2,6(1pe12.4))\n totam=pham*pmi%xmol(sel)/pmi%sumxmol\n xcol(ncol)=pham*pmi%xmol(sel)\n! right hand side (rhs) contribution is\n! - NP(phase)*\\sum_i \\sum_j dM(ie)/dy_i * dG/dy_j * z_ij\n xxx=xcol(nz2)\n! write(*,11)'MM xxx: ',nrow+1,(xcol(je),je=1,nz2)\n xcol(nz2)=xcol(nz2)-pham*mag\n!\n! in xcol are values summed over all phases and components\n! then copy summed columns to row nrow in matrix smat\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 11A',nrow\n gx%bmperr=4212; goto 1000\n endif\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n deallocate(xcol)\n! add N^prescribed - N^current to rhs (right hand side)\n! cvalue is the prescibed composition assuming one F.U. of phase ...??\n cvalue=xknown(sel)\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam\n! write(*,11)'MM row: ',nrow,cvalue,totam,(smat(nrow,ncol),ncol=1,nz2)\n! relative check for convergence if cvalue>1.0\n conv: if(abs(totam-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue)))then\n if(converged.lt.5) then\n converged=5\n! write(*,*)'1: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=cvalue\n cerr%dif(cerr%nvs)=totam-cvalue\n! write(*,266)'Unconverged condition N or N(A): ',sel,cvalue,totam\n!266 format(a,i3,4(1pe12.4))\n endif\n endif\n endif conv\n enddo elloop1\n!----------------------------------------------------------\n! all conditions set\n!380 continue\n! there was a strange error that the matrix had been changed on return ...\n! do nrow=1,nz1\n! write(*,11)'MM smat2: ',nrow,(smat(nrow,ncol),ncol=1,nz2)\n! enddo\n goto 1000\n1000 continue\n return\n end subroutine setup_comp2cons\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine setup_equilmatrix\n!\\begin{verbatim}\n subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,&\n dncol,converged,ceq)\n! handels external conditions on extensive variables in the equil matrix\n! meqrec and phr contains data for phases, nz1 is dimension of equlibrium\n! matrix, smat is the equilibrium matrix, tcol and pcol are columns for\n! variable T or P, dncol is the column with phase amount variables.\n! converged is used to indicate calling routine and set if not converged\n! external variable.\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n double precision smat(nz1,nz1+1)\n integer nz1,tcol,pcol,converged,dncol\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_condition), pointer :: condition,lastcond\n TYPE(meq_phase), pointer :: pmi\n! cmix dimensioned for 2 terms ...\n integer cmix(22),cmode,stvix,stvnorm,sel,sph,scs,jph,jj,ie,je,ke,ncol\n integer notf,nz2,nrow,nterms,mterms,moffs,ncol2,iph\n integer xterm,yindex,jy,errall\n double precision cvalue,totam,pham,mag,mat,map,xxx,zval,xval,ccf(5),evalue\n! the next line of values are a desperate search for a solution\n double precision totalmol,totalmass,check1,check2,amount,mag1,mat1,map1\n double precision hmval,gref,tpvalsave(2),cib\n double precision, dimension(:), allocatable :: xcol,mamu,mamu1,zcol,qmat\n double precision, allocatable :: xxmm(:),wwnn(:),hval(:)\n logical :: vbug=.FALSE.,calcmolmass,notdone,nosave\n double precision bbug,dvalue\n character encoded*32,name*32\n! For saving calculated terms in calc_dgdyterms\n! type(saveddgdy), target :: savedrec\n! type(saveddgdy), pointer :: saved\n!-------------------------------------------------------------------\n! Formulating the equil equation in general:\n! Variables (one column per variable):\n! - The chemical potentials of the components: MEQREC%NREL\n! minus the number of fixed chemical potentials: -MEQREC%NFIXMU\n! - The variation in T if not fixed +1\n! - The variation in P if not fixed +1\n! - The variation of the amounts of stable phases: MEQREC%NSTPH\n! minus those that have fixed amount: -MEQREC%NFIXPH\n!\n! The variables will be ordered: MU, DeltaT, DeltaP, Delta Phase amounts\n! this is important for the order of columns in the equil matrix\n!\n! Equations (one row per equation):\n! If T or P are variable extra columns and terms are needed\n! - The expression for the Gibbs energy for each stable phase, M_A mu_A = G\n! if a fixed chemical potentials incorporated that incorporated\n! if T or P variable an extra term for these\n! - The user defined conditions like:\n! - Amount of components, N(A)= or B(A)=\n! - The total amount of moles, N=, or mass, B=\n! - Overall mole fractions, x(A)=, or mass fractions, w(A)=\n! - Phase specific mole or mass fractions, x(FCC,C)= or w(LIQUID,B)=\n! - The volume V=; enthalpy H= etc., with phase spec and normallizing\n! - relations between state variables x(C14,Fe)-x(liq,Fe)= 0 etc.\n!\n! The equations will always have the G expressions first. The other will \n! be random (or in order of the user entered them)\n!\n! There must be as many equations as there are variables and the construction\n! of the equations can be rather complex. \n! At present only a limited set has been implemented.\n!\n! A serious bug concerning mole fraction condition was fixed 2014.09.30\n!\n!-------------------------------------------------------------------\n! zero all values in equil matrix, dimension (nz1)x(nz1)\n nz2=nz1+1\n smat=zero\n ycondTlimit=.false.\n! CCI Bugfixes by Clement Introini indicated by CCI 2018.02.20\n evalue=zero\n! dncol=0\n! write(*,*)'in setup_equil: ',converged,nz1,meqrec%tpindep\n if(converged.ge.0) then\n! converged < 0 means called from dot derivative, then tcol or pcol set\n! otherwise set them to zero\n tcol=0\n pcol=0\n dncol=0\n! else\n! write(*,11)meqrec%nstph,dncol\n!11 format('setup: ',10i5)\n endif\n!-----------------------------------------------------------\n! step 2.1 the Gibbs energies for the stable phases (incl fixed)\n allstableph: do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n! if(meqrec%noofits.le.2) &\n! write(*,12)'pha: ',jph,meqrec%nstph,jj,&\n! phr(jj)%iph,phr(jj)%ics,&\n! phr(jj)%curd%amfu,phr(jj)%curd%gval(1,1)\n!12 format(a,5i3,6(1pe12.4))\n! column nz2 is the right hand side of the equation, to molar G\n smat(jph,nz2)=phr(jj)%curd%gval(1,1)\n! write(*,313)'Gm: ',0,0,jph,nz2,smat(jph,nz2),ceq%tpval(1)\n! one column with amount of component A for each variable chemical potential\n! components with fixed chemical potential are automatically skipped\n ncol=1\n xxx=zero\n gloop: do je=1,meqrec%nrel\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.je) then\n! meqrec%mufixel(ke) is the component number with fix chemical potential\n! DONE: reference state must be handelled (may depend on T) ??\n!\n!---------------------------------------------------------\n! handling of user defined reference states for components\n iph=ceq%complist(je)%phlink\n if(iph.gt.0) then\n! lokph is index of phase record, to get phase index use phlink ....\n! iph=ceq%phase_varres(lokph)%phlink\n! write(*,34)'MM refst: ',je,ke,iph,ceq%complist(je)%endmember\n34 format(a,3i4,4x,10i3)\n! we must also handle reference state at fix T !!\n tpvalsave=ceq%tpval\n! write(*,*)'MM calling calcg_endmember 2: ',-iph\n call calcg_endmember(-iph,ceq%complist(je)%endmember,&\n gref,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'MM error calculating reference state'\n ceq%tpval=tpvalsave\n goto 1000\n endif\n! this is only place where we need to use %mufixvalref\n! mufixval should be referred to SER, mufixvalref prescribed value for user ref\n meqrec%mufixval(ke)=meqrec%mufixvalref(ke)+gref\n! write(*,35)'MM gref: ',ke,meqrec%mufixvalref(ke),gref,&\n! meqrec%mufixval(ke)\n35 format(a,i3,6(1pe12.4))\n! also copy to cmuval !!?? YES !!!\n ceq%cmuval(je)=meqrec%mufixval(ke)\n! else\n! write(*,*)'No userdefined reference state'\n endif\n!---------------------------------------------------------\n!\n xxx=smat(jph,nz2)\n smat(jph,nz2)=smat(jph,nz2)-&\n phr(jj)%xmol(je)*meqrec%mufixval(ke)\n! write(*,312)'fix mu G: ',jj,je,ke,xxx,smat(jph,nz2),&\n! phr(jj)%xmol(je),meqrec%mufixval(ke)\n312 format(a,3i3,6(1pe12.4))\n cycle gloop\n endif\n enddo\n smat(jph,ncol)=phr(jj)%xmol(je)\n ncol=ncol+1\n enddo gloop\n! write(*,*)'MM dncol: ',ncol,dncol,meqrec%tpindep\n! variable T and P? \n if(meqrec%tpindep(1)) then\n! column for variable T, value is -dG/dT ??\n if(tcol.eq.0) then\n tcol=ncol\n dncol=ncol\n ncol=ncol+1\n endif\n smat(jph,tcol)=-phr(jj)%curd%gval(2,1)\n endif\n if(meqrec%tpindep(2)) then\n! column for variable P, value is +dG/dP ??\n if(pcol.eq.0) then\n pcol=ncol\n dncol=ncol\n ncol=ncol+1\n endif\n! PVARIABLE in G\n smat(jph,pcol)=-phr(jj)%curd%gval(3,1)\n endif\n! if(meqrec%noofits.le.2) &\n! write(*,13)'Row: ',jph,jj,(smat(jph,je),je=1,nz2)\n!13 format(a,2i2,7(1pe10.2))\n enddo allstableph\n! we have generated meqrec%nstph rows with ncol columns and rhs in column nz2\n! The columns for delta_phase-amounts should be zero\n! dncol is number of variable potentials (including T or P if variable)\n if(dncol.eq.0) dncol=ncol-1\n! do iz=1,dncol\n! write(*,228)'smat 1: ',(smat(iz,jz),jz=1,nz2)\n! enddo\n!228 format(a,6(1pe12.4))\n! nrow=meqrec%nstph\n!-------------------------------------------------------------------\n! step 2.2 equations due to user conditions on extensive/normalizzed properties\n! nz2 is number of columns, last column is right hand side (rhs)\n! nrow is number of nows already filled (G for stable ph)\n! nz2=nz1+1\n!\n! >>>>>>>>>>> THIS IS UNFINISHED, ONLY A FEW STATE VARIABLES ALLOWED\n! expressions only for N and x and H ... added V mm ... y 190720\n!\n nrow=meqrec%nstph\n lastcond=>ceq%lastcondition\n condition=>lastcond\n allocate(mamu(meqrec%nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 17: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! for saving partial dgdyterms, set nosave=.TRUE. to use old calc_dgdyterms1\n! nosave=.TRUE.\n! nosave always FALSE as there are places to save results in phase_varres\n nosave=.FALSE.\n! savedrec%sameit=0\n! saved=>savedrec\n350 continue\n! cmode=0 means calculate and return current value\n cmode=0\n cmix=0\n condition=>condition%next\n! This is the condition, cvalue is the prescibed value\n! cmode and cmix contain information how to calculate its current value\n! write(*,*)'MM calling apply',condition%noofterms\n! apply_condition in gtp3X.F90 ??\n call apply_condition_value(condition,cmode,cvalue,cmix,ccf,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,71)'MM apply 2: ',cmode,cvalue,cmix,ccf(1)\n71 format(a,i3,1pe12.4,22i4,1pe12.4)\n! if(condition%noofterms.gt.1) write(*,351)nrow,cmode,cmix,nterms,cvalue,&\n! (ccf(jj),jj=1,condition%noofterms)\n! Only cmix(1)=5 is interesting here. potentials already cared for\n if(cmix(1).ne.5) then\n! loop if not the last condition\n! write(*,*)'Taking next condition: ',cmix(1)\n if(.not.associated(condition,lastcond)) goto 350\n goto 380\n endif\n! check if several terms\n mterms=1\n nterms=condition%noofterms\n! do something with the condition ... it can be N=1, x(A)=.1, VM(GAS)=1e-6 etc.\n! THE MASTER VERSION OF THIS TABLE in PMOD25C.F90\n! symb cmix(2) indices irrelevant Property\n! U 10 (phase#set) 6 Internal energy (J)\n! UM 11 \" 6 per mole components\n! UW 12 \" 6 per kg\n! UV 13 \" 6 per m3\n! UF 14 \" 6 per formula unit\n! S 2x \" 7 entropy\n! V 3x \" 8 volume\n! H 4x \" 9 enthalpy\n! A 5x \" 10 Helmholtz energy\n! G 6x \" 11 Gibbs energy\n! NP 7x \" 12 moles of phase\n! BP 8x \" 13 mass of moles\n! DG 9x \" 15 Driving force\n! Q 10x \" 14 Internal stability\n! N 11x (component/phase#set,component) 16 moles of components\n! X 111 \" 17 mole fraction of components\n! B 12x \" 18 mass of components\n! W 122 \" 19 mass fraction of components\n! Y 13 phase#set,constituent#subl 20 constituent fraction\n!----- model variables <<<< these now treated differently\n stvix=cmix(2)/10\n! stvnorm is normalization, 0, 1, 2, 3 or 4\n! 0=none; 1=per mole; 2=per mass; 3=per volume; 4=per formula unit\n stvnorm=mod(cmix(2),10)\n select case(stvix)\n case default\n write(*,*)'not a condition:',stvix,stvnorm,cmix(1),cmix(2),cmix(3)\n gx%bmperr=4208; goto 1000\n case(1,5) \n! stvix=1..6: U, S, V, H, A, G, some conditions not implemented\n! 1 2 3 4 5 6\n write(*,*)'Not implemented yet: ',stvix,stvnorm\n gx%bmperr=4207; goto 1000\n!------------------------------------------------------------------\n! Entropy for system or phase(s)\n case(2) ! S entropy condition\n write(*,*)'MM entropy condition testing: ',nterms,nrow,nz1\n if(stvnorm.eq.0) then\n! not normallized \n if(cmix(3).eq.0) then\n! condition is S=value\n sph=0\n else\n! condition is S(phase#set)=value\n sph=cmix(3); scs=cmix(4)\n endif\n write(*,*)'MM not normallized entropy conditions not implemented'\n gx%bmperr=4207; goto 1000\n else\n! entropy difference: to use the condition SM(solid)-SM(liquid)=0\n! for equientropy lines ...\n! s1-s2=0: delta-s = ds/dT dT + ds/dy dy + ... = 0\n xterm=3\n xxx=zero\n! calculate and store the drivatives in xcol\n! How to know wich is the independent for each index?\n! SEE HOW A V condition is calculated below!!\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 18: ',errall\n gx%bmperr=4370; goto 1000\n endif\n220 continue\n if(mterms.le.nterms) then\n! loop over ALL phases\n sph=cmix(xterm); scs=cmix(xterm+1)\n do jph=1,meqrec%nphase\n if(phr(jph)%iph.eq.sph .and. phr(jph)%ics.eq.scs) then\n! extract the value of SM for phase in mterms\n! write(*,*)'MM: sph,scs: ',mterms,xterm,sph,scs\n xxx=xxx+ccf(mterms)*phr(sph)%curd%gval(2,1)/&\n phr(sph)%curd%abnorm(1)\n write(*,230)'MM S: ',ccf(mterms),phr(sph)%curd%gval(2,1),&\n phr(sph)%curd%abnorm(1),phr(sph)%curd%amfu,xxx\n230 format(a,6(1pe12.4))\n xterm=xterm+4\n mterms=mterms+1\n goto 220\n endif\n enddo\n write(*,*)'MM cannot find phase for EEC',mterms\n gx%bmperr=4399; goto 1000\n endif\n endif\n nrow=nrow+1\n write(*,230)'MM equientropy: ',ceq%tpval(1),cvalue,xxx\n smat(nrow,1)=xxx\n! gx%bmperr=4207; goto 1000\n!------------------------------------------------------------------\n case(3) ! V volume condition, almost the same a H condition\n! Volume for system or phase, NOT normallized\n if(stvnorm.eq.0) then\n! not normallized\n if(cmix(3).eq.0) then\n! condition is V=value\n sph=0\n else\n! condition is V(phase#set)=value\n sph=cmix(3); scs=cmix(4)\n endif\n! FU(alpha) is formula units of alpha phase, V=\\sum_alpha VM(alpha) VM(alpha)\n! dVM(alpha) = d2GM/dPdy_i*c_iA*\\mu_A+\n! \\sum_i dGM/dP*dP + ??\n! \\sum_alpha ???\n! UNFINISHED ??\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 19: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n totam=zero\n notf=0\n check1=zero\n check2=zero\n notdone=.TRUE.\n vallph: do jph=1,meqrec%nstph\n! sum over all stable phases\n jj=meqrec%stphl(jph)\n pmi=>phr(jj)\n! if phase is not fixed there is a column in xcol for variable amount\n! This has to be done before loop of elements\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n if(sph.gt.0) then\n! if a phase is specified, skip all other phases\n if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) &\n cycle vallph\n endif\n! moles formula unit of phase\n pham=pmi%curd%amfu\n allocate(hval(pmi%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 20: ',errall\n gx%bmperr=4370; goto 1000\n endif\n notdone=.FALSE.\n if(.not.allocated(mamu1)) then\n! it will be deallocated when leaving this subroutine ??\n allocate(mamu1((meqrec%nrel)),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 21: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n ncol=1\n if(stvix.eq.3) then\n! V condition, calculate the terms d2G/dPdy_i for all constituents\n do ie=1,pmi%ncc\n hval(ie)=pmi%curd%dgval(3,ie,1)\n enddo\n! write(*,*)'Volume condition: ',pcol,pmi%ncc,hval(1)\n endif\n! write(*,75)'hval: ',hval\n! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel)\n! calculate the terms to be multiplied with the unknown mu(ie)\n vallel: do ie=1,meqrec%nrel\n! multiply terms with the inverse phase matrix and hval()\n! but also return values without this in mamu1,mag1,mat1 and map1 needed\n! for normalization and if there is a condition on chemical potentials\n call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,&\n mamu,mag,mat,map,mamu1,mag1,mat1,map1,&\n pmi,ceq%cmuval,meqrec%noofits)\n if(gx%bmperr.ne.0) goto 1000\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.ie) then\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie)\n! write(*,102)'fix mu V:',nz2,ie,pham,&\n! meqrec%mufixval(ke),mamu1(ie),&\n! pham*meqrec%mufixval(ke)*mamu1(ie),xcol(nz2)\n cycle vallel\n endif\n enddo\n xcol(ncol)=xcol(ncol) - pham*mamu(ie)\n ncol=ncol+1\n enddo vallel\n! vallel loop should end here as mat and map are element independent\n! If T or P are variable, mat and map include \\sum_j hval(j)\n if(tcol.gt.0) then\n xxx=xcol(tcol)\n! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, gval(5,1) is d2G/dTdP=dV/dT\n xcol(tcol)=xcol(tcol)+&\n 2.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! Why is d2G/dTdP multiplied by T??\n! >500 its 1.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! 27 its 2.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! 80 its 5.0D-3*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! 158 its 1.0D-2*pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! slow pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! bad pham*ceq%tpval(1)*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! slow pham*(ceq%tpval(1)*pmi%curd%gval(5,1)-mat)\n! wrong pham*(mat-ceq%tpval(1)*pmi%curd%gval(5,1))\n! write(*,*)'VCONDT: ',tcol,xcol(tcol)\n endif\n! PVARIABLE for condition on V\n if(pcol.gt.0) then\n xxx=xcol(pcol)\n! gval(3,1) is dG/dP, gval(6,1) is d2G/dP2, sign???\n xcol(pcol)=xcol(pcol)+pham*(pmi%curd%gval(6,1)-map)\n! xcol(pcol)=xcol(pcol)+pham*(map-pmi%curd%gval(6,1))\n! pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1))\n! write(*,*)'VCONDP: ',pcol,xcol(pcol)\n endif\n! uncertain if enddo hallel here or after label 7000 above ...\n deallocate(hval)\n if(stvix.eq.3) then\n! sum the total volume (or for a single phase its volume)\n! slow totam=totam+pham*pmi%curd%gval(3,1)\n! totam=totam+pham*pmi%curd%gval(3,1)\n totam=totam+pham*pmi%curd%gval(3,1)\n! wrong totam=totam+pham*pmi%curd%gval(3,1)*ceq%rtn\n endif\n! Now the term multipled with change of the amount of the phase\n if(pmi%phasestatus.ne.PHFIXED) then\n xcol(dncol+notf)=pmi%curd%gval(3,1)\n endif\n! term to the RHS, sign???\n xcol(nz2)=xcol(nz2)+pham*mag\n! slow xcol(nz2)=xcol(nz2)+pham*mag\n! as slow xcol(nz2)=xcol(nz2)-pham*mag\n enddo vallph\n if(sph.gt.0 .and. notdone) then\n! if sph.ne.0 it is possible that the specified phase is not stable, check that\n! the vallph loop has beed done at least once\n write(*,*)'Unnormalized volume condition of unstable phase'\n! These values are most probably all zero making system matrix singular\n write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2)\n gx%bmperr=4196; goto 1000\n endif\n! Add difference to the RHS. Totam is summed above, cvalue is prescribed value\n! write(*,74)'Volume: ',nrow+1,ceq%tpval(1),ceq%rtn,&\n! xcol(nz2),totam,cvalue/ceq%rtn\n! sign? xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn\n xcol(nz2)=xcol(nz2)-totam+cvalue/ceq%rtn\n! xcol(nz2)=xcol(nz2)-totam+cvalue\n! write(*,75)'RHS: ',xcol(nz2),totam,cvalue/ceq%rtn,ceq%rtn,&\n! totam*ceq%rtn,ceq%tpval(1)\n! test if condition converged, use relative error \n! slow if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then\n if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then\n! if(abs(totam-cvalue).gt.ceq%xconv*abs(cvalue)) then\n! write(*,75)'Unconverged volume: ',ceq%tpval(1),&\n! if(vbug) write(*,75)'Unconverged volume: ',ceq%tpval(1),&\n! write(*,75)'Unconverged volume: ',ceq%tpval(1),&\n! totam,cvalue,totam-cvalue,ceq%xconv*abs(cvalue)\n! totam,cvalue/ceq%rtn,totam-cvalue/ceq%rtn\n if(converged.lt.5) then\n converged=5\n! write(*,*)'2: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=cvalue\n cerr%dif(cerr%nvs)=totam-cvalue\n endif\n endif\n endif\n! we have one more equation to add to the equilibrium matrix\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 5A'\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n deallocate(xcol)\n else\n! volume is normalized\n write(*,*)'Normalized volume condition not implemented yet'\n gx%bmperr=4207; goto 1000\n endif\n!------------------------------------------------------------------\n case(4) ! Enthaly condition (Heat balance). \n! Enthalpy for system or phase, normallized or not\n! gx%bmperr=4207; goto 1000\n if(stvnorm.eq.0) then\n! not normallized\n if(cmix(3).eq.0) then\n! condition is H=value or V=value\n sph=0\n else\n! condition is H(phase#set)=value or V(phase#set)=value\n sph=cmix(3); scs=cmix(4)\n endif\n! FU(alpha) is formula units of alpha phase\n! dH=\\sum_alpha FU(alpha)(dG/y_i-Td2G/dTdy_i)*c_iA*\\mu_A + \n! (-Td2G/dT2 + \\sum_i (dG/dy_i - Td2G/dTdY_i)*c_iT)*dT + ...\n! +\\sum_alpha (G-TdG/dT)*\\delta FU(alpha) =\n! \\sum_alpha FU(alpha)\\sum_i(dG/dy_i-Td2G/dTdy_i)*c_iG + H\\tilde - H\n! write(*,*)'Condition on H: ',pmi%ncc,dncol\n! dV = \\sum_alpha FU(alpha)(d2G/dPdy_i)*c_iA*\\mu_A+\n! \\sum_i dG/dP*dP + ??\n! \\sum_alpha ???\n! Condition H=value and H(phase)=value are OK, HM=value is NOT OK Why??\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 22: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n totam=zero\n notf=0\n check1=zero\n check2=zero\n notdone=.TRUE.\n hallph: do jph=1,meqrec%nstph\n! sum over all stable phases\n jj=meqrec%stphl(jph)\n pmi=>phr(jj)\n! if phase is not fixed there is a column in xcol for variable amount\n! This has to be done before loop of elements\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n if(sph.gt.0) then\n! if a phase is specified, skip all other phases\n if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) &\n cycle hallph\n endif\n! moles formula unit of phase\n pham=pmi%curd%amfu\n allocate(hval(pmi%ncc),stat=errall)\n notdone=.FALSE.\n if(.not.allocated(mamu1)) then\n! it will be deallocated when leaving this subroutine ??\n allocate(mamu1((meqrec%nrel)),stat=errall)\n endif\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 23: ',errall\n gx%bmperr=4370; goto 1000\n endif\n ncol=1\n if(stvix.eq.3) then\n! V condition, calculate the terms d2G/dPdy_i for all constituents\n! THIS IS REDUNDANT, V HAS ITIS OWN CASE NOW\n do ie=1,pmi%ncc\n hval(ie)=pmi%curd%dgval(3,ie,1)\n enddo\n! write(*,*)'Volume condition: ',pcol,pmi%ncc,hval(1)\n else\n! H condition, calculate the terms dG/dy_i - T*d2G/dTdy_i for all constituents\n do ie=1,pmi%ncc\n hval(ie)=pmi%curd%dgval(1,ie,1)-&\n ceq%tpval(1)*pmi%curd%dgval(2,ie,1)\n enddo\n! write(*,*)'Enthalpy condition: ',tcol,hval(1)\n endif\n! write(*,75)'hval: ',hval\n! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel)\n! calculate the terms to be multiplied with the unknown mu(ie)\n hallel: do ie=1,meqrec%nrel\n! multiply terms with the inverse phase matrix and hval()\n! but also return values without this in mamu1,mag1,mat1 and map1 needed\n! for normalization and if there is a condition on chemical potentials\n call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,&\n mamu,mag,mat,map,mamu1,mag1,mat1,map1,&\n pmi,ceq%cmuval,meqrec%noofits)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,99)'hfix 1: ',ceq%tpval(1),mag,mat,map,mamu\n99 format(a,6(1pe12.4))\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.ie) then\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie)\n! write(*,102)'fix mu H6:',nz2,ie,pham,&\n! meqrec%mufixval(ke),mamu1(ie),&\n! pham*meqrec%mufixval(ke)*mamu1(ie),xcol(nz2)\n102 format(a,2i3,6(1pe12.4))\n cycle hallel\n endif\n enddo\n xcol(ncol)=xcol(ncol) - pham*mamu(ie)\n ncol=ncol+1\n enddo hallel\n! I think hallel loop should end here as mat and map are element independent\n! If T or P are variable, mat and map include \\sum_j hval(j)\n if(tcol.gt.0) then\n xxx=xcol(tcol)\n! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, sign????\n xcol(tcol)=xcol(tcol)+&\n pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat)\n endif\n! PVARIABLE condition on H\n if(pcol.gt.0) then\n xxx=xcol(pcol)\n! gval(3,1) is dG/dP, gval(5,1) is d2G/dTdP, sign???\n xcol(pcol)=xcol(pcol)+pham*(pmi%curd%gval(3,1)-map)\n! xcol(pcol)=xcol(pcol)+pham*(map-&\n! pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1))\n!>> xcol(pcol)=xcol(pcol)-pham*(map-&\n! pmi%curd%gval(3,1)+ceq%tpval(1)*pmi%curd%gval(5,1))\n! write(*,363)'d2G/dPdy: H',nrow+1,ie,pcol,&\n! xxx,xcol(pcol),pham,mat\n endif\n! uncertain if enddo hallel here or after label 7000 above ...\n! enddo hallel\n! hval no longer needed\n deallocate(hval)\n if(stvix.eq.3) then\n! sum the total volune (or for a single phase its volume)\n totam=totam+pham*pmi%curd%gval(3,1)\n! write(*,211)'HMS total volume:',totam,ceq%rtn*totam,cvalue\n211 format(a,5(1pe12.4))\n else\n! Sum the total enthalpy (for a single phase just one value)\n totam=totam+pham*(pmi%curd%gval(1,1)-&\n ceq%tpval(1)*pmi%curd%gval(2,1))\n! write(*,73)'pham: ',sph,jj,pham,totam,ceq%cmuval(1),ceq%cmuval(2)\n endif\n! Now the term multipled with change of the amount of the phase\n if(pmi%phasestatus.ne.PHFIXED) then\n xcol(dncol+notf)=pmi%curd%gval(1,1)-&\n ceq%tpval(1)*pmi%curd%gval(2,1)\n endif\n! term to the RHS, sign???\n! xcol(nz2)=xcol(nz2)-pham*mag\n xcol(nz2)=xcol(nz2)+pham*mag\n! write(*,76)'Check2: ',jj,pham,mag,pham*mag\n enddo hallph\n if(sph.gt.0 .and. notdone) then\n! if sph.ne.0 it is possible that the specified phase is not stable, check that\n! the hallph loop has beed done at least once\n write(*,*)'Unnormalized enthalpy condition of unstable phase'\n! These values are most probably all zero making system matrix singular\n write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2)\n177 format(a,i2,6(1pe10.2))\n gx%bmperr=4196; goto 1000\n endif\n! write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2)\n! Add difference to the RHS. Totam is summed above, cvalue is prescribed value\n! write(*,74)'Enthalpy: ',nrow+1,ceq%tpval(1),ceq%rtn,&\n! xcol(nz2),totam,cvalue/ceq%rtn\n xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn\n! write(*,75)'RHS: ',xcol(nz2),totam,cvalue,ceq%rtn,cvalue/ceq%rtn\n! test if condition converged, use relative error \n if(abs(totam-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then\n! write(*,75)'Unconverged enthalpy: ',ceq%tpval(1),&\n! totam,cvalue/ceq%rtn,totam-cvalue/ceq%rtn\n if(converged.lt.5) then\n converged=5\n! write(*,*)'3: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=cvalue/ceq%rtn\n cerr%dif(cerr%nvs)=totam-cvalue/ceq%rtn\n endif\n endif\n endif\n! we have one more equation to add to the equilibrium matrix\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 5A'\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n! write(*,*)'H conv: ',ceq%tpval(1)\n! write(*,74)'hline: ',nrow,xcol\n75 format(a,6(1pe12.4))\n74 format(a,i2,6(1pe11.3))\n73 format(a,2i3,6(1pe11.3))\n! check1 and check2 should be equal if we set H as current value and release T\n! write(*,75)'Check: ',check1,check2\n deallocate(xcol)\n! ..........................................................\n else\n! normallized HM (per mole, 1), HW (per mass, 2) or HV (per volume, 3)\n! write(*,*)'*** Normallized enthalpy not yet implemented as condition'\n! gx%bmperr=4207; goto 1000\n! UNFINISHED \n if(stvnorm.ne.1) then\n write(*,*)'Only normallizing per mole implemented'\n gx%bmperr=4207; goto 1000\n endif\n! ie=0 means no element specification\n ie=0\n if(cmix(3).eq.0) then\n! condition is HM=value\n sph=0\n else\n! condition is HM(phase#set)=value\n! UNFINISHED, does not converge \n! gx%bmperr=4207; goto 1000\n sph=cmix(3); scs=cmix(4)\n endif\n! dH=\\sum_alpha FU(alpha)(dG/y_i-Td2G/dTdy_i)c_iA\\mu_A + \n! (-Td2G/dT2 + \\sum_i (dG/dy_i - Td2G/dTdY_i)c_iT)dT + ...\n! +\\sum_alpha (G-TdG/dT)\\delta FU(alpha) =\n! \\sum_alpha FU(alpha)\\sum_i(dG/dy_i-Td2G/dTdy_i)c_iG + H-\\tilde H\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 24: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n totam=zero\n notf=0\n check1=zero\n check2=zero\n notdone=.TRUE.\n if(.not.allocated(mamu1)) then\n! it will be deallocated when leaving this subroutine ??\n allocate(mamu1((meqrec%nrel)),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 25: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n! current value of molar enthalpy\n if(sph.eq.0) then\n call get_state_var_value('HM ',hmval,encoded,ceq)\n totalmol=one\n else\n! current value of molare enthalpy for a phase\n call get_phase_name(sph,scs,encoded)\n name='HM('//encoded\n jj=len_trim(name)\n name(jj+1:)=')'\n call get_state_var_value(name,hmval,encoded,ceq)\n endif\n call get_state_var_value('N ',totalmol,encoded,ceq)\n hmval=hmval/ceq%rtn\n! this is not yet implemented\n write(*,*)'hmval, totalmol: ',hmval, totalmol\n if(gx%bmperr.ne.0) goto 1000\n hmallph: do jph=1,meqrec%nstph\n! sum over all stable phases\n jj=meqrec%stphl(jph)\n pmi=>phr(jj)\n! if phase is not fixed there is a column in xcol for variable amount\n! This has to be done before loop of elements\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n if(sph.gt.0) then\n! if a phase is specified, skip all other phases\n if(.not.(sph.eq.phr(jj)%iph .and. scs.eq.phr(jj)%ics)) &\n cycle hmallph\n pham=one\n else\n pham=pmi%curd%amfu\n endif\n! moles formula unit of phase\n allocate(hval(pmi%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 26: ',errall\n gx%bmperr=4370; goto 1000\n endif\n notdone=.FALSE.\n! calculate the terms dG/dy_i - T*d2G/dTdy_i for all constituents\n do ie=1,pmi%ncc\n hval(ie)=pmi%curd%dgval(1,ie,1)-&\n ceq%tpval(1)*pmi%curd%dgval(2,ie,1)\n enddo\n write(*,73)'hmval: ',sph,ie,hmval\n! write(*,75)'cmuvamanyl: ',(ceq%cmuval(ie),ie=1,meqrec%nrel)\n! ncol is increemented for each variable chemical potential\n ncol=1\n! calculate the terms to be multiplied with the unknown mu(ie)\n hmallel: do ie=1,meqrec%nrel\n! multiply terms with the inverse phase matrix and hval\n! but also return values without this in mamu1,mag1,mat1 and map1 needed\n! for normalization ...\n call calc_dgdytermshm(meqrec%nrel,ie,meqrec%tpindep,hval,&\n mamu,mag,mat,map,mamu1,mag1,mat1,map1,&\n pmi,ceq%cmuval,meqrec%noofits)\n if(gx%bmperr.ne.0) goto 1000\n! In this loop we subtract H/N*\\sum_B \\Delta M_B for all terms\n ncol2=1\n hmloop1: do je=1,meqrec%nrel\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.je) then\n! components with fix chemical potential added to rhs, do not increment ncol2!!!\n xcol(nz2)=xcol(nz2)+&\n pham*hmval*mamu1(je)*meqrec%mufixval(ke)\n! write(*,102)'fix mu 1: ',nz2,je,pham,mamu1(je),&\n! meqrec%mufixval(ke)\n cycle hmloop1\n endif\n enddo\n! mamu(B) = \\sum_i \\sum_j \\sum_A dM^a_B/dy_i dM^a_A z^a_ij\n xcol(ncol2)=xcol(ncol2)-pham*hmval*mamu1(je)\n! write(*,102)'HM jel:',je,ncol2,pham,&\n! mamu(je),hmval,mamu1(je),xcol(ncol2)\n ncol2=ncol2+1\n enddo hmloop1\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.ie) then\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie)\n! write(*,102)'fix mu HM 3:',nz2,ke,pham,&\n! meqrec%mufixval(ke),mamu1(ie),xcol(nz2)\n cycle hmallel\n endif\n enddo\n! mamu(ie) = \\sum_i hval(i) \\sum_j \\sum_B dM^a_B/dy_j z^a_ij\n xcol(ncol)=xcol(ncol) - pham*mamu(ie)\n! write(*,102)'HM col:',ie,ncol,pham,mamu(ie),xcol(ncol)\n ncol=ncol+1\n! check1=check1-pham*mamu(ie)*ceq%cmuval(ie)\n! write(*,76)'check1: ',ie,check1,pham*mamu(ie)*ceq%cmuval(ie)\n76 format(a,i2,6(1pe12.4))\n enddo hmallel\n! UNFINSHED: problems converging with normallized enthalpy condition \n! If T or P are variable, mat and map include \\sum_j hval(j)\n if(tcol.gt.0) then\n xxx=xcol(tcol)\n! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, sign????\n! the equation above should be better but ....\n xcol(tcol)=xcol(tcol)+&\n pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat)\n! pham*(ceq%tpval(1)*pmi%curd%gval(4,1)-mat+hmval*mat1)\n! write(*,102)'HM dt: ',0,tcol,pham,&\n! ceq%tpval(1)*pmi%curd%gval(4,1),mat,hmval,mat1,xcol(tcol)\n endif\n if(pcol.gt.0) then\n! condition on H and variable P\n xxx=xcol(pcol)\n! gval(3,1) is dG/dP, gval(5,1) is d2G/dTdP, sign??? UNFINISHED TEST\n xcol(pcol)=xcol(pcol)+pham*(map-hmval*map1-&\n pmi%curd%gval(3,1)-ceq%tpval(1)*pmi%curd%gval(5,1))\n endif\n! Now the term multipled with change of the amount of the phase, not pham\n if(pmi%phasestatus.ne.PHFIXED) then\n xcol(dncol+notf)=xcol(dncol+notf)+pmi%curd%gval(1,1)-&\n ceq%tpval(1)*pmi%curd%gval(2,1)\n! ceq%tpval(1)*pmi%curd%gval(2,1)-hmval\n! write(*,102)'HM dn: ',ie,dncol+notf,0.0,&\n! pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1),&\n! hmval,xcol(dncol+notf)\n endif\n! term to the RHS\n! xcol(nz2)=xcol(nz2)+pham*(mag-hmval*mag1)\n xcol(nz2)=xcol(nz2)+pham*mag\n! write(*,102)'HM rhs:',ie,nz2,pham,mag,hmval,mag1,xcol(nz2)\n! hval can be differnt for next phase\n deallocate(hval)\n enddo hmallph\n if(sph.gt.0 .and. notdone) then\n! if sph.ne.0 it is possible that the specified phase is not stable, check that\n! the hallph loop has beed done at least once\n write(*,*)'Normalized enthalpy condition of unstable phase'\n! These values are most probably all zero making system matrix singular\n write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2)\n gx%bmperr=4196; goto 1000\n endif\n! write(*,177)'xcol: ',nz2,(xcol(jj),jj=1,nz2)\n! Add difference to the RHS. Totam is summed above, cvalue is prescribed value\n! write(*,74)'Enthalpy: ',nrow+1,ceq%tpval(1),ceq%rtn,&\n! xcol(nz2),totam,cvalue/ceq%rtn\n! xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn\n xcol(nz2)=xcol(nz2)/totalmol-hmval+cvalue/ceq%rtn\n! write(*,75)'RHS: ',xcol(nz2),hmval,cvalue/ceq%rtn,totalmol,&\n! ceq%tpval(1)\n! test if condition converged, use relative error \n if(abs(hmval-cvalue/ceq%rtn).gt.ceq%xconv*abs(cvalue)) then\n write(*,75)'Unconverged enthalpy: ',&\n hmval*ceq%rtn,cvalue,hmval-cvalue/ceq%rtn\n if(converged.lt.5) then\n converged=5 \n! write(*,*)'4: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=hmval\n cerr%dif(cerr%nvs)=hmval-cvalue/ceq%rtn\n endif\n endif\n endif\n! we have one more equation to add to the equilibrium matrix\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 5B'\n! we must divide all terms in the LHS with totalmol\n do ncol=1,nz1\n smat(nrow,ncol)=xcol(ncol)/totalmol\n enddo\n smat(nrow,nz2)=xcol(nz2)\n! write(*,*)'H conv: ',ceq%tpval(1)\n! write(*,74)'hline: ',nrow,xcol\n! check1 and check2 should be equal if we set H as current value and release T\n! write(*,75)'Check: ',check1,check2\n deallocate(xcol)\n endif\n! already calculated above\n!------------------------------------------------------------------\n case(6) ! G\n! Gibbs energy, for system or a phase\n gx%bmperr=4207; goto 1000\n if(stvnorm.eq.0) then\n! not normallized\n if(cmix(3).eq.0) then\n! condition is G=value\n sph=0\n else\n! condition is G(phase#set)=value\n gx%bmperr=4207; goto 1000\n sph=cmix(3); scs=cmix(4)\n endif\n! current value of dG=\\sum_A dM_A \\mu_A + G -\\tilde G=0\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 27: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n!...UNFINISHED\n gx%bmperr=4207; goto 1000\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 6A'\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n! set rhs to G^prescribed - G^current \n! smat(nrow,nz2)=cvalue\n deallocate(xcol)\n else\n! normallizing can be M (per mole, 1), W (per mass, 2) or V (per volume, 3?)\n gx%bmperr=4207; goto 1000\n endif\n!------------------------------------------------------------------\n case(7) ! NP\n! Amount of phase in moles, use fix phase instead\n write(*,352)stvix,stvnorm\n352 format('Not implemented yet, use set status phase=fix: ',2i5)\n gx%bmperr=4207; goto 1000\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 7A'\n!------------------------------------------------------------------\n case(8) ! BP\n! Amount of phase in mass, use fix phase instead\n write(*,352)stvix,stvnorm\n gx%bmperr=4207; goto 1000\n nrow=nrow+1\n if(nrow.gt.nz1) stop 'MM too many equations 8A'\n!------------------------------------------------------------------\n! 9 and 10 (DG and Q) not allowed as conditions\n!------------------------------------------------------------------\n case(11) ! N or X with or without indices and normalization\n! 160818: adding possibility to have several terms a*N(A)-b*N(B)=cvalue\n1100 continue\n if(stvnorm.eq.0) then\n moffs=0\n! write(*,*)'MM condition for N: ',nterms,sph,sel\n! return here for second term\n1107 continue\n if(cmix(3).eq.0) then\n! condition is N=fix\n sel=0; sph=0\n elseif(cmix(4+moffs).eq.0) then\n! condition is N(A)=fix\n sel=cmix(3+moffs); sph=0\n else\n! condition is N(phase#set,A)=fix; how to handle if phase#set not stable?\n! write(*,*)'Condition N(phase#set,A)=fix not allowed'\n! gx%bmperr=4208; goto 1000\n sel=cmix(5+moffs); sph=cmix(3+moffs); scs=cmix(4+moffs)\n endif\n! write(*,*)'Condition on N, N(A) or N(phase,A)',sph,sel\n! Formulate equation for total amount N:\n! rhs: N-N+\\sum_alpha N^a + \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j\n! \\sum_B \\sum_alpha N^a \\sum_i \\sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B)\n! \\sum_alpha N^a \\sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT\n! \\sum_alpha N^a \\sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP\n! \\sum_A M^a_A *deltaN^a\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 28: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n totam=zero\n! notf keeps track on entered non-fixed phases with variable amount\n notf=0\n! THE CALCULATION FOR N= and N(A)= seems OK\n! sum over all phases to handle conditions like N(phase#set,A)=fix\n! as the phase#set may not be stable\n! write(*,*)'Loop for all all phases for condition N='\n nallph: do jj=1,meqrec%nphase\n pmi=>phr(jj)\n if(sph.eq.0) then\n! skip if not stable\n if(phr(jj)%stable.eq.0) cycle nallph\n else\n! condition is for a specific phase#compset, N(phase#compset,comp)=A\n if(phr(jj)%iph.ne.sph .or. phr(jj)%ics.ne.scs) cycle nallph\n write(*,*)'N(phase#set,component) not implemented'\n gx%bmperr=4207; goto 1000\n endif\n! moles formula unit of phase set above\n pham=pmi%curd%amfu\n! write(*,*)'MMz pham: ',phr(jj)%iph,pham\n! if phase is not fixed there is a column in xcol for variable amount\n! This has to be done before loop of elements\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n ncol=1\n! write(*,*)'Loop for elements: ', jj,phr(jj)%iph,phr(jj)%ics,ncol\n nallel: do ie=1,meqrec%nrel\n! if sel=/=0 then skip all components except sel\n if(sel.gt.0 .and. ie.ne.sel) cycle nallel\n! multiply terms with the inverse phase matrix\n! This is called for each condition, maybe try to save values ...\n if(nosave) then\n call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits)\n else\n! this routine which should work in parallel ...\n call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,meqrec%noofits)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! the call above calculates (A is \"ie\", z_ij is the inverted phase matrix): \n! mamu_A(B=1..nrel) = \\sum_i \\sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij\n! mag_A = \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j\n! mat_A = \\sum_i \\sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j\n! map_A = \\sum_i \\sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n! goto 8000 .... skipping nloop1 with je fails ....\n!??????????????????? is this loop needed ?????????????????????? YES !!!\n ncol=1\n nloop1: do je=1,meqrec%nrel\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.je) then\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n xcol(nz2)=xcol(nz2)+pham*mamu(je)*meqrec%mufixval(ke)\n! write(*,102)'fix mu N: ',sel,je,pham,&\n! meqrec%mufixval(ke),mamu(je),&\n! pham*mamu(je)*meqrec%mufixval(ke),xcol(nz2)\n cycle nloop1\n endif\n enddo\n! mamu(B) = \\sum_i \\sum_j \\sum_A dM^a_B/dy_i dM^a_A z^a_ij\n xcol(ncol)=xcol(ncol)-pham*mamu(je)\n ncol=ncol+1\n enddo nloop1\n! goto 9000\n!9000 continue\n! If T or P are variable\n if(tcol.gt.0) then\n xxx=xcol(tcol)\n xcol(tcol)=xcol(tcol)+pham*mat\n! write(*,363)'d2G/dTdy 2: ',nrow+1,ie,tcol,&\n! xxx,xcol(tcol),pham,mat\n endif\n! condition on N and variable P\n if(pcol.gt.0) then\n xxx=xcol(pcol)\n xcol(pcol)=xcol(pcol)+pham*map\n! write(*,363)'MM d2G/dPdyi: ',nrow+1,ie,pcol,&\n! xxx,xcol(pcol),pham,map\n endif\n! last columns on lhs are amounts of element ie for all stable non-fix phases\n! dncol should indicate last column with potential, can be different for\n! derivative, notf is set above\n if(pmi%phasestatus.ne.PHFIXED) then\n! notf indicates the column for amount of a component in stable nonfixed phase\n! sum of moles in phase will be multiplied with delta-phase_amount\n if(sel.gt.0 .and. sel.eq.ie) then\n xcol(dncol+notf)=pmi%xmol(ie)\n else\n xcol(dncol+notf)=xcol(dncol+notf)+pmi%xmol(ie)\n endif\n endif\n! Maybe this should be included also for fixed phases ....?? YES\n! right hand side (rhs) contribution is\n! - NP(phase)*\\sum_i \\sum_j dM(ie)/dy_i * dG/dy_j * z_ij\n xxx=xcol(nz2)\n xcol(nz2)=xcol(nz2)-pham*mag\n enddo nallel\n! this is to used on the RHS for compare with prescribed value\n if(sel.gt.0) then\n totam=totam+pham*pmi%xmol(sel)\n else\n totam=totam+pham*pmi%sumxmol\n endif\n! tafidbug\n! write(*,665)xxx,pham,mag,cvalue,totam,&\n! xxx-pham*mag+cvalue-totam\n665 format('RHS: ',6(1pe12.4))\n enddo nallph\n!\n! 160818: adding code to have several terms ... same as for x below\n nmany: if(mterms.lt.nterms) then\n! this branch if 2 or more terms\n if(mterms.eq.1) then\n! allocate arry to save intermediate results\n! -Wuninitialized gave a warning: qmat.dim[0].ubound may be uninitilzed\n! when used a few lines below but adding this removed this ... \n if(.not.allocated(qmat)) then\n allocate(qmat(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 29: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n qmat=zero\n evalue=zero\n endif\n! save xcol and then go back and calculate next term\n! maybe ccf should be included ??? YES!!! must correct also xterms!!!\n do ncol=1,nz2\n qmat(ncol)=qmat(ncol)+ccf(mterms)*xcol(ncol)\n enddo\n evalue=evalue+ccf(mterms)*totam\n! write(*,664)'MM nsel1:',moffs,sel,sph,totam,ccf(mterms),&\n! cvalue,evalue\n! write(*,666)'MM evalue1: ',mterms,evalue,ccf(mterms),totam\n! write(*,666)'MM q:',mterms,evalue,(qmat(ncol),ncol=1,nz2)\n666 format(a,i2,6(1pe12.4))\n! prepare for next term by incrementing mterms and moffs\n mterms=mterms+1\n moffs=moffs+4\n deallocate(xcol)\n! deallocate(zcol)\n goto 1107\n elseif(nterms.gt.1) then\n! for last term when more than 1\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 11A0',nrow\n gx%bmperr=4209; goto 1000\n endif\n do ncol=1,nz2\n smat(nrow,ncol)=qmat(ncol)+ccf(mterms)*xcol(ncol)\n enddo\n evalue=evalue+ccf(mterms)*totam\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+evalue\n! write(*,664)'MM nsel2:',moffs,sel,sph,totam,ccf(mterms),&\n! cvalue,evalue\n664 format(a,3i3,6(1pe12.4))\n! write(*,666)'MM evalue: ',mterms,evalue,ccf(mterms),totam\n! write(*,666)'MM s:',mterms,evalue,(smat(nrow,ncol),ncol=1,nz2)\n! 160818: end code added for N(A)-N(B)\n else\n! only one terms (original code unchanged)\n! in xcol are values summed over all phases and components\n! then copy summed columns to row nrow in matrix smat\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 11A',nrow\n gx%bmperr=4212; goto 1000\n endif\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n! add N^prescribed - N^current to rhs (right hand side)\n xxx=smat(nrow,nz2)\n! convergence problems using condition fix phase with amount >0, change sign ...\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam\n evalue=totam\n endif nmany\n! tafidbug\n! smat(nrow,nz2)=smat(nrow,nz2)+cvalue-totam\n! write(*,355)'MM N: ',cvalue,totam,(smat(nrow,jj),jj=1,nz2)\n355 format(a,6(1pe12.4))\n! write(*,363)'RHSN: ',nrow,nz2,0,smat(nrow,nz2),xxx,cvalue,totam,&\n! cvalue-totam\n deallocate(xcol)\n! relative check for convergence if cvalue>1.0\n! if(abs(totam-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue))) then\n if(abs(evalue-cvalue).gt.ceq%xconv*max(1.0d0,abs(cvalue))) then\n if(converged.lt.5) then\n converged=5\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=cvalue\n cerr%dif(cerr%nvs)=evalue-cvalue\n endif\n! write(*,*)'5: converged=5',cerr%nvs\n endif\n! endif\n if(vbug) then\n if(sel.eq.0) then\n write(*,266)'Unconverged condition N or N(A): ',sel,&\n cvalue,evalue,evalue-cvalue\n else\n write(*,266)'Unconverged condition N or N(A): ',sel,&\n cvalue,evalue,evalue-cvalue\n endif\n endif\n endif\n!----------------------------------------------------------\n elseif(stvnorm.gt.1) then\n! only normallizing of N with respect to amount of moles (M) is allowed\n write(*,*)'N can only be normalled with M',stvix,stvnorm,cmix(2)\n gx%bmperr=4208; goto 1000\n else\n!------------------------------------------------------------\n! condition is x(A)=fix or x(phase,A)=fix or several terms for x(...)\n! return here if several terms, value of xxmm ???\n moffs=0\n1120 continue\n! x(A)=fix and x(phase#set,A)=fix conditions. x(A)=N(A)/N; x(ph,A)=N(ph,A)/N(ph)\n! above N=fix and N(A)=fix are treated as they have a \"simple\" summation, \n! We must sum over all phases and constituents for the normallizing factor\n! definition: X(A)=N(A)/N; \n! derivative: dX(A)=dN(A)/N - N(A)/N**2 *dN\n! sum dN(A) and dN at the same time and multiply the sums with 1/N \n! and -N(A)/N**2 in the end.\n if(cmix(3+moffs).eq.0) then\n write(*,*)'Condition NM=fix is illegal'\n gx%bmperr=4208; goto 1000\n elseif(cmix(4+moffs).eq.0) then\n! condition is x(A)=fix\n sel=cmix(3+moffs); sph=0\n else\n! condition is x(phase#set,A)=fix\n! write(*,33)cmix\n33 format('Condition x(phase#set,A)=fix?',10i4)\n sel=cmix(5+moffs); sph=cmix(3+moffs); scs=cmix(4+moffs)\n endif\n if(.not.allocated(xxmm)) then\n! this call returns the current fractions and total amounts. We need\n! to do it only once inside this subroutine. xxmm are deallocated at exit\n allocate(xxmm(meqrec%nrel),stat=errall)\n allocate(wwnn(meqrec%nrel),stat=errall)\n calcmolmass=.FALSE.\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 30: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n if(.not.calcmolmass) then\n call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq)\n if(gx%bmperr.ne.0) goto 1000\n calcmolmass=.TRUE.\n endif\n! two summations, zcol sums the term dN(A); xcol sums dN (as above)\n allocate(xcol(nz2),stat=errall)\n allocate(zcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 31: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n zcol=zero\n totam=zero\n zval=zero\n xval=zero\n! LOOP FOR ALL PHASES (why not all stable??)\n! dncol+notf indicate column for the amount of phases with variable amount\n notf=0\n! sum over all phases to handle conditions like x(phase#set,A)=fix\n! as the phase#set may not be stable\n bbug=zero\n xallph: do jj=1,meqrec%nphase\n pmi=>phr(jj)\n if(sph.eq.0) then\n! skip this phase if not stable and condition not on a specific phase (sph)\n! WOW COMPLICATION, I have another test for stability ... suck\n if(phr(jj)%stable.eq.0) cycle xallph\n pham=pmi%curd%amfu\n else\n! condition on specific phase, skip this phase if not the right one\n if(phr(jj)%iph.ne.sph .or. &\n phr(jj)%ics.ne.scs) cycle xallph\n! note this destroys calculated values from calc_molmass above ...\n call calc_phase_molmass(sph,scs,xxmm,wwnn,&\n totalmol,totalmass,amount,ceq)\n calcmolmass=.FALSE.\n pham=one\n totalmol=one\n! write(*,355)'MM cpm: ',totalmol,amount,pham,xxmm\n! totalmol depend on amout of phase stable, irrelevant here\n if(gx%bmperr.ne.0) goto 1000\n endif\n! notf indicates the column for the variable amount of the phase\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n xallel: do ie=1,meqrec%nrel\n! we cannot skip summation over all element as that is needed for normallizing\n! calculate a term for each column to be multiplied with chemical potential\n! we must sum xcol for all elemenets and add to zcol for element sel\n! if sel=/=0 then we sum also zcol(sel) for all phases\n if(nosave) then\n call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits)\n else\n call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,meqrec%noofits)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! write(*,355)'MM dgdy: ',mamu\n ncol=1\n xloop2: do je=1,meqrec%nrel\n!---------------------------------------------------------------------\n! BIG TROUBLE HERE FOR FIXED CHEMICAL POTENTIAL !!!!! FIXED NOW ... NO!! ??\n! but still problems combining with other conditions on H etc ...\n! it works when we have N(A)=fix (code above) but not with x(A)=fix\n! Calculate one column for each component to be multiplied with chem.pot.\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n do ke=1,meqrec%nfixmu\n! check for elements with fixed chemical potentials, they go to RHS\n if(meqrec%mufixel(ke).eq.je) then\n! the sign here should be opposite from xcol(ncol)= below\n! write(*,*)'In xloop2: ',ie,ke,je,sel,nrow\n! xcol(nz2)=xcol(nz2)-&\n xcol(nz2)=xcol(nz2)+&\n pham*mamu(je)*meqrec%mufixval(ke)\n! bbug=bbug-pham*mamu(je)\n! write(*,102)'fix mu xall: ',sel,je,pham,&\n! meqrec%mufixval(ke),mamu(je),&\n! pham*mamu(je)*meqrec%mufixval(ke),xcol(nz2)\n! zcol needed because we have a normallized property (mole fraction)\n! NOTE it should be ie here and NOT je ??? and opposite sign from xcol(nz2)\n if(ie.eq.sel) then\n zcol(nz2)=zcol(nz2)+&\n pham*mamu(je)*meqrec%mufixval(ke)\n! write(*,102)'fix mu xsel: ',ie,je,pham,&\n! meqrec%mufixval(ke),mamu(je),&\n! pham*mamu(je)*meqrec%mufixval(ke),zcol(nz2)\n! abug=-pham*mamu(je)\n endif\n cycle xloop2\n endif\n enddo\n! mamu(B) = \\sum_i \\sum_j dM^a_B/dy_i dM^a_A z^a_ij\n! sum over all elements for normallizing\n xcol(ncol)=xcol(ncol)-pham*mamu(je)\n if(sel.eq.ie) then\n! if this is the specified element sum to zcol\n zcol(ncol)=zcol(ncol)-pham*mamu(je)\n endif\n ncol=ncol+1\n enddo xloop2\n!-----------------------------------------------------------------------\n! If T or P are variable, mat is \\sum_i d2G/dy_idT, map is \\sum_i d2G/dy_idP\n if(tcol.gt.0) then\n xcol(tcol)=xcol(tcol)+pham*mat\n if(sel.eq.ie) then\n zcol(tcol)=zcol(tcol)+pham*mat\n endif\n! write(*,363)'d2G/dTdy 3: ',nrow+1,ie,tcol,&\n! xxx,xcol(tcol),pham,mat\n363 format(a,3i3,6(1pe12.4))\n endif\n if(pcol.gt.0) then\n xcol(pcol)=xcol(pcol)+pham*map\n if(sel.eq.ie) then\n zcol(pcol)=zcol(pcol)+pham*map\n endif\n endif\n! columns for phase amounts\n if(pmi%phasestatus.ne.PHFIXED) then\n! write(*,*)'MM 363A: ',dncol,notf,ie,sel\n if(sph.eq.0) then\n xcol(dncol+notf)=xcol(dncol+notf)+pmi%xmol(ie)\n! write(*,*)'MM 363B: ',dncol,notf,ie,xcol(dncol+notf)\n if(ie.eq.sel) then\n zcol(dncol+notf)=zcol(dncol+notf)+pmi%xmol(ie)\n endif\n endif\n endif\n! right hand side (rhs) contribution is (normallized below)\n! - NP(phase)*\\sum_i \\sum_j dM(ie)/dy_i * dG/dy_j * z_ij \n xcol(nz2)=xcol(nz2)-pham*mag\n if(sel.eq.ie) then\n zcol(nz2)=zcol(nz2)-pham*mag\n endif\n enddo xallel\n! totam and zval not used !!??\n totam=totam+pham*pmi%sumxmol\n! UNFINISHED: if sph nonzero next line must be changed to be for sph\n zval=zval+pham*pmi%xmol(sel)\n! sel=cmix(5); sph=cmix(3); scs=cmix(4)\n! write(*,*)'MM x(p,c): ',sph,scs,sel,zval\n enddo xallph\n!-------------- new code begin\n! can handle the case of several terms like x(liquid,S)-x(pyrrh,S)=0\n! x(Mg)-2*x(Si)=0\n xterms: if(mterms.lt.nterms) then\n! this branch if 2 or more terms\n if(mterms.eq.1) then\n! allocate array for saving intermediate results\n if(.not.allocated(qmat)) then\n allocate(qmat(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 32: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n qmat=zero\n evalue=zero\n endif\n! save zcol and xcol then go back and calculate next term\n! corrected by adding ccf factor!! (not needed for x(liq,a)-x(sol,a)=0 ....\n do ncol=1,nz2\n qmat(ncol)=qmat(ncol)+ccf(mterms)*&\n (zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol\n enddo\n evalue=evalue+ccf(mterms)*xxmm(sel)\n! prepare for next term by incrementing mterms and moffs\n mterms=mterms+1\n moffs=moffs+4\n! write(*,1117)'MM 2nd indices: ',moffs,(cmix(jj+moffs),jj=3,6)\n!1117 format(a,i3,2x,4i3)\n! write(*,1118)'MM xxmm:',mterms,sel,xxmm(sel)\n deallocate(xcol)\n deallocate(zcol)\n goto 1120\n elseif(nterms.gt.1) then\n! for last term of expression\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 11B: ',nrow,nz1,meqrec%nfixph\n gx%bmperr=4209; goto 1000\n endif\n! insert results in smat\n! write(*,1118)'MM endofexp:',mterms,sel,evalue,xxmm(sel)\n1118 format(a,2i3,6(1pe12.4))\n do ncol=1,nz2\n smat(nrow,ncol)=qmat(ncol)+&\n ccf(mterms)*(zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol\n enddo\n evalue=evalue+ccf(mterms)*xxmm(sel)\n! add x^prescribed - x^current to rhs (right hand side)\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+evalue\n!------------------new code end\n else\n! use this else branch when nterms=1, just a single x(a)=value\n nrow=nrow+1\n! if(bbug.ne.zero) then\n! looking for bug with activity conditions\n! write(*,16)'abug: ',sel,abug,bbug,xxmm(sel),&\n! abug-bbug*xxmm(sel),meqrec%mufixval(1),&\n! (abug-bbug*xxmm(sel))*meqrec%mufixval(1)\n!16 format(a,i3,6(1pe12.4))\n! else\n! write(*,16)'nomy : ',sel,zcol(1),xcol(1),&\n! xxmm(sel),zcol(1)-xcol(1)*xxmm(sel)\n! endif\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 11B: ',nrow,nz1,meqrec%nfixph\n gx%bmperr=4209; goto 1000\n endif\n! in xcol is dN and in zcol dN(A) summed over all phases and components\n! calculate the normallized values now\n! xmat=1/N*(dN(A) - (N(A)/N)*dN)\n! sum zcol and xcol to nrow in smat multiplying xcol with current amount\n! and normallizing with total amount, including the RHS (column nz2)\n do ncol=1,nz2\n smat(nrow,ncol)=(zcol(ncol)-xcol(ncol)*xxmm(sel))/totalmol\n enddo\n! subract x^prescribed - x^current to rhs (right hand side)\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+xxmm(sel)\n evalue=xxmm(sel)\n endif xterms\n deallocate(xcol)\n deallocate(zcol)\n! phase composition problem\n! write(*,355)'MM X: ',cvalue,xxmm(sel),totalmol,pham,&\n! (smat(nrow,jj),jj=1,nz2)\n! check on convergence\n! if(abs(xxmm(sel)-cvalue).gt.ceq%xconv) then\n if(abs(evalue-cvalue).gt.ceq%xconv) then\n if(converged.lt.5) then\n converged=5\n! write(*,*)'6: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=xxmm(sel)\n cerr%dif(cerr%nvs)=xxmm(sel)-cvalue\n endif\n endif\n! write(*,266)'Unconverged condition x(A): ',sel,cvalue,evalue\n! if(vbug) write(*,266)'Unconverged condition x(A): ',sel,&\n! cvalue,evalue\n endif\n endif\n! finished conditions on N and X with indices\n if(allocated(xxmm)) then\n deallocate(xxmm)\n deallocate(wwnn)\n endif\n!\n!------------------------------------------------------------------\n case(12) ! B or W\n! Amount of component in mass, can have indices and normallization\n! code copied from the case(11) for N and X and modified for mass\n1200 continue\n if(stvnorm.eq.0) then\n if(cmix(3).eq.0) then\n! condition is B=fix\n if(bwarning) then\n write(*,491)\n491 format(' *** WARNING, using B=value as condition can disable',&\n ' the gridminimizer'/&\n ' and cause convergence problem. Use N=value instead.')\n! Issue this message only once for each calculation\n bwarning=.FALSE.\n endif\n! write(*,*)'MM condition B=fix: ',stvnorm,cmix(3)\n sel=0; sph=0\n elseif(cmix(4).eq.0) then\n! condition is B(A)=fix\n sel=cmix(3); sph=0\n else\n! condition is B(phase#set,A)=fix; how to handle if phase#set not stable?\n write(*,*)'Condition B(phase#set,A)=fix not implemented'\n gx%bmperr=4208; goto 1000\n sel=cmix(5); sph=cmix(3); scs=cmix(4)\n endif\n! Formulate equation for total amount B: each M_A multiplied with mass_A\n! rhs: B-B+\\sum_alpha N^a + \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j \n! \\sum_B \\sum_alpha N^a \\sum_i \\sum_j dM^_A/dy_i dM^a_B/dy_j*z^a_ij *mu(B)\n! \\sum_alpha N^a \\sum_i d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j *deltaT\n! \\sum_alpha N^a \\sum_i d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j *deltaP\n! \\sum_A M^a_A *deltaN^a\n allocate(xcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 33: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n totam=zero\n! write(*,222)'MM xcol 1',totam,xcol\n222 format(a,10(1pe11.3))\n! notf keeps track on entered non-fixed phases with variable amount\n notf=0\n! not used zval=zero\n ballph: do jph=1,meqrec%nstph\n! sum over all stable phases\n jj=meqrec%stphl(jph)\n pmi=>phr(jj)\n! if phase is not fixed there is a column in xcol for variable amount\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n! amount of phase, amfu is moles formula units, abnorm(2) is mass per form.unit\n pham=pmi%curd%amfu\n ballel: do ie=1,meqrec%nrel\n! if sel=/=0 then skip all components except sel\n if(sel.gt.0 .and. ie.ne.sel) cycle\n! multiply terms with the inverse phase matrix\n if(nosave) then\n call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits)\n else\n call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,meqrec%noofits)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Calculated dgdyterms 3: ',mat\n! the call above calculates (A is \"ie\", z_ij is the inverted phase matrix): \n! mamu_A(B=1..nrel) = \\sum_i \\sum_j dM^a_A/dy_i dM^a_B/dy_j z^a_ij\n! mag_A = \\sum_i \\sum_j dM^a_A/dy_i z^a_ij dG/dy_j\n! mat_A = \\sum_i \\sum_j d2M^a_A/dTdy_i z^a_ij d2G/dTdy_j\n! map_A = \\sum_i \\sum_j d2M^a_A/dPdy_i z^a_ij d2G/dPdy_j\n ncol=1\n! calculate a term for each column to be multiplied with chemical potential\n! if the potential is fixed add the term to the rhs\n bloop1: do je=1,meqrec%nrel\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.je) then\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n! NOTE: mamu includes summation of two components, multiply with two masses!!!\n! write(*,98)'fix mu b:',sel,je,&\n! pham*mamu(je),meqrec%mufixval(ke),mass_of(ie,ceq)\n xcol(nz2)=xcol(nz2)+&\n pham*mamu(je)*meqrec%mufixval(ke)*mass_of(ie,ceq)\n cycle bloop1\n endif\n enddo\n! mamu(B) = \\sum_i \\sum_j \\sum_A dM^a_B/dy_i dM^a_A z^a_ij mass_A mass_B ???\n xcol(ncol)=xcol(ncol)-pham*mamu(je)*mass_of(ie,ceq)\n ncol=ncol+1\n enddo bloop1\n! If T or P are variable\n if(tcol.gt.0) then\n! xxx=xcol(tcol)\n xcol(tcol)=xcol(tcol)+pham*mat*mass_of(ie,ceq)\n! write(*,363)'d2G/dTdy 4: ',nrow-1,ie,tcol,&\n! xxx,xcol(tcol),pham,mat\n endif\n if(pcol.gt.0) then\n! xxx=xcol(pcol)\n xcol(pcol)=xcol(pcol)+pham*map*mass_of(ie,ceq)\n! write(*,363)'d2G/dPdy: ',nrow-1,ie,pcol,&\n! xxx,xcol(pcol),pham,mat\n endif\n! last columns are amounts of element ie for all stable non-fix phases\n! for all stable (non fixed) phases we have the mass multiplied with deltaaleph\n if(pmi%phasestatus.ne.PHFIXED) then\n! ?? zval=zval+pmi%xmol(ie)*mass_of(ie,ceq)\n if(sel.gt.0 .and. sel.eq.ie) then\n xcol(dncol+notf)=&\n pmi%xmol(ie)*mass_of(ie,ceq)\n! write(*,363)'xcola: ',ncol,ie,0,xcol(ncol),mass_of(ie,ceq)\n else\n xcol(dncol+notf)=xcol(dncol+notf)+&\n pham*pmi%xmol(ie)*mass_of(ie,ceq)\n endif\n endif\n! right hand side (rhs) contribution is\n! - BP(phase)*\\sum_i \\sum_j dM(ie)/dy_i * dG/dy_j * z_ij\n xcol(nz2)=xcol(nz2)-pham*mag*mass_of(ie,ceq)\n! write(*,222)'MM xcol 2',totam,xcol\n enddo ballel\n! sum of mass in phase will be multiplied with delta-phase_amount\n! write(*,202)'sumxmol mm: ',sel,pham,pmi%sumxmol,pmi%sumwmol\n if(sel.gt.0) then\n totam=totam+pham*pmi%xmol(sel)*mass_of(sel,ceq)\n else\n totam=totam+pham*pmi%sumwmol\n endif\n enddo ballph\n! write(*,222)'MM xcol 3',totam,xcol\n!......debug\n if(.not.allocated(xxmm)) then\n! this call returns the current fractions and total amounts. We need\n! to do it only once inside this subroutine. xxmm are deallocated at exit\n allocate(xxmm(meqrec%nrel),stat=errall)\n allocate(wwnn(meqrec%nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 34: ',errall\n gx%bmperr=4370; goto 1000\n endif\n call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n! if(sel.eq.0) write(*,*)'totalmass: ',totalmass,totam\n!\n! in xcol are values summed over all phases and components\n! copy summed columns to smat nrow\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 12A',nrow\n gx%bmperr=4209; goto 1000\n endif\n do ncol=1,nz2\n smat(nrow,ncol)=xcol(ncol)\n enddo\n! write(*,97)'Totalmass B: ',sel,totam,cvalue,totalmass,wwnn(sel)\n97 format(a,i4,6(1pe12.4))\n! add B^prescribed - B^current to rhs (right hand side)\n xxx=smat(nrow,nz2)\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam\n! write(*,363)'RHSB: ',nrow,nz2,0,smat(nrow,nz2),xxx,cvalue,totam,&\n! cvalue-totam\n deallocate(xcol)\n! check convergence\n if(abs(totam-cvalue).gt.ceq%xconv) then\n! write(*,266)'Unconverged condition B(A): ',sel,cvalue,zval\n if(converged.lt.5) then\n converged=5\n! write(*,*)'7: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=cvalue\n cerr%dif(cerr%nvs)=totam-cvalue\n endif\n endif\n endif\n! write(*,222)'MM xcol 3',totam,xcol\n if(vbug) then\n if(sel.eq.0) then\n write(*,363)'Condition B=fix',0,0,0,cvalue,totam\n else\n write(*,363)'Condition B(a)=fix',sel,0,0,cvalue,totam\n endif\n endif\n! write(*,223)'MM smat 1',nrow,(smat(nrow,ncol),ncol=1,nz2)\n223 format(a,i2,10(1pe11.3))\n elseif(stvnorm.ne.2) then\n! only normallizing of B with respect to mass (W) is allowed\n write(*,*)'Allowed normallizing with W only',stvix,stvnorm,cmix(2)\n gx%bmperr=4208; goto 1000\n else\n!-------------------------------\n! Conditions like w(A)=fix, w(phase#set,A)=fix\n! B=fix and B(A)=fix treated above as they have a \"simple\" summation, \n! We must sum over all phases and constituents for the normallizing factor\n! definition: W(A)=B(A)/B; \n! derivative: dW(A)=dB(A)/B - B(A)/N**2 *dB\n! sum dB(A) and dB at the same time and multiply the sums with 1/B\n! and -B(A)/B**2 in the end.\n if(cmix(3).eq.0) then\n write(*,*)'Condition BW=fix is illegal'\n gx%bmperr=4208; goto 1000\n elseif(cmix(4).eq.0) then\n! condition is x(A)=fix\n sel=cmix(3); sph=0\n else\n sel=cmix(5); sph=cmix(3); scs=cmix(4)\n endif\n if(.not.allocated(xxmm)) then\n! this call returns the current fractions and total amounts. We need\n! to do it only once inside this subroutine. xxmm are deallocated at exit\n allocate(xxmm(meqrec%nrel),stat=errall)\n allocate(wwnn(meqrec%nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 35: ',errall\n gx%bmperr=4370; goto 1000\n endif\n calcmolmass=.FALSE.\n endif\n if(.not.calcmolmass) then\n call calc_molmass(xxmm,wwnn,totalmol,totalmass,ceq)\n if(gx%bmperr.ne.0) goto 1000\n calcmolmass=.TRUE.\n endif\n! write(*,267)'wwnn: ',(wwnn(ncol),ncol=1,noel())\n! write(*,267)'xxmm: ',(xxmm(ncol),ncol=1,noel())\n! two summations, zcol sums the term dN(A); xcol sums dN (as above)\n allocate(xcol(nz2),stat=errall)\n allocate(zcol(nz2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 36: ',errall\n gx%bmperr=4370; goto 1000\n endif\n xcol=zero\n zcol=zero\n totam=zero\n zval=zero\n xval=zero\n notf=0\n! wallph: do jph=1,meqrec%nstph\n! jj=meqrec%stphl(jph)\n! sum over all phases to handle conditions like x(phase#set,A)=fix\n! as the phase#set may not be stable\n wallph: do jj=1,meqrec%nphase\n pmi=>phr(jj)\n if(sph.eq.0) then\n! skip this phase if not stable and condition not on a specific phase\n if(phr(jj)%stable.eq.0) cycle wallph\n pham=pmi%curd%amfu\n elseif(sph.gt.0) then\n! condition on a composition of a phase\n if(phr(jj)%iph.ne.sph .or. &\n phr(jj)%ics.ne.scs) cycle wallph\n! We need the phase comoposition\n call calc_phase_molmass(sph,scs,xxmm,wwnn,&\n totalmol,totalmass,amount,ceq)\n pham=one\n! totalmol=one\n totalmass=one\n endif\n! pmi=>phr(jj)\n! amount formula units of phase, set above\n! pham=pmi%curd%amfu\n if(pmi%phasestatus.ne.PHFIXED) notf=notf+1\n wallel: do ie=1,meqrec%nrel\n! calculate a term for each column to be multiplied with chemical potential\n! we must sum xcol for all elemenets and add to zcol for element sel\n! if sel=/=0 then we sum also zcol(sel) for all phases\n if(nosave) then\n call calc_dgdyterms1(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits)\n else\n call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,&\n mamu,mag,mat,map,pmi,meqrec%noofits)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Calculated dgdyterms 4: ',mat\n ncol=1\n! BUG TROUBLE WITH MIXED FIX CHEMICAL POT AND MASS FRACTION CONDITION !!!\n wloop2: do je=1,meqrec%nrel\n! Calculate one column for each component to be multiplied with chem.pot.\n! components with fix chemical potential added to rhs, do not increment ncol!!!\n! modified in accordance with condition on x\n do ke=1,meqrec%nfixmu\n if(meqrec%mufixel(ke).eq.je) then\n! write(*,98)'fix mu w:',sel,je,&\n! pham*mamu(je),meqrec%mufixval(ke),mass_of(ie,ceq)\n98 format(a,2i3,6f12.4)\n xcol(nz2)=xcol(nz2)+&\n pham*mamu(je)*meqrec%mufixval(ke)*mass_of(ie,ceq)\n if(ie.eq.sel) then\n! write(*,98)'fix mu u:',sel,ie,&\n! pham*mamu(je),meqrec%mufixval(ke),&\n! mass_of(ie,ceq)\n! VERY STRANGE ... zcol and xcol have both the term added here but\n! when calculating with mole frac and fix chem.pot they have different signs!!!\n zcol(nz2)=zcol(nz2)+&\n pham*mamu(je)*meqrec%mufixval(ke)*&\n mass_of(ie,ceq)\n endif\n cycle wloop2\n endif\n enddo\n! mamu(B) = \\sum_i \\sum_j dM^a_B/dy_i dM^a_A z^a_ij\n xcol(ncol)=xcol(ncol)-pham*mamu(je)*mass_of(ie,ceq)\n if(sel.eq.ie) then\n zcol(ncol)=zcol(ncol)-pham*mamu(je)*mass_of(ie,ceq)\n endif\n! problem that this reurn whatever for 2nd and higher equilibria\n! write(*,*)'mass of: ',ie,mass_of(ie,ceq)\n ncol=ncol+1\n enddo wloop2\n! If T or P are variable\n if(tcol.gt.0) then\n xcol(tcol)=xcol(tcol)+pham*mat*mass_of(ie,ceq)\n if(sel.eq.ie) then\n zcol(tcol)=zcol(tcol)+pham*mat*mass_of(ie,ceq)\n endif\n! write(*,363)'d2G/dTdy 5: ',nrow-1,ie,tcol,&\n! xxx,xcol(tcol),pham,mat\n endif\n if(pcol.gt.0) then\n xcol(pcol)=xcol(pcol)+pham*map*mass_of(ie,ceq)\n if(sel.eq.ie) then\n zcol(pcol)=zcol(pcol)+pham*map*mass_of(ie,ceq)\n endif\n endif\n! last columns are amounts of element ie for all stable non-fix phase,\n if(pmi%phasestatus.ne.PHFIXED) then\n if(sph.eq.0) then\n! all phases with variable amount, sum over all components\n xcol(dncol+notf)=xcol(dncol+notf)+&\n pmi%xmol(ie)*mass_of(ie,ceq)\n if(ie.eq.sel) then\n zcol(dncol+notf)=zcol(dncol+notf)+&\n pmi%xmol(ie)*mass_of(ie,ceq)\n endif\n! else\n! no coefficint for phase amount if phase specific composition!!\n endif\n endif\n! right hand side (rhs) contribution is\n! - NP(phase)*\\sum_i \\sum_j dM(ie)/dy_i * dG/dy_j * z_ij * mass_ie\n xcol(nz2)=xcol(nz2)-pham*mag*mass_of(ie,ceq)\n if(sel.eq.ie) then\n zcol(nz2)=zcol(nz2)-pham*mag*mass_of(ie,ceq)\n endif\n enddo wallel\n! totam never used ???\n if(sel.gt.0) then\n totam=totam+pham*pmi%xmol(sel)*mass_of(sel,ceq)\n else\n totam=totam+pham*pmi%sumwmol\n endif\n! UNFINISHED: if sph=/=0 next line must be changed\n! zval=zval+pham*pmi%xmol(sel)*mass_of(sel,ceq)\n enddo wallph\n! in xcol is dB and in zcol dB(A) summed over all phases and components\n! calculate the normallized values now\n! xmat=dB(A)/B - B(A)*dB/B**2\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM too many equations 12B',nrow,nz1\n gx%bmperr=4209; goto 1000\n endif\n! write(*,97)'Totalmass W: ',sel,wwnn(sel),cvalue,totalmass,totam\n! copy to smat row nrow. totalmass=1 if phase specific composition\n do ncol=1,nz2\n smat(nrow,ncol)=(zcol(ncol)-xcol(ncol)*wwnn(sel))/totalmass\n enddo\n! add W^prescribed - W^current to rhs (right hand side)\n smat(nrow,nz2)=smat(nrow,nz2)-cvalue+wwnn(sel)\n deallocate(xcol)\n deallocate(zcol)\n! check on convergence\n! write(*,266)'massbalance condition w(A): ',sel,cvalue,wwnn(sel)\n if(abs(wwnn(sel)-cvalue).gt.ceq%xconv) then\n if(converged.lt.5) then\n converged=5\n! write(*,*)'8: converged=5',cerr%nvs\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=5\n cerr%val(cerr%nvs)=wwnn(sel)\n cerr%dif(cerr%nvs)=wwnn(sel)-cvalue\n endif\n! write(*,*)'8B: converged=5',cerr%nvs\n endif\n! write(*,266)'Unconverged condition w(A): ',sel,cvalue,wwnn(sel)\n266 format(a,i3,3(1pe14.6))\n! write(*,267)'wwnn: ',(wwnn(ncol),ncol=1,noel())\n! write(*,267)'xxmm: ',(xxmm(ncol),ncol=1,noel())\n!267 format(a,8F9.5)\n endif\n! if(sph.eq.0) then\n! write(*,363)'Condition w(A)=fix',sel,0,0,cvalue,wwnn(sel)\n! else\n! this is not implemented yet\n! write(*,363)'Condition w(phase#set,A)=fix',sph,sel,0,cvalue,zval\n! endif\n endif\n! finished conditions on B and W with indices\n if(allocated(xxmm)) then\n deallocate(xxmm)\n deallocate(wwnn)\n endif\n!\n!------------------------------------------------------------------\n case(13) ! Y ycond\n! Constituent fraction: phase#set, (subl.,) constituent index (over all subl)\n! NOTE differences also interesting y(B2,A)-y(B2,A#2) is 2nd order transf\n! nterms is number of terms, mterms=1 here\n moffs=3\n! write(*,*)'MM stvix, mterms & nterms: ',stvix,mterms,nterms,nz2\n! xcol not needed as we have no sums over several phases\n! allocate(xcol(nz2))\n! xcol=zero\n! we do not use calc_dgdyterms as we have a single constituent yindex\n! call calc_dgdyterms1X(meqrec%nrel,ie,meqrec%tpindep,&\n! mamu,mag,mat,map,pmi,meqrec%noofits)\n! mamu is an array, normally set to zero in calc_dgdyterms\n! also mag, mat and map\n mamu=zero\n mag=zero\n mat=zero\n map=zero\n dvalue=zero\n! this is executed for each iteration, this value must be set earlier\n! deltaTycond=2.5d1\n yterms: do mterms=1,nterms\n! loop for all terms in constion, we may have y_i-y_j =fix\n! cmix(3,4,5,6) are for first term, cmix(7,8,9,10) for second etc\n! for each term ccf(1..5) gives the factor in front of y\n! constituent is cmix(3) (sequental for all sublattices?)\n! write(*,*)'MM phase and compset :',cmix(moffs),cmix(moffs+1)\n! write(*,'(a,i3,2(1pe12.4))')'MM constituent & value :',&\n! cmix(moffs+2),cvalue,ccf(mterms)\n! cmix(moffs+4) NOT USED \n sph=cmix(moffs); scs=cmix(moffs+1)\n yindex=cmix(moffs+2)\n findphase: do jj=1,meqrec%nphase\n! phase with y condition may not be stable ... loop for all phases\n! write(*,*)'MM phase: ',meqrec%nphase,jj,phr(jj)%iph\n if(phr(jj)%iph.ne.sph .or. phr(jj)%ics.ne.scs) cycle findphase\n pmi=>phr(jj)\n! write(*,*)'MM found phase: ',jj,yindex,phr(jj)%curd%yfr(yindex)\n! The equation is \\Delta y_i = yknown (or \\Delta y_i - \\Delta y_j = dyknown)\n! we should set up a row where index \"i\" is known constituent\n! \\sum_A \\sum_k dM_A/dy_i e_ik \\mu_A + \\sum_k d2G/dy_i dT e_ik \\Delta T = \n! \\sum_k dG/dy_i e_ik +ycurr - yknown\n! where e_ij is the inverted phase matrix\n! The values of the constituent fractions must be set before calculating e_ij\n! this requires some new indicator in meq_onephase\n! IF the condition is a difference y_i-y_j=a it will be assumed y_i is correct\n! at the start of the calculation and we set y_j=y_i-a before each iteration\n yallel: do ie=1,meqrec%nrel\n cib=zero\n! write(*,333)'MM dy: ',(pmi%dxmol(ie,jy),jy=1,pmi%ncc)\n333 format(a,10(1pe12.4))\n do jy=1,pmi%ncc\n! \\sum_A \\sum_k e_ik dM_A/dy_k\n! suck the formula below does not work unless y_i correct, suck\n cib=cib+pmi%invmat(jy,yindex)*pmi%dxmol(ie,jy)\n! write(*,'(a,i3,3(1pe12.4))')'MM cib 1: ',jy,cib,&\n! pmi%invmat(jy,yindex),pmi%dxmol(ie,jy)\n enddo\n mamu(ie)=mamu(ie)+ccf(mterms)*cib\n! write(*,*)'MM mamu: ',ie,mamu(ie),cib\n enddo yallel\n cib=zero\n do jy=1,pmi%ncc\n! \\sum_k e_ik dG/dy_k\n cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(1,jy,1)\n! write(*,'(a,i3,3(1pe12.4))')'MM cib 2: ',jy,cib,&\n! pmi%invmat(jy,yindex),pmi%curd%dgval(1,jy,1)\n enddo\n! WoW it works with correct signs! Note: y_presc - y_calc!!!\n dvalue=-ccf(mterms)*pmi%curd%yfr(yindex)\n mag=mag+ccf(mterms)*(cib-pmi%curd%yfr(yindex))\n! write(*,373)'MM mag: ',mag,cib,&\n! ccf(mterms),-pmi%curd%yfr(yindex),cvalue\n if(meqrec%tpindep(1)) then\n! failed attempt to improve convergence\n! ycondTlimit=.true.\n! add coefficient for Delta T\n cib=zero\n do jy=1,pmi%ncc\n! + \\sum_k e_ik d2G/dTdy_ik \\Delta T \n cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(2,jy,1)\n! OR: + \\sum_k e_ik d2G/dTdy_i \\Delta T \n! I have not tested eithor of these\n! cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(2,yindex,1)\n enddo\n! When T is variable with y condition one must restrict change in T !!!\n mat=mat+ccf(mterms)*cib\n endif\n! write(*,'(a,i2,6(1pe12.4))')'MM mat: ',mterms,&\n! ceq%tpval(1),dvalue+cvalue,ccf(mterms),mat,cib\n if(meqrec%tpindep(2)) then\n! add coefficient for Delta P\n cib=zero\n do jy=1,pmi%ncc\n! + \\sum_k e_ik d2G/dPdy_i \\Delta P\n! I have not tested this\n cib=cib+pmi%invmat(jy,yindex)*pmi%curd%dgval(3,jy,1)\n enddo\n map=map+ccf(mterms)*cib\n endif\n exit findphase\n enddo findphase\n! finished this term, any more?\n moffs=moffs+4\n enddo yterms\n! add the prescribed value\n mag=mag+cvalue\n! dvalue is the current value which should become cvalue at equilibrium\n dvalue=dvalue+cvalue\n! write(*,373)'MM mamu: ',mat,map,mag,mamu\n! write(*,*)'MM nrow mm: ',nrow,nz1,nz2\n373 format(a,10(1pe12.4))\n!-------------------\n nrow=nrow+1\n if(nrow.gt.nz1) then\n write(*,*)'MM Too many equations 13'\n gx%bmperr=4209; goto 1000\n endif\n! now mamu(1..nrel) are the coefficients for \\mu; mat&map is coeff for Delta T&P\n! assuming no activity conditionw ...\n do jj=1,meqrec%nrel\n smat(nrow,jj)=mamu(jj)\n enddo\n! after exiting loop jj=meqrec%nrel+1\n if(meqrec%tpindep(1)) then\n! Failed attempt to improve convergence\n! smat(nrow,jj)=-5.0D0*mat\n smat(nrow,jj)=-mat\n jj=jj+1\n endif\n if(meqrec%tpindep(2)) then\n smat(nrow,jj)=-map\n jj=jj+1\n endif\n! mag is right hand side including y-y\n smat(nrow,nz2)=mag\n! write(*,'(a,i2,6(1pe12.4))')'MM *** ycond:',nrow,(smat(nrow,jj),jj=1,nz2)\n! gx%bmperr=4207; goto 1000\n! \n end select\n!\n! loop if not the last condition\n! write(*,*)'Taking next condition',cmix(1)\n if(.not.associated(condition,lastcond)) goto 350\n!=====================================================================\n380 continue\n! write whole smat\n! used to find ycond ....\n! do jj=1,nz1\n! write(*,390)jj,(smat(jj,jy),jy=1,nz2)\n! enddo\n390 format('#:',i2,6(1pe12.4),6(4x,1pe12.4))\n1000 continue\n! we must ?? deallocate all data in the savedrec\n! if(allocated(savedrec%save1)) then\n! jj=size(saved%save1)\n! deallocate(savedrec%save1)\n! write(*,*)'MM deallocated saved%save1',jj\n! endif\n! if(allocated(savedrec%save2)) deallocate(savedrec%save2)\n! if(allocated(savedrec%save3)) deallocate(savedrec%save3)\n! if(allocated(savedrec%save4)) deallocate(savedrec%save4)\n! if(allocated(savedrec%save5)) deallocate(savedrec%save5)\n return\n end subroutine setup_equilmatrix\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_onephase\n!\\begin{verbatim}\n subroutine meq_onephase(meqrec,pmi,ceq)\n! this subroutine calculates new constituent fractions for a phase iph+ics\n! with given T, P and chemical potentials for the components \n! For ionic liquids the sites on the sublattices varies with composition\n! THIS IS A FIRST VERSION WITHOUT ANY TRICKS FOR SPEED\n! this will check if EEC set and modify G for solid phases with higher entropy\n! pmi is pointer to a record in meq_phase, local to this thread\n! than the liquid\n implicit none\n TYPE(meq_phase), pointer :: pmi\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(meq_setup) :: meqrec\n!\\end{verbatim}\n integer nrel,i2sly(2),info\n integer ik,iph,ics,jz,iz,jk,ierr,kk,kkk,ll,lokcs,ncc,loksp,ncl\n! integer nd1,nd2,neq,nochange,nsl,nspel,nv,ncon,icon,jxsym,kxsym\n integer nd1,nd2,neq,nochange,nsl,nspel,nv,ncon,icon,jxsym,errall\n! needed for call to get_phase_data\n integer, dimension(maxsubl) :: nkl\n integer, dimension(maxconst) :: knr\n double precision, dimension(5) :: qq\n double precision, dimension(maxsubl) :: sites\n! needed for call to get_species_data\n integer, dimension(maxspel) :: ielno\n double precision, dimension(maxspel) :: stoi\n! testing lapacl+blas inverting symmetric matrix\n double precision, allocatable, dimension(:) :: lapack\n double precision xxxx,yyyy\n! minimal y, charge\n double precision, parameter :: ymin=1.0D-12,ymingas=1.0D-30,qeps=1.0D-30\n! derivative of moles of component wrt y_ks\n double precision, dimension(maxel) :: addmol\n! for mass balance and charge\n double precision, dimension(maxconst) :: yarr,dqsum\n! phase matrix, its inverse is returned as part of pmi\n double precision, dimension(:,:), allocatable :: pmat\n double precision qsp,sumsit,ykvot,ysum,qsum,spmass,yva,fion\n double precision, dimension(:,:), allocatable :: sumion\n character name*24\n! logical nolapack\n! write(*,'(a,5i5)')'in meq_onephase: ',ceq%eqno,&\n! pmi%iph,pmi%ics,meqrec%noofits\n! set eecextrapol to TRUE when entering, \n! set to FALSE inside check_eec if phase has higher entropy than liquid\n! I am no longer sure this is needed??\n! eecextrapol=.TRUE.\n! Maybe nolapack be removed??\n! nolapack=.TRUE.\n! nolapack=.FALSE.\n iph=pmi%iph\n ics=pmi%ics\n nrel=meqrec%nrel\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 10: ',iph,ics\n! for each phase \"pmi\" set eeccheck=0 at first interation\n! THIS IS CURRNTLY NOT USED, will be added later\n if(meqrec%noofits.eq.1) then\n pmi%eeccheck=0\n elseif(meqrec%tpindep(1).or.meqrec%tpindep(2)) then\n! if T or P not conditions set eeccheck=0 at each iteration\n pmi%eeccheck=0\n endif\n! extract phase structure\n! write(*,*)'MM calling get_phase_data: ',iph\n! if(mmdebug.ne.0) then\n! write(*,*)'MM meq_onephase 12: ',iph,ics\n! gtpdebug=1\n! endif\n! get_phase_data modified to ignore nonexisting composition sets\n call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq)\n! if(mmdebug.ne.0) then\n! write(*,*)'MM meq_onephase 13: ',iph,ics,nsl,gx%bmperr\n! gtpdebug=0\n! endif\n! write(*,*)'MM back from get_phase_data',gx%bmperr\n if(gx%bmperr.ne.0) then\n! handling of parallel by openMP\n!$ if(.TRUE.) then\n! this is written if parallel\n!$ write(*,7)'get_phase_data error in meq_onephase: ',iph,ics,&\n!$ omp_get_thread_num(),gx%bmperr\n!$ else\n! this is written if not parallel\n write(*,7)'get_phase_data error in meq_onephase: ',iph,ics,gx%bmperr\n!$ endif\n7 format(a,2i3,2x,2i5)\n goto 1000\n endif\n! make sure all fractions >ymin and sums in all sublattices are equal to unity\n nochange=0\n ncc=0\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 20: ',nsl,ncc\n do ll=1,nsl\n ysum=zero\n ncl=ncc\n do ik=1,nkl(ll)\n ncc=ncc+1\n if(yarr(ncc).lt.ymin) then\n if(test_phase_status_bit(iph,PHGAS)) then\n if(yarr(ncc).lt.ymingas) then\n yarr(ncc)=ymingas\n nochange=1\n endif\n else\n nochange=1\n yarr(ncc)=ymin\n endif\n endif\n ysum=ysum+yarr(ncc)\n enddo\n ykvot=one/ysum\n if(abs(ykvot-one).gt.ymingas) then\n nochange=1\n do ik=1,nkl(ll)\n yarr(ncl+ik)=yarr(ncl+ik)*ykvot\n enddo\n endif\n enddo\n if(nochange.ne.0) then\n! if constitution changed save it. qq will be updated automatically\n! write(*,*)'MM calling set_constitution 2:',ceq%eqno,iph,ics\n call set_constitution(iph,ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'MM never error 17',iph,ics\n! output if compiled with OpenMP\n!$ write(*,*)'Thread :',ceq%eqname,omp_get_thread_num(),gx%bmperr\n goto 1000\n endif\n endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 30: '\n if(test_phase_status_bit(iph,PHEXCB)) then\n! If external charge balance phase matrix has one more line+column\n pmi%chargebal=1\n nd1=ncc+1\n! pmi%charge=qq(2)\n pmi%curd%netcharge=qq(2)\n! if(qq(2).gt.1.0D-8) write(*,*)'Charge: ',iph,ics,qq(2)\n else\n pmi%chargebal=0\n nd1=ncc\n! pmi%charge=zero\n pmi%curd%netcharge=zero\n endif\n!--------------------------\n! sublattice rows, nd2=nd1+1 because I use Lukas matrix inverter\n nd1=nd1+nsl\n nd2=nd1+1\n! write(*,*)'MM meq_onephase: allocate pmat',allocated(pmat)\n! Allocate phase matrix, one extra dimension if external charge balance\n! last column of pmat is left hand side ?? (reminicent from Lukas program)\n! allocate(pmat(nd1,nd2))\n! pmat should be a square matrix\n allocate(pmat(nd1,nd1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 37: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! return dimension of pmi%invmat\n if(pmi%idim.eq.0) then\n pmi%idim=nd1\n pmi%ncc=ncc\n allocate(pmi%invmat(nd1,nd1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 38: ',errall\n gx%bmperr=4370; goto 1000\n endif\n pmi%invmat=zero\n! write(*,*)'Allocated invmat: ',nd1,ncc\n! meqrec is not available in this routine ?? but meqrec%nrel passed in call\n allocate(pmi%xmol(nrel),stat=errall)\n allocate(pmi%dxmol(nrel,ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 39: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! write(*,*)'Allocated phase matrix: ',nd2,noel(),ncc\n endif\n! value of RT should be moved before phase loop\n ceq%rtn=globaldata%rgas*ceq%tpval(1)\n!--------------------------------------------------\n! now treat different phase types\n call get_phase_variance(iph,nv)\n! write(*,*)'MM phase variance: ',nv\n nvzero: if(nv.eq.0) then\n!------------------------------------- stoichiometric phase, fixed composition\n! For stoichiometric phases calculate just G with T and P derivatives\n! and driving force. All pmi%dxmol=zero but one must also calculate \n! pmi%xmol and save it for all future iterations\n! It must also be saved in curd%abnorm(1) ?? done in set_constitution ??\n! write(*,*)'MM xdone: ',pmi%xdone,iph,nv\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 40: '\n if(pmi%xdone.eq.1) goto 90\n! we must call set_constitution once to have correct abnorm etc\n! write(*,*)'MM calling set_constitution 3: ',iph,ics\n call set_constitution(iph,ics,yarr,qq,ceq)\n qsum=zero\n dqsum=zero\n pmi%xmol=zero\n pmi%dxmol=zero\n pmi%sumxmol=zero\n pmi%sumwmol=zero\n sumsit=zero\n do ll=1,nsl\n sumsit=sumsit+sites(ll)\n enddo\n kkk=0\n sublatt: do ll=1,nsl\n allconst: do ik=1,nkl(ll)\n kkk=kkk+1\n loksp=knr(kkk)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra)\n call get_species_component_data(loksp,nspel,ielno,&\n stoi,spmass,qsp,ceq)\n if(gx%bmperr.ne.0) goto 1000\n addmol=zero\n do jz=1,nspel\n addmol(jz)=stoi(jz)\n enddo\n dqsum(kkk)=qsp\n! 160820: forgotten to multiply with site ratio??!!\n qsum=qsum+sites(ll)*qsp\n do jz=1,nspel\n if(ielno(jz).gt.0) then\n! ignore vacancies, taken care of by using sumsit=qq(1) above\n pmi%dxmol(ielno(jz),kkk)=zero\n pmi%xmol(ielno(jz))=pmi%xmol(ielno(jz))+&\n sites(ll)*addmol(jz)\n endif\n enddo\n enddo allconst\n enddo sublatt\n! if(qsum.ne.zero) then\n if(abs(qsum).gt.1.0D-14) then\n! if qsum not zero this phase should be suspended as it cannot be stable\n write(*,88)'Stoichiometric phase with net charge: ',iph,ics,qsum\n88 format(a,2i4,2(1pe12.4))\n endif\n! meqrec is not available in this routine ??\n do iz=1,nrel\n pmi%sumxmol=pmi%sumxmol+pmi%xmol(iz)\n pmi%sumwmol=pmi%sumwmol+pmi%xmol(iz)*mass_of(iz,ceq)\n enddo\n! phase_varres(lokcs)%abnorm already set by set_constitution\n pmi%xdone=1\n!\n90 continue\n! lokcs is set inside this subroutine\n call calcg(iph,ics,2,lokcs,ceq)\n if (gx%bmperr.ne.0) then\n! write(*,91)'calcg error in meq_onephase ',iph,gx%bmperr,ceq%eqno\n91 format(a,3i5)\n goto 1000\n endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 45: '\n eec1: if(globaldata%sysreal(1).gt.one) then\n! EEC check for stoichiometric phases\n! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P\n yyyy=zero\n if(associated(meqrec%pmiliq)) then\n! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!!\n! write(*,*)'MM eec1A: DS',meqrec%seecliq,&\n! pmi%curd%gval(2,1)/pmi%curd%abnorm(1)\n if(pmi%curd%gval(2,1)/pmi%curd%abnorm(1).lt.meqrec%seecliq) then\n! too high entropy, set G=1.0 (avoid 0.0 ...)\n yyyy=pmi%curd%gval(1,1)\n pmi%curd%gval(1,1)=one\n! write(*,*)'MM eec1B: new G:',pmi%curd%gval(1,1),yyyy\n endif\n else\n! write(*,*)'MM eec1 No liquid entropy for stoichiometric phase!'\n endif\n endif eec1\n! set the inverted phase matrix to zero !!!\n pmi%invmat=zero\n! do ik=1,ncc\n! pmi%invmat(ik,ik)=one\n! enddo\n! maybe some common ending\n goto 900\n endif nvzero\n!--------------------------------------------- zero some arrays, ideal phase\n pmi%xmol=zero\n pmi%dxmol=zero\n pmi%sumxmol=zero\n pmi%sumwmol=zero\n pmi%xdone=-1\n! if(phase_model(iph,ics,PHID,ceq)) then\n! write(*,*)'MM test ideal: ',test_phase_status_bit(iph,PHID)\n ideal: if(test_phase_status_bit(iph,PHID)) then\n!--------------------------------------------- ideal phase (subst, no excess)\n! write(*,*)'Phase is ideal'\n if(test_phase_status_bit(iph,PHLIQ)) then\n! write(*,*)'MM liquid ideal: ',pmi%iph,pmi%ics\n meqrec%pmiliq=>pmi\n endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 50: ideal'\n! special treatment of ideal phase (gas), sites assumed to be unity\n! 1. Calculate M_i and dM_i/dy^s_k and the net charge charge Q and dQ/dy^s_k\n pmi%xmol=zero\n pmi%dxmol=zero\n qsum=zero\n dqsum=zero\n ncon=0\n do ik=1,nkl(1)\n loksp=knr(ik)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,spmass,&\n qsp,ceq)\n if(gx%bmperr.ne.0) goto 1000\n addmol=zero\n do jk=1,nspel\n addmol(jk)=stoi(jk)\n enddo\n dqsum(ik)=qsp\n qsum=qsum+qsp*yarr(ik)\n! It seems dxmol(element,constituent) is equal to the stoichiometry\n! i.e. for a molecule H2O dM_H/dy_H2O=2; dM_O/dy_H2O=1, not 2/3 and 1/3\n do jk=1,nspel\n if(ielno(jk).ne.0) then\n pmi%dxmol(ielno(jk),ik)=addmol(jk)\n pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+addmol(jk)*yarr(ik)\n! else\n! bug discovered 2024: substitutional Va means ielno(jk) is 0\n! write(*,*)'Matsmin line 5891: Vacancies have no amount'\n! continue\n endif\n enddo\n ncon=ncon+1\n enddo\n! meqrec is not available in this routine ??\n do ik=1,nrel\n pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik)\n! write(*,*)'sumwmol 2: ',pmi%xmol(ik),mass_of(ik,ceq)\n pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq)\n enddo\n! now calculate G and all 1st and 2nd derivatives\n! This can be speeded up as all 2nd derivatives of constituents are RT/y\n! The calculated values are used also in other parts of the code \n call calcg(iph,ics,2,lokcs,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'MM Error calculating phase',iph,ics,gx%bmperr\n goto 1000\n endif\n eec2: if(globaldata%sysreal(1).gt.one) then\n! EEC check for ideal phases except gas\n! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P\n xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1)\n if(test_phase_status_bit(iph,PHLIQ)) then\n if(associated(meqrec%pmiliq)) then\n! this is a second liquid\n if(xxxx.lt.meqrec%seecliq) then\n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n else\n! this is the first (or maybe only) liquid composition set\n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n elseif(.not.test_phase_status_bit(iph,PHGAS)) then\n if(associated(meqrec%pmiliq)) then\n! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!!\n if(xxxx.lt.meqrec%seecliq) then\n! G is set to -RT*ideal entropy/RT\n! write(*,*)'MM eec2A: ',pmi%curd%gval(1,1)\n pmi%curd%gval(1,1)=-pmi%curd%gval(2,1)\n! no need to set other derivatives\n endif\n else\n write(*,*)'MM eec2 no liquid entropy to test!'\n endif\n endif\n! write(*,*)'MM eec2B: ',pmi%curd%gval(1,1)\n endif eec2\n! calculate phase matrix elements\n! temporarely ignore that the phase matrix is symmetric\n! ceq%phase_varres(lokcs)%...\n! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P\n! dgval(1,1:N,1) are first derivatives of G wrt constituent 1:N\n! dgval(2,1:N,1) are second derivatives of G wrt constituent 1:N and T\n! dgval(3,1:N,1) are second derivatives of G wrt constituent 1:N and P\n! d2gval(ixsym(N*(N+1)/2),1) are 2nd derivatives of G wrt constituents N and M\n! Last index is other properties than G like TC, BMAGN etc.\n! if(.not.nolapack) then\n! if(pmi%chargebal.eq.1) then\n! neq=ncon+ll+1\n! allocate(lapack(neq*(neq+1)/2))\n! else\n! neq=ncon+ll\n! allocate(lapack(neq*(neq+1)/2))\n! endif\n! lapack=zero\n! endif\n pmat=zero\n! this is for an ideal phase with no excess\n do ik=1,nkl(1)\n do jk=ik,nkl(1)\n! ll=ixsym(ik,jk)\n ll=kxsym(ik,jk)\n pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ll,1)\n if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk)\n! if(.not.nolapack) lapack(ll)=ceq%phase_varres(lokcs)%d2gval(ll,1)\n enddo\n enddo\n neq=nkl(1)\n! write(*,770)(yarr(ik),ik=1,nkl(1))\n!770 format('yfrac: ',4(1pe16.8))\n! add one column and row for each sublattice (here only one)\n neq=neq+1\n do jk=1,neq-1\n pmat(jk,neq)=one\n pmat(neq,jk)=one\n enddo\n if(pmi%chargebal.eq.1) then\n! if external charge balance add one column and one row\n neq=neq+1\n do jk=1,nkl(1)\n! this is the row\n pmat(jk,neq)=dqsum(jk)\n! this is the column\n pmat(neq,jk)=dqsum(jk)\n enddo\n endif\n! invert the phase matrix (faster routine should be used) IDEAL PHASE\n! removed second argument\n! call mdinv(nd1,nd2,pmat,pmi%invmat,neq,ierr)\n call mdinv(nd1,pmat,pmi%invmat,neq,ierr)\n if(ierr.eq.0) then\n write(*,*)'MM Numeric problem 1, phase/set: ',iph,ics\n write(*,*)'Phase matrix singular 1:',pmi%iph,pmi%ics,pmi%ncc,ierr\n do jk=1,neq\n write(*,73)(pmat(ik,jk),ik=1,neq)\n enddo\n73 format(1x,6(1pe12.4))\n gx%bmperr=4205; goto 1000\n endif\n goto 900\n endif ideal\n!---------------------------------------------- no analytical 2nd derivatives\n! phases with models with no analytical second derivatives ....\n! if(phase_model(iph,ics,PHNODGDY2,ceq)) then\n! if(test_phase_status_bit(iph,PHNODGDY2,ceq)) then\n if(test_phase_status_bit(iph,PHNODGDY2)) then\n! write(*,*)'Models without 2nd derivatives not implemented'\n gx%bmperr=4206; goto 1000\n endif\n!----------------------------------------------- ionic liquid phase\n! write(*,*)'MM test I2SL: ',test_phase_status_bit(iph,PHIONLIQ)\n ionliq: if(test_phase_status_bit(iph,PHIONLIQ)) then\n! write(*,*)'Warning; ionic liquid model not fully implemented'\n! Calculate M_A and dM_A/dy_i taking into account that P and Q varies \n! call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq)\n if(test_phase_status_bit(iph,PHLIQ)) then\n meqrec%pmiliq=>pmi\n! write(*,*)'MM liquid ionic: ',pmi%iph,pmi%ics\n endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 55: '\n pmi%ionliq=nkl(1)\n pmi%xmol=zero\n pmi%dxmol=zero\n qsum=zero\n dqsum=zero\n pmi%sumxmol=zero\n pmi%sumwmol=zero\n allocate(sumion(nrel,2),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 40: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! pmi%sumiliq=zero\n! end extra\n ncon=0\n sumion=zero\n yva=zero\n! write(*,217)'y: ',ncc,(yarr(ik),ik=1,ncc)\n i2sly=nkl(1)+nkl(2)+1\n do ll=1,nsl\n do ik=1,nkl(ll)\n ncon=ncon+1\n loksp=knr(ncon)\n! pmi%ikon(ncon)=loksp\n! if only neutrals we can have a single wildcard in first sublattice ...\n if(loksp.lt.0) then\n if(ll.eq.1 .and. nkl(1).eq.1) cycle\n write(*,*)'Illegal wildcard constituent in ionic liquid'\n gx%bmperr=4197; goto 1000\n endif\n if(btest(pmi%curd%constat(ncon),CONVA)) then\n! This is the nypothetical vacancy .... its charge is sites(2) = Q\n yva=yarr(ncon)\n! save its index in isly(1), otherwise that is number of constit+1\n i2sly(1)=ncon\n! pmi%valency(ncon)=sites(2)\n! write(*,*)'Va: ',ncon,yva\n else\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,&\n spmass,qsp,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! i2sly is index of first neutral (if any) otherwise number of constit+1\n if(qsp.eq.zero .and. i2sly(2).gt.ncon) i2sly(2)=ncon\n! write(*,*)'Species: ',ncon,i2sly,qsp\n! if(qsp.eq.zero .and. i2sly(2).eq.0) i2sly(2)=ncon\n! pmi%valency(ncon)=abs(qsp)\n! write(*,*)'charge: ',ncon,qsp\n do jk=1,nspel\n notva: if(ielno(jk).gt.0) then\n! ignore vacancies in species\n qsp=sites(ll)*stoi(jk)\n pmi%dxmol(ielno(jk),ncon)=qsp\n pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+qsp*yarr(ncon)\n sumion(ielno(jk),ll)=sumion(ielno(jk),ll)+&\n stoi(jk)*yarr(ncon)\n! take into account that the site ratios depend on constitition in corrion_..\n! write(*,21)'ddMA:',jk,ielno(jk),ncon,ll,&\n! pmi%dxmol(ielno(jk),ncon),qsp,sites(ll),stoi(jk)\n!21 format(a,4i3,4(1pe12.4))\n! sums used in calc_dgdyterms1 to handle that sites(ll) depend on constitition\n! pmi%sumiliq(ielno(jk),ll)=pmi%sumiliq(ielno(jk),ll)+&\n! stoi(jk)*yarr(ncon)\n! Hm, the statement above not necessary as below it is already included ....\n endif notva\n enddo\n endif\n enddo\n enddo\n! save these as needed in calc_dgdyterms\n! i2sly(1) is index of vacancy, if no vacancy equal to #of constituents+1\n! i2sly(2) is index if first neutral, if no neutal equal to #of constituents+1\n pmi%i2sly=i2sly\n pmi%yva=yva\n! zero matrix\n pmat=zero\n!...........................................\n! goto 261\n! now handle that site ratios depend on constituent fractions\n! (maybe also that the formula unit depend on composition)\n! phlista(lokph)%i2slx; lokph=pmi%curd%phlink\n! BUT: phlista is private ....\n! M_A = P*M'_A + Q*M\"_A M'_A and M\"_A are in sumion(A,1:2))\n! P=\\sum_j (-v_j)y_j + Qy_Va j is anion\n! Q=\\sum_i v_iy_i i is cation\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 60: '\n icon=0\n do ik=1,nkl(1)\n icon=icon+1\n do jk=1,nrel\n! for cations: extra dM_A/dyi = v_i*y_Va*M'_A + v_i*M\"_A where i is cation\n qsp=pmi%curd%dpqdy(icon)*(yva*sumion(jk,1)+sumion(jk,2))\n! note dxmol(jk,icon) has been multiplied with sites(1) above ....\n pmi%dxmol(jk,icon)=pmi%dxmol(jk,icon)+qsp\n enddo\n enddo\n! i2sly(1) is index of vacancy, i2sly(2) index of first neutral\n! If no vacancy or no neutral the corresponding i2sly is ncc+1\n do ik=1,nkl(2)\n icon=icon+1\n if(icon.lt.min(i2sly(1),i2sly(2))) then\n do jk=1,nrel\n! for anions: extra dM_A/dyj = (-v_j)*M'_A where j is anion\n qsp=pmi%curd%dpqdy(icon)*sumion(jk,1)\n pmi%dxmol(jk,icon)=pmi%dxmol(jk,icon)+qsp\n! write(*,654)'Extra term anjon: ',jk,icon,pmi%dxmol(jk,icon),qsp\n enddo\n else\n! note icon not updated correctly if neutrals, use ncon below\n exit\n endif\n enddo\n! take care of a vacancy\n if(icon.eq.i2sly(1)) then\n do jk=1,nrel\n! for Va: extra dM_A/dyi = Q*M'_A where i is vacancy\n pmi%dxmol(jk,icon)=sites(2)*sumion(jk,1)\n! write(*,654)'Extra term for Va: ',jk,icon,&\n! pmi%dxmol(jk,icon),sites(2)*sumion(jk,1)\n enddo\n endif\n! Derivatives with respect to neutrals have no extra term\n! do jk=1,nrel\n! write(*,217)'dMA2:',jk,(pmi%dxmol(jk,ik),ik=1,ncc)\n! enddo\n! one may exit loop above with different values of ncon and icon, \n! ncon is the total number of constituents\n icon=ncon\n!......................................... end handling P and Q variation\n261 continue\n! meqrec is not available in this routine ??\n do ik=1,nrel\n pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik)\n pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq)\n enddo\n! now calculate G and all 1st and 2nd derivatives\n! The calculated values are used also in other parts of the code \n call calcg(iph,ics,2,lokcs,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'MM Error calculating G 1: ',iph,ics,lokcs\n goto 1000\n endif\n! correction of I2SL second derivatives due to variation of P and Q\n if(meqrec%noofits.gt.1) then\n! NOTE pmat is dimensioned pmat(nd1,nd2)\n call corriliq_d2gdyidyj(nkl,knr,ceq%cmuval,pmi,ncon,nd1,pmat,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n eec3: if(globaldata%sysreal(1).gt.one) then\n! EEC check for ionic liquid phase (no need to test for PHLIQ)\n! gval(1:6,1) are G, G.T, G.P, G.T.T, G.T.P, G.P.P\n xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1)\n if(associated(meqrec%pmiliq)) then\n! we already have a liquid \n if(xxxx.gt.meqrec%seecliq) then\n! this liquid has higher entropy \n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n else\n! save link to liquid with higest entropy\n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n! write(*,*)'MM eec3: ',meqrec%seecliq,associated(meqrec%pmiliq)\n endif eec3\n! write(*,17)'pots: ',(ceq%cmuval(ik),ik=1,3)\n! do ll=1,nd1\n! write(*,17)'cion: ',(pmat(ll,ik),ik=1,nd1)\n! enddo\n! calculate phase matrix elements, the second derivatives\n! note pmat has some contributions above ??\n neq=icon\n fion=one\n do ik=1,icon\n do jk=ik,icon\n pmat(ik,jk)=fion*pmat(ik,jk)+&\n ceq%phase_varres(lokcs)%d2gval(kxsym(ik,jk),1)\n! ceq%phase_varres(lokcs)%d2gval(ixsym(ik,jk),1)\n! remove next line when using a routine inverting a symmetric matrix\n if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk)\n enddo\n enddo\n! Then set the sublattice elements\n kk=0\n do ll=1,nsl\n do ik=1,nkl(ll)\n! set the sublattice columns and rows\n kk=kk+1\n pmat(kk,neq+ll)=one\n pmat(neq+ll,kk)=one\n enddo\n enddo\n neq=neq+nsl\n! write(*,65)'pdim: ',nd1,nd2,neq,ncon,icon,nsl,(nkl(ll),ll=1,nsl)\n!65 format(a,6i4,10i3)\n! do ll=1,nd1\n! write(*,17)'pmat: ',(pmat(ll,ik),ik=1,nd1)\n17 format(a,6(1pe12.4))\n! enddo\n! invert the phase matrix (faster routine should be used) IONIC LIQUID MODEL\n! call mdinv(nd1,nd2,pmat,pmi%invmat,nd1,ierr)\n! write(*,*)'Value 2 of nolapsck: ',nolapack,.not.nolapack\n! removed 2nd argument\n call mdinv(nd1,pmat,pmi%invmat,nd1,ierr)\n if(ierr.eq.0) then\n! write(*,*)'MM Numeric problem 2, phase/set: ',iph,ics\n write(*,*)'Phase matrix singular 2:',pmi%iph,pmi%ics,pmi%ncc,ierr\n gx%bmperr=4205; goto 1000\n endif\n! do ll=1,nd1\n! write(*,17)'pinv: ',(pmi%mat(ll,ik),ik=1,nd1)\n! enddo\n! maybe some common ending\n goto 900\n endif ionliq\n!------------------------------------------------- all other phase models (CEF)\n! For all other phases calculate G and all first and second derivatives\n! for current composition\n300 continue\n! write(*,*)'MM CEF phase?',ceq%eqno\n! Calculate M_i and dM_i/dy^s_k and the net charge charge Q and dQ/dy^s_k\n! call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq)\n! how to normalize xmol? use qq(1)!!, it handels vacancies .... ????\n! write(*,*)'MM Phase 1: ',pmi%iph,pmi%ics\n! if(test_phase_status_bit(iph,PHLIQ)) then\n! write(*,*)'MM liquid other: ',pmi%iph,pmi%ics\n! meqrec%pmiliq=>pmi\n! endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 70: '\n sumsit=one\n pmi%xmol=zero\n pmi%dxmol=zero\n qsum=zero\n dqsum=zero\n ncon=0\n pmi%sumxmol=zero\n pmi%sumwmol=zero\n subll: do ll=1,nsl\n constll: do ik=1,nkl(ll)\n ncon=ncon+1\n loksp=knr(ncon)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,spmass,qsp,ceq)\n if(gx%bmperr.ne.0) goto 1000\n addmol=zero\n do jk=1,nspel\n addmol(jk)=stoi(jk)\n enddo\n dqsum(ncon)=sites(ll)*qsp\n qsum=qsum+sites(ll)*qsp*yarr(ncon)\n do jk=1,nspel\n! write(*,963)'xmol: ',ncon,ik,jk,ielno(jk),sites(ll)\n!963 format(a,4i3,6(1pe12.4))\n if(ielno(jk).gt.0) then\n! ignore vacancies\n! addmol(jk) can be replaced by stoi(jk) when I know it works ....\n pmi%dxmol(ielno(jk),ncon)=sites(ll)*addmol(jk)\n pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+&\n sites(ll)*addmol(jk)*yarr(ncon)\n endif\n enddo\n enddo constll\n enddo subll\n! write(*,*)'MM segmentation fault test 1',nrel\n! meqrec is not available in this routine ??\n do ik=1,nrel\n pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik)\n! write(*,*)'sumwmol 3:',pmi%xmol(ik),mass_of(ik,ceq)\n pmi%sumwmol=pmi%sumwmol+pmi%xmol(ik)*mass_of(ik,ceq)\n enddo\n! write(*,*)'MM segmentation fault test 2'\n! write(*,92)'onephase 3: ',pmi%iph,nsl,pmi%xdone,pmi%sumxmol,qq(1)\n!92 format(a,3i3,6(1pe12.4))\n! write(*,17)'Vacanies: ',qq\n! do i=1,noel()\n! write(*,17)'xm: ',pmi%xmol(i)\n! write(*,17)'dxm: ',(pmi%dxmol(i,j),j=1,ncon)\n! enddo\n! now calculate G and all 1st and 2nd derivatives\n! The calculated values are stored and used also in other parts of the code \n! write(*,*)'MM segmentation fault test 3',iph,ics\n call calcg(iph,ics,2,lokcs,ceq)\n if(gx%bmperr.ne.0) then\n write(*,11)'MM Error calculating G 2: ',iph,ics,lokcs,gx%bmperr\n11 format(a,5i5)\n goto 1000\n endif\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase 80: '\n! write(*,*)'MM segmentation fault 10',globaldata%sysreal(1)\n eec4: if(globaldata%sysreal(1).gt.one) then\n! check of EEC for a CEF phase\n! if(pmi%eeccheck.eq.0) then\n! This is first iteration or we have variable T or P\n xxxx=pmi%curd%gval(2,1)/pmi%curd%abnorm(1)\n! write(*,*)'MM eec4A: ',meqrec%noofits,associated(meqrec%pmiliq)\n if(test_phase_status_bit(iph,PHLIQ)) then\n! This is a liquid phase\n if(associated(meqrec%pmiliq)) then\n! We have several liquids, take the highest entropy (note xxx is -entropy!)\n if(xxxx.lt.meqrec%seecliq) then\n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n! write(*,*)'MM eec4B: second liquid'\n else\n! this is the first (or maybe only) liquid composition set\n meqrec%pmiliq=>pmi\n meqrec%seecliq=xxxx\n endif\n! write(*,'(a,l2,5(1pe12.4))')'MM eec4C: liq:',&\n! associated(meqrec%pmiliq),meqrec%seecliq,&\n! pmi%curd%gval(2,1),pmi%curd%abnorm(1)\n elseif(.not.test_phase_status_bit(iph,PHGAS)) then\n! this is a condensed phase which should have its entropy checked\n! NOTE gval(2,1) is dG/dT i.e. the negative of entropy!!\n if(xxxx.lt.meqrec%seecliq) then\n! write(*,*)'MM eec4D S(solid)>S(liquid)',-xxxx,-meqrec%seecliq\n! replace G and all derivates with a phase with just configurational entropy\n! in the pmi%curd%gval, pmi%curd%dgval and pmi%curd%d2gval\n yyyy=pmi%curd%gval(1,1)\n call calc_eec_gibbsenergy(pmi%curd,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n endif\n! write(*,'(a,5(1pe12.4))')'MM eec4F: ',pmi%curd%gval(1,1),yyyy,&\n! -meqrec%seecliq,-xxxx\n! else\n! write(*,*)'MM no EEC'\n endif eec4\n! calculate phase matrix elements, first and second derivatives\n! write(*,*)'MM segmentation fault 19'\n pmat=zero\n neq=ncon\n! write(*,*)'MM segmentation fault 20'\n! here we are calculating CEF models\n do ik=1,ncon\n! OK jxsym=ixsym(ik,ik); kxsym=0\n jxsym=ixsym(ik,ik)\n do jk=ik,ncon\n! fatal parallel execution frequently here ... why?? Error message:\n! index '0' of dimension 1 of array 'ceq' below lower bound of 1\n! pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ixsym(ik,jk),1)\n! modified code:\n ll=kxsym(ik,jk)\n! ll=ixsym(ik,jk)\n! OK jxsym=jxsym+kxsym; kxsym=jk\n! increment jxsym at the end of the loop ...\n! testing replacing ixsym .... too complicated ...\n if(ll.ne.jxsym) then\n! write(*,*)'Problems: ',ik,jk,ll,jxsym\n stop \"Problemns with ixsym\"\n! else\n! write(*,*)'No problems: ',ik,jk,ll,jxsym,kxsym\n endif\n! attempt to avoid a crash\n!$ if(lokcs.le.0 .or. ll.le.0) then\n!$ write(*,491)'meq_onephase error: ',lokcs,ll,omp_get_thread_num()\n491 format(' *** ',a,4i5)\n!$ goto 1000\n!$ endif\n pmat(ik,jk)=ceq%phase_varres(lokcs)%d2gval(ll,1)\n! if(.not.nolapack) lapack(ll)=ceq%phase_varres(lokcs)%d2gval(ll,1)\n! remove next line when using an inversion for symmetric matrix\n if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk)\n! this is an attempt to avoid calling ixsym ... it works\n jxsym=jxsym+jk\n enddo\n! write(*,17)'row2A: ',(pmat(ik,jj),jj=1,nd1)\n enddo\n! Then set the sublattice elements\n! write(*,*)'MM segmentation fault 20'\n kk=0\n do ll=1,nsl\n do ik=1,nkl(ll)\n! set the sublattice columns and rows\n kk=kk+1\n pmat(kk,neq+ll)=one\n pmat(neq+ll,kk)=one\n enddo\n! write(*,17)'row3: ',(pmat(ncon+ll,jj),jj=1,nd1)\n enddo\n neq=neq+nsl\n if(pmi%chargebal.eq.1) then\n! if external charge balance add one column and one row\n! It causes problem to invert the phase matrix below for a phase like\n! M2O3 with cations CE+3 and LA+3 as the phase is always neutral \n! and the charge balance not needed.\n neq=neq+1\n do jk=1,ncon\n! this is the row\n pmat(jk,neq)=dqsum(jk)\n! this is the column\n pmat(neq,jk)=dqsum(jk)\n enddo\n endif\n! write the phase matrix on a file\n! open(33,file='phasemat.dat ',access='sequential',status='unknown')\n! write(33,*)'Phase matrix',nd1\n! do jk=1,nd1\n! write(33,111)jk,(pmat(jk,ll),ll=1,nd1)\n111 format('>',i4,1x,4(1pe15.6))\n! enddo\n! debug output\n! write(*,*)'Phase matrix',nd1,neq,pmi%chargebal\n! do j=1,neq\n! write(*,17)'pmat: ',(pmat(i,j),i=1,neq)\n! enddo\n! invert the phase matrix (using LAPACK+BLAS ... 50% faster than with Leo)\n! removed 2nd argument\n! call mdinv(nd1,nd2,pmat,pmi%invmat,neq,ierr)\n! write(*,*)'MM segmentation fault 30'\n call mdinv(nd1,pmat,pmi%invmat,neq,ierr)\n if(ierr.eq.0) then\n write(*,*)'MM Numeric problem 3, phase/set:',iph,ics\n! if(ocv()) write(*,556)'Phase matrix singular 3:',meqrec%noofits,&\n if(pmi%chargebal.eq.1) then\n! can be problem with external chargebalance not needed ...\n call get_phase_name(pmi%iph,1,name)\n write(*,553)'Try to suspend phase: ',trim(name)\n553 format(a,a)\n endif\n556 format(a,6i5)\n! emergency fix does not work ...\n pmi%invmat=zero\n do jk=1,neq\n pmi%invmat(jk,jk)=one/neq\n enddo\n! do jk=1,neq\n! write(*,18)'3Y mat:',jk,(pmat(ik,jk),ik=1,neq)\n! enddo\n! do jk=1,neq\n! write(*,18)'3Y inv:',jk,(pmi%invmat(ik,jk),ik=1,neq)\n! enddo\n18 format(a,i3,7(1pe10.2))\n! do jk=1,neq\n! write(*,73)(pmat(ik,jk),ik=1,neq)\n! enddo\n gx%bmperr=4205; goto 1000\n endif\n goto 900\n!-------------------------------------------\n900 continue\n!\n! if(mmdebug.ne.0) write(*,*)'MM meq_onephase exit: '\n goto 1000\n!--------------------------------------------\n1000 continue\n! write(*,*)'MM exit meq_onephase'\n return\n end subroutine meq_onephase !ixsym\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine corriliq_d2gdyidyj\n!\\begin{verbatim}\n subroutine corriliq_d2gdyidyj(nkl,knr,curmu,pmi,ncc,nd1,pmat,ceq)\n! correction of d2G/dy1dy2 for ionic liquid because the formula unit is\n! not fixed. This contributes ONLY to the second derivaties of G and\n! is not really part of the model itself, only needed when minimizing G\n implicit none\n type(gtp_equilibrium_data), pointer :: ceq\n TYPE(meq_phase), pointer :: pmi\n integer ncc,nd1,nkl(*),knr(*)\n double precision curmu(*),pmat(nd1,*)\n!\\end{verbatim}\n! corr = \\sum_A \\mu_A*d2(N_A)/dy_i/dy_k ; i cation, k cation, anion, Va\n! N_A = P*\\sum_i b_Ai y_i + Q(\\sum_j b_Aj y_j + ... ) b_Ai stoich.fact. of A\n! P = \\sum_j v_j y_j + y_Va Q\n! Q = \\sum_i v_i y_i \n!\n! Derivativs of P and Q\n! dP/dy_i = y_Va v_i; dP/dy_j = v_j; dP/dy_Va = Q\n! dQ/dy_i = v_i dQ/dy_j = zero dQ/dy_Va = zero\n! d2P/dy_idy_Va = v_i\n! \n! d(N_A\\mu_A)/dy_i = dP/dy_i\\sum_jb_Aj + v_i\n!\n integer icon,jcon,loksp,nspel,ielno(10),el,allions,nobug\n double precision stoi(10),spmass,qsp1,qsp2,add1,add2,yva,sumcat,bug\n double precision bugfix\n!tafidbug\n! write(*,*)'Skipping liquid correction'\n! goto 1000\n! this correction term affects only second derivatives and thus convergence \n! speed and stability. But it seems just to mess up everything.\n!\n! dpqdy(1..ncc) is the absolute value of the charge of the species\n! It is not used as we must get species data, better not to use ...\n! i2sly(1) is index of vacancy, i2sly(2) is index of first neutral\n! If either is missing it is equal to number of constituents+1\n allions=min(pmi%i2sly(1),pmi%i2sly(2))\n! write(*,12)'mu: ',(curmu(i1),i1=1,noel())\n12 format(a,6(1pe12.4))\n if(nkl(1).eq.0) then\n! no cations (bor anions), only neutrals, no need to calculate anything \n! write(*,*)'Liquids without cations have fixed stoichiometry 1.0\n goto 1000\n endif\n! If there are vacancies we save its fraction here, if not set to zero\n! if(pmi%i2sly(1).lt.ncc) then\n if(pmi%i2sly(1).le.ncc) then\n yva=pmi%curd%yfr(pmi%i2sly(1))\n else\n yva=zero\n endif\n! write(*,11)'corrion 1: ',yva,pmi%i2sly,nkl(1)+nkl(2),allions,ncc\n11 format(a,1pe12.4,10i5)\n! to simplify testing, 0 means include contribution from pairs of cations\n nobug=0\n bugfix=one\n sumcat=zero\n! just loop for all cations here. Inside this loop we step jcon\n! for all constituents up to vacancies or last anion.\n do icon=1,nkl(1)\n! icon=0\n! do i1=1,nkl(1)\n! do i1=1,allions-1\n! loop for all cations and anions\n! icon=icon+1\n loksp=knr(icon)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp1,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,spmass,qsp1,ceq)\n if(gx%bmperr.ne.0) goto 1000\n add2=zero\n do el=1,nspel\n! skip any vacancy in a species, they have zero chemical potential anyway\n if(ielno(el).gt.0) add2=add2+stoi(el)*curmu(ielno(el))\n enddo\n add1=add2\n! write(*,13)'first cat: ',icon,0,qsp1,add1\n13 format(a,2i3,6(1pe12.4))\n!-------------------------2nd derivatives wrt two cations\n jcon=icon\n do while(jcon.le.nkl(1))\n! loop for all pairs of cations incl twins, nkl(1) is number of cations\n! A smart but messy solution is to skip this loop for jcon=icon ...\n loksp=knr(jcon)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,&\n spmass,qsp2,ceq)\n if(gx%bmperr.ne.0) goto 1000\n add2=zero\n do el=1,nspel\n if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el))\n enddo\n bug=add2\n! sumcat is used below for derivative wrt cation and vacancy\n if(icon.eq.1) then\n sumcat=sumcat+pmi%curd%yfr(jcon)*add2\n! write(*,13)'sumcat: ',0,jcon,yva,pmi%curd%yfr(jcon),&\n! add2,sumcat\n endif\n! if there are no vacancies the derivative of P is zero wrt two cations\n! this is \\sum_A dP/dy_icon*b_Ajcon*mu_A+\\sum_A dP/dy_jcon*b_Aicon*mu_A\n if(nobug.eq.0 .and. yva.gt.zero) then\n add2=bugfix*yva*(qsp1*add2+qsp2*add1)\n! if(abs(yva*(add2)).gt.1.0D2) then\n! This is a sensitive point for convergence, values of 1.0D+33 found !!!\n! But bad converge also when small values, less than 100\n! add2=-1.0D2\n! endif\n! write(*,13)'pmat caca: ',icon,jcon,qsp1,yva,bug,add2\n! store value in pmat as correction to d2G/dyidyj\n pmat(icon,jcon)=-add2\n! tafidbug 2\n! pmat(icon,jcon)=add2\n endif\n jcon=jcon+1\n enddo\n! ------------------------ 2nd derivative wrt to cation and anion\n do while(jcon.lt.allions)\n! loop for all anions, allions-1 is last anion\n loksp=knr(jcon)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,&\n spmass,qsp2,ceq)\n if(gx%bmperr.ne.0) goto 1000\n add2=zero\n do el=1,nspel\n if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el))\n enddo\n bug=add2\n! This is \\sum_A dP/dy_jcon*b_Aicon*mu_A+\\sum_A dQ/dy_icon*b_Ajcon*mu_A\n! Note dP/dy = -qsp2 as qsp2 is negative\n add2=qsp1*add2-qsp2*add1\n! write(*,13)'pmat caan: ',icon,jcon,qsp2,bug,add2\n! store value in pmat as correction to d2G/dyidyj\n pmat(icon,jcon)=-add2\n! tafidbug 2\n! pmat(icon,jcon)=add2\n jcon=jcon+1\n enddo\n!------------- second derivative wrt cation and vacancy\n! if(icon.le.nkl(1) .and. jcon.eq.pmi%i2sly(1)) then\n if(jcon.le.ncc .and. jcon.eq.pmi%i2sly(1)) then\n! if no vacancy then i2sly(1)=ncc+1\n! This is \\sum_A d2P/dy_icon dy_Va*\\sum_k y_k*b_Ak*\\mu_A + Q * b_Aicon*\\mu_A\n add2=qsp1*sumcat+pmi%curd%sites(2)*add1\n! It think the line above is correct but the one below works better ...\n! add2=qsp1*sumcat\n! write(*,13)'pmat cava: ',icon,jcon,qsp1,&\n! sumcat,pmi%curd%sites(2),add1,add2\n! store value in pmat as correction to d2G/dyidyj\n pmat(icon,jcon)=-add2\n! tafidbug 2\n! pmat(icon,jcon)=add2\n jcon=jcon+1\n endif\n!------------- second derivative wrt cation and neutral\n! is this really correct??\n do while(jcon.le.ncc)\n loksp=knr(jcon)\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2,spextra)\n call get_species_component_data(loksp,nspel,ielno,stoi,spmass,&\n qsp2,ceq)\n if(gx%bmperr.ne.0) goto 1000\n add2=zero\n do el=1,nspel\n if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el))\n enddo\n bug=add2\n! This is \\sum_A dQ/dy_icon * b_Ajcon * mu_A, icon is cation and jcon neutal\n add2=qsp1*add2\n! write(*,13)'pmat cane: ',icon,jcon,qsp1,bug,add2\n pmat(icon,jcon)=-add2\n! tafidbug 2\n! pmat(icon,jcon)=add2\n jcon=jcon+1\n enddo\n!------------- no other terms\n enddo\n! write(*,*)'Correction to phase matrix from corriliq: ',&\n! pmi%curd%phtupx,nobug\n! do icon=1,ncc\n! write(*,1100)(pmat(icon,jcon),jcon=1,ncc)\n! enddo\n1100 format(6(1pe12.4))\n1000 continue\n return\n end subroutine corriliq_d2gdyidyj\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function same_composition\n!\\begin{verbatim}\n logical function same_composition(jj,phr,meqrec,ceq,dgm)\n! returns .TRUE. if phase phr(jj) has almost exactly the same composition\n! as another composition set of the same phase that is stable\n! dgm just for debug output\n! =============================================================\n! The composition of the phases are compared as ordered phases one can have\n! the same constitution but distributed on different sets of sublattices ....\n! ==============================================================\n implicit none\n integer jj\n double precision dgm\n TYPE(meq_phase), dimension(*) :: phr\n TYPE(meq_setup) :: meqrec\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jp,jy\n! If the difference is larger than xdiff then the compositions are not the same\n! double precision, parameter :: xdiff=0.01D0\n! FINETUNING: a large value of xdiff may mean you miss a miscibility gap\n! a small value may create bad convergence\n! 0.05 fails to find L1_2/A1/L1_0 in Au-Cu ...\n! double precision, parameter :: xdiff=0.05D0\n! 0.01 works better for Au-Cu ... maybe other problems ...\n double precision, parameter :: xdiff=0.01D0\n double precision, dimension(maxel) :: xmol1,xmol2,wmass\n double precision amount,totmol,totmass,xdiffm,xdiffc\n! CCI\n same_composition=.FALSE.\n! check if any other compset of the phase stable with same composition\n call calc_phase_molmass(phr(jj)%iph,phr(jj)%ics,xmol1,wmass,&\n totmol,totmass,amount,ceq)\n if(gx%bmperr.ne.0) goto 1000\n xdiffm=one\n! write(*,*)'MM testing same composition',jj,phr(jj)%iph,phr(jj)%ics\n! ?? strange loop limits ??\n! do jp=jj-1,1,-1\n do jp=1,meqrec%nphase\n if(phr(jp)%iph.eq.phr(jj)%iph) then\n if(phr(jp)%stable.eq.1) then\n call calc_phase_molmass(phr(jp)%iph,phr(jp)%ics,xmol2,wmass,&\n totmol,totmass,amount,ceq)\n if(gx%bmperr.ne.0) goto 1000\n do jy=1,meqrec%nrel\n xdiffc=abs(xmol1(jy)-xmol2(jy))\n if(xdiffc.lt.xdiffm) then\n xdiffm=xdiffc\n endif\n if(xdiffc.gt.xdiff) goto 110\n! if(abs(xmol1(jy)-xmol2(jy)).gt.xdiff) goto 110\n enddo\n! we have found another stable composition set with same composition\n goto 300\n endif\n elseif(phr(jp)%iph.lt.phr(jj)%iph) then\n cycle\n else\n exit\n endif\n110 continue\n enddo\n same_composition=.FALSE.\n goto 1000\n!--------------------------------------------------------\n! we found a stable composition set with the same composition\n300 continue\n same_composition=.TRUE.\n if(ocv()) write(*,117)'Not added comp.set phase: ',phr(jj)%iph,&\n phr(jj)%ics,phr(jp)%ics,xdiffm\n117 format(a,i3,2i4,2x,1pe12.4)\n! One cannot have two composition sets with same composition.\n! try to reset this composition set to default constition\n call set_default_constitution(phr(jj)%iph,phr(jj)%ics,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! goto 1000\n!\n1000 continue\n return\n end function same_composition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine two_stoich_same_comp\n!\\begin{verbatim}\n recursive subroutine two_stoich_same_comp(irem,iadd,mapx,meqrec,inmap,ceq)\n! we have found two phases stable with same composition\n! ONLY USED WHEN MAPPING with tie-lines in plane\n! ceq is equilibrium record\n implicit none\n integer irem,iadd,inmap,mapx\n type(meq_setup) :: meqrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! type(map_node), pointer :: mapnode,newnode,oldnext\n! type(map_line), pointer :: nodexit\n type(gtp_equilibrium_data), pointer :: newceq\n integer nrel,nel,iph,ics,jj,seqx,phfix,lokph,lokcs,phstable,phfixtupix\n type(gtp_condition), pointer :: pcond,lastcond\n! needed for solving a nonlinear equation\n integer, parameter :: lwa=100\n type(gtp_state_variable), target :: axstv1\n type(gtp_state_variable), pointer :: axstv\n integer nv,info,ip\n double precision newphfra,fvec(5),tol,wa(lwa),value,xv(5),tinit\n character phases*48\n! logical isotherm\n integer idum,jdum,savefix(2),saveent\n! \n! write(*,*)'In two_stoich_same_comp'\n! write(*,*)'MM found two stable stochiometric phases with same composition'\n! THIS SHOULD NOT BE USED FOR ISOPLETHS ??\n! if(meqrec%nrel.ne.2) then\n! How to check if I should use this routine? Only 2 components?\n! If we have an activity condition one could have 3 components ....\n! write(*,*)'MM This routine should be used only when tie-lines in plane'\n! gx%bmperr=4399; goto 1000\n! endif\n! call get_state_var_value('X(O) ',value,phases,ceq)\n! write(*,806)meqrec%fixph(1,1),meqrec%fixph(2,1),mapx,iadd,value\n806 format('MM why fix phase/set: ',i3,i2,' entered: ',i3,', new fix: ',i3,&\n 1pe12.4)\n phases=' '\n! in some call iadd can be larger than its dimentsion leading to crash\n if(iadd.gt.size(meqrec%phr)) then\n write(*,*)'Error matsmin: calling two_stich_comp; ',iadd,mapx\n gx%bmperr=4399; goto 1000\n endif\n call get_phasetup_name(meqrec%phr(iadd)%curd%phtupx,phases)\n ip=len_trim(phases)\n phases(ip+2:)='and'\n call get_phasetup_name(meqrec%phr(irem)%curd%phtupx,phases(ip+6:))\n if(gx%bmperr.ne.0) goto 1000\n write(*,'(a)')'MM two compounds stable at same composition: '//trim(phases)\n! new T calculated in this routine should be close to current value\n tinit=ceq%tpval(1)\n! write(*,22)'MM in two_stoich_same_comp: ',irem,iadd,ceq%tpval(1)\n!22 format(/20('-')/a,2i5,F8.2)\n! call list_conditions(kou,ceq)\n! We cannot calculate an equilibrium with two phases with exactly the same\n! composition. But we can calculate the T where the two stoichiometric\n! phases have the same Gibbs energy using the calc_tzero routine!\n! Assuming the conditions are not too involved ... but we are dealing with a\n! system with tie-lines in the plane, binary or ternary.\n! use the variables tzph1 and tzph2 (in matsmin) to specify the phases involved\n! DOES NOT WORK IN PARALLEL!!\n tzph1=irem; tzph2=iadd\n phases=' '\n call get_phasetup_name(tzph1,phases)\n nv=len_trim(phases)\n call get_phasetup_name(tzph2,phases(nv+2:))\n!\n! write(*,27)'MM two compounds: ',tzph1,tzph2,trim(phases)\n27 format(a,2i4,2x,a)\n nv=1\n tol=1.0D-6\n! hybrid1 can solve a system of nonlinear equations by calling\n! subroutine tzcalc_stoich(nv,xv,fvec,iflag) is in matsmin.F90\n! the tzceq is a pointer declared in matmin and used in tzcalc_stoich\n tzceq=>ceq\n xv(1)=tzceq%tpval(1)\n call hybrd1(tzcalc_stoich,nv,xv,fvec,tol,info,wa,lwa)\n if(info.ne.1) then\n! info=0 means improper input parameters\n! =2 Too many calls to tzcalc_stoich\n! =3 tol is too small\n! =4 Convergence too slow\n! write(*,*)'HYBRD solver return error: ',info\n if(gx%bmperr.eq.0) gx%bmperr=4371\n endif\n if(gx%bmperr.ne.0) goto 1000\n if(abs(ceq%tpval(1)-tinit).gt.2.0D1) then\n write(*,654)ceq%tpval(1),tinit\n654 format('MM Error, too large change in T: ',2F10.2)\n gx%bmperr=4399; goto 1000\n endif\n! To have correct chemical potentials we must call meq_sameset again\n! But with T fix and phase iadd set dormant\n! Now set current value of T as condition\n! call list_conditions(kou,ceq)\n! loop all conditions until we find T and set it active.\n! Maybe remove some other condition??\n lastcond=>ceq%lastcondition\n pcond=>lastcond\n nv=0\n jdum=0\n condloop1: do while(.TRUE.)\n! loop for all conditions\n nv=nv+1\n! write(*,*)'State variable: ',nv,pcond%statev,pcond%prescribed\n if(pcond%statev.eq.1) then\n! This is T, the axis condition, set as active with calculated value of T\n pcond%prescribed=xv(1)\n if(pcond%active.ne.0) then\n write(*,77)xv(1)\n77 format('Two identical stoichiometric phases want to be stable ',&\n 'at T=',F10.3)\n gx%bmperr=4399; goto 1000\n endif\n pcond%active=0\n jdum=nv\n else\n if(gx%bmperr.ne.0) then\n write(*,*)'Error extraction axis state variable value',gx%bmperr\n goto 1000\n endif\n endif\n pcond=>pcond%next\n if(associated(pcond,lastcond)) exit condloop1\n enddo condloop1\n if(jdum.eq.0) then\n write(*,*)'Error, no condition on T!'\n gx%bmperr=4399; goto 1000\n endif\n! extract which phase is fixed (only one)\n savefix(1)=meqrec%fixph(1,1)\n savefix(2)=meqrec%fixph(1,2)\n! and which is entered\n jdum=0\n do jj=1,meqrec%nphase\n if(meqrec%phr(jj)%stable.eq.1) then\n if(meqrec%phr(jj)%iph.eq.savefix(1) .and. &\n meqrec%phr(jj)%ics.eq.savefix(2)) then\n! write(*,*)'MM Fix phase: ',meqrec%fixph(1,1),meqrec%fixph(1,2)\n cycle\n endif\n if(jdum.eq.0) then\n! write(*,*)'MM Entered phase',jdum,jj\n jdum=jj\n! elseif(jj.ne.irem) then\n! write(*,*)'MM More than one entered phase',jdum,jj\n endif\n endif\n enddo\n! we must keep saveent to return the entered phase when generating exits!\n saveent=jdum\n! write(*,*)'MM old fix phase/set and entered: ',meqrec%fixph(1,1),&\n! meqrec%fixph(2,1),saveent\n!meq_sameset and ignore any change of the set of stable phases\n! We must call meq_sameset again to have correct chemical potential at this T\n! write(*,*)'MU(*) before meq_sameset: ',ceq%cmuval(1),ceq%cmuval(2)\n! Now we have calculated T when both stoichiometric phases are stable\n! and set this T as condition. \n! set the phase iadd as suspend to avoid it will try to be stable\n meqrec%phr(iadd)%phasestatus=PHSUS\n meqrec%noofits=0\n! call list_conditions(kou,ceq)\n! Strange here we have one degree of freedom! how can we calculate? No check!!\n! But we must have a condition on the amount\n! mapx set to zero inside this routine. Make sure no error code set!!\n if(gx%bmperr.ne.0) gx%bmperr=0\n! write(*,*)'MM calling meq_sameset from two_stoich_same_comp'\n! write(*,*)'This is a recursive call as we call two_stoich from meq_sameset!'\n call meq_sameset(idum,jdum,mapx,meqrec,meqrec%phr,inmap,ceq)\n! write(*,*)'MU(*) after meq_sameset: ',ceq%cmuval(1),ceq%cmuval(2)\n if(gx%bmperr.ne.0) then\n! write(*,*)'MM Error calling meq_sameset from two_stoich',gx%bmperr\n goto 1000\n endif\n! return the entered phase in mapx (maybe not needed?)\n! call get_state_var_value('X(O) ',value,phases,ceq)\n mapx=saveent\n! write(*,807)meqrec%fixph(1,1),meqrec%fixph(2,1),mapx,iadd,value\n807 format('MM old fix phase/set: ',i3,i2,' entered: ',i3,', new fix: ',i3,&\n 1pe12.4)\n! restore status of new phase found at nodepoint as entered\n meqrec%phr(iadd)%phasestatus=PHENTERED\n! write(*,*)'Conditions for the invariant:'\n! call list_conditions(kou,ceq)\n! write(*,*)'Exiting two_stoich_same_comp'\n! we must set this error code to return to mapping routines\n! This means two stoichiometric phases stable an node point\n gx%bmperr=4364\n1000 continue\n! Make sure status of new phase found at nodepoint as set as entered\n meqrec%phr(iadd)%phasestatus=PHENTERED\n return\n end subroutine two_stoich_same_comp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_dgdyterms1\n!\\begin{verbatim}\n subroutine calc_dgdyterms1(nrel,ia,tpindep,mamu,mag,mat,map,pmi,&\n curmux,noofits)\n! THIS SUBROUTINE IS NO LONGER USED!? Cannot be used in parallel\n! any change must also be made in subroutine calc_dyterms2 and calc_dgdytermsh\n! calculate the terms in the deltay expression for amounts of component ia\n!\n! DM_A = \\sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp\n!\n! where MAMU=\\sum_i dM_A/dy_i*\\sum_j invmat(i,j)*dM_B/dy_j\n! c_iB=\\sum_j invmat(i,j)*dM_B/dy_j etc etc\n!\n! it may not be very efficient but first get it right ....\n! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable\n!\n! >>> ATTENTION, there is a FASTER VERSION calc_dgdyterms1X\n! >>> ATTENTION not safe for parallelization ....\n!\n implicit none\n integer ia,nrel,noofits\n logical tpindep(2)\n double precision, dimension(*) :: mamu\n double precision mag,mat,map\n double precision curmux(*)\n! pmi is the phase data record for this phase\n type(meq_phase), pointer :: pmi\n!\\end{verbatim} %+\n! these are to be multiplied with mu(ib), nothing, deltaT, deltaP\n integer iy,jy,ib,nocon,errall\n! initial values for saved results OLD VERSION\n integer :: sameit=0,big1p=0,big2p=0,big1n=0,big2n=0\n double precision cig,cit,cip,haha\n double precision morr\n double precision, allocatable, dimension(:) :: zib\n! ATTENTION, see calc_dgdyterms1X !!!! for better routine\n double precision, allocatable, dimension(:,:) :: maybesave\n double precision, allocatable, dimension(:,:) :: save1\n double precision, allocatable, dimension(:,:) :: save2\n! NOTE THIS SUBROUTINE IS NO LONGER USED!!\n save sameit,big1p,big1n,big2p,big2n\n save save1,save2\n logical big\n!\n!-----------\n! \\sum_i \\sum_j e_ij*dM_A/dy_i dG/dy_j\n! skip code for saving as that is implemented in calc_dgdytermes1X\n! write(*,*)'Using calc_dgdyterms1 without saving'\n goto 100\n! code below to be ignored\n!\n if(noofits.ne.sameit) then\n! new iteration, discard saved values\n big1p=0; big1n=0\n big2p=0; big2n=0\n sameit=noofits\n goto 100\n endif\n! use save values for the phases with many constituents\n! if(test_phase_status_bit(phasetuple(phr(jj)%iph)%ixphase,&\n if(10*pmi%iph+pmi%ics.eq.big1p) then\n! write(*,13)'MM using saved values 1:',noofits,sameit,big1p,big1n,ia\n13 format(a,2i5,5x,2i5,5x,3i5)\n mag=zero\n mat=zero\n map=zero\n do ib=1,nrel\n mamu(ib)=zero\n enddo\n do iy=1,big1n\n morr=pmi%dxmol(ia,iy)\n do ib=1,nrel\n mamu(ib)=mamu(ib)+save1(ib,iy)*morr\n enddo\n mag=mag+save1(nrel+1,iy)*morr\n if(tpindep(1)) mat=mat+save1(nrel+2,iy)*morr\n if(tpindep(2)) map=map+save1(nrel+3,iy)*morr\n enddo\n goto 1000\n elseif(10*pmi%iph+pmi%ics.eq.big2p) then\n! write(*,13)'MM using saved values 2:',noofits,sameit,big2p,big2n,ia\n mag=zero\n mat=zero\n map=zero\n do ib=1,nrel\n mamu(ib)=zero\n enddo\n do iy=1,big2n\n morr=pmi%dxmol(ia,iy)\n do ib=1,nrel\n mamu(ib)=mamu(ib)+save2(ib,iy)*morr\n enddo\n mag=mag+save2(nrel+1,iy)*morr\n if(tpindep(1)) mat=mat+save2(nrel+2,iy)*morr\n if(tpindep(2)) map=map+save2(nrel+3,iy)*morr\n enddo\n goto 1000\n endif\n!------------------------------------ calculate as usual\n100 continue\n!----------------------------------\n mag=zero\n mat=zero\n map=zero\n! if(tpindep(2)) then\n! write(*,99)'MM d2G/dPdy: ',(pmi%curd%dgval(3,jy,1),jy=1,pmi%ncc)\n!99 format(a,6(1pe11.3))\n! endif\n! noofits=1 means phase is ideal, use only diagonal\n nocon=pmi%ncc\n! if(allocated(zib)) deallocate(zib)\n allocate(zib(nrel),stat=errall)\n if(nocon.gt.nrel) then\n big=.TRUE.\n if(allocated(maybesave)) deallocate(maybesave)\n allocate(maybesave(nrel+3,nocon),stat=errall)\n else\n big=.FALSE.\n endif\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 41: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do ib=1,nrel\n mamu(ib)=zero\n enddo\n do iy=1,nocon\n zib=zero\n cig=zero; cit=zero; cip=zero\n do jy=1,nocon\n haha=pmi%invmat(jy,iy)\n do ib=1,nrel\n zib(ib)=zib(ib)+haha*pmi%dxmol(ib,jy)\n enddo\n cig=cig+haha*pmi%curd%dgval(1,jy,1)\n! always calculate cit because cp debug ?? dgval(2,jy,1) is d2G/dTdy_j\n if(tpindep(1)) cit=cit+haha*pmi%curd%dgval(2,jy,1)\n if(tpindep(2)) cip=cip+haha*pmi%curd%dgval(3,jy,1)\n enddo\n morr=pmi%dxmol(ia,iy)\n do ib=1,nrel\n mamu(ib)=mamu(ib)+zib(ib)*morr\n if(big) maybesave(ib,iy)=zib(ib)\n enddo\n mag=mag+morr*cig\n if(tpindep(1)) mat=mat+morr*cit\n if(tpindep(2)) map=map+morr*cip\n if(big) then\n maybesave(nrel+1,iy)=cig\n maybesave(nrel+2,iy)=cit\n maybesave(nrel+3,iy)=cip\n endif\n enddo\n goto 1000\n!\n! Ignore the code for saveing below, use calc_dgdyterms1X\n! To speed up calculations we save same values\n! what must be saved is what should be multiplied with pmi%dxmol(ia,iy)\n! write(*,*)'Checking for saving ',noofits,10*pmi%iph+pmi%ics,nocon\n if(nocon.le.nrel) goto 1000\n! ATTENTION this is not really used any longer, see calc_dgdyterms1X !!!\n if(nocon.gt.big1n) then\n! save all data for this phase with a large number of constituents\n big1p=10*pmi%iph+pmi%ics\n big1n=nocon\n if(allocated(save1)) deallocate(save1)\n allocate(save1(nrel+3,nocon),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 42: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do iy=1,nocon\n do ib=1,nrel+3\n save1(ib,iy)=maybesave(ib,iy)\n enddo\n enddo\n! write(*,*)'Saved 1 values for ',noofits,big1p,big1n\n elseif(nocon.gt.big2n) then\n! save all data for this phases with a large number of constituents\n big2p=10*pmi%iph+pmi%ics\n big2n=nocon\n if(allocated(save2)) deallocate(save2)\n allocate(save2(nrel+3,nocon),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 43: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do iy=1,nocon\n do ib=1,nrel+3\n save2(ib,iy)=maybesave(ib,iy)\n enddo\n enddo\n! write(*,*)'Saved 2 values for ',noofits,big2p,big2n\n! else\n! write(*,*)'dgdy not saved: ',noofits,10*pmi%iph+pmi%ics,nocon\n endif\n1000 continue\n return\n end subroutine calc_dgdyterms1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine calc_dgdyterms1X\n!\\begin{verbatim}\n subroutine calc_dgdyterms1X(nrel,ia,tpindep,mamu,mag,mat,map,pmi,noofits)\n! THIS SUBROUTINE using allocatable arrays in phase_varres!!\n! any change must also be made in subroutine calc_dyterms2 and calc_dgdytermsh\n! calculate the terms in the deltay expression for amounts of component ia\n!\n! DM_A = \\sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp\n!\n! where MAMU=\\sum_i dM_A/dy_i*\\sum_j invmat(i,j)*dM_B/dy_j\n! c_iB=\\sum_j invmat(i,j)*dM_B/dy_j etc etc\n!\n! it may not be very efficient but first get it right ....\n! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable\n!\n! >>> THIS IS THE PRINCIPAL VERSION of calc_dgdyterms WITH SAVE\n!\n implicit none\n integer ia,nrel,noofits\n logical tpindep(2)\n double precision, dimension(*) :: mamu\n double precision mag,mat,map\n! no longer used ...\n! type(saveddgdy), pointer :: saved\n! pmi is the phase data record for this phase\n type(meq_phase), pointer :: pmi\n!\\end{verbatim} %+\n! THIS IS THE ONE CURRENTLY USED IN THE MINIMIZATIONS\n! these are to be multiplied with mu(ib), nothing, deltaT, deltaP\n integer iy,jy,ib,nocon,errall\n! initial values for saved results\n! integer :: sameit=0,big1p=0,big2p=0,big1n=0,big2n=0\n double precision cig,cit,cip,haha\n double precision morr\n double precision, allocatable, dimension(:) :: zib\n!\n!-----------\n! \\sum_i \\sum_j e_ij*dM_A/dy_i dG/dy_j\n!\n nocon=pmi%ncc\n mag=zero\n mat=zero\n map=zero\n do ib=1,nrel\n mamu(ib)=zero\n enddo\n! the logic here is a bit complicated ...\n! At the first iteration the pmi%curd%invsaved is deallocated\n! and the pmi%curd%invsavediter set to 0\n! but at first iteration no values are saved\n! so all terms calculated at each call\n! At the second iteration a new pmi%curd%invsaved is allocated\n! and values are calculated and saved and pmi%curd%invsavediter set to 2\n! and these saved values are used in second and later calls\n! At later iterations new values are calculated and saved in pmi%curd%invsaved\n! at first call if pmi%curd%invsavediter is less than current iteration\n! otherwise the saved values are used. \n! The first iteration could be improved slightly but I am not sure\n! pmi%curd%invsavediter can be trusted at the first iteration.\n!---------------------------------\n if(noofits.le.1) then\n! At the first iteration deallocate as we may have new conditions\n if(allocated(pmi%curd%invsaved)) deallocate(pmi%curd%invsaved)\n pmi%curd%invsavediter=0\n! write(*,17)'MM dgdycalc1X: ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved)\n17 format(a,6i7,l2,4i4)\n goto 100\n! UNFINISHED: VALGRIND indicates unititial variable ...\n elseif(pmi%curd%invsavediter.ne.noofits) then\n! no values saved for this phase and iteration, recalcute\n! 123456789.12345\n! write(*,17)'MM new iter: ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved)\n goto 100\n elseif(.not.allocated(pmi%curd%invsaved)) then\n! write(*,17)'MM Not allocated?',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved)\n goto 100\n endif\n! use save values for the phase\n! 123456789.12345\n! write(*,17)'MM using save: ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),&\n! size(pmi%curd%invsaved)\n if(allocated(pmi%curd%invsaved)) then\n do iy=1,nocon\n morr=pmi%dxmol(ia,iy)\n do ib=1,nrel\n mamu(ib)=mamu(ib)+pmi%curd%invsaved(ib,iy)*morr\n enddo\n mag=mag+pmi%curd%invsaved(nrel+1,iy)*morr\n if(tpindep(1)) mat=mat+pmi%curd%invsaved(nrel+2,iy)*morr\n if(tpindep(2)) map=map+pmi%curd%invsaved(nrel+3,iy)*morr\n enddo\n goto 1000\n else\n write(*,*)'MM ERROR: not allocated!',noofits,pmi%iph,pmi%ics,nocon,ia\n gx%bmperr=4399; goto 1000\n endif\n!------------------------------------ calculate as usual and save at the end\n100 continue\n!----------------------------------\n! next time for same iteration use saved values for this phase\n! sameit=noofits\n! allocate the pmi%curd%invsaved at first iteration\n if(noofits.gt.1 .and. .not.allocated(pmi%curd%invsaved)) then\n allocate(pmi%curd%invsaved(nrel+3,nocon),stat=errall)\n! write(*,17)'MM allocate ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),&\n! nrel,(nrel+3)*nocon,size(pmi%curd%invsaved)\n endif\n allocate(zib(nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 44: ',errall\n gx%bmperr=4370; goto 1000\n endif\n!\n! write(*,17)'MM calculate: ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),&\n! nrel,(nrel+3)*nocon\n do iy=1,nocon\n zib=zero\n cig=zero; cit=zero; cip=zero\n do jy=1,nocon\n haha=pmi%invmat(jy,iy)\n do ib=1,nrel\n zib(ib)=zib(ib)+haha*pmi%dxmol(ib,jy)\n enddo\n cig=cig+haha*pmi%curd%dgval(1,jy,1)\n! always calculate cit because cp debug ?? dgval(2,jy,1) is d2G/dTdy_j\n if(tpindep(1)) cit=cit+haha*pmi%curd%dgval(2,jy,1)\n if(tpindep(2)) cip=cip+haha*pmi%curd%dgval(3,jy,1)\n enddo\n morr=pmi%dxmol(ia,iy)\n do ib=1,nrel\n mamu(ib)=mamu(ib)+zib(ib)*morr\n if(noofits.gt.1) pmi%curd%invsaved(ib,iy)=zib(ib)\n enddo\n mag=mag+morr*cig\n if(tpindep(1)) mat=mat+morr*cit\n if(tpindep(2)) map=map+morr*cip\n if(noofits.gt.1) then\n pmi%curd%invsaved(nrel+1,iy)=cig\n pmi%curd%invsaved(nrel+2,iy)=cit\n pmi%curd%invsaved(nrel+3,iy)=cip\n endif\n enddo\n pmi%curd%invsavediter=noofits\n! write(*,17)'MM saveing: ',noofits,pmi%iph,pmi%ics,nocon,ia,&\n! pmi%curd%invsavediter,allocated(pmi%curd%invsaved),&\n! size(pmi%curd%invsaved)\n!\n1000 continue\n return\n end subroutine calc_dgdyterms1X\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_dgdyterms2\n!\\begin{verbatim} %-\n subroutine calc_dgdyterms2(iy,nrel,mamu,mag,mat,map,pmi)\n! Called only by meq_calc_phase_derivative\n! for the contribution to G for a single phase\n! it should be similar to calc_dgdyterms1\n implicit none\n integer iy,nrel\n double precision mag,mat,map,mamu(*)\n type(meq_phase), pointer :: pmi\n!\\end{verbatim} %+\n! these are to be multiplied with mu(ib), nothing, deltaT, deltaP\n! I am not sure if this is used ...\n integer jy,ib\n double precision sum,cig,cit,cip\n!\n! write(*,*)'entering calc_dgdyterms2: ',iy,nrel,allocated(pmi%invmat)\n mag=zero\n do ib=1,nrel\n sum=zero\n do jy=1,pmi%ncc\n sum=sum+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy)\n enddo\n mamu(ib)=sum\n enddo\n!-----------\n! \\sum_i \\sum_j e_ij*dM_A/dy_i dG/dy_j\n cig=zero\n cit=zero\n cip=zero\n do jy=1,pmi%ncc\n cig=cig+pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1)\n cit=cit+pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1)\n cip=cip+pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1)\n enddo\n mag=cig\n mat=cit\n map=cip\n1000 continue\n return\n end subroutine calc_dgdyterms2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_dgdytermsh\n!\\begin{verbatim} %-\n subroutine calc_dgdytermsh(nrel,ia,tpindep,hval,mamu,mag,mat,map,pmi,&\n curmux,noofits)\n! This is a variant of dgdyterms1 including a term multiplied with each\n! term (hval) in the summation over the comstituents as needed when calculating\n! an equation for fix V or H. If hval(i)=1.0 it should give the same\n! results as dgdyterms1\n!\n! calculate the terms in the deltay expression for amounts of component ia\n!\n! DM_A = \\sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp\n!\n! where MAMU=\\sum_i dM_A/dy_i*\\sum_j invmat(i,j)*dM_B/dy_j\n! c_iB=\\sum_j invmat(i,j)*dM_B/dy_j etc etc\n!\n! it may not be very efficient but first get it right ....\n! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable\n implicit none\n integer ia,nrel,noofits\n logical tpindep(2)\n double precision, dimension(*) :: hval,mamu\n double precision mag,mat,map\n double precision curmux(*)\n! pmi is the phase data record for this phase\n type(meq_phase), pointer :: pmi\n!\\end{verbatim} %+\n! THIS IS MODIFIED FOR CONDITIONS ON H and related properties\n! these are to be multiplied with mu(ib), nothing, deltaT, deltaP\n! CHARRGE BALANCE TERM ADDED 150610!!!\n integer iy,jy,ib,neq\n double precision sum,cig,cit,cip,cib\n double precision morr,curmu(maxel),maq\n!\n! write(*,9)'in calc_dgdytermsh: ',ia,0,0,pmi%chargebal\n9 format(a,4i3,6(1pe12.4))\n mag=zero\n do ib=1,nrel\n sum=zero\n do iy=1,pmi%ncc\n cib=zero\n do jy=1,pmi%ncc\n cib=cib+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy)\n enddo\n sum=sum+cib*hval(iy)\n! write(*,11)'termsh mu: ',ib,iy,0,hval(iy),sum\n11 format(a,3i2,6(1pe12.4))\n enddo\n mamu(ib)=sum\n enddo\n!-----------\n! if(noofits.eq.1) then\n! curmu=zero\n! else\n do iy=1,nrel\n curmu(iy)=curmux(iy)\n enddo\n! endif\n!-----------\n! \\sum_i \\sum_j e_ij*dM_A/dy_i dG/dy_j and other terms\n! for phases with extrenal chargebalance we have one more row with index\n! number of constituents+sublattices+1\n if(pmi%chargebal.eq.1) neq=pmi%ncc+size(pmi%curd%sites)+1\n maq=zero\n mag=zero\n mat=zero\n map=zero\n do iy=1,pmi%ncc\n cig=zero\n cit=zero\n cip=zero\n do jy=1,pmi%ncc\n! I inversed order of iy, jy, does it still converge??\n cig=cig-pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1)\n! write(*,11)'termsh g: ',ia,iy,jy,pmi%invmat(jy,iy),&\n! pmi%curd%dgval(1,jy,1),cig\n! always calculate cit because cp debug!!\n! hval(j)=dG/dy_j-Td2G/dTdy_j or something similar\n if(tpindep(1)) then\n cit=cit-pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1)\n! write(*,11)'termsh t: ',ia,iy,jy,pmi%curd%dgval(2,jy,1),cit\n endif\n if(tpindep(2)) cip=cip-pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1)\n enddo\n! morr=pmi%dxmol(ia,iy)\n morr=hval(iy)\n mag=mag+morr*cig\n mat=mat+morr*cit\n map=map+morr*cip\n! if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(neq,iy)\n if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(iy,neq)\n enddo\n! if(pmi%chargebal.eq.1) then\n! Looking for the reason of bad convergence with enthalpy condition this\n! was investigated but the correction is so small it is ignored.\n! For phases with external charge balance there is one more term, e_ig*Q\n! number of equations are constituents+sublattices+1\n! neq=pmi%ncc+size(pmi%curd%sites)+1\n! qscale=one\n! qscale=1.0D12\n! maq=maq*pmi%curd%netcharge*qscale\n! write(*,911)'eiq> ',pmi%curd%phtupx,pmi%chargebal,neq,pmi%ncc,&\n! pmi%curd%netcharge,mag,maq,(pmi%invmat(jy,neq),jy=1,neq)\n! pmi%curd%netcharge,mag,maq,(pmi%invmat(neq,jy),jy=1,neq)\n911 format(a,4i4,3(1pe12.4),/6(1pe12.4))\n! The contribution \\sum_i e_iq*Q should be added (or subtracted) from mag\n! mag=mag+maq\n! endif\n! write(*,11)'termsh: ',ia,0,0,mag,mat,map,(mamu(jy),jy=1,nrel)\n1000 continue\n return\n end subroutine calc_dgdytermsh\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_dgdytermshm\n!\\begin{verbatim} %-\n subroutine calc_dgdytermshm(nrel,ia,tpindep,hval,mamu,mag,mat,map,&\n mamu1,mag1,mat1,map1,pmi,curmux,noofits)\n! This is a variant of dgdyterms1 including a term multiplied with each\n! term (hval) in the summation over the comstituents as needed when calculating\n! an equation for fix V or H. If hval(i)=1.0 it should give the same\n! results as dgdyterms1\n!\n! Probably only one of calc_dgdytermshm or calc_dgdytermsh is needed\n! calculate the terms in the deltay expression for amounts of component ia\n!\n! DM_A = \\sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp\n!\n! where MAMU=\\sum_i dM_A/dy_i*\\sum_j invmat(i,j)*dM_B/dy_j\n! c_iB=\\sum_j invmat(i,j)*dM_B/dy_j etc etc\n!\n! it may not be very efficient but first get it right ....\n! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable\n implicit none\n integer ia,nrel,noofits\n logical tpindep(2)\n double precision, dimension(*) :: hval,mamu,mamu1\n double precision mag,mat,map,mag1,mat1,map1\n double precision curmux(*)\n! pmi is the phase data record for this phase\n type(meq_phase), pointer :: pmi\n!\\end{verbatim}\n! THIS IS MODIFIED FOR CONDITIONS ON H and related properties\n! these are to be multiplied with mu(ib), nothing, deltaT, deltaP\n! CHARGE BALANCE TERM ADDED 150610!!!\n integer iy,jy,ib,neq\n double precision sum,sum1,cig,cit,cip,cib\n! these variables are probably redundant\n double precision morr,curmu(maxel),maq,maq1\n!\n! write(*,9)'in calc_dgdytermsh: ',ia,nrel,pmi%ncc,pmi%chargebal\n9 format(a,4i3,6(1pe12.4))\n mag=zero\n do ib=1,nrel\n sum=zero\n sum1=zero\n do iy=1,pmi%ncc\n cib=zero\n do jy=1,pmi%ncc\n cib=cib+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy)\n enddo\n sum=sum+cib*hval(iy)\n sum1=sum1+cib*pmi%dxmol(ia,iy)\n! write(*,11)'termsh mu: ',ib,iy,0,hval(iy),pmi%dxmol(ia,iy),sum,sum1\n11 format(a,3i2,6(1pe12.4))\n enddo\n mamu(ib)=sum\n mamu1(ib)=sum1\n! write(*,11)'dgdyhm: ',ia,ib,0,mamu(ib),mamu1(ib)\n enddo\n!-----------\n! if(noofits.eq.1) then\n! curmu=zero\n! else\n do iy=1,nrel\n curmu(iy)=curmux(iy)\n enddo\n! endif\n!-----------\n! \\sum_i \\sum_j e_ij*dM_A/dy_i dG/dy_j and other terms\n! for phases with extrenal chargebalance we have one more row with index\n! number of constituents+sublattices+1\n if(pmi%chargebal.eq.1) neq=pmi%ncc+size(pmi%curd%sites)+1\n maq1=zero\n mag1=zero\n mat1=zero\n map1=zero\n maq=zero\n mag=zero\n mat=zero\n map=zero\n do iy=1,pmi%ncc\n cig=zero\n cit=zero\n cip=zero\n do jy=1,pmi%ncc\n! I inversed order of iy, jy, does it still converge??\n cig=cig-pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1)\n! write(*,11)'termsh g: ',ia,iy,jy,pmi%invmat(jy,iy),&\n! pmi%curd%dgval(1,jy,1),cig\n! always calculate cit because cp debug!!\n! hval(j)=dG/dy_j-Td2G/dTdy_j or something similar\n if(tpindep(1)) then\n cit=cit-pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1)\n! write(*,11)'termsh t: ',ia,iy,jy,pmi%curd%dgval(2,jy,1),cit\n endif\n if(tpindep(2)) cip=cip-pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1)\n enddo\n morr=pmi%dxmol(ia,iy)\n mag1=mag1+morr*cig\n mat1=mat1+morr*cit\n map1=map1+morr*cip\n if(pmi%chargebal.eq.1) maq1=maq1+morr*pmi%invmat(iy,neq)\n!\n morr=hval(iy)\n mag=mag+morr*cig\n mat=mat+morr*cit\n map=map+morr*cip\n! if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(neq,iy)\n if(pmi%chargebal.eq.1) maq=maq+morr*pmi%invmat(iy,neq)\n enddo\n1000 continue\n return\n end subroutine calc_dgdytermshm\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_evaluate_all_svfun\n!\\begin{verbatim}\n subroutine meq_evaluate_all_svfun(kou,ceq)\n! evaluate (and list if kou>0) the values of all state variable functions\n implicit none\n integer kou\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! THIS SUBROUTINE MOVED FROM gtp3D\n! if kou<0 no output\n character actual_arg(10)*24,star*2\n integer kf,nsvfun\n double precision val\n nsvfun=nosvf()\n if(kou.gt.0) write(kou,75)\n75 format('No Name ',12x,'Value')\n all: do kf=1,nsvfun\n! functions with bit SVFVAL set will be ignored by meq_evaluate_svfun \n! write(*,*)'MM meq_svfun: ',kf,svflista(kf)%name,&\n! btest(svflista(kf)%status,SVFVAL),ceq%svfunres(kf)\n star=' '\n if(btest(svflista(kf)%status,SVFVAL)) star='**'\n if(btest(svflista(kf)%status,SVFEXT)) star='<>'\n! if(btest(svflista(kf)%status,SVFVAL)) then\n! write(*,*)'MM only explit evaluation of: ',trim(svflista(kf)%name)\n! if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,svflista(kf)%value,'*'\n! if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,ceq%svfunres(kf),'*'\n! if(kou.gt.0) write(kou,78)kf,svflista(kf)%name,ceq%svfunres(kf),'**'\n78 format(i3,1x,a,1x,1PE15.7,1x,a)\n!78 format(i3,1x,a,1x,1PE15.8,a,' SVFVAL set')\n! cycle all\n! endif\n! actual arguments needed if svflista(kf)%nactarg>0\n! write(*,*)'MM meq_svfun evaluate ',kf,svflista(kf)%name\n if(btest(svflista(kf)%status,SVFVAL)) then\n! I am not really sure where the last calculated value is ???\n! better to return zero than some arbitrary value\n val=zero\n else\n val=meq_evaluate_svfun(kf,actual_arg,0,ceq)\n endif\n! write(*,*)'MM meq_svfun evaluated: ',val\n if(gx%bmperr.ne.0) then\n if(kou.gt.0) then\n write(kou,76)kf,svflista(kf)%name,gx%bmperr\n76 format(i3,1x,a,' cannot be calculated due to error ',i5)\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,992)trim(bmperrmess(gx%bmperr))\n992 format('Meaning: ',a/)\n endif\n endif\n gx%bmperr=0\n elseif(kou.gt.0) then\n write(kou,77)kf,svflista(kf)%name,val,star\n77 format(i3,1x,a,1x,1PE15.7,' ',a)\n endif\n! save the value in current equilibrium ... probably already done ...\n ceq%svfunres(kf)=val\n enddo all\n1000 continue\n return\n end subroutine meq_evaluate_all_svfun\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine meq_get_state_varorfun_value\n!\\begin{verbatim}\n subroutine meq_get_state_varorfun_value(statevar,value,dummy,ceq)\n! used in OCPLOT to extact value of state variable of symbol\n! NOTE if a specific function is given only this function evaluated\n implicit none\n character statevar*(*),dummy*(*)\n double precision value\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character encoded*64,actual_arg(2)*16\n integer lrot,mode,olderr\n!\n! write(*,*)'In meq_get_state_varofun: ',trim(statevar)\n! if not derivative this will work\n call get_state_var_value(statevar,value,encoded,ceq)\n! write(*,*)'MM meq_get_state_varofun: ',gx%bmperr,value\n if(gx%bmperr.ne.0) then\n! if error try using meq_evaluate_svfun\n olderr=gx%bmperr\n gx%bmperr=0\n encoded=statevar\n call capson(encoded)\n! call find_svfun(encoded,lrot,ceq)\n call find_svfun(encoded,lrot)\n! write(*,*)'In meq_get_state_varofun 2: ',&\n! trim(statevar),lrot,gx%bmperr,olderr\n if(gx%bmperr.ne.0) then\n! if error here return previous error code\n! write(*,*)'In meq_get_state_varofun 3: ',gx%bmperr\n value=zero\n gx%bmperr=olderr; goto 1000\n else\n mode=1\n actual_arg=' '\n! segmentation fault in this routine call from smp2B for a Cp value\n! after shifting to a new maptop record (several STEP/MAP)\n value=meq_evaluate_svfun(lrot,actual_arg,mode,ceq)\n endif\n endif\n! return calculated state variable symbol and always set special_circumstances=0\n dummy=encoded\n! always reset to zero\n special_circumstances=0\n1000 continue\n return\n end subroutine meq_get_state_varorfun_value\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable double precision function meq_evaluate_svfun\n!\\begin{verbatim}\n double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq)\n! evaluates all funtions as they may depend on each other\n! actual_arg are names of phases, components or species as @Pi, @Ci and @Si\n! needed in some deferred formal parameters (NOT IMPLEMENTED YET)\n! if mode=1 always evaluate, if mode=0 several options\n implicit none\n integer lrot,mode\n character actual_arg(*)*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! THIS SUBROUTINE MOVED FROM gtp3D\n! character encoded*60\n double precision argval(20)\n type(gtp_state_variable), target :: tsvr,tsvr2\n type(gtp_state_variable), pointer :: svr,svr2\n integer jv,jt,istv,ieq,nsvfun,ii\n double precision value\n!\n! modified here to handle symbols that can be used as conditions\n! write(*,*)'MM: --------- start meq_evaluate_svfun',trim(svflista(lrot)%name)\n value=zero\n argval=zero\n nsvfun=nosvf()\n ieq=0\n istv=0\n! FIRST ALL SYMBOLS ARE EVALUATED HERE\n! write(*,*)'MM meq_evaluate_svfun 1 ',lrot,mode,svflista(lrot)%narg\n! locate function\n if(lrot.le.0 .or. lrot.gt.nsvfun) then\n gx%bmperr=4140; goto 1000\n endif\n! this seems OK\n! write(*,17)'meq_evaluate_svfun 2',lrot,trim(svflista(lrot)%name),&\n! svflista(lrot)%narg,&\n! btest(svflista(lrot)%status,SVFVAL),&\n! btest(svflista(lrot)%status,SVFEXT),&\n! btest(svflista(lrot)%status,SVCONST),&\n! btest(svflista(lrot)%status,SVFTPF),&\n! btest(svflista(lrot)%status,SVFDOT),&\n! btest(svflista(lrot)%status,SVNOAM)\n17 format(a,i3,2x,a,i3,6l2)\n if(svflista(lrot)%narg.eq.0) goto 300\n! get values of arguments\n jv=0\n jt=0\n100 continue\n jt=jt+1\n istv=svflista(lrot)%formal_arguments(1,jt)\n! write(*,*)'MM meq_evaluate_svfun 3A',jt,istv\n if(istv.gt.-1000 .and. istv.lt.0) then\n! istv values between -1000 and -1 are (negative) indices to functions\n! istv values less than -1000 are parameter identication symbols\n! if eqnoval nonzero it indicates from which equilibrium to get its value\n ieq=svflista(lrot)%eqnoval\n!********************************************************************\n! Note!! it should be evaluated!! Not implemented ... ???\n!********************************************************************\n if(ieq.eq.0) then\n value=ceq%svfunres(-istv)\n else\n value=eqlista(ieq)%svfunres(-istv)\n endif\n! write(*,*)'in meq_evaluate_svfun 3X',ieq,istv,value\n else\n! the need for 1:10 was a new bug discovered in GNU fortran 4.7 and later\n svr=>tsvr\n! inside make_stvrec istv values less than -1000 are converted\n call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt))\n if(gx%bmperr.ne.0) goto 1000\n if(svflista(lrot)%formal_arguments(10,jt).eq.0) then\n! get state variable or symbol value ... NOTE writing a TYPE wariable !!!\n! write(*,*)'MM meq_evaluate_svfun 3D: ',svr\n call state_variable_val(svr,value,ceq)\n! error check at the end of if...\n else\n! if special_circumstances=1 return with error code (supress a value to plot)\n if(special_circumstances.eq.1) then\n! write(*,*)'MM special_circumstances: ',special_circumstances\n! error code 4373 means value supressed due to special_circumstances\n gx%bmperr=4373; goto 1000\n endif\n! state variable derivative, the denominator is the next variable\n jt=jt+1\n svr2=>tsvr2\n! write(*,*)'MM meq_evaluate_svfun 3W: ',jt,svr\n call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt))\n! write(*,77)'MM meq_eval: ',jt,&\n! (svflista(lrot)%formal_arguments(ii,jt),ii=1,10)\n77 format(a,i2,':',20i5)\n! This routine need access to subroutines in the minimizer !!!\n call meq_state_var_dot_derivative(svr,svr2,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM back from meq_state_var_dot_derivative',value\n endif\n endif\n if(gx%bmperr.ne.0) goto 1000\n jv=jv+1\n argval(jv)=value\n! write(*,*)'in meq_evaluate_svfun 3B: ',jv,jt,argval(jv)\n if(jt.lt.svflista(lrot)%narg) goto 100\n! all arguments evaluated (or no arguments needed)\n300 continue\n! write(*,'(a,5i5,2l2)')'MM in meq_evaluate_svfun 300: ',lrot,mode,ieq,&\n! svflista(lrot)%eqnoval,istv,&\n! btest(svflista(lrot)%status,SVFVAL),&\n! btest(svflista(lrot)%status,SVFEXT),&\n! btest(svflista(lrot)%status,SVCONST)\n modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then\n! if mode=0 and SVFEXT=TRUE use value from equilibrium svflista(lrot)%eqnoval\n! write(*,*)'MM symbol mode=0 SVFEXT=TRUE: ',lrot,ieq,istv,argval(1)\n ieq=svflista(lrot)%eqnoval\n if(ceq%eqno.eq.ieq) then\n value=evalf(svflista(lrot)%linkpnode,argval)\n! write(*,*)'MM symbol calculated: ',lrot,ieq,istv,argval(1)\n if(pfnerr.ne.0) then\n write(*,*)'MM evaluate_svfun putfunerror ',pfnerr\n gx%bmperr=4141; goto 1000\n endif\n! why store value in svfunres(-istv) ??? THIS MUST BE WRONG AND UNECESSARY\n! we should store the value in the function restult for this equilibrium\n ceq%svfunres(lrot)=value\n! write(*,350)'MM evaluated here: ',ieq,lrot,value\n else\n value=eqlista(ieq)%svfunres(lrot)\n ceq%svfunres(lrot)=value\n! write(*,350)'MM value from equilbrium: ',ieq,lrot,value\n endif\n elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then\n! If mode=0 and SVFVAL set then return the stored value\n! do not evaluate, just return the stored value in svfv(lrot) !!!\n! copy to current ceq!!\n value=svflista(lrot)%svfv\n ceq%svfunres(lrot)=value\n! write(*,*)'MM in meq_evaluate_svfun 19:',lrot,ieq,value\n! write(*,350)'HMS evaluate svfun 2: ',0,lrot,value,svflista(lrot)%svfv\n350 format(a,2i4,4(1pe13.5))\n! write(*,*)'MM in meq_evaluate_svfun 20: ',lrot,ieq,ceq%eqno,value\n elseif(btest(svflista(lrot)%status,SVCONST)) then\n! symbol is a constant, just return value\n value=svflista(lrot)%linkpnode%value\n ceq%svfunres(lrot)=value\n! write(*,*)'MM symbol is a constant',lrot,value\n else\n! if mode=1 always evaluate except if wrong eqilibrium!!\n! write(*,*)'in meq_evaluate_svfun 5',argval(1)\n if(svflista(lrot)%eqnoval.eq.0) then\n value=evalf(svflista(lrot)%linkpnode,argval)\n if(pfnerr.ne.0) then\n write(*,*)'evaluate_svfun putfunerror ',pfnerr\n gx%bmperr=4141; goto 1000\n endif\n ceq%svfunres(lrot)=value\n elseif(svflista(lrot)%eqnoval.eq.ceq%eqno) then\n value=evalf(svflista(lrot)%linkpnode,argval)\n! write(*,350)'HMS evaluate svfun 8: ',ieq,lrot,value,ceq%tpval(1)\n if(pfnerr.ne.0) then\n write(*,*)'evaluate_svfun putfunerror ',pfnerr\n gx%bmperr=4141; goto 1000\n endif\n ceq%svfunres(lrot)=value\n else\n ieq=svflista(lrot)%eqnoval\n value=eqlista(ieq)%svfunres(lrot)\n write(*,360)trim(svflista(lrot)%name),ieq,ceq%eqno\n360 format('Attempt to evaluate symbol ',a,&\n ' for the wrong equilibrium:',2i5)\n ceq%svfunres(lrot)=value\n endif\n endif modeval\n1000 continue\n meq_evaluate_svfun=value\n return\n end function meq_evaluate_svfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine initiate_meqrec\n!\\begin{verbatim}\n subroutine initiate_meqrec(svr,svar,meqrec,ceq)\n! this is to setup data for a state var derivative calculation\n! taken from the normal initialization of an equilibrium calculation\n! it also solves a modified equil matrix once to get delta-amounts and mu\n TYPE(meq_setup), pointer :: meqrec\n TYPE(gtp_state_variable), pointer :: svr\n double precision, allocatable :: svar(:)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(meq_phase), pointer :: pmi\n integer iph,ics,kst,ie,mph,lokph,lokcs,nz1,tcol,pcol,dncol,converged\n integer ierr,nz2,jel,ztableph1,ztableph2,ztableph3,errall\n double precision, allocatable :: smat(:,:)\n double precision xxx\n!\n! if(mmdebug.ne.0) write(*,*)'MM Entering initiate_meqrec 1'\n! NOTE svar must be allocated!!\n! svar=zero\n! write(*,*)'MM Entering initiate_meqrec 2'\n if(btest(ceq%status,EQNOEQCAL)) then\n! error if no sucessful equilibrium calculation or a failed one\n! write(*,*)'No equilibrium calculated, no derivatives'\n! allocate(svar(1)); svar(1)=zero\n gx%bmperr=4198; goto 1000\n elseif(btest(ceq%status,EQFAIL)) then\n! write(*,*)'Last equilibrium calculation failed, no derivatives'\n! allocate(svar(1)); svar(1)=zero\n gx%bmperr=4198; goto 1000\n elseif(btest(ceq%status,EQINCON)) then\n! give warning if conditions have changed\n write(*,15)\n15 format('Conditions changed since last equilibrium calc,',&\n ' values may be wrong.')\n! EQNOACS is not used at present but means probably \"no automatic comp.set\"\n! allocate(svar(1)); svar(1)=zero\n! gx%bmperr=4198; goto 1000\n endif\n! meqrec is a pointer to an allocated record!\n! allocate(meqrec)\n! we must enter data into meqrec here, some set outside ...\n! meqrec%typesofcond=2\n meqrec%nrel=noel()\n meqrec%maxsph=noel()+2\n meqrec%nfixph=ceq%nfixph\n meqrec%nfixmu=ceq%nfixmu\n! this returns total number of phases including composition sets\n! call sumofphcs(meqrec%nphase,ceq)\n! meqrec%nphase=totalphcs(ceq)\n! if we are calculating a dot_derivative the number of phases in the dynamic\n! memory may be different from that in the static memory!!\n! if(mmdotder.ne.0) write(*,*)'MM inititate_meqrec, mmdotder nonzero!'\n meqrec%nphase=nonsusphcs(ceq)\n if(gx%bmperr.ne.0) goto 1000\n allocate(meqrec%phr(meqrec%nphase),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 45: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! this means T and P are fixed (not independent)\n meqrec%tpindep=.FALSE.\n mph=0\n ztableph1=0\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 20:',noph()\n! loop for all phases, we must set values of phase number etc\n! meqrec%phr is later called \"pmi\"\n meqrec%nstph=0\n do iph=1,noph()\n do ics=1,noofcs(iph)\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(mmdotder.ne.0) then\n! test if composition set exists!! lokcs is always nonzero\n! but if the sites are not allocated the composition set does not exist\n if(allocated(ceq%phase_varres(lokcs)%sites)) then\n kst=test_phase_status(iph,ics,xxx,ceq)\n else\n! write(*,*)'MM composition set does not exist!'\n kst=PHSUS\n endif\n else\n kst=test_phase_status(iph,ics,xxx,ceq)\n endif\n! meqrec%nv=meqrec%nv+1\n if(kst.ge.PHDORM) then\n mph=mph+1\n meqrec%phr(mph)%iph=iph\n! write(*,*)'phases: ',mph,iph\n meqrec%phr(mph)%ics=ics\n! set number of constituents, DO NOT USE size(...curd%size(yfr)!!!\n meqrec%phr(mph)%ncc=noconst(iph,ics,ceq)\n meqrec%phr(mph)%phasestatus=kst\n meqrec%phr(mph)%ionliq=-1\n meqrec%phr(mph)%i2sly=0\n if(test_phase_status_bit(iph,PHIONLIQ)) meqrec%phr(mph)%ionliq=1\n! set link to calculated values of G etc.\n! call get_phase_compset(iph,ics,lokph,lokcs)\n meqrec%phr(mph)%curd=>ceq%phase_varres(lokcs)\n if(kst.ge.PHENTSTAB) then\n! this phase has the stable bit set\n ztableph1=ztableph1+1\n ztableph2=lokcs\n ztableph3=iph\n meqrec%phr(mph)%stable=1\n meqrec%nstph=meqrec%nstph+1\n! store the index of the phase in phr, not the phase number \n meqrec%stphl(meqrec%nstph)=mph\n else\n! unstable phase\n meqrec%phr(mph)%stable=0\n endif\n meqrec%phr(mph)%idim=0\n! valgrind found one case xdone was not initiated ....\n meqrec%phr(mph)%xdone=0\n! else\n! nothing to do for suspended or hidden phase\n endif\n enddo\n enddo\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 30:'\n if(ztableph1.eq.1) then\n! if there is a single stable phase, does it have fixed composition?\n! write(*,*)'MM a single stable phase',ztableph2\n if(size(ceq%phase_varres(ztableph2)%sites)-&\n size(ceq%phase_varres(ztableph2)%yfr).eq.0) then\n! write(*,*)'MM fixed composition: ',ztableph2\n xxx=-ceq%tpval(1)*ceq%phase_varres(ztableph2)%gval(4,1)\n! The problem here was created somewhere else when the function for a phase\n! to be optimized were changed, probably when trying to create\n! already existing MAPNODE records. That error not found !!\n! Calculate G for this phase !!!\n! call calcg(ztableph3,1,2,ztableph2,ceq)\n allocate(svar(1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 46: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! ATTENTION: THIS IS A VERY TEMPORARY FIX!!!!\n! gval(4,1) is the CP of a stoichiometric compound\n svar(1)=-ceq%tpval(1)*ceq%phase_varres(ztableph2)%gval(4,1)\n! write(*,321)'MM fixed composition: ',ztableph2,&\n! lokcs,xxx,svar(1),ceq%tpval(1)\n!321 format(a,2i5,4(1pe12.4))\n goto 1000\n endif\n endif\n meqrec%nphase=mph\n! keep memory of adding/removing phases\n! write(*,*)'MM total number of phases: ',mph\n! copy current values of ceq%complist%chempot(1) to ceq%cmuval, why??\n do ie=1,meqrec%nrel\n ceq%cmuval(ie)=ceq%complist(ie)%chempot(1)/ceq%rtn\n enddo\n meqrec%dormlink=0\n! This can be done in PARALLEL for all phases\n! nullify liquid pointer\n nullify(meqrec%pmiliq)\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 40:',meqrec%nphase\n do mph=1,meqrec%nphase\n! loop to calculte and invert the phase matrices\n pmi=>meqrec%phr(mph)\n! write(*,*)'Inverting phase matrix ',mph\n! This will calculate all G, dG/dZ1 and d2G/dZ1dZ2 and the inverted phase matrix\n! if(mmdebug.ne.0) write(*,*)'MM calling meq_onephase: ',mph\n call meq_onephase(meqrec,pmi,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calculating phase matrix'\n gx%bmperr=4199; goto 1000\n endif\n enddo\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 41:'\n! now we will solve a modified phase matrix and calculate svar\n! copy part of it from ceq%savesmat, copy also any fix mu and phase\n! no problem to allocate as meqrec just allocated\n if(ceq%nfixmu.gt.0) then\n meqrec%nfixmu=ceq%nfixmu\n allocate(meqrec%mufixel(meqrec%nfixmu),stat=errall)\n do mph=1,ceq%nfixmu\n meqrec%mufixel(mph)=ceq%fixmu(mph)\n enddo\n endif\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 42:'\n if(ceq%nfixph.gt.0) then\n meqrec%nfixph=ceq%nfixph\n allocate(meqrec%fixph(2,meqrec%nfixph),stat=errall)\n do mph=1,ceq%nfixph\n meqrec%fixph(1,mph)=ceq%fixph(1,mph)\n meqrec%fixph(2,mph)=ceq%fixph(2,mph)\n enddo\n endif\n! negative value of ceq%sysmatdim means no matrix saved\n nz1=abs(ceq%sysmatdim)+1\n allocate(smat(nz1,nz1+1),stat=errall)\n smat=zero\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 43:'\n allocate(svar(nz1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 47: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! savesysmat not used, all equations calculated again\n! do mph=1,nz1-1\n! do ie=1,nz1-1\n! smat(mph,ie)=ceq%savesysmat(mph,ie)\n! enddo\n! enddo \n! write(*,*)'Saved equil matrix',nz1\n! do jel=1,nz1\n! write(*,86)(smat(jel,nz2),nz2=1,nz1+1)\n! enddo\n!86 format(6(1pe12.4))\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 44:'\n tcol=0\n pcol=0\n! dncol is number of variable potentials (including T or P if variable)\n dncol=meqrec%nrel-meqrec%nfixmu\n converged=-1\n if(svr%statevarid.eq.1) then\n tcol=nz1\n meqrec%tpindep(1)=.TRUE.\n elseif(svr%statevarid.eq.2) then\n pcol=nz1\n meqrec%tpindep(2)=.TRUE.\n else\n write(*,*)'Derivatives with respect to T and P allowed only'\n gx%bmperr=4213; goto 1000\n endif\n!-------------------------------------------------------------------\n! if(mmdebug.ne.0) write(*,854)'dncol mm: ',tcol,pcol,dncol,converged,nz1\n854 format(a,10i5)\n call setup_equilmatrix(meqrec,meqrec%phr,nz1,smat,tcol,pcol,&\n dncol,converged,ceq)\n! set all terms in the RHS to zero\n nz2=nz1+1\n do mph=1,nz1\n smat(mph,nz2)=zero\n enddo\n!\n! Add extra variable Delta-T for all stable phases: this is dG/dT\n! This is redundant now??\n do mph=1,meqrec%nstph\n jel=meqrec%stphl(mph)\n smat(mph,nz1)=-meqrec%phr(jel)%curd%gval(2,1)\n enddo\n! this is the line for Delta T or Delta P, all terms zero except last\n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 48:'\n smat(nz1,nz1)=one\n smat(nz1,nz2)=one\n! check matrix and rhs\n! write(*,*)'Equil matrix and solution in MM initiate_meqrec'\n! do jel=1,nz1\n! write(*,89)jel,(smat(jel,nz2),nz2=1,nz1+1)\n! enddo\n89 format('MM qq: ',i2,6(1pe12.4))\n! solve equil matrix \n! if(mmdebug.ne.0) write(*,*)'MM initiate_meqrec 50:',nz1\n call lingld(nz1,nz1+1,smat,svar,nz1,ierr)\n if(ierr.ne.0) then\n write(*,*)'MM initiate_meqrec: error in lingld',ierr,nz1,ceq%eqno\n! do jel=1,nz1\n! write(*,89)jel,(smat(jel,nz2),nz2=1,nz1+1)\n! enddo\n! write(*,89)0,(svar(jel),jel=1,nz1)\n gx%bmperr=4214; goto 1000\n! else\n endif\n! write(*,89)0,(svar(jel),jel=1,nz1)\n1000 continue\n return\n end subroutine initiate_meqrec ! allocated svar ??\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_state_var_dot_derivative\n!\\begin{verbatim}\n subroutine meq_state_var_dot_derivative(svr1,svr2,value,ceq)\n! calculates a state variable value, dot derivative, (in some cases)\n! svr1 and svr2 identifies the state variables in (dstv1/dstv2)\n! check that svr2 2 is a condition\n! value is calculated value\n! ceq is current equilibrium\n! NOTE that when plotting after a STEP/MAP the number of phases in the\n! dynamic memory (ceq) may be different that the static memory\n! this is indicated by setting mmdotder nonzero\n!\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_state_variable), pointer :: svr1,svr2\n double precision value\n!\\end{verbatim}\n! variables needed to calculate phase inverse\n TYPE(meq_setup), allocatable, target :: meqrec1\n TYPE(meq_setup), pointer :: meqrec\n ! TYPE(meq_phase), pointer :: pmi\n TYPE(gtp_condition), pointer :: pcond\n integer iel,mph,jj,nterm,errall\n double precision xxx,sumam,summass,sumvol,s298\n double precision, allocatable :: svar(:)\n character dum*128,elsym*2\n!\n! this indicate that the number of phases in ceq may be different from\n! the static number of phases\n mmdotder=1\n value=zero\n! write(*,*)'MM meq_state_var_dot_derivative 1'\n! if(svr2%statevarid.ne.1) then\n! This if statement added trying to avoid spurious error (caused by -O2??)\n! write(dum,*)'In meq_state_var_value_derivative:',&\n! svr2%statevarid,ceq%tpval(1)\n! endif\n! we must check if there is a condition on svr2\n pcond=>ceq%lastcondition\n if(.not.associated(pcond)) then\n! write(*,*)'There are no conditions at all!'\n gx%bmperr=4143; goto 1000\n endif\n! all conditions have just one term at present\n nterm=1\n call get_condition(nterm,svr2,pcond)\n if(gx%bmperr.ne.0) then\n write(*,71)\n71 format('To calculate a derivative the state variable after the dot',&\n ' must be a condition')\n goto 1000\n elseif(pcond%active.eq.1) then\n! active=1 means not active\n write(*,71)\n goto 1000\n endif\n! Currently only implemented H.T and HM.T\n if(.NOT.(svr2%statevarid.eq.1 .or. svr2%statevarid.eq.2)) then\n write(*,*)'Derivatives with respect to T and P only'\n gx%bmperr=4213; goto 1000\n endif\n!------------\n! write(*,17)'minimzer: meq_state_var_value_derivative: ',&\n! svr1%statevarid,svr1%oldstv,svr1%argtyp,&\n! svr2%statevarid,svr2%oldstv,svr2%argtyp\n!17 format(a,10i4)\n! meqrec creates the data structure for the equilibrium data\n! this routine also calculated Delta-amount of phases and delta-mu\n allocate(meqrec1,stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 48: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! problems with map7 ???\n meqrec1%status=0\n meqrec=>meqrec1\n! write(*,88)'MM calling initiate_meqrec',svr2%statevarid,ceq%eqno\n88 format(a,2i4)\n! indicate this is not an iteration by setting iteration number to -1\n meqrec%noofits=-1\n! looking for segmentation fault from CP calculation when plotting\n! mmdebug=1\n! initiate_meqrec will ignore nonexisting compostion sets\n call initiate_meqrec(svr2,svar,meqrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM back from initiate_meqrec in meq_state_var_dot_derivative'\n! mmdebug=0\n! addremloop\n iel=size(svar)\n! write(*,18)(svar(jj),jj=1,iel)\n18 format('svar: ',6(1pe12.4),(6x,6e12.4))\n if(iel.eq.1) then\n! iel=1 means a single stoichiometrc phase stable, svar(1) is CP/RT/T ??\n! There can be a phase specification ... \n if(svr1%statevarid.ge.6 .and. svr1%statevarid.lt.15 .and. &\n svr1%argtyp.eq.2) then\n! write(*,*)'MM Single stoichiometric phase stable',iel,svr1%argtyp\n! nothing done?\n continue\n else\n if(svr1%norm.eq.2) then\n! it is HW.T ....! where is mass of the phase? Which phase? Which element?\n! write(*,*)'MM single phase stable which phase?'\n if(noel().eq.1) then\n call get_element_data(1,elsym,dum(1:24),dum(25:48),summass,&\n xxx,s298)\n if(gx%bmperr.ne.0) goto 1000\n endif\n value=svar(1)*ceq%rtn/summass\n else\n value=svar(1)*ceq%rtn\n endif\n goto 1000\n endif\n endif\n!---------------\n!100 continue\n! if no phase specified loop over all stable phases\n! write(*,*)'We have initiad meqrec: ',svr1%statevarid\n if(svr1%statevarid.eq.3 .and. svr2%statevarid.eq.1) then\n! This is MU(X).T\n! it should simply be svar(svr1.%component) !!\n! write(*,*)'MM: MU(A).T: ',svr1%argtyp,svr1%component\n iel=svr1%component\n call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,&\n svar,jj,xxx,ceq)\n value=xxx*ceq%rtn\n! there can be a suffix S ??\n! gx%bmperr=4215; goto 1000\n! CCI already corrected\n elseif(svr1%statevarid.ge.6 .and. svr1%statevarid.lt.15) then\n! This is derivatives of U, S, etc, H has svr1%statevarid=9, oldstv=40\n! Partly DONE: implement H(phase).T and normalizing \n iel=0\n jj=1\n sumam=zero\n summass=zero\n sumvol=zero\n! write(*,*)'MM Calculating H.T',svr1%argtyp,meqrec%nphase\n! This \"if\" statement should be included in the loop below\n if(svr1%argtyp.eq.2) then\n! if argtyp=2 then it is a value for a single phase\n! write(*,*)'MM svr1%argtyp 1: ',svr1%argtyp,svr1%phase,svr1%compset\n fph: do mph=1,meqrec%nphase\n! write(*,*)'fphloop: ',mph,meqrec%phr(mph)%iph,meqrec%phr(mph)%ics\n! what is meqrec%iphl(mph) ???\n! if(meqrec%iphl(mph).eq.svr1%phase .and.&\n! meqrec%icsl(mph).eq.svr1%compset) exit fph\n if(meqrec%phr(mph)%iph.eq.svr1%phase .and.&\n meqrec%phr(mph)%ics.eq.svr1%compset) exit fph\n enddo fph\n66 if(mph.gt.meqrec%nphase) then\n gx%bmperr=4050; goto 1000\n endif\n! dummy statement to avoid some strange unknown error calculating Cp\n write(dum,*)'MM svr1%argtyp 2: ',svr1%argtyp,mph,iel\n call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,&\n svar,jj,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM HM(phase).T: ',xxx,meqrec%phr(mph)%curd%abnorm(1),&\n! meqrec%phr(mph)%curd%amfu\n! normalized? svr1%norm>0\n if(svr1%norm.ne.0) then\n if(svr1%norm.eq.1) then\n! xxx is HM for one formula unit. if %norm=1 return HM.T \n value=xxx/meqrec%phr(mph)%curd%abnorm(1)\n elseif(svr1%norm.eq.2) then\n! xxx is HW per mass HW.T\n value=xxx/meqrec%phr(mph)%curd%abnorm(2)\n elseif(svr1%norm.eq.3) then\n! norm=3 per volume HV.T\n write(*,*)'Normalizing per volume not implemented: ',svr1%norm\n gx%bmperr=4399; goto 1000\n elseif(svr1%norm.eq.4) then\n! norm=4 per formula unit, HF.T\n value=xxx\n else\n! no other normallizing\n write(*,*)'Unown normalizing: ',svr1%norm\n gx%bmperr=4399; goto 1000\n endif\n else\n! not normalized value for a single phase, if amount zero return zero\n if(meqrec%phr(mph)%curd%amfu.eq.zero) then\n! elseif %amfu=0 return H.T=0\n value=zero\n else\n! else returm HM.T*NP(alpha) ???\n value=xxx*meqrec%phr(mph)%curd%amfu/meqrec%phr(mph)%curd%abnorm(1)\n endif\n endif\n goto 77\n endif\n! sum over all stable phases\n do mph=1,meqrec%nphase\n! ignore phases with zero amount\n if(meqrec%phr(mph)%curd%amfu.gt.zero) then\n! the hope is that the phase amounts in svar are in the same order as\n! in svar as ordered in meqrec%phr ...\n! SEGMENTATION FAULT on LINUX with -O2 unless write statement at 69 is there\n! It happends in macro step1 if you run all macros. No error if just step1\n! STRANGE !!!\n call meq_calc_phase_derivative(svr1,svr2,meqrec,mph,iel,&\n svar,jj,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n sumam=sumam+&\n meqrec%phr(mph)%curd%amfu*meqrec%phr(mph)%curd%abnorm(1)\n summass=summass+&\n meqrec%phr(mph)%curd%amfu*meqrec%phr(mph)%curd%abnorm(2)\n jj=jj+1\n! this dummy write statement is to avoid SEGMENTATION FAULT when -O2\n! The segmentation fault persists also in oc5P if this write removed!!\n! write(dum,69)'MM der: ',mph,ceq%tpval(1),value,xxx,&\n! meqrec%phr(mph)%curd%amfu\n69 format(a,i3,6(1pe14.6))\n else\n xxx=zero\n endif\n value=value+xxx\n enddo\n if(svr1%norm.eq.1) then\n! normallize with respect to number of moles of atoms\n! write(*,*)'MM sumam: ',value,sumam\n value=value/sumam\n elseif(svr1%norm.eq.2) then\n! xxx is HW per mass HW.T\n value=value/summass\n elseif(svr1%norm.ne.0) then\n! no other normallizing implemented\n write(*,*)'Illegal normalizing: ',svr1%norm\n gx%bmperr=4399; goto 1000\n endif\n77 continue\n elseif(svr1%statevarid.eq.17) then\n! This should be x(phase,element).T\n! write(*,*)'MM: X(PHASE,A).T not implemented',svr1%argtyp,svr1%phase,&\n! svr1%compset,svr1%component\n do mph=1,meqrec%nphase\n if(svr1%phase.eq.meqrec%phr(mph)%iph .and. &\n svr1%compset.eq.meqrec%phr(mph)%ics) then\n call meq_slope(mph,svr1,meqrec,value,ceq)\n write(*,*)'meq_slope: Not implemented x(phase,element).T'\n gx%bmperr=4215; goto 1000\n endif\n enddo\n! write(*,*)'No such phase'\n! gx%bmperr=4050\n else\n write(*,900)svr1%statevarid,svr1%argtyp,svr1%phase,svr1%compset,&\n svr1%component\n900 format('MM: this dot derivative not implemented',6i5)\n gx%bmperr=4215; goto 1000\n endif\n1000 continue\n! meqrec1 deallocated automatically?\n if(allocated(meqrec1)) deallocate(meqrec1)\n! if(svr2%statevarid.ne.1) then\n! This if statement added trying to avoid spurious error (caused by -O2??)\n! write(dum,*)'MM exit meq_state_var_value_derivative',value\n! endif\n! reset mmdotder to zero\n! write(*,*)'MM exit meq_state_var_dotderivative'\n mmdotder=0\n return\n end subroutine meq_state_var_dot_derivative\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n \n!\\addtotable subroutine meq_calc_phase_derivative\n!\\begin{verbatim}\n subroutine meq_calc_phase_derivative(svr1,svr2,meqrec,iph,iel,&\n svar,jj,value,ceq)\n! Calculate contribution for one phase, one or all elements\n! svr1 and svr2 identifies the state variables in (dstv1/dstv2)\n! value is calculated value returned\n! iph and iel indicate possible phase or element\n! svar is solution to equil matrix, potentials and phase amounts\n! jj is an attempt to index phases in svar, starting with 1\n! ceq is current equilibrium\n!\n! THIS IS UNFINISHED can only handle H.T\n!\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_state_variable), target :: svr1,svr2\n TYPE(meq_setup), pointer :: meqrec\n integer iph,iel,jj\n double precision value,svar(*)\n!\\end{verbatim}\n! variables needed to calculate phase inverse\n TYPE(meq_phase), pointer :: pmi\n integer jy,jel,jz,phncc,errall\n double precision x1,x2,x3\n double precision mag,mat,map,dpham,musum,dy,hconfig\n double precision, allocatable :: mamu(:)\n!\n! THE MASTER VERSION OF THIS TABLE in GTP3C.F90\n! symb cmix(2) indices statevarid Property\n! U 10 (phase#set) 6 Internal energy (J)\n! UM 11 \" 6 per mole components\n! UW 12 \" 6 per kg\n! UV 13 \" 6 per m3\n! UF 14 \" 6 per formula unit\n! S 2x \" 7 entropy\n! V 3x \" 8 volume\n! H 4x \" 9 enthalpy\n! A 5x \" 10 Helmholtz energy\n! G 6x \" 11 Gibbs energy\n! NP 7x \" 12 moles of phase\n! BP 8x \" 13 mass of moles\n! DG 9x \" 15 ? Driving force\n! Q 19x \" 14 ? Internal stability\n! N 11x (component/phase#set,component) 16 moles of components\n! X 111 \" 17 mole fraction of components\n! B 12x \" 18 mass of components\n! W 122 \" 19 mass fraction of components\n! Y 13 phase#set,constituent#subl 20 constituent fraction\n! statevarid=1 is T, 2 is P, 3 is MU, 4 is AC, 5 is LNAC\n!------------------------------------------------------------\n! write(*,*)'MM meq_calc_phase_derivative',iph,iel\n allocate(mamu(meqrec%nrel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 49: ',errall\n gx%bmperr=4370; goto 1000\n endif\n pmi=>meqrec%phr(iph)\n value=zero\n! CCI\n hconfig=zero\n if(iel.lt.0) then\n! sum for all elements\n write(*,*)'sum over elements not implemented'\n gx%bmperr=4216\n elseif(iel.eq.0) then\n! independent of element, return for phase\n musum=zero\n! pmi%ncc here is not set correctly ... WHEN?\n! phncc=size(pmi%curd%yfr)\n phncc=pmi%ncc\n! PROBLEM 181208: step5 macro: size(pmi%curd%yfr) is 1000 (default)\n! but pmi%ncc is 8 (total number of constituents)\n! I do not remember why this was changed\n! write(*,*)'MM derivative: ',iph,pmi%ncc,phncc\n! do jy=1,pmi%ncc\n do jy=1,phncc\n! The loop to handle the contribution from fractions in each phase dZ/dyi\n dy=zero\n! special if just a single element ...\n if(allocated(pmi%invmat)) then\n call calc_dgdyterms2(jy,meqrec%nrel,mamu,mag,mat,map,pmi)\n if(gx%bmperr.ne.0) goto 1000\n else\n! we have a stoichiometric phase with a single component ??\n! write(*,*)'MM No inverted phase matrix allocated',jy\n mamu=zero; mag=zero\n! gx%bmperr=4399; goto 1000\n endif\n jz=1\n if(meqrec%nfixmu.gt.0) then\n! if there are fixed potentials such elements should be ignored here\n! as there is no value in svar (value is zero as fixed)\n write(*,*)'Dot derivatives with potential condition not implemented'\n goto 1000\n endif\n! sum the contribution for the potentials\n do jel=1,meqrec%nrel\n jz=jz+1\n dy=dy+mamu(jel)*svar(jel)\n! write(*,666)'dy: ',mamu(jel),svar(1),dy\n enddo\n dy=dy-mat\n! write(*,666)'dy: ',mat,dy\n! here we check which state variable we take derivative of, H is 9\n! write(*,*)'MM svr1: ',svr1%statevarid,svr1%norm\n select case(svr1%statevarid)\n case default\n! state variables 1..5 are potentials, 14-15 not possible to derivate\n write(*,*)'Illegal state variable id:',svr1%statevarid\n gx%bmperr=4188; goto 1000\n case(6) !U = G + TS - PV = G - T G.T - P G.P\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(7) !S = -G.T\n hconfig=-pmi%curd%dgval(2,jy,1)\n case(8) !V = G.P\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(9) !H = G + TS = G - T G.T\n! this gives contribution also when plotting H(liq).T and HM(liq).T in step1\n! but it is identical to Thermo-Calc .... thus correct\n hconfig=pmi%curd%dgval(1,jy,1)-ceq%tpval(1)*pmi%curd%dgval(2,jy,1)\n case(10) !A = G - PV = G - P G.P\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(11) !G itself, dG/dy\n hconfig=pmi%curd%dgval(1,jy,1)\n case(12) !NP phase amount\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(13) !BP phase mass\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(16) !N\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(17) !X\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(18) !B\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(19) !W\n write(*,*)'Not implemented yet: ',svr1%statevarid\n case(20) !Y\n write(*,*)'Not implemented yet: ',svr1%statevarid\n end select\n! if(svr1%statevarid.eq.9) then\n! hconfig=pmi%curd%dgval(1,jy,1)-ceq%tpval(1)*pmi%curd%dgval(2,jy,1)\n! endif\n musum=musum+hconfig*dy\n! write(*,*)'musum: ',musum,dy\n enddo\n x1=zero; x2=zero\n! write(*,765)'x3= ',ceq%rtn,pmi%curd%amfu,musum\n if(svr1%norm.eq.1 .and. svr1%argtyp.eq.2) then\n! for HM(phase).T the change in of phase amount should be ignored\n dpham=zero\n x3=musum*ceq%rtn\n else\n! extract the change in phase amount (for stable phases!!!)\n! we have to take care of fixed chemical potentials, the number of\n! elements+1-(#fixed mu) should be the index of dpham,\n! the change in phase amount\n! The way of indexing with jj is dangerous ...\n dpham=svar(meqrec%nrel+jj)\n! for current amount\n x3=musum*ceq%rtn*pmi%curd%amfu\n endif\n! write(*,665)'dpham: ',meqrec%nrel,jj,svar(meqrec%nrel+jj-1),&\n! svar(meqrec%nrel+jj)\n665 format(a,2i3,6(1pe14.6))\n! here we again select the state variable we take derivative of, H is 9\n! write(*,*)'MM svr2: ',svr1%statevarid,svr1%norm\n select case(svr1%statevarid)\n case default\n! state variables 1..5 are potentials, 14-15 not possible to derivate\n write(*,*)'Illegal state variable id:',svr1%statevarid\n gx%bmperr=4188; goto 1000\n case(6) !U = G + TS - PV\n write(*,*)'Not implemented yet: ',svr1%statevarid\n gx%bmperr=4215\n case(7) !S = -dG/dT\n x1=-ceq%rtn*dpham*pmi%curd%gval(2,1)\n x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1)\n write(*,*)'Not implemented yet: ',svr1%statevarid\n gx%bmperr=4215\n case(8) !V = dG/dP\n write(*,*)'Not implemented yet: ',svr1%statevarid\n gx%bmperr=4215\n case(9) !H = G + TS = G - T G.T\n! x1 is change in phase amount times H. Skip this if svr1%norm.eq.1 \n x1=-ceq%rtn*dpham*&\n (pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1))\n! write(*,666)'x1: ',ceq%rtn,dpham,pmi%curd%gval(1,1),&\n! ceq%tpval(1)*pmi%curd%gval(2,1),x1\n! x2 is phase_amount * dH/dT = .. -T*d2G/dT2 = -T\n! CCI changed order of tests, does not work for step1\n if(dpham.ne.zero) then\n! there is a change in phase amounts\n x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1)\n elseif(svr1%norm.eq.1) then\n!xCCI if(svr1%norm.eq.1) then\n! compared with Thermo-Calc this seems correct, it is just HM(phase).T\n x2=-ceq%rtn*ceq%tpval(1)*pmi%curd%gval(4,1)\n! write(*,444)'Phase: ',iph,x1,x2,x3\n!444 format(a,i3,3(1pe14.6))\n!xCCI else\n!xCCI x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1)\n else\n! This is H.T or H(phase).T, should be (amount of phase)*HM.T\n! when there is no change of amount of phase\n x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1)\n endif\n! CCI end of correction\n case(10) !A = G - PV\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(11) !G itself\n x1=-ceq%rtn*dpham*pmi%curd%gval(1,1)\n x2=ceq%rtn*pmi%curd%amfu*pmi%curd%gval(2,1)\n! write(*,*)'G.T: ',x1,x2\n case(12) !NP phase amount\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(13) !BP phase mass\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(16) !N moles\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(17) !X mole fraction\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(18) !B mass\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(19) !W mass fraction\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n case(20) !Y constituent fraction\n write(*,*)'Not implemeneted yet: ',svr1%statevarid\n end select\n! if(svr1%statevarid.eq.9) then\n! x1 is change in phase amount times H\n! x1=-ceq%rtn*dpham*(pmi%curd%gval(1,1)-ceq%tpval(1)*pmi%curd%gval(2,1))\n! x2 is phase_amount * dH/dT = .. -T*d2G/dT2 = -T\n! x2=-ceq%rtn*pmi%curd%amfu*ceq%tpval(1)*pmi%curd%gval(4,1)\n! endif\n! x3 is phase amount times change in configuration\n! x3=ceq%rtn*pmi%curd%amfu*musum\n! only derivativs wrt T are allowed!!\n! write(*,666)'CP= ',svr1%norm,x1,x2,x3,x1+x2+x3,dpham,pmi%curd%amfu\n666 format(a,i3,6(1pe12.4))\n! just to show the error\n! value=x2\n value=x1+x2+x3\n else\n! the derivative of the chemical potential of iel wrt T\n value=svar(iel)\n! write(*,*)'Chemical potential: ',iel,value\n! gx%bmperr=4215\n endif\n!\n1000 continue\n return\n end subroutine meq_calc_phase_derivative\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine meq_slope\n!\\begin{verbatim}\n subroutine meq_slope(mph,svr,meqrec,value,ceq)\n! Test subroutine for x(phase,A).T UNFINISHED\n TYPE(meq_setup) :: meqrec\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_state_variable) :: svr\n double precision value\n integer mph\n!\\end{verbatim}\n! TYPE(meq_phase), pointer :: pmi\n integer nsl,nkl(10),knr(maxconst)\n double precision yarr(maxconst),sites(10),qq(5)\n! \n call get_phase_data(svr%phase,svr%compset,nsl,nkl,knr,yarr,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! UNFINISHED\n!\n1000 continue\n return\n end subroutine meq_slope\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calfun\n!\\begin{verbatim}\n subroutine calfun(m,n,x,f,info,niter)\n! This is called by the LMDIF1 routines and calls an OC subroutine\n! as I had problems using EXTERNAL\n! M is number of errors\n! N is number of variables\n! NOTE order of X and F switched in CALFUN and ASSESSMENT_CALFUN !!!\n integer m,n,info,i,niter\n double precision f(m),x(n)\n!\\end{veratim}\n double precision sum\n! write(*,*)'MM enter calfun',info,niter,m,n\n if(info.eq.0) then\n sum=zero\n do i=1,m\n sum=sum+f(i)**2\n enddo\n if(niter.eq.-100) then\n continue\n elseif(niter.lt.0) then\n! this marks end of optimization output of the individual errors\n write(*,15)-niter,sum\n15 format(/'Final results after ',i3,&\n ' iteration, the sum of squares',1pe14.6)\n write(*,16)x\n16 format('Scaled param: ',4(1pe14.6)/5(1pe14.6))\n write(*,17)f\n17 format('Errors: '/6(1pe13.5))\n write(*,*)\n elseif(niter.ge.0) then\n write(*,18)niter,sum\n18 format(/'After ',i4,' iterations the sum of squares',1pe14.6)\n write(*,19)x\n19 format('Scaled param: ',4(1pe16.8)/5(1pe16.8))\n endif\n else\n! This routine is in the matsmin.F90 file\n! it returns the calculated value of the property to fit\n! This call removed and the whole subroutine is probably redundant\n call assessment_calfun(m,n,f,x)\n endif\n return\n end subroutine calfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine assessment_calfun\n!\\begin{verbatim}\n subroutine assessment_calfun(nexp,nvcoeff,errs,xyz)\n! nexp is number of experiments, nvcoeff number of coefficients\n! errs is the differences between experiments and value calculated by model\n! returned by this subroutine\n! xyz are the scaled current model parameter values\n implicit none\n integer nexp,nvcoeff\n double precision errs(*),XYZ(*)\n! type(gtp_assessmenthead), pointer :: ash\n!\\end{verbatim}\n! firstash is the data structure for assessment head (globally declared) \n integer i1,i2,iexp,symsym,mode,jj,savix,next\n double precision xxx,yyy,zzz\n type(gtp_equilibrium_data), pointer :: equil\n type(gtp_condition), pointer :: experiment\n type(gtp_state_variable), pointer :: svrrec\n character text*24\n double precision xa(100)\n!\n! write(*,*)'MM in assessment_calfun',nexp,nvcoeff\n! if(allocated(calcexp)) write(*,*)'Calculating Jacobian'\n! 1. copy values of X to the TP coefficinets, loop through all\n i2=1\n do i1=0,size(firstash%coeffstate)-1\n! write(*,*)'MM2 Testing value of firstash%coeffstate',i1\n if(firstash%coeffstate(i1).ge.10) then\n! write(*,*)'MM3 coefficient ',i1,i2,xyz(i2)\n! Attempt to handle that I divide coef with scaling factor ...\n zzz=xyz(i2)*firstash%coeffscale(i1)\n xxx=xyz(i2)*firstash%coeffscale(i1)\n call get_value_of_constant_index(firstash%coeffindex(i1),zzz)\n! write(*,16)i2,i1,xyz(i2),firstash%coeffscale(i1),xxx,zzz\n16 format('MM4 Opt coeff ',2i4,4(1pe12.4))\n savix=i1\n call change_optcoeff(firstash%coeffindex(i1),xxx)\n if(gx%bmperr.ne.0) goto 1000\n xa(i2)=xxx\n i2=i2+1\n! else\n! write(*,*)'MM5 coefficient not variable',i1\n endif\n enddo\n! 2. calculate all differences, skipping equilibria with weight zero\n! the array firstash%eqlista contain pointers to equilibria with experiments\n700 continue\n if(.not.allocated(firstash%eqlista)) then\n write(kou,*)' *** Warning: no experimental data!'\n do i1=1,nexp\n errs(i1)=zero\n enddo\n goto 1000\n! else\n! write(*,*)'MM6 First equilibrium number: ',firstash%firstexpeq\n! write(*,17)size(firstash%eqlista),firstash%firstexpeq\n17 format('MM Number of equilibra with experiments: ',i5,', first is ',i3)\n! do i1=1,size(firstash%eqlista)\n! write(*,21)i1,firstash%eqlista(i1)%p1%eqname\n!21 format('MM Equilibrium number ',i3,' and name: ',a)\n! enddo\n endif\n! Seach for any symbol that should be calculated at a particulat equilibrium\n! For example a reference enthalpy. This equilibrium must be calculated\n! before any parallel calculation of the others\n next=-1\n do while(next.ne.0)\n call find_symbol_with_equilno(next,i1)\n! write(*,*)' ******* checking for equilibrium to be calculated first'\n if(i1.gt.0) then\n if(firstash%eqlista(i1)%p1%weight.gt.zero) then\n equil=>firstash%eqlista(i1)%p1\n! write(*,*)' ******* equilibrium to be calculated first: ',i1\n! Force recalculation of all TP functions and parameters by changing saved T\n! This does not change the value of T used for the equilibrium\n equil%eq_tpres%tpused(1)=equil%tpval(1)+one\n! calculate the equilibria without grid minimizer\n mode=-1\n call calceq3(mode,.FALSE.,equil)\n if(gx%bmperr.ne.0) then\n write(kou,33)gx%bmperr,equil%eqno,trim(equil%eqname)\n gx%bmperr=0\n endif\n text=' '\n! evaluate symbol \"next\" (which is current!!) with force \n xxx=evaluate_svfun_old(next,text,1,equil)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0\n xxx=meq_evaluate_svfun(next,text,1,equil)\n endif\n! we do not need the value here, it is stored at the symbol\n! write(*,*)'MM Symbol at equil: ',next,i1,gx%bmperr,xxx\n endif\n endif\n enddo\n! loop through all equilibria with experiments\n! each can be calculated in parallel\n iexp=0\n if(gx%bmperr.ne.0) then\n write(*,*)'In assessment_calfun: resting error code: ',gx%bmperr\n gx%bmperr=0\n endif\n eqloop: do i1=1,size(firstash%eqlista)\n if(firstash%eqlista(i1)%p1%weight.eq.zero) then\n! write(*,29)i1,firstash%eqlista(i1)%p1%eqname\n29 format('MM Skipping equilibrium number ',i3,' and name: ',a)\n cycle eqloop\n endif\n! write(*,30)i1,trim(firstash%eqlista(i1)%p1%eqname)\n30 format('MM Assessment_calfun equilibrium number ',i3,' and name: ',a)\n equil=>firstash%eqlista(i1)%p1\n! Force recalculation of all TP functions and parameters by changing saved T\n equil%eq_tpres%tpused(1)=equil%tpval(1)+one\n! calculate the equilibria without grid minimizer\n! write(*,*)'MM calculating equil: ',equil%eqno\n! mode=-1 do not use gridmin and check after ...\n mode=-1\n call calceq3(mode,.FALSE.,equil)\n if(gx%bmperr.ne.0) then\n write(kou,33)gx%bmperr,equil%eqno,trim(equil%eqname)\n33 format(' *** Error ',i5,' calculating equilibrium no: ',i5,&\n ' with name ',a)\n gx%bmperr=0\n cycle\n! else\n! write(*,*)'Equilibrium calculated for ',equil%eqname\n endif\n! loop through all experiments, pointer set to first\n if(.not.associated(equil%lastexperiment)) then\n! write(*,*)'No experiments for equilibrium ',equil%eqno\n cycle eqloop\n endif\n experiment=>equil%lastexperiment%next\n! current value of the experiment\n500 continue\n iexp=iexp+1\n! write(*,*)'MM Setting pointer to experiment ',&\n! allocated(experiment%statvar),iexp\n nostv: if(.not.allocated(experiment%statvar)) then\n symsym=experiment%statev\n text=' '\n! WE MUST EVALUATE ALL SYMBOLS!!!\n call meq_evaluate_all_svfun(-1,equil)\n! write(*,*)'MM symsym: ',symsym\n xxx=evaluate_svfun_old(symsym,text,1,equil)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0\n! write(*,*)'MM using meq_evaluate_svfun',gx%bmperr\n xxx=meq_evaluate_svfun(symsym,text,1,equil)\n endif\n! write(*,*)'MM value: ',iexp,xxx\n else\n svrrec=>experiment%statvar(1)\n! write(*,*)'MM exp: ',svrrec%statevarid,svrrec%argtyp\n! svrrec%statevarid = 0 means symbol ...\n! this can handle state variable symbols also !!??\n call state_variable_val(svrrec,xxx,equil)\n endif nostv\n if(gx%bmperr.ne.0) then\n write(kou,*)' *** Error calculating experiment ',&\n equil%eqno,': ',trim(equil%eqname),symsym,gx%bmperr\n gx%bmperr=0\n errs(iexp)=zero\n goto 590\n endif\n if(experiment%symlink2.gt.0) then\n! added check if uncertainity is a symbol\n! xxx=evaluate_svfun_old(istv,' ',mode,ceq)\n! xxx=evaluate_svfun_old(symsym,text,1,equil)\n experiment%uncertainty=&\n evaluate_svfun_old(experiment%symlink2,' ',1,equil)\n endif\n! write(*,510)'MM errs',iexp,experiment%prescribed,xxx,&\n! experiment%uncertainty,equil%weight\n510 format(a,i4,6(1pe12.4))\n if(allocated(calcexp)) then\n! this is to enable calculating RSD at the end of an assessment\n! normally calcexp is not allocated!!\n calcexp(iexp)=xxx\n! write(*,555)'Jacobian: ',iexp,(xa(jj),jj=1,i2-1),xxx\n555 format(a,i3,6(1pe12.4))\n endif\n if(experiment%experimenttype.eq.0) then\n! take the difference between prescribed value\n errs(iexp)=(experiment%prescribed-xxx)*equil%weight/&\n experiment%uncertainty\n! write(*,*)'MM least.sq: ',iexp,f(iexp)\n elseif(experiment%experimenttype.eq.100) then\n! relative error\n yyy=1.0D-2*experiment%uncertainty*experiment%prescribed\n errs(iexp)=(experiment%prescribed-xxx)*equil%weight/yyy\n elseif(experiment%experimenttype.eq.-1) then\n! less than, uncertainty is penalty function factor\n if(xxx.gt.experiment%prescribed) then\n errs(iexp)=(xxx-experiment%prescribed)*equil%weight/&\n experiment%uncertainty\n else\n errs(iexp)=zero\n endif\n elseif(experiment%experimenttype.eq.1) then\n! larger than, uncertainty is penalty function factor\n if(xxx.lt.experiment%prescribed) then\n errs(iexp)=(xxx-experiment%prescribed)*equil%weight/&\n experiment%uncertainty\n else\n errs(iexp)=zero\n endif\n endif\n590 if(.not.associated(experiment,equil%lastexperiment)) then\n! if more experiments jump back to 500\n experiment=>experiment%next\n goto 500\n endif\n! done all experiments for this equilibrium\n enddo eqloop\n! write(*,*)'MM assessment_calfun calculated experiments: ',iexp,nexp\n! We have to restore the last value of the last coefficient\n if(allocated(calcexp)) then\n! write(*,*)'MM restore savix: ',savix,zzz\n call change_optcoeff(firstash%coeffindex(savix),zzz)\n endif\n1000 continue\n! write(*,*)'Exit assessment_calfun'\n return\n end subroutine assessment_calfun\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine listoptshort\n!\\begin{verbatim}\n subroutine listoptshort(lut,mexp,nvcoeff,errs)\n! short listing of optimizing variables and result\n integer lut,mexp,nvcoeff\n double precision, allocatable, dimension(:) :: errs\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: neweq\n integer i1,i2,j1,j2,j3,neq\n character name1*24,line*80\n double precision xxx,sum\n type(gtp_condition), pointer :: experiment\n!\n! list all experiments, only possible if there are experiments\n! write(*,*)'MM looking for segfault error in listoptshort'\n if(mexp.eq.0) then\n write(lut,666)\n666 format(/'No experiments so no results'/)\n goto 1000\n endif\n! list experiments, mexp is number of EXPERIMENTS, not equilibria!!\n write(lut,620)size(firstash%eqlista),mexp\n620 format(/'List of ',i5,' equilibria with ',i5,&\n ' experimental data values'/&\n! ' No Equil name Weight Experiment $ calculated',18x,&\n ' No Equil name Weight Property=experiment $ calculated',13x,&\n 'Error')\n j3=0\n! write(*,*)'MM segfault1:',size(firstash%eqlista)\n allequil: do i1=1,size(firstash%eqlista)\n! skip equilibria with zero weight\n! write(*,*)'MM segfault error 1'\n neweq=>firstash%eqlista(i1)%p1\n if(neweq%weight.eq.zero) cycle allequil\n name1=neweq%eqname(1:12)\n! LOOP for all experiments for this equilibrium (maybe none??)\n if(.not.associated(neweq%lastexperiment)) cycle allequil\n! write(*,*)'MM segfault error 2'\n experiment=>neweq%lastexperiment%next\n if(.not.associated(experiment)) cycle allequil\n!700 continue\n i2=neweq%lastexperiment%seqz\n! write(*,*)'number of experiments: ',i2\n neq=neweq%eqno\n! write(*,*)'MM segfault error 3',i2\n do j2=1,i2\n! j1 is position in line to write experiment\n j1=1\n line=' '\n! this subroutine returns experiment and calculated value: \"H=1000:200 $ 5000\"\n call meq_get_one_experiment(j1,line,j2,neweq)\n j3=j3+1\n! segmentation fault with errs after PLOT with APPEND but errs is allocated???\n! write(*,*)'MM segfault error 4A',j2,neq,lut,j3\n! write(*,*)'MM segfault error 4B: ',line(1:44)\n! write(*,*)'MM segfault error 4C',neweq%weight, size(errs)\n! write(*,*)'MM segfault error 4D',j2,errs(j3)\n! write(*,*)'MM segfault error 4E'\n if(neq.gt.0) then\n write(lut,622)neq,name1(1:15),neweq%weight,line(1:44),errs(j3)\n622 format(i4,1x,a,2x,F5.2,1x,a,1x,F6.2)\n neq=0\n else\n write(lut,623)line(1:44),errs(j3)\n623 format(28x,a,1x,F6.2)\n endif\n! list the equilibrium name just for the first (or only) experiment\n enddo\n! write(*,*)'MM segfault error 5'\n experiment=>experiment%next\n!590 if(.not.associated(experiment,neweq%lastexperiment)) then\n! experiment=>experiment%next\n! goto 700\n if(j2.lt.i2 .and. .not.associated(experiment)) then\n write(*,*)'Missing experiment in equilibrium ',neweq%eqno\n cycle allequil\n endif\n! write(*,*)'MM segfault error 6'\n enddo allequil\n! list sum of squares\n sum=zero\n do j1=1,mexp\n sum=sum+errs(j1)**2\n enddo\n! same as PARROT\n j1=mexp-nvcoeff\n if(j1.gt.0) then\n write(lut,621)sum,mexp,nvcoeff,j1,sum/j1\n else\n write(lut,621)sum,mexp,nvcoeff,0,zero\n endif\n621 format(/'Final sum of squared errors: ',1pe16.5,&\n ' using ',i4,' experiments and'/&\n i3,' coefficient(s). Degrees of freedom: ',i4,&\n ', normalized error: ',1pe13.4/)\n1000 continue\n return\n end subroutine listoptshort !700\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine meq_list_experiments\n!\\begin{verbatim}\n subroutine meq_list_experiments(lut,ceq)\n! list all experiments into text, special to handle derivatives ...\n implicit none\n integer lut\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer seqz,ip\n character text*72\n seqz=0\n100 continue\n seqz=seqz+1\n ip=1\n text=' '\n call meq_get_one_experiment(ip,text,seqz,ceq)\n! write(*,*)'MM Back from get_one'\n if(gx%bmperr.ne.0) then\n! error code for no more experiments or inactive experiment\n! write(*,*)'MM error line 3117: ',gx%bmperr,seqz,text(1:ip)\n! speciel error code meaning experiment is not active\n if(gx%bmperr.eq.7654) then\n gx%bmperr=0; goto 100\n endif\n gx%bmperr=0; goto 1000\n else\n write(lut,120)seqz,text(1:ip)\n120 format('Experiment ',i2,2x,a)\n endif\n goto 100\n!------------\n1000 continue\n gx%bmperr=0\n return\n end subroutine meq_list_experiments\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine meq_get_one_experiment\n!\\begin{verbatim} %-\n subroutine meq_get_one_experiment(ip,text,seqz,ceq)\n! list the experiment with the index seqz into text\n! It lists also experiments that are not active ??\n! UNFINISHED current value should be appended\n implicit none\n integer ip,seqz\n character text*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer iterm,symsym,mode\n TYPE(gtp_condition), pointer :: last,current\n type(gtp_state_variable), pointer :: svrrec\n double precision xxx\n character actual_arg*16\n!\n if(ip.le.0) ip=1\n text(ip:)=' '\n if(.not.associated(ceq%lastexperiment)) then\n write(*,*)'MM No experiments'\n gx%bmperr=4249; goto 1000\n endif\n last=>ceq%lastexperiment\n current=>last\n! write(*,*)'MM index of last experiment: ',current%seqz\n70 continue\n! write(*,*)'MM experiment number: ',seqz,current%seqz\n if(current%seqz.eq.seqz) goto 100\n current=>current%next\n if(.not.associated(current,last)) goto 70\n! no experiment with this index found or it is inactivated\n gx%bmperr=4131; goto 1000\n!\n100 continue\n if(current%active.eq.1) then\n! write(*,*)'MM Experiment not active '\n gx%bmperr=4218; goto 1000\n endif\n iterm=1\n150 continue\n! write(*,*)'MM Testing is symbol or state variable record',&\n! allocated(current%statvar)\n nostv: if(.not.allocated(current%statvar)) then\n! an experiment is a symbol!!! Then statvar is not allocated\n symsym=current%statev\n! write(*,*)'MM A symbol, not a state variable for this experiment',symsym\n! we must evaluate all state variable functions!!\n call meq_evaluate_all_svfun(-1,ceq)\n! get the symbol name\n text=svflista(symsym)%name\n ip=len_trim(text)+1\n! text(ip-1:ip-1)='='\n! write(*,*)'MM experiment: ',text(1:ip),ip\n else\n! write(*,*)'MM This experiment has a state variable record',&\n! allocated(current%statvar),allocated(current%indices),iterm\n symsym=0\n svrrec=>current%statvar(1)\n call encode_state_variable(text,ip,svrrec,ceq)\n if(iterm.lt.current%noofterms) then\n iterm=iterm+1; goto 150\n endif\n endif nostv\n! write(*,*)'MM ok here',symsym\n if(current%experimenttype.eq.0 .or. current%experimenttype.eq.100) then\n! write = followed by the value \n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='='\n ip=ip+1\n elseif(current%experimenttype.eq.-1) then\n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='<'\n ip=ip+1\n elseif(current%experimenttype.eq.1) then\n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='>'\n ip=ip+1\n endif\n! write(*,*)'MM experiment line 2: ',text(1:ip),ip\n if(current%symlink1.gt.0) then\n! the value is a symbol\n text(ip:)=svflista(current%symlink1)%name\n ip=len_trim(text)+1\n else\n! call wrinum(text,ip,10,0,current%prescribed)\n call wrinum(text,ip,8,0,current%prescribed)\n endif\n! uncertainty can also be a symbol\n text(ip:ip)=':'\n ip=ip+1\n! write(*,*)'MM experiment line 3: ',text(1:ip),ip,current%symlink2\n if(current%symlink2.gt.0) then\n! the value is a symbol\n text(ip:)=svflista(current%symlink2)%name\n ip=len_trim(text)+1\n else\n! call wrinum(text,ip,10,0,current%uncertainty)\n call wrinum(text,ip,8,0,current%uncertainty)\n endif\n! write(*,*)'MM ok here 2',symsym,text(1:ip)\n! write(*,*)'MM experiment line 2: ',text(1:ip),ip\n if(current%experimenttype.eq.100) then\n text(ip:ip)='%'\n ip=ip+1\n endif\n! write(*,*)'MM ok here 3',symsym\n! add the current value of the experiment after a $ sign\n! TROUBLE GETTING WRONG VALUE HERE WHEN USER DEFINED REFERENCE STATES\n if(symsym.eq.0) then\n call state_variable_val(svrrec,xxx,ceq)\n else\n! write(*,*)'MM ok here 4',symsym\n actual_arg=' '\n xxx=evaluate_svfun_old(symsym,actual_arg,1,ceq)\n endif\n if(gx%bmperr.ne.0) then\n! it is maybe a derivative ... \n! write(*,*)'MM we cannot evaluate a derivative here ...',gx%bmperr\n! but meq_evaluate_svfun not available here ... it is part of the minimizer\n gx%bmperr=0\n actual_arg=' '\n mode=1\n xxx=meq_evaluate_svfun(symsym,actual_arg,mode,ceq)\n! write(*,*)'MM meq_evaluate_svfun, mode=1: ',xxx\n endif\n if(gx%bmperr.ne.0) then\n write(*,*)'MM Error evaluating symbol: ',gx%bmperr\n text(ip:)=' $ ?? '\n ip=ip+5\n gx%bmperr=0\n else\n! write(*,*)'MM experimental state variable value: ',ip,xxx\n text(ip:)=' $'\n ip=ip+3\n! call wrinum(text,ip,12,0,xxx)\n call wrinum(text,ip,8,0,xxx)\n! write(*,*)'MM experiment line 3: ',text(1:ip),ip\n endif\n! write(*,*)'MM ok here 5'\n1000 continue\n! write(*,*)'MM experiment line 4: ',text(1:ip),ip,gx%bmperr\n return\n end subroutine meq_get_one_experiment\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_equilibrium_extra\n!\\begin{verbatim}\n subroutine list_equilibrium_extra(lut,ceq,pun)\n! list the extra character variables for calculate symboles and\n! list characters (if any), It is used in pmon and is part of matsmin\n! because it calls subroutines which need access to calculated results\n! If the first non-blank character of ceq%eqextra(3) is 0 (zero) then pun\n! will be used as a file number to generate a plotfile with calculated values\n implicit none\n integer lut,pun\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ip,slen,jj,last,kk\n character tval*24,symbol*24,encoded*24,date*12\n double precision xxx,xarr(6)\n! write(*,*)'MM calc/list extra: ',ceq%eqname\n!\n tval=' '\n symbol=' '\n extra: if(allocated(ceq%eqextra)) then\n ip=1\n if(eolch(ceq%eqextra(1),ip)) goto 190\n! write(*,*)'calc \"',ceq%eqextra(1)(ip:len_trim(ceq%eqextra(1))),'\"',lut\n calcs: if(ceq%eqextra(1)(ip:ip).ne.' ') then\n! this line contains symbols to be calculated\n! write(*,*)'MM calc extra: ',ceq%eqextra(1)(1:len_trim(ceq%eqextra(1)))\n ip=ip-1\n100 continue\n! Third argument 2 means terminate at a space, not at a comma \",\"\n! because some symbols may contain a comma\n call getext(ceq%eqextra(1),ip,2,tval,' ',slen)\n if(tval(1:1).ne.' ') then\n! This is for a symbol that is not a dot derivative ...\n! call find_svfun(tval,istv,ceq)\n call meq_get_state_varorfun_value(tval,xxx,symbol,ceq)\n! mode=1\n! call meq_evaluate_svfun(tval,' ',mode,ceq)\n if(gx%bmperr.ne.0) then\n! write(*,*)'MM Cannot find symbol: ',tval,' Error reset'\n gx%bmperr=0\n else\n! mode=1\n! meq_evaluate_svfun is declared in matsmin\n! xxx=meq_evaluate_svfun(istv,' ',mode,ceq)\n! xxx=evaluate_svfun_old(istv,' ',mode,ceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'MM Cannot calculate symbol: ',tval,' Error reset'\n! gx%bmperr=0; goto 100\n! endif\n! symbol empty??\n! write(lut,110)symbol(1:len_trim(symbol)),xxx\n write(lut,110)tval(1:len_trim(tval)),xxx\n110 format(3x,a,'=',1pe16.8)\n endif\n goto 100\n! else\n! write(*,*)'Found a space at position',ip\n endif\n endif calcs\n190 continue\n ip=1\n if(eolch(ceq%eqextra(2),ip)) goto 290\n lists: if(ceq%eqextra(2)(ip:ip).ne.' ') then\n! this line contains state variables and related things to be listed\n! write(*,*)'MM list extra: ',ceq%eqextra(2)(1:30)\n ip=ip-1\n200 continue\n! Third argument 2 means terminate at a space, not at a comma \",\"\n! because some symbols contains a comma.\n call getext(ceq%eqextra(2),ip,2,tval,' ',slen)\n! write(*,*)'MM variable: ',tval,slen\n if(tval(1:1).ne.' ') then\n if(index(tval,'*').gt.0) then\n write(*,*)'MM Not implemented wildcards'\n! call get_many_svar(tval,...\n else\n symbol=' '\n call get_state_var_value(tval,xxx,symbol,ceq)\n! This checks that the phase is stable ...\n! call get_stable_state_var_value(tval,xxx,symbol,ceq)\n if(gx%bmperr.ne.0) then\n! write(*,*)'MM Cannot list variable: ',tval,' Error reset'\n gx%bmperr=0\n else\n write(lut,110)trim(symbol),xxx\n endif\n endif\n goto 200\n endif\n endif lists\n290 continue\n ip=1\n if(eolch(ceq%eqextra(3),ip)) goto 390\n plots: if(ceq%eqextra(3)(ip:ip).eq.'0') then\n! this creates a plot file for calculated values\n! This is for plot_data set 0, calculated values'\n! next value must be number of columns with data to be plotted!!\n last=ip+1\n call getint(ceq%eqextra(3),last,ip)\n if(buperr.ne.0) then\n write(*,*)'MM Cannot extract number of columns'\n gx%bmperr=4399; goto 1000\n endif\n if(ip.gt.6) then\n write(*,*)'MM Too many columns in plot_data 0. Max: 6',ip\n gx%bmperr=4399; goto 1000\n endif\n if(pun.eq.0) then\n pun=30\n! plotdatafile='oc_many0'\n! write(*,*)'Opening oc_many0.plt '\n open(pun,file='oc_many0.plt',access='sequential',status='unknown')\n!\n! extract state variable symbols, first is x axis variable\n kk=last\n call getext(ceq%eqextra(3),kk,2,tval,' ',slen)\n call date_and_time(date)\n write(pun,305)date(1:4),date(5:6),date(7:8),&\n trim(tval),trim(ceq%eqextra(3))\n305 format('# GUNPLOT file generated by enter many_equilibria '/&\n 'set title \"Open Calphad 4.0 prerelease: ',a,'-',a,'-',a,&\n ' with GNUPLOT\"'/&\n '# set terminal pdf color'/&\n '# set output \"whatever\"'/&\n 'set xlabel \"',a,'\"'/&\n 'set ylabel \"whatever\"'/&\n 'set key bottom right'/&\n '# ',a/&\n '# THE DATA LINES MUST BE REPEATED AS MANY TIMES AS',&\n ' THERE ARE PLOT COMMANDS!')\n call getext(ceq%eqextra(3),kk,2,tval,' ',slen)\n if(ip.eq.2) then\n! with just two columns\n write(pun,310)trim(tval)\n310 format('plot \"-\" using 1:2 with points pt 5 ',&\n 'ps 1.5 title \"',a,'\"')\n else\n! this first line if 3 or more columns\n write(pun,311)trim(tval)\n311 format('plot \"-\" using 1:2 with points pt 5 ',&\n 'ps 1.5 title \"',a,'\",\\')\n endif\n! if ip>4 this for second and further lines until jj is ip-1\n do jj=3,ip-1\n call getext(ceq%eqextra(3),kk,2,tval,' ',slen)\n write(pun,312)jj,jj+3,trim(tval)\n312 format('\"\" using 1:',i2,' with points pt ',i2,&\n ' ps 1.5 title \"',a,'\",\\')\n enddo\n! if ip=3 this is second line, otherwise the last line\n if(ip.gt.3) then\n call getext(ceq%eqextra(3),kk,2,tval,' ',slen)\n write(pun,313)ip,ip+3,trim(tval)\n313 format('\"\" using 1:',i2,' with points pt ',i2,&\n ' ps 1.5 title \"',a,'\"')\n endif\n! the line consists of several state variables to be calculated and listed\n jj=0\n320 continue\n! write(*,321)trim(ceq%eqextra(3)),last\n321 format('3B extract: ',a,i5,' \"',a,'\"')\n! 3rd argument 2 means skipping , only space separators\n call getext(ceq%eqextra(3),last,2,tval,' ',slen)\n! write(*,321)trim(ceq%eqextra(3)),last,trim(tval)\n if(tval(1:1).eq.' ') then\n goto 350\n elseif(buperr.ne.0) then\n write(kou,*)'Error reading symbol: ',trim(ceq%eqextra(3))\n goto 350\n else\n jj=jj+1\n call get_state_var_value(tval,xarr(jj),encoded,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error getting: ',tval\n goto 350\n endif\n endif\n goto 320\n! no more values\n350 continue\n else\n! This is another line with values for plot_data set 0, file is open\n jj=0\n360 continue\n call getext(ceq%eqextra(3),last,2,tval,' ',slen)\n if(tval(1:1).eq.' ') then\n goto 370\n elseif(buperr.ne.0) then\n write(kou,*)'Error reading symbol: ',trim(ceq%eqextra(3))\n goto 370\n else\n jj=jj+1\n call get_state_var_value(tval,xarr(jj),encoded,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error getting: ',tval\n goto 370\n endif\n endif\n goto 360\n! no more values\n370 continue\n endif\n! write the line on the plot_data file\n if(jj.ne.ip) then\n write(*,*)'Wrong number of columns',jj,ip\n endif\n write(pun,380)(xarr(jj),jj=1,ip)\n380 format(6(1pe12.4))\n endif plots\n! else\n! write(*,*)'No extra lines found'\n endif extra\n390 continue\n1000 continue\n end subroutine list_equilibrium_extra\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine equilph1a\n!\\begin{verbatim}\n subroutine equilph1a(phtup,tpval,ceq)\n! equilibrates the constituent fractions of a phase using its current comp.\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n implicit none\n double precision tpval(*)\n TYPE(gtp_phasetuple), pointer :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(meq_setup) :: meqrec\n!\\end{verbatim} %+\n integer nel,ii,errall\n double precision, allocatable :: xknown(:),wmass(:),cpot(:)\n double precision totmol,totmass,amount\n nel=noel()\n allocate(xknown(nel),stat=errall)\n allocate(wmass(nel),stat=errall)\n allocate(cpot(nel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 50: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! find the current molefractions\n! call calc_phase_molmass(phtup%phaseix,phtup%compset,xknown,wmass,&\n call calc_phase_molmass(phtup%ixphase,phtup%compset,xknown,wmass,&\n totmol,totmass,amount,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! extract the current chemical potentials\n do ii=1,nel\n cpot=ceq%cmuval(ii)\n enddo\n if(gx%bmperr.ne.0) goto 1000\n! create the meqrec structure\n call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq)\n if(gx%bmperr.ne.0) goto 1000\n ceq%rtn=globaldata%rgas*tpval(1)\n! iterate until equilibrium found for this phase\n call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq)\n deallocate(xknown)\n deallocate(wmass)\n1000 continue\n return\n end subroutine equilph1a\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine equilph1b\n!\\begin{verbatim} %-\n subroutine equilph1b(phtup,tpval,xknown,gval,cpot,tyst,ceq)\n! equilibrates the constituent fractions of a phase for mole fractions xknown\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n! gval is the Gibbs energy calculated as xknown(i)*cpot(i)\n! cpot are the (calculated) chemical potentials\n! tyst is TRUE means no outut\n implicit none\n! integer mode\n TYPE(meq_setup) :: meqrec\n double precision tpval(*),xknown(*),cpot(*),gval\n TYPE(gtp_equilibrium_data), pointer :: ceq\n logical tyst\n!\\end{verbatim} %+\n TYPE(gtp_phasetuple), pointer :: phtup\n integer ii\n! extract the current chemical potentials as start values\n do ii=1,noel()\n cpot(ii)=ceq%cmuval(ii)\n enddo\n if(gx%bmperr.ne.0) goto 1000\n! create the meqrec structure\n call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! mabe we need RT ?\n ceq%rtn=globaldata%rgas*tpval(1)\n! iterate until equilibrium found for this phase\n call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq)\n! write(*,*)'We are in equilph1b',gx%bmperr\n gval=zero\n if(gx%bmperr.eq.0) then\n do ii=1,noel()\n gval=gval+xknown(ii)*cpot(ii)\n! write(*,*)'We are in equilph1b',gval\n enddo\n endif\n1000 continue\n return\n end subroutine equilph1b\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine equilph1c\n!\\begin{verbatim}\n subroutine equilph1c(meqrec,phr,tpval,xknown,ovar,ceq)\n! iterate constituent fractions of a phase for mole fractions xknown\n! tpval is T and P\n! xknown are mole fractions\n! ceq is a datastructure with all relevant thermodynamic data\n! ovar are the chemical potentials\n implicit none\n! integer phase\n double precision tpval(*),xknown(*),ovar(*)\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer nz1,nz2,converged,ierr,jj,nj,nk,nl,errall\n TYPE(meq_phase), pointer :: pmi\n double precision, allocatable :: smat(:,:),svar(:),yarr(:),ycorr(:)\n double precision chargefact,chargerr,pv,qq(5),ys,ycormax2\n! number of variables is number of components + one stable phase\n nz1=meqrec%nrel+1\n nz2=nz1+1\n allocate(smat(nz1,nz2),stat=errall)\n allocate(svar(nz1),stat=errall)\n! allocate(ovar(nz1))\n! current values of chemical potentials\n! do jj=1,meqrec%nrel\n! ovar(jj)=ceq%cmuval(jj)\n! enddo\n allocate(ycorr(phr(1)%ncc),stat=errall)\n allocate(yarr(phr(1)%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 51: ',errall\n gx%bmperr=4370; goto 1000\n endif\n chargefact=one\n chargerr=one\n! write(*,*)'We are in equilph1c: ',phr(1)%iph,phr(1)%ics,gx%bmperr\n! we have just one phase in phr, phr must be TARGET\n pmi=>phr(1)\n100 continue\n converged=0\n smat=zero\n! invert the phase matrix for pmi\n call meq_onephase(meqrec,pmi,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! all ok to here ???\n! setup mass balance equations, note some components may be missing\n! This is a simplified setup_equilmatrix using xknown as composition\n! call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,dncol,converged,ceq)\n call setup_comp2cons(meqrec,phr,nz1,smat,tpval,xknown,converged,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! debug output as the matrix had changed efter return from subroutine ...\n! do nk=1,nz1\n! write(*,111)'smat4: ',nk,(smat(nk,jj),jj=1,nz2)\n! enddo\n! goto 1000\n! solve the equilibrium matrix, some chemical potentials may be missing\n call lingld(nz1,nz2,smat,svar,nz1,ierr)\n if(ierr.ne.0) then\n write(*,*)'Error solving equilibrium matrix 2',ierr\n gx%bmperr=4203; goto 1000\n endif\n! check that svar(1..meqrec%nrel) has converged\n do jj=1,meqrec%nrel\n if(abs(svar(jj)-ovar(jj)).gt.1.0D1*ceq%xconv) then\n! write(*,103)'chempot7: ',svar(jj),ovar(jj),svar(jj)-ovar(jj)\n103 format(a,3(1pe12.4))\n converged=7\n endif\n! use ovar below to correct constitutions. Note ovar is chem.pot/RT\n ovar(jj)=svar(jj)\n enddo\n! write(*,111)'svar4: ',0,(svar(jj),jj=1,nz1)\n111 format(a,i2,6(1pe12.4))\n! check dxmol ... seems OK\n! do nk=1,phr(1)%ncc\n! write(*,111)'dxmol: ',nk,(phr(1)%dxmol(nl,nk),nl=1,meqrec%nrel)\n! enddo\n! update constituent fractions in just one phase\n! lap: do jj=1\n jj=1\n! The current chemical potentials are in ceq%cmuval(i) svar(1..n)\n! jj is stable, increment kk but do not make it larger than meqrec%nstph\n! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!!\n! jph=kk\n! kk=min(kk+1,meqrec%nstph)\n! if phr(jj)%xdone=1 then phase has no composition variation\n if(phr(jj)%xdone.eq.1) goto 1000\n!----------------------------------------------------\n ycormax2=zero\n! write(*,*)'cc: ',jj,phr(jj)%ncc\n! loop for all constituents\n moody: do nj=1,phr(jj)%ncc\n ys=zero\n do nk=1,phr(jj)%ncc\n pv=zero\n do nl=1,meqrec%nrel\n! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT)\n! USE values in svar(nl)\n! phr(jj)%dxmol(nl,nk) is the derivative of component nl\n! wrt constituent nk\n! pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk)\n! write(*,111)'pv1: ',nj,pv,ceq%complist(nl)%chempot(1),&\n! ovar(nl) is used instead of complist(nl)%chempot(1) as we do not want to\n! change the global values of the chemical potential\n pv=pv+ovar(nl)*phr(jj)%dxmol(nl,nk)\n! write(*,111)'pv1: ',nj,pv,ovar(nl),&\n! ceq%rtn,phr(jj)%dxmol(nl,nk)\n enddo\n! write(*,119)'cph1: ',jj,nj,nk,ys,pv,phr(jj)%curd%dgval(1,nk,1),&\n! phr(jj)%invmat(nj,nk)\n119 format(a,3i3,6(1pe12.4))\n pv=pv-phr(jj)%curd%dgval(1,nk,1)\n ys=ys+phr(jj)%invmat(nj,nk)*pv\n! write(*,111)'pv2: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),&\n! phr(1)%invmat(nj,nk)\n enddo\n if(phr(jj)%chargebal.eq.1) then\n! For charged phases add a term \n! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q\n ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n phr(jj)%curd%netcharge\n endif\n ycorr(nj)=ys\n if(abs(ycorr(nj)).gt.ycormax2) then\n ycormax2=ycorr(nj)\n endif\n if(abs(ys).gt.ceq%xconv) then\n! if the change in any constituent fraction larger than xconv continue iterate\n if(converged.lt.4) then\n! large correction in fraction of constituent fraction of stable phase\n! write(*,*)'mm converged 4B: ',jj,nj,ys\n converged=4\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=4\n cerr%val(cerr%nvs)=zero\n cerr%dif(cerr%nvs)=abs(ys)\n endif\n! yss=ys\n! yst=phr(jj)%curd%yfr(nj)\n endif\n! elseif(phr(jj)%stable.eq.1) then\n! check to find good convergence criteria in Re-V test case\n! if(abs(ycorr(nj)).gt.ysmm) then\n! jmaxy=jj\n! ysmm=abs(ycorr(nj))\n! ysmt=phr(jj)%curd%yfr(nj)\n! endif\n endif\n yarr(nj)=phr(jj)%curd%yfr(nj)+ycorr(nj)\n! write(*,119)'ycorr4: ',jj,nj,phr(jj)%chargebal,&\n! yarr(nj),phr(jj)%curd%yfr(nj),ycorr(nj),ys\n enddo moody\n! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<<\n! write(*,112)'YC: ',jj,(ycorr(nj),nj=1,phr(jj)%ncc)\n! write(*,112)'YZ: ',meqrec%noofits,(yarr(nj),nj=1,phr(jj)%ncc)\n112 format(a,i3,8F8.5)\n! write(*,*)'MM calling set_constitution 4: ',phr(jj)%iph,phr(jj)%ics\n call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! >>>>>>>>>>>>>>>>>> for all phases <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n meqrec%noofits=meqrec%noofits+1\n if(converged.gt.3) then\n if(meqrec%noofits.le.ceq%maxiter) goto 100\n write(*,*)'MM Too many iterations',ceq%maxiter\n elseif(meqrec%noofits.lt.6) then\n goto 100\n else\n if(.not.btest(meqrec%status,MMQUIET)) write(*,202)meqrec%noofits\n202 format('Calculation required ',i4,' its')\n endif\n1000 continue\n return\n end subroutine equilph1c\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine equilph1d\n!\\begin{verbatim}\n subroutine equilph1d(phtup,tpval,xknown,cpot,tyst,nend,mugrad,mobval,ceq)\n! equilibrates the constituent fractions of a phase for mole fractions xknown\n! and calculates the Darken matrix and unreduced diffusivities\n! phtup is phase tuple\n! tpval is T and P\n! ceq is a datastructure with all relevant thermodynamic data\n! cpot are the (calculated) chemical potentials\n! tyst is TRUE means no outut\n! nend is the number of values returned in mugrad\n! mugrad are the derivatives of the chemical potentials wrt mole fractions??\n! mobval are the mobilities\n implicit none\n integer nend\n logical tyst\n !CCI\n double precision, intent ( inout ) :: mugrad(*),mobval(*)\n double precision tpval(*),xknown(*),cpot(*)\n !CCI\n TYPE(gtp_phasetuple), pointer :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n TYPE(meq_setup) :: meqrec\n integer ii\n! extract the current chemical potentials as start values\n do ii=1,noel()\n cpot(ii)=ceq%cmuval(ii)\n enddo\n if(gx%bmperr.ne.0) goto 1000\n! create the meqrec structure\n! write(*,17)'MM equilph1d calling equilph1e',(xknown(ii),ii=1,noel())\n17 format(a,10(F6.3))\n! call equilph1_meqrec(phtup,meqrec,.FALSE.,ceq)\n call equilph1_meqrec(phtup,meqrec,tyst,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! mabe we need RT ?\n ceq%rtn=globaldata%rgas*tpval(1)\n! iterate until equilibrium found for this phase\n call equilph1e(meqrec,meqrec%phr,tpval,xknown,cpot,tyst,&\n nend,mugrad,mobval,ceq)\n1000 continue\n return\n end subroutine equilph1d\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine equilph1e\n!\\begin{verbatim} %-\n subroutine equilph1e(meqrec,phr,tpval,xknown,ovar,tyst,&\n noofend,mugrad,mobval,ceq)\n! iterate constituent fractions of a phase for mole fractions xknown\n! and calculate derivatives of MU and diffusion coefficients\n! tpval is T and P\n! xknown are mole fractions\n! nrel is the number of components (elements)\n! ovar are the chemical potentials\n! tyst is TRUE if no output\n! mugrad is the derivatives of the chemical potentials wrt mole fractions??\n! mobval are the mobilities\n! ceq is a datastructure with all relevant thermodynamic data\n implicit none\n integer noofend\n !CCI\n double precision, intent ( inout ) :: mugrad(*),mobval(*)\n double precision tpval(*),xknown(*),ovar(*)\n !CCI\n logical tyst\n TYPE(meq_setup) :: meqrec\n TYPE(meq_phase), dimension(*), target :: phr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer nz1,nz2,converged,ierr,jj,nj,nk,nl,is,jt\n integer lokph,nkl(maxsubl),first(maxsubl+1),current(maxsubl),nsl,nend\n integer deriv(maxsubl),ql,mend\n TYPE(meq_phase), pointer :: pmi\n double precision, allocatable :: smat(:,:),svar(:),yarr(:),delta(:)\n! dmuenddy is derivatives of mu for endmembers wrt all constituents\n double precision, allocatable :: dmuenddy(:,:),muend(:)\n double precision, allocatable :: py(:)\n double precision chargefact,chargerr,pv,qq(5),ys,ycormax2,muall\n double precision sumsum\n! ************** change in MODEL_PARAMETER_IDENTIFIER: MQ is now 1300!!\n! 800 + cs where cs is the constituent index counted over all sublattices ??\n! can be REDEFINED when new model parameter identifiers was added!!! \n! we get the current value (set in gtp3A.F90) by calling getmqindex below\n integer mqindex,errall\n! mqindex is a constant set in gtpini in models/gtp3A.F90\n! number of variables is number of components + one stable phase\n nz1=meqrec%nrel+1\n nz2=nz1+1\n allocate(smat(nz1,nz2),stat=errall)\n allocate(svar(nz1),stat=errall)\n! allocate(ovar(nz1))\n! current values of chemical potentials\n! do jj=1,meqrec%nrel\n! ovar(jj)=ceq%cmuval(jj)\n! enddo\n allocate(delta(phr(1)%ncc),stat=errall)\n allocate(yarr(phr(1)%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 52: ',errall\n gx%bmperr=4370; goto 1000\n endif\n chargefact=one\n chargerr=one\n! we have just one phase in phr, phr must be TARGET\n pmi=>phr(1)\n100 continue\n converged=0\n smat=zero\n! invert the phase matrix for pmi\n call meq_onephase(meqrec,pmi,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! all ok to here ???\n! setup mass balance equations, note some components may be missing\n! This is a simplified setup_equilmatrix using xknown as composition\n! call setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,dncol,converged,ceq)\n call setup_comp2cons(meqrec,phr,nz1,smat,tpval,xknown,converged,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'after setup_comp2cons: ',converged\n! debug output as the matrix had changed efter return from subroutine ...\n! do nk=1,nz1\n! write(*,111)'smat3: ',nk,(smat(nk,jj),jj=1,nz2)\n! enddo\n! goto 1000\n! solve the equilibrium matrix, some chemical potentials may be missing\n call lingld(nz1,nz2,smat,svar,nz1,ierr)\n if(ierr.ne.0) then\n write(*,*)'Error solving equilibrium matrix 3',ierr\n gx%bmperr=4203; goto 1000\n endif\n! check that svar(1..meqrec%nrel) has converged\n do jj=1,meqrec%nrel\n if(abs(svar(jj)-ovar(jj)).gt.1.0D1*ceq%xconv) then\n! write(*,103)'chempot: ',svar(jj),ovar(jj),svar(jj)-ovar(jj)\n103 format(a,3(1pe12.4))\n converged=7\n cerr%mconverged=converged\n if(cerr%nvs.lt.10) then\n cerr%nvs=cerr%nvs+1\n cerr%typ(cerr%nvs)=7\n cerr%val(cerr%nvs)=svar(jj)\n cerr%dif(cerr%nvs)=ovar(jj)\n endif\n endif\n ovar(jj)=svar(jj)\n enddo\n! write(*,111)'svar3: ',0,(svar(jj),jj=1,nz1)\n111 format(a,i2,6(1pe12.4))\n! check dxmol ... seems OK\n! do nk=1,phr(1)%ncc\n! write(*,111)'dxmol: ',nk,(phr(1)%dxmol(nl,nk),nl=1,meqrec%nrel)\n! enddo\n! update constituent fractions in just one phase\n! lap: do jj=1\n jj=1\n! The current chemical potentials are in ceq%cmuval(i) svar(1..n)\n! jj is stable, increment kk but do not make it larger than meqrec%nstph\n! save index in meqrec%stphl in jph !!!!!!!!!!! kk never used !!!!!!!!!\n! jph=kk\n! kk=min(kk+1,meqrec%nstph)\n! if phr(jj)%xdone=1 then phase has no composition variation\n if(phr(jj)%xdone.eq.1) goto 1000\n!----------------------------------------------------\n ycormax2=zero\n! write(*,*)'cc: ',jj\n! loop for all constituents\n! write(*,112)'Y0: ',meqrec%noofits,converged,(yarr(nj),nj=1,phr(jj)%ncc)\n moody: do nj=1,phr(jj)%ncc\n ys=zero\n do nk=1,phr(jj)%ncc\n pv=zero\n do nl=1,meqrec%nrel\n! ceq%cmuval(nl) is the chemical potential of element nl (divided by RT)\n! When a chemical potential is fixed use meqrec%mufixval\n! phr(jj)%dxmol(nl,nk) is the derivative of component nl\n! wrt constituent nk\n!? pv=pv+ceq%complist(nl)%chempot(1)/ceq%rtn*phr(jj)%dxmol(nl,nk)\n! pv=pv+ceq%cmuval(nl)*phr(jj)%dxmol(nl,nk)\n! pv=pv+svar(nl)*phr(jj)%dxmol(nl,nk)\n pv=pv+ovar(nl)*phr(jj)%dxmol(nl,nk)\n enddo\n pv=pv-phr(jj)%curd%dgval(1,nk,1)\n ys=ys+phr(jj)%invmat(nj,nk)*pv\n! write(*,111)'pv: ',nj,ys,pv,phr(1)%curd%dgval(1,nk,1),&\n! phr(1)%invmat(nj,nk)\n enddo\n if(phr(jj)%chargebal.eq.1) then\n! For charged phases add a term \n! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q\n ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*&\n phr(jj)%curd%netcharge\n endif\n delta(nj)=ys\n if(abs(delta(nj)).gt.ycormax2) then\n ycormax2=delta(nj)\n endif\n if(abs(ys).gt.ceq%xconv) then\n! if the change in any constituent fraction larger than xconv continue iterate\n if(converged.lt.4) then\n! large correction in fraction of constituent fraction of stable phase\n! write(*,*)'mm converged 4C: ',jj,nj,ys\n converged=4\n! yss=ys\n! yst=phr(jj)%curd%yfr(nj)\n endif\n! elseif(phr(jj)%stable.eq.1) then\n! check to find good convergence criteria in Re-V test case\n! if(abs(delta(nj)).gt.ysmm) then\n! jmaxy=jj\n! ysmm=abs(delta(nj))\n! ysmt=phr(jj)%curd%yfr(nj)\n! endif\n endif\n yarr(nj)=phr(jj)%curd%yfr(nj)+delta(nj)\n enddo moody\n! >>>>>>>>>>>>>>>>>> HERE the new constitution is set <<<<<<<<<<<<<<<<<<<<<\n! write(*,112)'YC: ',jj,(delta(nj),nj=1,phr(jj)%ncc)\n! write(*,112)'YY: ',meqrec%noofits,converged,(yarr(nj),nj=1,phr(jj)%ncc)\n112 format(a,2i3,8F8.5)\n! write(*,*)'MM calling set_constitution 5:',phr(jj)%iph,phr(jj)%ics\n call set_constitution(phr(jj)%iph,phr(jj)%ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!-------------------------- end of iteration\n! check convergence\n meqrec%noofits=meqrec%noofits+1\n if(converged.gt.3) then\n if(meqrec%noofits.le.ceq%maxiter) goto 100\n gx%bmperr=4204\n! write(*,*)'MM Too many iterations',ceq%maxiter\n goto 1000\n elseif(meqrec%noofits.lt.6) then\n goto 100\n else\n if(.not.btest(meqrec%status,MMQUIET)) write(*,202)meqrec%noofits\n202 format('Calculation required ',i4,' its')\n endif\n do is=1,meqrec%nrel\n ovar(is)=svar(is)\n enddo\n! goto 1000\n!----------------------------------------------------------\n! When the calculation converged we calculate mugrad and interdiffusivites\n! A nontrival expression:\n!\n! 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)+\n! \\sum_k\\sum_m x_k x_m d2G/dx_k/dx_m )\n!\n! NOTE THIS IS SYMMETRICAL, dmu_i/dx_j = dmu_j/dx_i.\n! If the phase is ideal then d2G/dx_i/dx_j = RT/x_i if i=j, otherwise zero\n! This gives for \n! dmu_i/dx_i = RT/N * (1-x_i)/x_i\n! dmu_i/dx_j = - RT/N (i not equal to j)\n!\n! We calc sum_k (x_k*d2G/dx_k/dx_i) in delta(i)\n! sum_m x_m ( sum_k (x_k*d2G/dx_k/dx_m)) in sumsum\n!\n! new use of delta !!!\n delta=zero\n muall=pmi%curd%gval(1,1)\n sumsum=zero\n! Here we calculate delta(is) = \\sum_jt y(jt)*d2G/dy_jt/dy_is and\n! sumsum = \\sum_m y(is) \\sum_jt y(jt)*d2G/dy_jt/dy_is\n! The loop of is is for all constituents\n do is=1,phr(1)%ncc\n! The loop for jt are for all constituents in all sublattices\n do jt=1,phr(1)%ncc\n! STRANGE that d2G/dy_Va/dy_Va is zero ... should be 1 (*RT) ...does not matter\n! if(is.gt.jt) stop \"wrong order 1\"\n! keep ixsym here as I do not know if jt>is or not \n delta(is)=delta(is)+pmi%curd%yfr(jt)*pmi%curd%d2gval(ixsym(is,jt),1)\n! write(*,*)'d2G/dy/dy: ',is,jt,pmi%curd%d2gval(ixsym(is,jt),1)\n enddo\n sumsum=sumsum+pmi%curd%yfr(is)*delta(is)\n muall=muall-pmi%curd%dgval(1,is,1)*pmi%curd%yfr(is)\n enddo\n! muall = G_m - \\sum_i y_i dG/dy_i\n! delta(i) = \\sum_j y_j d2G/dy_i/dy_j sum for all y_j for one y_i\n! sumsum = \\sum_i \\sum_j y_i y_j d2G/dy_i/dy_j sum for all y_i and y_j\n!-------------------- summations over all constituents in all sublattices\n! now we must generate the endmembers, loop over all sublattices\n! but sublattics and number of constituents in each are in the phase record\n! and protected ... use a subroutine ...\n lokph=pmi%curd%phlink\n call get_phase_structure(lokph,nsl,nkl)\n if(gx%bmperr.ne.0) goto 1000\n! ---------------------------------------------------------------------\n substitutional: if(nsl.eq.1) then\n! specially simple if nsl=1 (substitutional)\n noofend=nkl(1)\n allocate(muend(noofend),stat=errall)\n! calculate just mu(endmember)\n! loop1: do nend=1,noofend\n! muend(nend)=muall+pmi%curd%dgval(1,nend,1)\n! loop2: do jt=1,noofend\n! the chemical potential has the derivative of the constituent\n! muend(nend)=muend(nend)+pmi%curd%dgval(1,jt,1)\n! enddo loop2\n! enddo loop1\n! now we calculate dmu(end)/dy_is (just for substitutional)\n allocate(dmuenddy(noofend,pmi%ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 53: ',errall\n gx%bmperr=4370; goto 1000\n endif\n dmuenddy=zero\n! For a substitutional solution:\n! dmu_i/dx_j = 1/N ( d2G/dx_i/dx_j -\n! \\sum_k x_k d2G/dx_k/dx_i - \\sum_k x_k d2G/dx_k/dx_j+\n! \\sum_k\\sum_m x_k x_m d2G/dx_k/dx_m )\n! NOTE THIS SHOULD BE SYMMETRICAL, dmu_i/dx_j = dmu_j/dx_i.\n! use delta(i) and sumsum calculated above\n! write(*,*)'Derivatives of chemical potentials',noofend\n nl=0\n loop3: do is=1,noofend\n muend(is)=muall+pmi%curd%dgval(1,is,1)\n loop4: do jt=1,noofend\n! if(is.gt.jt) stop \"wrong order 2\"\n! keep using ixsym here as I do not know if jt>is\n dmuenddy(is,jt)=pmi%curd%d2gval(ixsym(is,jt),1)-&\n delta(is)-delta(jt)+sumsum\n! write(*,775)'dd1:',1,is,jt,&\n! dmuenddy(is,jt),pmi%curd%d2gval(ixsym(is,jt),1),&\n! delta(is),delta(jt),sumsum\n nl=nl+1\n mugrad(nl)=dmuenddy(is,jt)*ceq%rtn\n enddo loop4\n! write(*,777)'dd: ',(ceq%rtn*dmuenddy(is,jt),jt=1,noofend)\n!777 format(a,6(1pe12.4))\n enddo loop3\n! UNFINISHED ?? I do not divide by N\n! write(*,777)'mu: ',(muend(is),is=1,noofend)\n!-------------------\n else ! not substitutional below (2 or more sublattices)\n! now we have to handle sublattices and endmembers\n! nsl is number of sublattices and nkl(1..nsl) the number of const in each\n noofend=1\n is=1\n first=0\n do nl=1,nsl\n! nend is number of endmembers\n! here first and current are set to first constituent index in each sublattice\n noofend=noofend*nkl(nl)\n first(nl)=is\n current(nl)=is\n deriv(nl)=is\n is=is+nkl(nl)\n enddo\n! we need this to indicate when we reached the end\n first(nsl+1)=is\n allocate(muend(noofend),stat=errall)\n allocate(py(noofend),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 54: ',errall\n gx%bmperr=4370; goto 1000\n endif\n py=one\n! write(*,611)'first: ',nsl,(first(nj),nj=1,nsl)\n!611 format(a,i2,2x,10i3)\n! all partials have this term\n muend=muall\n! write(*,*)'MM muall: ',muall,pmi%curd%gval(1,1)\n! The partial Gibbs energy, for each sublattice add one dG/dy_is\n nend=0\n nj=0\n allpg: do while(nj.le.nsl)\n nend=nend+1\n! the partials constituents, G_I, are in current(1..nsl)\n nlloop: do nl=1,nsl\n is=current(nl)\n! 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\n! constituents are in current(1..nsl)\n muend(nend)=muend(nend)+pmi%curd%dgval(1,is,1)\n enddo nlloop\n! generate a new set of constituents in current\n nj=1\n888 continue\n current(nj)=current(nj)+1\n if(current(nj).eq.first(nj+1)) then\n! note first(nsl+1) is the end of all constituents\n current(nj)=first(nj)\n nj=nj+1\n if(nj.le.nsl) goto 888\n endif\n enddo allpg\n if(.not.tyst) then\n write(*,881)(muend(jt),jt=1,noofend)\n881 format('Calculated potentials for all endmembers/RT: '/6(1x,1pe12.4))\n endif\n!-----------------------------------------------------------------------\n! the part below is messy and unfinished\n!---------------- now the derivative of the partial Gibbs energy\n! The partial Gibbs energy, for each sublattice add one dG/dy_is\n! the derivative of the partial Gibbs energy wrt all other endmembers ....\n! dG_i/dn_J = 1/N_J( \\sum_s (d2G/dy_is/dy_js - delta(is) - delta(js)) + sumsum )\n! delta(is) = \\sum_s \\sum_k y_k d2G/dy_is/dy_k\n! sumsum = \\sum_k \\sum_m y_k y_m d2G/dy_k/dy_m (already added above)\n!---------------------------------------------------\n! all derivatives of the partial has the sumsum term\n allocate(dmuenddy(noofend,noofend),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 55: ',errall\n gx%bmperr=4370; goto 1000\n endif\n dmuenddy=sumsum\n nj=0\n nend=0\n allpartg: do while(nj.le.nsl)\n! loop for all partial Gibbs energies G_I\n nend=nend+1\n mend=0\n! write(*,773)'Partial: ',nend,(current(nl),nl=1,nsl)\n allql: do while(nj.le.nsl)\n! loop for all constituent endmembers n_J\n mend=mend+1\n! write(*,773)'Endmember: ',mend,(deriv(nl),nl=1,nsl)\n!773 format(a,i3,2x,10i3)\n lattloop: do nl=1,nsl\n! loop for all sublattices, skip sublattices with a single constituent??\n! if(nkl(nl).eq.1) cycle lattloop\n is=current(nl)\n! the 2nd derivative of G for constituents in same sublattice\n jt=deriv(nl)\n dmuenddy(nend,mend)=dmuenddy(nend,mend)-delta(is)-delta(jt)\n! add second derivatives wrt is and all constituents in deriv\n suckloop: do ql=1,nsl\n! keep using ixsym here as I do not know if isceq%phase_varres(phtup%lokvares)\n! set phase stable\n meqrec%phr(1)%stable=1\n meqrec%phr(1)%prevam=one\n meqrec%phr(1)%prevdg=zero\n meqrec%phr(1)%idim=0\n! number of constituents !!!\n meqrec%phr(1)%ncc=size(ceq%phase_varres(phtup%lokvares)%yfr)\n meqrec%dormlink=0\n meqrec%status=0\n if(tyst) then\n meqrec%status=ibset(meqrec%status,MMQUIET)\n else\n meqrec%status=ibclr(meqrec%status,MMQUIET)\n endif\n!\n meqrec%noofits=0\n! this replaces call to meq_sameset as we will never change stable phase\n! call equilph1c(meqrec,meqrec%phr,tpval,xknown,cpot,ceq)\n1000 continue\n return\n end subroutine equilph1_meqrec\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine check_eec_old\n!\\begin{verbatim}\n subroutine check_eec_old(pmisol,pmiliq,meqrec,ceq)\n! This checks EEC after calculating all phases if the solid phase has S > S^liq\n! it is called if T>globaldata%sysreal(1) (set in user i/f)\n! pmisol is pointer to solid data\n! pmiliq is pointer to liquid data\n! ceq is a datastructure with all relevant thermodynamic data\n implicit none\n type(meq_phase), pointer :: pmiliq,pmisol\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(meq_setup) :: meqrec\n!\\end{verbatim}\n integer sel\n double precision newg,ssol,sliq,fact,kvot\n logical :: once=.TRUE.\n save once\n! check if T meqrec%phr(ij)\n newg=zero\n do sel=1,meqrec%nrel\n newg=newg + pmisol%xmol(sel)*ceq%complist(sel)%chempot(1)\n enddo\n! For Al-50%Cr a pure Al-bcc becomes almost stable at 3500 K using 10000\n! pmisol%curd%gval(1,1)=(newg+1.0E4)*pmisol%curd%abnorm(1)/ceq%rtn\n pmisol%curd%gval(1,1)=(newg+1.0E3)*pmisol%curd%abnorm(1)/ceq%rtn\n! but tested for 5000 it still does not become stable.\n! pmisol%curd%gval(1,1)=(newg+5.0E3)*pmisol%curd%abnorm(1)/ceq%rtn\n! else\n! Entropy of solid less than liquid, all is OK\n endif\n1000 continue\n! write(*,*)'MM leaving check_eec'\n return\n end subroutine check_eec_old\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tzero\n!\\begin{verbatim}\n subroutine tzero(iph1,iph2,icond,value,ceq)\n! calculates the value of condition \"icond\" for two phases to have same G\n implicit none\n integer iph1,iph2,icond\n double precision value\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer, parameter :: lwa=100\n integer info,nv,ja,jb\n type(gtp_condition), pointer :: first\n type(gtp_phase_varres), pointer :: cps1,cps2\n double precision xv(5),fvec(5),tol,wa(lwa)\n! external tzcalc NOT NEEDED\n!\n! write(*,'(a,3i4,\" and \",3i4)')'In tzero!',iph1,phasetuple(iph1)%ixphase,&\n! phasetuple(iph1)%lokph,&\n! iph2,phasetuple(iph2)%ixphase,phasetuple(iph2)%lokph\n! in some way ceq, iph1, iph2 and icond must be transferred to tzcalc\n tzceq=>ceq\n! always use first composition set, iph is also index in phasetuple\n! tzph1=phasetuple(iph1)%lokph; tzph2=phasetuple(iph2)%lokph\n tzph1=iph1; tzph2=iph2\n! find the condition\n first=>ceq%lastcondition\n tzcond=>first%next\n ja=0\n do while(.not.associated(first,tzcond))\n! we should only count ACTIVE conditions\n if(tzcond%active.eq.0) then\n ja=ja+1\n if(ja.eq.icond) goto 100\n tzcond=>tzcond%next\n endif\n enddo\n! the loop above does not find the last condition !!! SUCK\n if(icond.ne.ja+1) then\n write(*,*)'No such condition'\n gx%bmperr=4399; goto 1000\n! else\n! the last condition was the selected one\n endif\n!\n100 continue\n! Set status of all phases except iph1 and iph2 as suspended\n call change_many_phase_status('* ',-3,zero,ceq)\n call change_phtup_status(iph1,1,one,ceq)\n call change_phtup_status(iph2,1,one,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! start value of condition to vary\n xv(1)=tzcond%prescribed\n! write(*,*)'Found condition, current value ',xv(1)\n! do we need to think about parallelization?\n! calculate the zero\n! write(*,*)'Calling hybrd1',xv(1)\n nv=1\n! testing tzero calculation with larger composition difference in the phases?\n! tol=1.0D-2 this is max difference in G, maybe relative??\n! tzcalc used by hybrd1 to calculate G individually for the two phases\n tol=1.0D-6\n call hybrd1(tzcalc,nv,xv,fvec,tol,info,wa,lwa)\n if(info.ne.1) then\n! info=0 Improper input parameters\n! =2 Too many iterations \n! =3 tol variable too small\n! =4 Too slow progress\n! write(*,*)'HYBRD solver return error: ',info\n if(gx%bmperr.eq.0) gx%bmperr=4371\n else\n endif\n if(gx%bmperr.ne.0) goto 1000\n tzcond%prescribed=xv(1)\n value=xv(1)\n1000 continue\n! restore suspeded phases and set no equilibrium\n ceq%status=ibset(ceq%status,EQINCON)\n call change_many_phase_status('* ',0,zero,ceq)\n if(gx%bmperr.eq.0) then\n! set amount of the two phases\n cps1=>tzceq%phase_varres(phasetuple(tzph1)%lokvares)\n cps2=>tzceq%phase_varres(phasetuple(tzph2)%lokvares)\n cps1%amfu=one\n cps2%amfu=one\n endif\n return\n end subroutine tzero\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tzcalc\n!\\begin{verbatim}\n subroutine tzcalc(nv,xv,fvec,iflag)\n! calculates the value of a condition for two phases to have same G\n! called by hybrd1 used by tzero\n implicit none\n integer nv,iflag\n double precision xv(*),fvec(*)\n!\\end{verbatim}\n type(gtp_phase_varres), pointer :: cps1,cps2\n integer mode,lokph1,lokph2,lokvares1,lokvares2\n double precision gm1,gm2\n! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !!\n! write(*,*)'In tzcalc: ',tzph1,tzph2\n! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1)\n!\n lokph1=phasetuple(tzph1)%lokph\n lokph2=phasetuple(tzph2)%lokph\n lokvares1=phasetuple(tzph1)%lokvares\n lokvares2=phasetuple(tzph2)%lokvares\n cps1=>tzceq%phase_varres(lokvares1)\n cps2=>tzceq%phase_varres(lokvares2)\n!\n mode=0\n! we have to calculate each phase separately and compare G values (per atom)\n! Set current value of condition\n tzcond%prescribed=xv(1)\n! write(*,*)'Prescribed condition: ',tzcond%prescribed\n! on entry both phases 1 and 2 are entered, suspend phase 2\n call change_phtup_status(tzph2,-3,one,tzceq)\n call calceq3(mode,.FALSE.,tzceq)\n if(gx%bmperr.ne.0) goto 1100\n gm1=cps1%gval(1,1)/cps1%abnorm(1)\n! write(*,*)'Phase 1: ',gm1\n! suspend phase 1 and restore 2\n call change_phtup_status(tzph1,-3,one,tzceq)\n call change_phtup_status(tzph2,1,one,tzceq)\n call calceq3(mode,.FALSE.,tzceq)\n if(gx%bmperr.ne.0) goto 1100\n gm2=cps2%gval(1,1)/cps2%abnorm(1)\n! write(*,*)'Phase 2: ',gm2\n! restore phase 1\n call change_phtup_status(tzph1,1,one,tzceq)\n fvec(1)=gm1-gm2\n! maybe relative? No as gm1 and gm2 are divided by RT and around 1.0\n! write(*,'(a,4(1pe12.4))')'tzcalc: ',xv(1),gm1,gm2,fvec(1)\n! fvec(1)=cps1%gval(1,1)/cps1%abnorm(1)-cps2%gval(1,1)/cps2%abnorm(1)\n1000 continue\n return\n1100 continue\n! error quit also calling routine by setting value to zero\n write(*,*)'Quit tzcalc due to error: ',gx%bmperr\n fvec(1)=zero; goto 1000\n end subroutine tzcalc\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine liquid_eet\n!\\begin{verbatim}\n subroutine liquid_eet(iph1,iph2,icond,value,ceq)\n! calculates the value of condition \"icond\" when they have equal entropy, EET\n implicit none\n integer iph1,iph2,icond\n double precision value\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer, parameter :: lwa=100\n integer info,nv,ja,jb\n type(gtp_condition), pointer :: first\n type(gtp_phase_varres), pointer :: cps1,cps2\n double precision xv(5),fvec(5),tol,wa(lwa)\n! external tzcalc NOT NEEDED\n!\n! write(*,'(a,3i4,\" and \",3i4)')'In tzero!',iph1,phasetuple(iph1)%ixphase,&\n! phasetuple(iph1)%lokph,&\n! iph2,phasetuple(iph2)%ixphase,phasetuple(iph2)%lokph\n! in some way ceq, iph1, iph2 and icond must be transferred to tzcalc\n tzceq=>ceq\n! always use first composition set, iph is also index in phasetuple\n! tzph1=phasetuple(iph1)%lokph; tzph2=phasetuple(iph2)%lokph\n tzph1=iph1; tzph2=iph2\n! find the condition\n first=>ceq%lastcondition\n tzcond=>first%next\n ja=0\n do while(.not.associated(first,tzcond))\n! we should only count ACTIVE conditions\n if(tzcond%active.eq.0) then\n ja=ja+1\n if(ja.eq.icond) goto 100\n tzcond=>tzcond%next\n endif\n enddo\n! the loop above does not find the last condition !!! SUCK\n if(icond.ne.ja+1) then\n write(*,*)'No such condition'\n gx%bmperr=4399; goto 1000\n! else\n! the last condition was the selected one\n endif\n!\n100 continue\n! Set status of all phases except iph1 and iph2 as suspended\n! call change_many_phase_status('* ',-3,zero,ceq)\n! call change_phtup_status(iph1,1,one,ceq)\n! call change_phtup_status(iph2,1,one,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n! start value of condition to vary\n xv(1)=tzcond%prescribed\n! write(*,*)'Found condition, current value ',xv(1)\n! do we need to think about parallelization?\n! calculate the zero\n! write(*,*)'Calling hybrd1',xv(1)\n nv=1\n! testing tzero calculation with larger composition difference in the phases?\n! tol=1.0D-2 this is max difference in G, maybe relative??\n! eetcalc is used to calculate the entropy difference of the two phases\n tol=1.0D-6\n call hybrd1(eetcalc,nv,xv,fvec,tol,info,wa,lwa)\n if(info.ne.1) then\n! info=0 Improper input parameters\n! =2 Too many iterations \n! =3 tol variable too small\n! =4 Too slow progress\n write(*,*)'HYBRD solver return error: ',info\n if(gx%bmperr.eq.0) gx%bmperr=4371\n else\n endif\n if(gx%bmperr.ne.0) goto 1000\n tzcond%prescribed=xv(1)\n value=xv(1)\n1000 continue\n! restore suspeded phases and set equilibrium may be onconsistent\n! ceq%status=ibset(ceq%status,EQINCON)\n! call change_many_phase_status('* ',0,zero,ceq)\n! if(gx%bmperr.eq.0) then\n! set amount of the two phases\n! cps1=>tzceq%phase_varres(phasetuple(tzph1)%lokvares)\n! cps2=>tzceq%phase_varres(phasetuple(tzph2)%lokvares)\n! cps1%amfu=one\n! cps2%amfu=one\n! endif\n return\n end subroutine liquid_eet\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine eetcalc\n!\\begin{verbatim}\n subroutine eetcalc(nv,xv,fvec,iflag)\n! calculates the value of a condition for two phases to have same entropy\n! called by hybrd1 used by liquid_eet\n implicit none\n integer nv,iflag\n double precision xv(*),fvec(*)\n!\\end{verbatim}\n type(gtp_phase_varres), pointer :: cps1,cps2\n integer mode,lokph1,lokph2,lokvares1,lokvares2\n double precision sm1,sm2\n! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !!\n! write(*,*)'In eetcalc: ',tzph1,tzph2\n! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1)\n!\n lokph1=phasetuple(tzph1)%lokph\n lokph2=phasetuple(tzph2)%lokph\n lokvares1=phasetuple(tzph1)%lokvares\n lokvares2=phasetuple(tzph2)%lokvares\n cps1=>tzceq%phase_varres(lokvares1)\n cps2=>tzceq%phase_varres(lokvares2)\n!\n mode=0\n! we have to calculate the equilibrium and the entropy difference of the phases\n! Set current value of condition\n tzcond%prescribed=xv(1)\n! write(*,*)'Prescribed condition: ',tzcond%prescribed\n! UNFINISHED BELOW\n! on entry both phases 1 and 2 are entered, suspend phase 2\n! call change_phtup_status(tzph2,-3,one,tzceq)\n call calceq3(mode,.FALSE.,tzceq)\n if(gx%bmperr.ne.0) goto 1100\n! value is divided by RT\n sm1=8.31451*tzceq%tpval(1)*cps1%gval(2,1)/cps1%abnorm(1)\n sm2=8.31451*tzceq%tpval(1)*cps2%gval(2,1)/cps2%abnorm(1)\n!\n fvec(1)=sm1-sm2\n! write(*,'(a,F7.2,F7.4,2(1pe12.4))')'EET: ',xv(1),fvec(1),sm1,sm2\n!\n1000 continue\n return\n1100 continue\n! error quit also calling routine by setting value to zero\n! write(*,*)'Quit eetcalc, most likely there is no EET for this phase'\n fvec(1)=zero; gx%bmperr=4375\n goto 1000\n end subroutine eetcalc\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tzcalc_stoich\n!\\begin{verbatim}\n subroutine tzcalc_stoich(nv,xv,fvec,iflag)\n! calculates the value of a condition for two phases to have same G\n! called from smp2A during mapping\n! Both phases have the same composition (stoichiometric constraits)\n implicit none\n integer nv,iflag\n double precision xv(*),fvec(*)\n!\\end{verbatim}\n type(gtp_phase_varres), pointer :: cps1,cps2\n integer mode,lokph1,lokph2,lokvares1,lokvares2,moded\n double precision gm1,gm2\n! we transfer the data needed by tzph1,tzph2,tzceq and tzcond !!\n! write(*,*)'In tzcalc: ',tzph1,tzph2\n! write(*,*)'Current value of condition: ',tzcond%prescribed,xv(1)\n!\n! Tested for U-O with 3 phase ORTHO_A20, TETRA_U C1_MO2: T=942.02 K\n lokph1=phasetuple(tzph1)%lokph\n lokph2=phasetuple(tzph2)%lokph\n lokvares1=phasetuple(tzph1)%lokvares\n lokvares2=phasetuple(tzph2)%lokvares\n cps1=>tzceq%phase_varres(lokvares1)\n cps2=>tzceq%phase_varres(lokvares2)\n!\n mode=0\n! only G values, no derivatives\n moded=0\n! we have two phases with fixed composition and search T for the same value\n! of the Gibbs energy. \n! We can directly calculate the Gibbs energy of each phase\n! Set current value of condition\n! tzcond%prescribed=xv(1)\n! write(*,*)'Prescribed condition: ',tzcond%prescribed\n! on entry both phases 1 and 2 are entered, suspend phase 2\n! call change_phtup_status(tzph2,-3,one,tzceq)\n! call calceq3(mode,.FALSE.,tzceq)\n! if(gx%bmperr.ne.0) goto 1100\n if(xv(1).lt.1.0D-1) then\n! write(*,*)'Attempt to calculate for T less than 1'\n iflag=-1; gx%bmperr=4187; goto 1000\n endif\n tzceq%tpval(1)=xv(1)\n call calcg_internal(lokph1,moded,cps1,tzceq)\n if(gx%bmperr.ne.0) goto 1200\n call calcg_internal(lokph2,moded,cps2,tzceq)\n if(gx%bmperr.ne.0) goto 1200\n gm1=cps1%gval(1,1)/cps1%abnorm(1)\n! write(*,*)'Phase 1: ',gm1\n! suspend phase 1 and restore 2\n! call change_phtup_status(tzph1,-3,one,tzceq)\n! call change_phtup_status(tzph2,1,one,tzceq)\n! call calceq3(mode,.FALSE.,tzceq)\n! if(gx%bmperr.ne.0) goto 1100\n gm2=cps2%gval(1,1)/cps2%abnorm(1)\n fvec(1)=gm1-gm1\n! write(*,*)'Phase 2: ',gm2\n! restore phase 1\n call change_phtup_status(tzph1,1,one,tzceq)\n fvec(1)=gm1-gm2\n! write(*,'(a,4(1pe12.4))')'tzcalc_stoich: ',xv(1),gm1,gm2,fvec(1)\n1000 continue\n return\n1100 continue\n! error quit also calling routine by setting value to zero\n write(*,*)'Quit tzcalc_stoich due to error: ',gx%bmperr\n iflag=-1; goto 1000\n1200 continue\n write(*,1210)gx%bmperr\n1210 format('Error calculating Gibbs energy ',i5)\n iflag=-1; goto 1000\n end subroutine tzcalc_stoich\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_paraeq\n!\\begin{verbatim}\n subroutine calc_paraeq(tupix,icond,xcond,meqrec,meqrec1,ceq)\n! calculates a paraequilibrium between two phases tupix(1&2)\n! icond is the index of the fast diffusing element\n! xcond are the fractions of the element in the two phases at paraequilibrium\n implicit none\n integer tupix(2),icond\n double precision xcond(2)\n TYPE(meq_setup), pointer :: meqrec\n TYPE(meq_setup), allocatable, target :: meqrec1\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! at paraequilibrium the two phases has the same composition (set as conditions)\n! except for one element fastel which is a fast diffusion element (such as C)\n! It requires solving a nonlinear equation to find a \"tie-line\" between\n! the two phases which have the same composition except for fastel\n! We have two variables, the composion of \"fastel\" in each phase\n! We calculate each phase separately with different fractions of fastel, x(C)\n! and extract the chemical potential of fastel, mu(C)\n! and a \"combined\" chemical potential for all other elements.\n! This is calculated as (G-x(C)*mu(C))/(1-x(C)) where G is the Gibbs energy\n! The two function values are the difference of these two potentials\n! calculated for each phase\n! meqrec is needed for step_paraeq\n!\n integer nv,info,ja,errall\n integer, parameter :: lwa=20,minus1=-1\n double precision fracs(2),fvec(2),wa(lwa),muval,xsave,ntot,nalpha,nbeta,xtest\n double precision, parameter :: tol=1.0D-10\n type(gtp_phasetuple), pointer :: ph1,ph2\n type(gtp_condition), pointer :: first,pcond\n type(gtp_state_variable), target :: p1svr,p2svr\n type(gtp_state_variable), pointer :: svr\n character encoded*24,fractions*64,elname*24\n type(map_fixph), allocatable :: mapfix\n logical verbose\n! We must passing links and info to paraeqfun, the subroutine called by hybrd1\n! THIS DOES NOT WORK IF CALCULATIONS ARE MADE IN PARALLEL\n! tzceq is pointer to equilibrium; tzcond pointer to first condition\n! write(*,*)'MM in calc_paraeq',tzph1,tzph2,icond\n if(.not.allocated(meqrec1)) then\n! this is when called from user i/f, step_paraequil allocates before call\n! data will be added by calceq7\n allocate(meqrec1,stat=errall)\n if(errall.ne.0) then\n! write(*,*)'MM Allocation error 19: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n meqrec=>meqrec1\n meqrec%status=0\n if(allocated(mapfix)) deallocate(mapfix)\n! verbose=.FALSE.\n xcond=zero\n tzceq=>ceq\n tzph1=tupix(1); tzph2=tupix(2)\n! write(*,*)'MM allocated meqrec1, calling calceq7'\n!\n! Calculate an equilibrium with the two phases\n! call calceq3(minus1,verbose,tzceq)\n call calceq7(minus1,meqrec,mapfix,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM Back from calceq7'\n! exctract various values\n call get_state_var_value('N ',ntot,encoded,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! this is quite clumsy ... can it be fixed?\n call get_component_name(icond,elname,tzceq)\n! do not use this routine, requires a tuple record\n! call get_phasetuple_name(tzph1,encoded)\n call get_phasetup_name(tzph1,encoded)\n fractions='X('//trim(encoded)//','//trim(elname)//') '\n call get_state_var_value(fractions,fracs(1),encoded,tzceq)\n! call get_state_var_value('X(FCC,C) ',fracs(1),encoded,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n call get_phasetup_name(tzph2,encoded)\n fractions='X('//trim(encoded)//','//trim(elname)//') '\n call get_state_var_value(fractions,fracs(2),encoded,tzceq)\n! write(*,*)'MM fraction composition: ',trim(fractions)\n! call get_state_var_value('X(BCC,C) ',fracs(2),encoded,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'MM Initial fractions: ',fracs(1),fracs(2)\n! tzcond should be the condition for the element tzel\n first=>ceq%lastcondition%next\n pcond=>first\n ja=0\n findxcond: do while(.true.)\n if(pcond%active.eq.1) cycle findxcond\n ja=ja+1\n if(pcond%statvar(1)%argtyp.eq.1) then\n if(pcond%statvar(1)%component.eq.icond) then\n tzcond=>pcond\n p1svr=pcond%statvar(1)\n p2svr=pcond%statvar(1)\n! this is the condition on the total amount of fast diffusing element ??\n xsave=pcond%prescribed\n! write(*,'(a,F10.6,3i4)')'MM fraction condition',pcond%prescribed,&\n! pcond%statvar(1)%statevarid,pcond%statvar(1)%oldstv\n endif\n endif\n! write(*,*)'MM other conditions: ',ja,pcond%statvar%statevarid,&\n! pcond%statvar%component\n pcond=>pcond%next\n if(associated(pcond,first)) exit findxcond\n if(ja.gt.100) then\n write(*,*)'Eternal loop exit 1',ja\n gx%bmperr=4399; goto 1000\n endif\n enddo findxcond\n! musvr and xsvr are module global variables used by hybrid subroutine\n! musvr is typically\n! 3 0 0 0 0 1 0 0 1 0 1.0 3\n musvr%statevarid=3; musvr%norm=0; musvr%unit=0; musvr%phref=0\n musvr%argtyp=1; musvr%phase=0; musvr%compset=0; musvr%component=icond\n musvr%constituent=0; musvr%coeff=one; musvr%oldstv=3\n svr=>musvr\n call state_variable_val(svr,muval,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! we should use mole fractions to calculate alloy potential\n! The %oldstv is important! But completely undocumented\n!=========================================================\n! This assumes fraction is mole fraction\n xsvr=musvr\n xsvr%statevarid=17; xsvr%oldstv=111\n! DO NOT CHANGE xsvr, IT IS USED IN THE CALCULATING ROUTINE\n!=========================================================\n nv=2\n! call list_conditions(kou,tzceq)\n!\n!==================================\n!\n! solve the non-linear equation (this is the simplified call ....)\n call hybrd1(paraeqfun,nv,fracs,fvec,tol,info,wa,lwa)\n! nv number of variables and functions; fracs(nv) values of the fractions\n! fvec(nv) returned values of the functions; tol required tolerance\n! info returned information of result\n! ws is workspace with dimension lwa; lwa integer > nv*(3*n+13)/2 (=2*19/2)\n if(info.ne.1) then\n if(info.eq.0) write(*,*)'MM hybrd1 called with illegal arguments'\n if(info.eq.2) write(*,*)'MM hybrd1 fails too many iterations'\n if(info.eq.3) write(*,*)'MM hybrd1 fails too high tolerance required'\n if(info.eq.4) write(*,*)'MM hybrd1 fails too slow progress'\n gx%bmperr=4399; goto 1000\n endif\n! the phase amounts should be adjusted to a composition in the middle\n xsave=0.5*(fracs(1)+fracs(2))\n! return solution:\n! write(*,*)'MM conditions at the solution:'\n! call list_conditions(kou,tzceq)\n xcond(1)=fracs(1)\n xcond(2)=fracs(2)\n! We should set the phase amounts to reproduce the overall condition\n if(xcond(1).gt.xcond(2)) then\n nalpha=(xsave-xcond(2))/(xcond(1)-xcond(2))\n else\n nalpha=(xsave-xcond(1))/(xcond(2)-xcond(1))\n endif\n nbeta=ntot-nalpha\n if(nalpha.lt.zero .or. nbeta.lt.zero) then\n write(*,'(a,5(1x,F10.6))')'Paraequil error:',xsave,xcond,nalpha,nbeta\n gx%bmperr=4399\n else\n! set amounts of phases correspondng to condition\n! write(*,'(a,2F10.6)')'calc_paraeq: NP(*): ',nalpha,nbeta\n call change_phase_status(phasetuple(tzph1)%ixphase,&\n phasetuple(tzph1)%compset,PHENTSTAB,nalpha,tzceq)\n call change_phase_status(phasetuple(tzph2)%ixphase,&\n phasetuple(tzph2)%compset,PHENTSTAB,nbeta,tzceq)\n endif\n!\n1000 continue\n! restore original condition\n tzcond%prescribed=xsave\n return\n end subroutine calc_paraeq ! meqrec\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine paraeqfun\n!\\begin{verbatim}\n subroutine paraeqfun(nv,fracs,fvec,iflag)\n! called by hydrid1 to solve a nonlinear system of equations setup\n! by calc_paraeq to calculate the difference in chemical potential \n! for a two-phase paraequilibrium. Arguments are: \n! nv number of variables, fracs the variable values, fvec the functions\n! calculated by this routine\n implicit none\n integer nv,iflag\n double precision fracs(*),fvec(*)\n!\\end{verbatim}\n integer, parameter :: minus1=-1\n double precision gm,mucmat,muamat,mucgro,muagro,xcmat,xcgro,mutest,xtest,val\n type(gtp_state_variable), pointer :: svr\n integer ip\n character encoded*24\n logical verbose\n! \n! The 2 variables are the fractions of the fast diffusing element in 2 phases\n! The functions are the chemical potential of the fast diffusing element\n! and the \"extrapolated\" chemical potential of an alloy with zero fraction\n! of the fast diffusing element, calculated for each phases as\n! (G-x(C)*mu(C))/(1-x(C))\n! where G is the Gibbs energy of the phase and x(C) the fraction of C\n! The difference of these potentials calculated for each element in each phase\n! should be zero at paraequilibrium.\n! THIS ROUTINE DOES NOT WORK IF CALCULATIONS IN PARALLEL\n!\n! At paraequilibrium the two phases has the same composition (set as conditions)\n! except for one element fastel which is a fast diffusion element (such as C)\n! It requires solving a nonlinear equation to find a \"tie-line\" between\n! the two phases which have the same composition except for fastel\n! We have two variables, the composion of \"fastel\" in each phase\n! We calculate each phase separately with different fractions of fastel, x(C)\n! and extract the chemical potential of fastel, mu(C)\n! and a \"combined\" chemical potential for all other elements.\n! This is calculated as (G-x(C)*mu(C))/(1-x(C)) where G is the Gibbs energy\n! The two function values are the difference of these two potentials\n! calculated for each phase\n!\n! iflag should not be changed except to force termination by setting iflag=-1\n! NOTE tzceq, tzcond, tzph1 and tzph2 global variables in this module!\n! fractions must be betwee 1E-12 and 1\n if(fracs(1).lt.1.0D-12) fracs(1)=1.0D-12 \n if(fracs(1).gt.1.0D0) fracs(1)=1.0D0\n if(fracs(2).lt.1.0D-12) fracs(2)=1.0D-12 \n if(fracs(2).gt.1.0D0) fracs(2)=1.0D0\n! write(*,'(a,2(1pe12.4))')'>>>> Paraeqfun 1: ',fracs(1),fracs(2)\n! calculate the Gibbs energy and the partial Gibbs energies of each phase \n! for the current set of conditions\n! It is possible to calculate each phase separately ignoring conditions\n! but then it is not trivial to obtain the chemical potentials\n! or call calceq2/calceq7 with all phses except one suspended\n!\n verbose=.FALSE.\n! write(*,*)'Matrix and growing phases: ',tzph1,tzph2\n! suspend growing phase and calculate normal equilibrium for matrix\n call change_phase_status(phasetuple(tzph2)%ixphase,&\n phasetuple(tzph2)%compset,PHSUS,zero,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! set condition on composition equal to fracs(1)\n tzcond%prescribed=fracs(1)\n! do ip=1,nooftup()\n! if(test_phase_status(phasetuple(ip)%ixphase,phasetuple(ip)%compset,&\n! val,tzceq).ge.0) then\n! write(*,*)'Stable phase (matrix)',phasetuple(ip)%ixphase,&\n! phasetuple(ip)%compset,val\n! endif\n! enddo\n! write(*,*)'Calculating with matrix phase',phasetuple(tzph1)%ixphase,&\n! phasetuple(tzph1)%compset\n! calceq3 will modify the fraction of components not set as conditions (Fe)\n call calceq3(minus1,verbose,tzceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed calculation for matrix phase',fracs(1),gx%bmperr\n goto 1000\n endif\n! extract value of G and MU(C) and calculate M(X)=(G-x(c)*mu(C))/(1-x(C)) \n! write(*,*)'Extracting values for matrix phase'\n call get_state_var_value('GM ',gm,encoded,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n svr=>musvr\n call state_variable_val(svr,mucmat,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n svr=>xsvr\n call state_variable_val(svr,xcmat,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! check\n! call get_state_var_value('MU(C) ',mutest,encoded,tzceq)\n! if(gx%bmperr.ne.0) goto 1000\n! call get_state_var_value('X(C) ',xtest,encoded,tzceq)\n! if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,4(1pe12.4))')'Matrix test: ',mucmat,mutest,xcmat,xtest\n!\n muamat=(gm-xcmat*mucmat)/(one-xcmat)\n! write(*,'(a,4(1pe12.4))')'Matrix G, x and mu: ',gm,xcmat,mucmat,muamat\n!\n! suspend matrix phase and calculate normal equilibrium for growing!\n call change_phase_status(phasetuple(tzph2)%ixphase,&\n phasetuple(tzph2)%compset,PHENTSTAB,one,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n call change_phase_status(phasetuple(tzph1)%ixphase,&\n phasetuple(tzph1)%compset,PHSUS,zero,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n! set condition on composition equal to fracs(2)\n tzcond%prescribed=fracs(2)\n! do ip=1,nooftup()\n! if(test_phase_status(phasetuple(ip)%ixphase,phasetuple(ip)%compset,&\n! val,tzceq).ge.0) then\n! write(*,*)'Stable phase (growing)',phasetuple(ip)%ixphase,&\n! phasetuple(ip)%compset,val\n! endif\n! enddo\n! write(*,*)'Calculating with growing phase: ',phasetuple(tzph2)%ixphase,&\n! phasetuple(tzph2)%compset\n! calceq3 will modify the fraction of components not set as conditions (Fe)\n call calceq3(minus1,verbose,tzceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed calculation for growing phase',fracs(2),gx%bmperr\n goto 1000\n endif\n! extract value of G and MU(C) and calculate M(X)=(G-x(c)*mu(C))/(1-x(C)) \n! write(*,*)'Extracting values for growing phase'\n! call get_stable_state_var_value('GM ',gm,encoded,tzceq)\n call get_state_var_value('GM ',gm,encoded,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n svr=>musvr\n call state_variable_val(svr,mucgro,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n svr=>xsvr\n call state_variable_val(svr,xcgro,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n! test\n! call get_state_var_value('MU(C) ',mutest,encoded,tzceq)\n! if(gx%bmperr.ne.0) goto 1000\n! call get_state_var_value('X(C) ',xtest,encoded,tzceq)\n! if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,4(1pe12.4))')'Matrix test: ',mucgro,mutest,xcgro,xtest\n! we have to use mole fraction, to calculate muamat\n muagro=(gm-xcgro*mucgro)/(one-xcgro)\n! write(*,'(a,4(1pe12.4))')'Growing G, x and mu: ',gm,xcgro,mucgro,muagro\n\n fvec(1)=muamat-muagro\n fvec(2)=mucmat-mucgro\n! write(*,'(a,4(1pe12.4))')'>>>> Paraeqfun 9: ',fracs(1),fracs(2),&\n! fvec(1),fvec(2)\n! restore matrix as entered\n call change_phase_status(phasetuple(tzph1)%ixphase,&\n phasetuple(tzph1)%compset,PHENTSTAB,one,tzceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n1000 continue\n if(gx%bmperr.ne.0) then\n write(*,*)'MM Error inside paraeqfun',gx%bmperr\n iflag=-1\n endif\n! iflag=-1\n return\n end subroutine paraeqfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calculate_carefully\n!\\begin{verbatim}\n subroutine calculate_carefully(mode,ceq)\n implicit none\n! calculate an equilirium carefully (bosses_method)\n! step 1: Calculate with gridminimizer and merge (already done)\n! Alternatively enter with a set of stable phases\n! which has converged at another calculation.\n! 2: suspend unstable phases\n! 3: calculate with iterative method, \n! 4: set all suspended as dormant, \n! 5: calculate iterative again to see if any dormant has dgm>0\n! 6: if so set it entered and goto 5\n! 7: set all phases entered\n! mode 0 means all step, nonzero may change some of these steps\n! mode 1 means set phases entered one by one, largest driving force first\n integer mode\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer, allocatable, dimension(:) :: phcsstat\n integer ntups,mtups,itup,lokcs,ns,naa,phmax,saverr,errall\n double precision dgmax\n character phname*24\n logical again\n! 2. loop for all phases to suspend all not stable\n! 3. calculate equilibrium with remaining phases without gridminimizer\n! 4. loop for all phases to set suspended to dormant\n! 5. calculate equilibrium with current set of phases without gridminimizer\n! 6. If a dormant phase has dgm>0 set it entered and go back to 5\n! Alternatively do this one by one\n! 7. set all dormant phases entered\n! ntups=noofphasetuples()\n! if error 4363 then reset error code and continue\n if(gx%bmperr.ne.0) then\n! this error means a phase has been restored with positive dgm\n! write(*,*)'MM error code set 1:',gx%bmperr\n if(gx%bmperr.ne.4363) goto 1000\n gx%bmperr=0\n endif\n ntups=nooftup()\n allocate(phcsstat(ntups),stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 57: ',errall\n gx%bmperr=4370; goto 1000\n endif\n phcsstat=0\n ns=0\n do itup=1,ntups\n lokcs=phasetuple(itup)%lokvares\n if(ceq%phase_varres(lokcs)%dgm.lt.zero) then\n! suspend phases with negative dgm\n! if already suspended ignore\n if(ceq%phase_varres(lokcs)%phstate.gt.PHSUS) then\n ceq%phase_varres(lokcs)%phstate=PHSUS\n phcsstat(itup)=PHSUS\n ns=ns+1\n endif\n endif\n enddo\n write(*,12)ns\n12 format('Phases set suspended except those found stable by gridmin',i5)\n! calculate equilibrium with just these phases without grid minimizer\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n! this error means a phase has been restored with positive dgm\n! write(*,*)'MM error code set 2:',gx%bmperr\n if(gx%bmperr.ne.4363) goto 900\n gx%bmperr=0\n endif\n write(*,17)ntups-ns,ns,' suspended '\n17 format('MM Equilibrium calculated with ',i4,' entered and ',i4,a,'phases')\n! set all suspended phases as dormant, maybe some has disapperard\n! some composition sets may have disappeared\n mtups=nooftup()\n if(ntups-mtups.gt.0) write(*,18)ntups-mtups\n18 format('MM deleted ',i3,' composition sets')\n do itup=1,mtups\n if(phcsstat(itup).eq.PHSUS) then\n! set a suspended phase as dormant\n lokcs=phasetuple(itup)%lokvares\n ceq%phase_varres(lokcs)%phstate=PHDORM\n phcsstat(itup)=PHDORM\n endif\n enddo\n write(*,19)\n19 format('Calculating again with all suspended phases set as dormant')\n! calculate equilibrium with entered and dormant phases\n100 continue\n again=.false.\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n! this error means a phase has been restored with positive dgm\n write(*,*)'MM error code set 3:',gx%bmperr\n if(gx%bmperr.ne.4363) goto 900\n gx%bmperr=0\n endif\n write(*,17)mtups-ns,ns,' dormant '\n! if mode=0 set all dormant phases with dgm>0 entered\n! if mode=1 set the dormant phase with largest dgm>0 as entered\n ntups=nooftup()\n naa=0\n dgmax=zero\n phmax=0\n do itup=1,ntups\n if(phcsstat(itup).eq.PHDORM) then\n lokcs=phasetuple(itup)%lokvares\n! maybe enter phases one by one ...\n if(ceq%phase_varres(lokcs)%dgm.gt.zero) then\n if(mode.eq.0) then\n ceq%phase_varres(lokcs)%phstate=PHENTERED \n phcsstat(itup)=PHENTERED\n ns=ns-1\n naa=naa+1\n again=.true.\n elseif(ceq%phase_varres(lokcs)%dgm.gt.dgmax) then\n dgmax=ceq%phase_varres(lokcs)%dgm\n phmax=itup\n endif\n endif\n endif\n enddo\n if(mode.eq.1 .and. phmax.gt.0) then\n! write(*,*)'MM entering phase with largest driving force ',phmax,dgmax\n lokcs=phasetuple(phmax)%lokvares\n ceq%phase_varres(lokcs)%phstate=PHENTERED \n phcsstat(phmax)=PHENTERED\n call get_phasetup_name(phmax,phname)\n ns=ns-1\n naa=naa+1\n again=.true.\n write(*,200)trim(phname),dgmax\n200 format('MM Setting ',a,' with dgm= ',1pe12.4,' as entered')\n endif\n if(again) then\n if(mode.eq.0) write(*,*)'MM set ',naa,' dormant phases as entered'\n goto 100\n endif\n! we have found a solution, set all phases as entered\n! or we have an error so restore suspended phases\n900 continue\n if(gx%bmperr.ne.0) then\n write(*,*)'Calculation not converged, some phases remain as dormant'\n goto 1000\n endif\n saverr=gx%bmperr\n gx%bmperr=0\n ns=0\n ntups=nooftup()\n! ntups=noofphasetuples()\n do itup=1,ntups\n if(phcsstat(itup).le.PHDORM) then\n lokcs=phasetuple(itup)%lokvares\n ceq%phase_varres(lokcs)%phstate=PHENTERED \n ns=ns+1\n endif\n enddo\n gx%bmperr=saverr\n if(ns.gt.0) write(*,'(a,i4,a)')'MM Remaining ',ns,' phases set as entered'\n1000 continue\n return\n end subroutine calculate_carefully\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine calctrans\n!\\begin{verbatim}\n subroutine calctrans(cline,last,ceq)\n! calculate a phase transition\n character cline*(*)\n integer last\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character name1*30\n integer j1,iph,ics\n double precision xxx\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: stvr\n!\n write(kou,2090)\n2090 format('To calculate when a phase will appear/disappear',&\n ' by releasing a condition.')\n if(btest(ceq%status,EQNOEQCAL)) then\n write(kou,2095)\n2095 format('You must make an equilibrium calculation before using',&\n ' this command.')\n goto 1000\n endif\n call gparcx('Phase name: ',cline,last,1,name1,' ','?Calculate transform')\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 1000\n j1=test_phase_status(iph,ics,xxx,ceq)\n if(j1.eq.PHFIXED) then\n write(kou,*)'Phase status already fixed'\n goto 1000\n endif\n call list_conditions(kou,ceq)\n write(kou,2097)\n2097 format('You must release one condition, give its number')\n call gparidx('Condition number',cline,last,j1,1,'?CALCULATE transform')\n if(j1.le.0 .or. j1.gt.noel()+2) then\n write(kou,*)'No such condition'\n goto 1000\n endif\n! this finds condition with given number\n call locate_condition(j1,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%active.eq.0) then\n! the condition is active, deactivate it!\n pcond%active=1\n else\n write(kou,*)'This condition is not active!'\n goto 1000\n endif\n! Condition released, now set the phase as fix with zero moles\n call change_phase_status(iph,ics,PHFIXED,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! Calculate equilibrium\n call calceq2(1,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! get the value of the released condition and set it to the new value\n stvr=>pcond%statvar(1)\n call state_variable_val(stvr,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(kou,2099)xxx\n2099 format('The transition occurs at ',1pe16.8,', set as condition')\n pcond%prescribed=xxx\n pcond%active=0\n! set phase back as entered and stable\n! write(*,*)'Set phase back as entered'\n call change_phase_status(iph,ics,PHENTSTAB,zero,ceq)\n1000 continue\n return\n end subroutine calctrans\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_conf_interval\n!\\begin{verbatim}\n recursive subroutine calc_conf_interval(lut,unc,ceq)\n! Provide some confidence intervals of the results\n! lut is output unit\n! unc is condition uncertainty in %\n! ceq is equilibrium record\n implicit none\n integer lut\n double precision unc\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ie,je,ip,it,jt,kt,cc,loktup,iph,ics,mode,nterm,kp\n logical once,noTcond,silent\n character name*32,text*128\n! max/min for stable phase amounts, chemical potentials\n double precision, allocatable :: pham(:),phamax(:),phamin(:)\n double precision, allocatable :: mum(:),mumax(:),mumin(:)\n double precision, allocatable :: cmax(:),cmin(:)\n double precision porg,gm,gmin,gmax,sm,smin,smax,gsum,ssum,rtg\n TYPE(gtp_phase_varres), pointer :: varrec\n TYPE(gtp_condition), pointer :: pcond,last\n TYPE(gtp_state_variable), pointer :: svrrec\n!\n write(kou,2)\n2 format(/'Providing an estimate of the confidence intervals'/&\n 'If T is a condition it must be the first'/)\n! write(*,*)'Not implemented yet'\n! goto 1000\n if(unc.gt.1.0D1) then\n write(*,*)'Condition uncertainties must be less than 10%'\n goto 1000\n endif\n! Equilibrium should already be calculated, do not use the grid minimizer\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Please calculate the equilibrium before this command!'\n ceq%status=ibset(ceq%status,EQFAIL)\n goto 1000\n endif\n! allocate arrays: stable phases, potentials (including T)\n ie=noel()\n allocate(mum(ie+1),mumin(ie+1)); allocate(mumax(ie+1))\n! ip is phaces, it is tuples, a phase may have more than one composition set\n ip=noph()\n it=nooftup()\n allocate(pham(it),phamin(it)); allocate(phamax(it))\n! conditions is ie+2\n allocate(cmin(ie+2)); allocate(cmax(ie+2))\n! list the current equilibrium, maybe replaced by using LIST RESULT before\n! this may eventually be provided by case(12) in pmon6\n write(lut,*)' *** Conditions:'\n call list_conditions(lut,ceq)\n write(lut,*)' *** Some global data:'\n call list_global_results(lut,ceq)\n! mode=1000 means list stable phases with mole fractions in value order\n mode=1000\n once=.TRUE.\n write(lut,5)\n5 format(/' *** Stable phase data:')\n phloop: do iph=1,ip\n do ics=1,9\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n! if a composition set does not exist take next phase\n if(gx%bmperr.ne.0) then\n gx%bmperr=0; cycle phloop\n endif\n enddo\n enddo phloop\n! loop to collect element data, it is stored in ceq%phase_varres\n! write(*,*)'Extracting chemical potentials: ',allocated(ceq%cmuval),&\n! size(ceq%cmuval),size(mum)\n do je=1,ie\n mum(je)=ceq%cmuval(je)\n mumin(je)=ceq%cmuval(je)\n mumax(je)=ceq%cmuval(je)\n enddo\n! maybe T is not a condition?\n mum(ie+1)=ceq%tpval(1)\n mumin(ie+1)=ceq%tpval(1)\n mumax(ie+1)=ceq%tpval(1)\n gsum=zero; ssum=zero\n do loktup=1,it\n! wow phase_varres(1) is for the SER phase .... ???\n! varrec=>ceq%phase_varres(loktup+1)\n varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares)\n if(varrec%dgm.eq.zero) then\n! this is a stable phase, its amount can be zero\n pham(loktup)=varrec%amfu\n phamin(loktup)=varrec%amfu\n phamax(loktup)=varrec%amfu\n gsum=gsum+varrec%amfu*varrec%gval(1,1)\n ssum=ssum+varrec%amfu*varrec%gval(2,1)\n else\n pham(loktup)=varrec%dgm\n phamin(loktup)=varrec%dgm\n phamax(loktup)=varrec%dgm\n endif\n enddo\n! total G and S\n gm=gsum\n gmin=gsum\n gmax=gsum\n sm=-ssum\n smin=-ssum\n smax=-ssum\n! loop to list phases close to stability\n do jt=1,it\n if(pham(jt).lt.zero .and. pham(jt).gt.-0.1D0) then\n call get_phasetuple_name(phasetuple(jt),name)\n write(lut,220)pham(jt),trim(name)\n220 format('Phase close to become stable ',1pe12.4,': ',a)\n endif\n enddo\n! Suppress output from calceq\n silent=btest(globaldata%status,GSSILENT)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n write(lut,230)\n230 format(/'Condition=value; +/-phase change relative original equilibrium')\n! now loop for all conditions to change each with +/-unc limit\n! and calculate extra equilibria to provide a confidence interval\n! save results from all and try to provide some estimate \n noTcond=.TRUE.\n last=>ceq%lastcondition%next\n pcond=>last\n cond: do while(.TRUE.)\n if(pcond%active.eq.0) then\n! condition is active \n if(pcond%noofterms.gt.1) then\n! write(*,*)'Ignoring expressions as conditions'\n goto 500\n elseif(pcond%statev.lt.0) then\n! write(*,*)'Ignoring fix phase as conditions'\n goto 500\n endif\n! write(*,250)pcond%statev,pcond%prescribed\n250 format('State variable index and value: ',i4,1pe12.4,l2)\n! special if no T condition\n if(pcond%statev.eq.1) noTcond=.FALSE.\n! ignore P\n if(pcond%statev.eq.2) goto 500\n! ignore N= (add also B and some others)\n if(pcond%statev.eq.110) goto 500\n! ignore conditions with a symbol as value\n if(pcond%symlink1.gt.0) goto 500\n! change condition -unc, calculate without gridmin to avoid creare new comp.sets\n porg=pcond%prescribed\n pcond%prescribed=pcond%prescribed*(one-0.01D0*unc)\n! save condition value just changed in \"text\"\n kp=1\n text=' '\n svrrec=>pcond%statvar(1)\n call encode_state_variable(text,kp,svrrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n text(kp:kp)='='\n kp=kp+1\n call wrinum(text,kp,10,0,pcond%prescribed)\n text(kp:kp)=';'\n kp=max(kp+2,20)\n! call list_conditions(lut,ceq)\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n write(lut,*)'Estimation failed as equilibrium calculation failed'\n write(*,*)'Estimation failed as equilibrium calculation failed'\n ceq%status=ibset(ceq%status,EQFAIL)\n! restore condition value\n pcond%prescribed=pcond%prescribed+0.01D0*unc\n goto 1000\n endif\n! save change in potentials\n do je=1,ie\n if(mumin(je).gt.ceq%cmuval(je)) mumin(je)=ceq%cmuval(je)\n if(mumax(je).lt.ceq%cmuval(je)) mumax(je)=ceq%cmuval(je)\n enddo\n if(noTcond) then\n! if T is not a condition save it\n if(mumin(ie+1).gt.ceq%tpval(1)) mumin(ie+1)=ceq%tpval(1)\n if(mumax(ie+1).lt.ceq%tpval(1)) mumax(ie+1)=ceq%tpval(1)\n endif\n! save changes in phase amount and stability\n gsum=zero; ssum=zero\n do loktup=1,it\n! REMEMBER phase_varres(1) is for the SER phase ???\n! varrec=>ceq%phase_varres(loktup+1)\n! varrec=>ceq%phase_varres(loktup)\n varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares)\n if(varrec%dgm.eq.zero) then\n! the ohase is stable\n if(pham(loktup).lt.zero) then\n! the phase was not stable originally\n call get_phasetuple_name(phasetuple(loktup),name)\n text(kp:)='+'//name\n kp=len_trim(text)+2\n phamax(loktup)=varrec%amfu\n else\n if(phamin(loktup).gt.varrec%amfu) phamin(loktup)=varrec%amfu\n if(phamax(loktup).lt.varrec%amfu) phamax(loktup)=varrec%amfu\n endif\n gsum=gsum+varrec%amfu*varrec%gval(1,1)\n ssum=ssum+varrec%amfu*varrec%gval(2,1)\n else\n! the phase is not stable\n if(pham(loktup).ge.zero) then\n call get_phasetuple_name(phasetuple(loktup),name)\n text(kp:)='-'//name\n kp=len_trim(text)+2\n phamin(loktup)=varrec%dgm\n else\n if(phamin(loktup).gt.varrec%dgm) phamin(loktup)=varrec%dgm\n if(phamax(loktup).lt.varrec%dgm) phamax(loktup)=varrec%dgm\n endif\n endif\n enddo\n if(gmin.gt.gsum) gmin=gsum\n if(gmax.lt.gsum) gmax=gsum\n if(smin.gt.-ssum) smin=-ssum\n if(smax.lt.-ssum) smax=-ssum\n! list new condition value just calculated, possibly with new phases\n write(lut,'(a)')trim(text)\n! change condition +unc to upper limit -------------------\n pcond%prescribed=porg*(one+0.01D0*unc)\n! save condition value just changed in \"text\"\n kp=1\n text=' '\n svrrec=>pcond%statvar(1)\n call encode_state_variable(text,kp,svrrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n text(kp:kp)='='\n kp=kp+1\n call wrinum(text,kp,10,0,pcond%prescribed)\n text(kp:kp)=';'\n kp=max(kp+2,20)\n! call list_conditions(lut,ceq)\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n write(lut,*)'Estimation failed as equilibrium calculation failed'\n write(*,*)'Estimation failed as equilibrium calculation failed'\n ceq%status=ibset(ceq%status,EQFAIL)\n! restore condition value\n pcond%prescribed=pcond%prescribed+0.01D0*unc\n goto 1000\n endif\n! save change in potenials\n do je=1,ie\n if(mumin(je).gt.ceq%cmuval(je)) mumin(je)=ceq%cmuval(je)\n if(mumax(je).lt.ceq%cmuval(je)) mumax(je)=ceq%cmuval(je)\n enddo\n if(noTcond) then\n! note je is ie+1 after loop above\n if(mumin(ie+1).gt.ceq%tpval(1)) mumin(ie+1)=ceq%tpval(1)\n if(mumax(ie+1).lt.ceq%tpval(1)) mumax(ie+1)=ceq%tpval(1)\n endif\n! save changes in phase amount and stability\n gsum=zero; ssum=zero\n do loktup=1,it\n varrec=>ceq%phase_varres(phasetuple(loktup)%lokvares)\n if(varrec%dgm.eq.zero) then\n! the phase is stable\n! write(*,*)'check: ',loktup,pham(loktup)\n if(pham(loktup).lt.zero) then\n! the phase was not stable originally\n call get_phasetuple_name(phasetuple(loktup),name)\n text(kp:)='+'//name\n kp=len_trim(text)+2\n phamax(loktup)=varrec%amfu\n else\n if(phamin(loktup).gt.varrec%amfu) phamin(loktup)=varrec%amfu\n if(phamax(loktup).lt.varrec%amfu) phamax(loktup)=varrec%amfu\n endif\n gsum=gsum+varrec%amfu*varrec%gval(1,1)\n ssum=ssum+varrec%amfu*varrec%gval(2,1)\n else\n! the phase is not stable\n if(pham(loktup).ge.zero) then\n call get_phasetuple_name(phasetuple(loktup),name)\n text(kp:)='-'//name\n kp=len_trim(text)+2\n phamax(loktup)=varrec%amfu\n else\n if(phamin(loktup).gt.varrec%dgm) phamin(loktup)=varrec%dgm\n if(phamax(loktup).lt.varrec%dgm) phamax(loktup)=varrec%dgm\n endif\n endif\n enddo\n if(gmin.gt.gsum) gmin=gsum\n if(gmax.lt.gsum) gmax=gsum\n if(smin.gt.-ssum) smin=-ssum\n if(smax.lt.-ssum) smax=-ssum\n! list new condition value just calculated, possibly with new phases\n write(lut,'(a)')trim(text)\n! restore original condition\n pcond%prescribed=porg\n! next condition\n endif\n500 continue\n pcond=>pcond%next\n if(associated(pcond,last)) exit cond\n enddo cond\n! listing variations in potentials\n write(lut,600)\n600 format(/'Variations in chemical potentials/RT:'/&\n 'Element original min max')\n do je=1,ie\n! there is no way to get element names from index ... suck\n call get_component_name(je,name,ceq)\n write(lut,610)name(1:2),mum(je),mumin(je),mumax(je)\n610 format(a,10x,1pe14.6,5x,2e12.4)\n enddo\n if(noTcond) then\n write(lut,615)mum(ie+1),mumin(ie+1),mumax(ie+1)\n615 format(/'Variation of T:: ',F10.2,5x,2F10.2,' K')\n endif\n rtg=globaldata%rgas*ceq%tpval(1)\n write(lut,620)gm*rtg,gmin*rtg,gmax*rtg,sm*rtg,smin*rtg,smax*rtg\n620 format(/'Gibbs energy: ',1pe14.6,5x,2e12.4,' J'/&\n 'Entropy : ',1pe14.6,5x,2e12.4,' J/K')\n write(lut,630)\n630 format(/'Variations in stable phase amounts:',&\n ' (negative value means unstable)'/&\n 'original amount min max')\n loop7: do jt=1,it\n iph=phasetuple(jt)%lokph; ics=phasetuple(jt)%compset\n! skip phases that are not entered\n if(test_phase_status(iph,ics,gsum,ceq).lt.-1) cycle loop7\n if(phamax(jt).ge.zero) then\n call get_phasetuple_name(phasetuple(jt),name)\n write(lut,640)pham(jt),phamin(jt),phamax(jt),trim(name)\n640 format(1pe12.4,5x,2e12.4,3x,a)\n endif\n enddo loop7\n! of the confidence interval within the condition uncertainties\n1000 continue\n! resstore silen mode\n if(.NOT.silent) then\n globaldata%status=ibclr(globaldata%status,GSSILENT)\n endif\n return\n end subroutine calc_conf_interval\n \n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine list_stable_phases\n!\\begin{verbatim}\n subroutine list_stable_phases(text,its,iadd,irem,meqrec,ceq)\n! debug listing of stable phases\n! meqrec contains all necessary data ...\n character*(*) text\n integer its,iadd,irem\n type(meq_setup) :: meqrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ii,ij,ik\n double precision gsum,xmol(50),wmass(50),totmol,totmass\n! NOTE: phases in stphl should always be in increasing order!!\n call calc_molmass(xmol,wmass,totmol,totmass,ceq)\n if(gx%bmperr.ne.0) stop 'Error when calling list_stable_phases'\n gsum=zero\n do ii=1,meqrec%nrel\n gsum=gsum+xmol(ii)*ceq%complist(ii)%chempot(1)\n enddo\n write(*,100)text,its,iadd,irem,meqrec%nstph,gsum,totmol,&\n (meqrec%stphl(ii),ii=1,meqrec%nstph)\n do ii=2,meqrec%nstph\n if(meqrec%stphl(ii-1).gt.meqrec%stphl(ii)) then\n stop 'phases in wrong order!!'\n endif\n enddo\n100 format(a,i3,2i4,i3,2(1pe12.4),20i4)\n! do ii=1,meqrec%nstph,5\n! iph1=meqrec%stphl(ii=1,meqrec%nstph)\n! write(*,200)meqrec%phr(\n! enddo\n return\n end subroutine list_stable_phases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nend MODULE liboceqplus\n\n" }, { "path": "src/models/OC-isoC.h", "content": "#if !defined __OCASI__\n#define __OCASI__\n\n/* Modification history\n160829 Bo Sundman Update\n2015-2016 Matthias Stratmann and Cristophe Sigli Modifications\n2014 Teslos? First version\n\nThis contains the structure of TYPE variables in OC \nneeded for the OC/TQ OCASI interface \n\nNOTE there is also a c_gtp_equilibrium_data structure defined in \nliboctqisoc.F90 */\n\ntypedef struct {\n int forcenewcalc;\n double tpused[2];\n double results[6];\n} tpfun_parres;\n\ntypedef struct {\n int splink, phlink, status;\n char refstate[16];\n int *endmember;\n double tpref[2];\n double chempot[2];\n double mass, molat;\n} gtp_components;\n\ntypedef struct {\n int lokph, compset, ixphase, lokvares, nextcs;\n} gtp_phasetuple;\n\ntypedef struct {\n int statevarid, norm, unit, phref, argtyp;\n int phase, compset, component, constituent;\n double coeff;\n int oldstv;\n} gtp_state_variable;\n\ntypedef struct {\n int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis;\n char id;\n double *dsites;\n int *nooffr;\n int *splink;\n int *y2x;\n double *dxidyj;\n double fsites;\n} gtp_fraction_set;\n\n//struct gtp_fraction_set;\n\ntypedef struct {\n int nextfree, phlink, status2, phstate,phtupx;\n double abnorm[3];\n char prefix[4], suffix[4];\n int *constat;\n double *yfr;\n double *mmyfr;\n double *sites;\n double *dpqdy;\n double *d2pqdvay;\n //struct gtp_fraction_set disfra;\n double amfu, netcharge, dgm;\n int nprop;\n int *listprop;\n double **gval;\n double ***dgval;\n double **d2gval;\n double curlat[3][3];\n double **cinvy;\n double *cxmol;\n double **cdxmol;\n double *addg;\n} gtp_phase_varres;\n\ntypedef struct gtp_condition {\n int noofterms, statev, active, iunit, nid, iref, seqz, experimenttype;\n int symlink1, symlink2;\n int **indices;\n double *condcoeff;\n double *prescribed, current, uncertainity;\n // should this be a struct ??\n gtp_state_variable *statvar;\n struct gtp_condition *next, *previous;\n} gtp_condition;\n\ntypedef struct {\n int status, multiuse, eqno, next;\n char eqname[24], comment[72];\n double tpval[2], rtn;\n double weight;\n double *svfunres;\n gtp_condition *lastcondition, *lastexperiment;\n gtp_components *complist;\n double **compstoi, **invcompstoi;\n gtp_phase_varres *phase_varres;\n tpfun_parres *eq_tpres;\n double *cmuval;\n double xconv;\n double gmindif;\n int maxiter;\n char eqextra[80];\n int sysmatdim, nfixmu, nfixph;\n int *fixmu;\n int *fixph;\n double **savesysmat;\n} gtp_equilibrium_data; \n \n#endif\n\n" }, { "path": "src/models/gtp3.F90", "content": "!\n!***************************************************************\n! General Thermodynamic Package (GTP)\n! for thermodynamic modelling and calculations\n!\nMODULE GENERAL_THERMODYNAMIC_PACKAGE\n!\n! Copyright 2011-2021, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n! contact person: bo.sundman@gmail.com\n!\n!-----------------------------------------------------------------------\n!\n!\n! for known unfinished/unchecked bugs and parallelization problems\n! look for BEWARE\n!\n! Using open MP parallelization (also added to metlib4.F90 for error code)\n!$ use OMP_LIB\n!\n use ocnum\n use metlib\n use ocparam\n!\n!! overall OC version number\n character (len=8), parameter :: version=' 6.112 '\n!\n!\n! data structure for non-encrypted TP functions\n!\n! use #include rather than include to have preprocessor options\n! include \"gtp3_dd1.F90\" for TP functions without decrypted databases\n#include \"gtp3_dd1.F90\"\n!\n! most global data structure definitions\n!\n! include \"gtp3_dd2.F90\" all other data structures\n#include \"gtp3_dd2.F90\"\n!\n! XML elements and attributes\n#include \"gtp3_xml.F90\"\n!\nCONTAINS\n\n! 1-5: initialization, how many, find things, get things, set things, \n!include \"gtp3A.F90\"\n#include \"gtp3A.F90\"\n\n! 12: enter data\n!include \"gtp3B.F90\"\n#include \"gtp3B.F90\"\n\n! 10: list data\n!include \"gtp3C.F90\"\n#include \"gtp3C.F90\"\n\n! 11: save and read from files\n!include \"gtp3D.F90\"\n#include \"gtp3D.F90\"\n\n! 9A: Read/write TDB/UNFORMATTED\n!include \"gtp3E.F90\"\n#include \"gtp3E.F90\"\n\n! 9B: Read/write XML\n!include \"gtp3EX.F90\"\n!include \"gtp3EY.F90\"\n#include \"gtp3EX.F90\"\n#include \"gtp3EY.F90\"\n\n! 7-8: state variable functions, interactive things\n!include \"gtp3F.F90\"\n#include \"gtp3F.F90\"\n\n! 13-15: status for things, unfinished things, internal stuff\n!include \"gtp3G.F90\"\n#include \"gtp3G.F90\"\n\n! 16: Additions (magnetic and others)\n!include \"gtp3H.F90\"\n#include \"gtp3H.F90\"\n\n! 6: calculate things, gtp3XQ for MQMQA\n!include \"gtp3X.F90\"\n#include \"gtp3X.F90\"\n#include \"gtp3XQ.F90\"\n\n! 17-18: Grid minimizer and miscellaneous\n!include \"gtp3Y.F90\"\n#include \"gtp3Y.F90\"\n\n! 19: TPFUN routines for non-encrypted databases\n!include \"gtp3Z.F90\"\n#include \"gtp3Z.F90\"\n\nEND MODULE GENERAL_THERMODYNAMIC_PACKAGE\n\n" }, { "path": "src/models/gtp3A.F90", "content": "!\n! gtp3A.F90 included in gtp3.F90\n!\n!****************************************************\n! general subroutines for creating and handling elements, species, phases etc\n! accessable externally\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> size 08.05.2025\n!> Master include file gtp3 3 kB\n!> Declaration of TPfun datastructures gtp3_dd1 5 kB\n!> Declaration other datastructures gtp3_dd2 115 kB\n!> Declaration of XML datastructures gtp3_xml 23 kB\n!> 1. Initialization and reinitiate gtp3A 117 kB\n!> 2. Number of things gtp3A \n!> 3. Find things gtp3A \n!> 4. Get things gtp3A \n!> 5. Set things gtp3A \n!> 6. Section: enter data gtp3B 367 kB\n!> 7. List data ............................ gtp3C 173 kB\n!> 8. Interactive things gtp3D 93 kB\n!> 9A. Read and save on files gtp3E 281 kB\n!> 9B. Read and save on XTDB files gtp3EX 67 kB\n!> 9C. Read and save on XTDB files gtp3EY 135 kB\n!> 10. State variable manipulations gtp3F 170 kB\n!> 11. Status of things gtp3G 79 kB\n!> 12. Unfinished things gtp3G\n!> 13. Internal stuff gtp3G\n!> 14. Additions and model properties gtp3H 178 kB\n!> 15. Calculate G for a phase gtp3X 246 kB\n!> 15B. Calculate G for MQMQA gtp3XQ 80 kB\n!> 16. Grid minimizer gtp3Y 284 kB\n!> 17. Miscellaneous gtp3Y\n!> 18. TP functions gtp3Z 140 kB \n!\n! But subroutines and functions have been added here and there\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine init_gtp\n!\\begin{verbatim}\n subroutine init_gtp(intvar,dblvar)\n! initiate the data structure\n! create element and species record for electrons and vacancies\n! the allocation of many arrays should be provided calling this routne\n! intvar and dblvar will eventually be used for allocations and defaults\n implicit none\n integer intvar(*)\n double precision dblvar(*)\n!\\end{verbatim}\n character tpname*16,tpfun*80\n integer jl,ieq,ip,lrot,npid\n!\n noofel=0; noofsp=0; noofph=0; nooftuples=0\n! write(*,3)' *** init_gtp should read MPID from AppendXTDB',maxel,maxsp,maxph\n3 format(a,10i5)\n! allocate records for elements\n allocate(ellista(-1:maxel))\n allocate(elements(-1:maxel))\n! allocate records for species\n allocate(splista(maxsp))\n allocate(species(maxsp))\n! allocate records for phases\n allocate(phlista(0:maxph))\n allocate(phases(0:maxph))\n phases=0\n allocate(phasetuple(0:2*maxph))\n do jl=1,2*maxph\n!CCI (array not scalar)\n phasetuple(jl)%nextcs=0\n!CCI\n enddo\n! phases(0) is refrence phase, evidently this index is never set\n phases(0)=0\n!---------------------------\n! create special element /-\n ellista(-1)%symbol='/-'\n ellista(-1)%name='Electron'\n ellista(-1)%ref_state='Electron_gas'\n ellista(-1)%mass=zero\n ellista(-1)%h298_h0=zero\n ellista(-1)%s298=zero\n ellista(-1)%status=0\n ellista(-1)%alphaindex=-1\n! The electron does not have any corresponing species\n ellista(-1)%splink=-1\n elements(-1)=-1\n! create special elements VA\n ellista(0)%symbol='VA'\n ellista(0)%name='Vacancy'\n ellista(0)%ref_state='Vacuum'\n ellista(0)%mass=zero\n ellista(0)%h298_h0=zero\n ellista(0)%s298=0.0D0\n ellista(0)%status=0\n ellista(0)%alphaindex=0\n! splink set below\n! ellista(0)%splink=0\n! allocate element link array\n allocate(splista(1)%ellinks(1))\n allocate(splista(1)%stoichiometry(1))\n splista(1)%symbol='VA'\n splista(1)%mass=zero\n splista(1)%charge=zero\n splista(1)%status=0\n splista(1)%quadindex=0\n! set status bits that is is also an element and it is the vacancy\n splista(1)%status=ibset(splista(1)%status,SPEL)\n splista(1)%status=ibset(splista(1)%status,SPVA)\n splista(1)%alphaindex=1\n splista(1)%noofel=1\n splista(1)%ellinks(1)=0\n splista(1)%stoichiometry(1)=one\n elements(0)=0\n noofsp=1\n species(1)=1\n! link from element Va to species Va\n ellista(0)%splink=1\n! write(*,3)'more allocate: ',maxrefs,maxprop,maxeq,maxtpf,maxsvfun\n allocate(bibrefs(maxrefs))\n allocate(propid(maxprop))\n! first free data reference record (static)\n reffree=1\n addrecs=0\n!---------------------------------------\n noofem=0\n noofint=0\n noofprop=0\n!----------------------------------------\n! initiate equilibrium record list\n! dimension arrays for in first equilibrium record including phase_varres\n allocate(eqlista(maxeq))\n do jl=1,maxeq-1\n! new 2019.12.17 zero status word!!\n eqlista(jl)%status=0\n eqlista(jl)%nexteq=jl+1\n enddo\n eqlista(maxeq)%nexteq=-1\n eqfree=1\n! create first equilibrium record incl complist\n call enter_equilibrium('DEFAULT_EQUILIBRIUM ',ieq)\n if(gx%bmperr.ne.0) then\n write(*,*)' error in first enter_equilibrium',gx%bmperr\n goto 1000\n endif\n firsteq=>eqlista(1)\n! nullify some pointers because of error entering first\n nullify(firsteq%lastcondition,firsteq%lastexperiment)\n! set phase_varres free list in firsteq. These are always allocated together\n do jl=1,2*maxph-1\n firsteq%phase_varres(jl)%nextfree=jl+1\n enddo\n! NOTE last phase_varres record used for copy in shiftcompsets\n firsteq%phase_varres(2*maxph)%nextfree=-1\n! csfree and highcs are declared in gtp3.F90\n csfree=1; highcs=0\n! convergence criteria for constituent fractions, 1e-6 works most often\n! But one should take care to equilibrate fractions smaller than xconv!!!\n!CCI\n call initialize_default_global_parameters(firsteq)\n!CCI\n! initiate tp functions\n! write(*,*)'init_gtp: initiate TP fuctions'\n jl=maxtpf\n call tpfun_init(jl,firsteq%eq_tpres)\n!------------------------------------\n! Property records define what can be used as \"id\" for parameters, the first\n! must be G for the \"chemical\" part. The others are connected to various\n! additions or are simply properties that may depend on composition and is\n! needed in other contexts, like mobilities, viscosities etc.\n! create property id records for G\n npid=1\n! propid(npid)%symbol='G '\n propid(npid)%symbol=modparid(1)\n propid(npid)%note='Energy '\n propid(npid)%status=0\n! This indicates if there are unkown or undefined MPI in a TDB file\n nundefmpi=0\n!============================================================\n! VERY IMPORTANT: The properties defined below must not be equal to state\n! variables, or abbreviation of state variables.\n! If so they cannot be listed and other errors may occur\n! IMPORTANT any changes must be propagated to gtp3F: state_variable_val3 !!!\n! after label 200!!\n!\n! ANY CHANGES HERE MUST BE MADE ALSO IN SUBROUTINE state_variable_val3\n! IN THE RESULTS THE TYPE OF VARIABLE WILL BE STORED USING THE npid INDEX HERE\n! OLD SAVE FILES MAY HAVE OTHER MEANING OF npid !!\n!\n!============================================================\n! Mixed Curie/Neel Temperature, set bits that TC and BM cannot depend on T 2\n npid=npid+1\n! propid(npid)%symbol='TC '\n propid(npid)%symbol=modparid(2)\n propid(npid)%note='Combined Curie/Neel T' \n propid(npid)%status=0\n! TC cannot depend on T but on P\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Average Bohr magneton number 3\n npid=npid+1\n! propid(npid)%symbol='BMAG '\n propid(npid)%symbol=modparid(3)\n propid(npid)%note='Average Bohr magneton numb'\n propid(npid)%status=0\n! BM cannot depend on either T or P ??\n propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n!.......................................\n! Specific Curie temperature 4\n npid=npid+1\n! propid(npid)%symbol='CTA '\n propid(npid)%symbol=modparid(4)\n propid(npid)%note='Curie temperature'\n propid(npid)%status=0\n! CTA cannot depend on either T or P ??\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Specific Neel temperature 5\n npid=npid+1\n! propid(npid)%symbol='NTA '\n propid(npid)%symbol=modparid(5)\n propid(npid)%note='Neel temperature'\n propid(npid)%status=0\n! NTA cannot depend on T but on P\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Individual Bohr magneton number 6 SPECIAL THIS HAS CONSTITUENT INDEX\n npid=npid+1\n! propid(npid)%symbol='IBM '\n propid(npid)%symbol=modparid(6)\n propid(npid)%note='Individual Bohr magneton numb'\n! 123456789.123456789.12345678-\n propid(npid)%status=0\n! IBM cannot depend on either T or P and it is individual\n propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX)\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Debye or Einstein temperature 7\n npid=npid+1\n! propid(npid)%symbol='LNTH '\n propid(npid)%symbol=modparid(7)\n propid(npid)%note='LN(Debye or Einstein temp)'\n propid(npid)%status=0\n! LNTH cannot depend on T but on P\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!....................................... 8\n! Molar volume at T=298.15, 1 bar\n npid=npid+1\n! propid(npid)%symbol='V0 '\n propid(npid)%symbol=modparid(8)\n propid(npid)%note='Volume at T0, P0 '\n propid(npid)%status=0\n! Constant independent on temperature or pressure\n propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n!....................................... 9\n! Thermal expansion at 1 bar\n npid=npid+1\n! propid(npid)%symbol='VA '\n propid(npid)%symbol=modparid(9)\n propid(npid)%note='Thermal expansion '\n propid(npid)%status=0\n! Not P dependent, only T dependent\n propid(npid)%status=ibset(propid(npid)%status,IDONLYT)\n!....................................... 10\n! Bulk modulus as function of T and P\n npid=npid+1\n! propid(npid)%symbol='VB '\n propid(npid)%symbol=modparid(10)\n propid(npid)%note='Bulk modulus '\n propid(npid)%status=0\n!....................................... 11\n! Extra volume parameter\n npid=npid+1\n! propid(npid)%symbol='VC '\n propid(npid)%symbol=modparid(11)\n propid(npid)%note='Alternative volume parameter'\n propid(npid)%status=0\n!....................................... 12\n! Diffusion volume parameter, suffix S on V create confusion with S as SER?\n npid=npid+1\n! propid(npid)%symbol='VS '\n propid(npid)%symbol=modparid(12)\n propid(npid)%note='Diffusion volume parameter '\n propid(npid)%status=0\n!.......................................\n! Activation energy of mobility 13\n npid=npid+1\n! propid(npid)%symbol='MQ '\n propid(npid)%symbol=modparid(13)\n propid(npid)%note='Mobility activation energy'\n propid(npid)%status=0\n! MQ is specific for a constituent\n propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX)\n! indicate this parameter must not have wildcard constituents\n nowildcard(1)=npid\n! in subroutine equilph1e we use the index of MQ to find mobility values\n mqindex=npid*100\n!.......................................\n! RT*ln(Frequency factor of mobility) 14\n npid=npid+1\n! propid(npid)%symbol='MF '\n propid(npid)%symbol=modparid(14)\n propid(npid)%note='RT*LN(mobility freq.fact.)'\n propid(npid)%status=0\n! MF is specific for a constituent\n propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX)\n! indicate this parameter must not have wildcard constituents\n nowildcard(2)=npid\n!.......................................\n! Magnetic mobility factor 15\n npid=npid+1\n! propid(npid)%symbol='MG '\n propid(npid)%symbol=modparid(15)\n propid(npid)%note='Magnetic mobility factor'\n propid(npid)%status=0\n! MG is specific for a constituent\n propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX)\n! indicate this parameter must not have wildcard constituents\n nowildcard(3)=npid\n!....................................... 13 fd 11\n! Liquid two-state model 16\n npid=npid+1\n! propid(npid)%symbol='G2 '\n propid(npid)%symbol=modparid(16)\n propid(npid)%note='Liquid two state parameter'\n propid(npid)%status=0\n!.......................................\n! Smooth unit step function (or second Einstein function) 17\n npid=npid+1\n! propid(npid)%symbol='THT2 '\n propid(npid)%symbol=modparid(17)\n propid(npid)%note='LN(Smooth step function Tcrit)'\n propid(npid)%status=0\n! THT2 cannot depend on T but on P\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Second Einstein delta CP 18\n npid=npid+1\n! propid(npid)%symbol='DCP2 '\n propid(npid)%symbol=modparid(18)\n propid(npid)%note='Smooth step function increm.'\n propid(npid)%status=0\n! DXP2 cannot depend on T but on P\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Lattice parameter in direction X 19\n npid=npid+1\n! propid(npid)%symbol='LPX '\n propid(npid)%symbol=modparid(19)\n propid(npid)%note='Lattice param X axis'\n propid(npid)%status=0\n! lattice parameters may depend on T and P\n!.......................................\n! Lattice parameter in direction Y 20\n npid=npid+1\n! propid(npid)%symbol='LPY '\n propid(npid)%symbol=modparid(20)\n propid(npid)%note='Lattice param Y axis'\n propid(npid)%status=0\n! lattice parameters may depend on T and P\n!.......................................\n! Lattice parameter in direction Z 21\n npid=npid+1\n! propid(npid)%symbol='LPZ '\n propid(npid)%symbol=modparid(21)\n propid(npid)%note='Lattice param Z axis'\n propid(npid)%status=0\n! lattice parameters may depend on T and P\n!.......................................\n! This is an angle for non-cubic lattices 22\n npid=npid+1\n! propid(npid)%symbol='LPTH '\n propid(npid)%symbol=modparid(22)\n propid(npid)%note='Lattice angle TH'\n propid(npid)%status=0\n! Angle may depend on T and P \n!.......................................\n! This is an elastic \"constant\" 23\n npid=npid+1\n! propid(npid)%symbol='EC11 '\n propid(npid)%symbol=modparid(23)\n propid(npid)%note='Elastic const C11'\n propid(npid)%status=0\n! The elastic constant may depend on T and P\n!.......................................\n! This is another elastic \"constant\" 24\n npid=npid+1\n! propid(npid)%symbol='EC12 '\n propid(npid)%symbol=modparid(24)\n propid(npid)%note='Elastic const C12'\n propid(npid)%status=0\n! The elastic constant may depend on T and P\n!.......................................\n! This is yet another elastic \"constant\" 25\n npid=npid+1\n! propid(npid)%symbol='EC44 '\n propid(npid)%symbol=modparid(25)\n propid(npid)%note='Elastic const C44'\n propid(npid)%status=0\n! The elastic constant may depend on T and P\n!.......................................\n! VERY SPECIAL this model parameter identifier has no addition\n! thus no check for addition in enter_parameter subroutine (gtp3B.F90)\n! UNIQUAC interaction parameter 26\n! IF THIS IS CHANGED TO ANOTHER NUMBER CHANGES NEEDED IN GTP3B: mpiwarning\n npid=npid+1\n! propid(npid)%symbol='UQT '\n propid(npid)%symbol=modparid(26)\n propid(npid)%note='UNIQUAC residual parameter '\n propid(npid)%status=0\n! UQT is specific for a constituent, 2600+constituent index\n propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX)\n!.......................................\n! Electrical resistivity 27\n npid=npid+1\n! propid(npid)%symbol='RHO '\n propid(npid)%symbol=modparid(27)\n propid(npid)%note='Electric resistivity'\n propid(npid)%status=0\n!....................................... f.d. 18 now 28\n! Viscosity 28\n npid=npid+1\n! propid(npid)%symbol='VISC '\n propid(npid)%symbol=modparid(28)\n propid(npid)%note='Viscosity'\n propid(npid)%status=0\n!....................................... \n! Thermal conductivity as function of T and P: 29\n npid=npid+1\n! propid(npid)%symbol='LAMB '\n propid(npid)%symbol=modparid(29)\n propid(npid)%note='Thermal conductivity '\n propid(npid)%status=0\n!.......................................\n! From MatCalc databases 30\n npid=npid+1\n! propid(npid)%symbol='HMVA '\n propid(npid)%symbol=modparid(30)\n propid(npid)%note='Enthalpy of vacancy form. '\n propid(npid)%status=0\n! this parameter does not depend on T ??\n! propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Schottky anomaly T 31\n npid=npid+1\n! propid(npid)%symbol='TSCH '\n propid(npid)%symbol=modparid(31)\n propid(npid)%note='Schottky anomaly T '\n propid(npid)%status=0\n! this parameter does not depend on T ??\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Schottky anomaly CP/R 32\n npid=npid+1\n! propid(npid)%symbol='CSCH '\n propid(npid)%symbol=modparid(32)\n propid(npid)%note='Schottky anomaly Cp/R. '\n propid(npid)%status=0\n! this parameter does not depend on T ??\n propid(npid)%status=ibset(propid(npid)%status,IDONLYP)\n!.......................................\n! Modified Quasichemical model coordination factor 33\n npid=npid+1\n! propid(npid)%symbol='QCZ'\n propid(npid)%symbol=modparid(33)\n propid(npid)%note='MQMQA cluster coord factor (not used)'\n propid(npid)%status=0\n propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n!.......................................\n! Modified MQMQA parameter factor 34\n npid=npid+1\n! propid(npid)%symbol='GG'\n propid(npid)%symbol=modparid(34)\n propid(npid)%note='MQMQA excess parameter'\n propid(npid)%status=0\n! propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n!.......................................\n! GG\n npid=npid+1\n! propid(npid)%symbol='GQ'\n propid(npid)%symbol=modparid(35)\n propid(npid)%note='MQMQA excess parameter'\n propid(npid)%status=0\n! propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n!.......................................\n! Modified MQMQA parameter factor 36\n npid=npid+1\n! propid(npid)%symbol=modparid(36)\n propid(npid)%symbol='GB'\n propid(npid)%note='MQMQA excess parameter'\n propid(npid)%status=0\n! This parameter does not depend on T and P\n! propid(npid)%status=ibset(propid(npid)%status,IDNOTP)\n\n!.......................................\n! The array modparid is declared in gtp3_dd2.F90 with 40 items.\n! debug output\n! do jl=1,npid\n! write(*,33)jl,propid(jl)%symbol,trim(propid(jl)%note)\n!33 format(i3,2x,a4,2x,a)\n! enddo\n!.......................................\n! This IF statement should be at the last parameter identifier, maxprop=50 ?\n if(npid.gt.maxprop) then\n write(*,*)'Too many parameter identifiers, increase maxprop'\n gx%bmperr=4250; goto 1000\n endif\n! write(*,*)'3A number of model parameter identifiers: ',npid\n! IMPORTANT any changes must be propagated to gtp3F: state_variable_val3 !!!\n!.......................................\n! IMPORTRANT: When adding more parameter identifiers one should NEVER\n! NEVER USE A NAME ENDING IN D as that will be taken as a \"disordered\" part\n! The number of defined properties, should be less than maxprop (=50?)\n! IMPORTANT: In the addition records one must use the parameter identifier\n! to extract the calculated composition dependent values\n! IMPORTANT: in gtp3F new variables must be added to be able to list/plot them\n ndefprop=npid\n!-------------------------------------------------\n!CCI : GSVIRTUAL enables to do calculation with virtual elements\n globaldata%status=ibclr(globaldata%status,GSVIRTUAL)\n!CCI\n! globaldata record; set gas constant mm\n globaldata%status=0\n! set beginner, no data, no phase, no equilibrium calculated\n globaldata%status=ibset(globaldata%status,GSBEG)\n! globaldata%status=ibset(globaldata%status,GSADV)\n globaldata%status=ibset(globaldata%status,GSNODATA)\n globaldata%status=ibset(globaldata%status,GSNOPHASE)\n firsteq%status=ibset(firsteq%status,EQNOEQCAL)\n! set that dense grid is used by default\n! globaldata%status=ibset(globaldata%status,GSXGRID)\n! set gas constant and some default values\n globaldata%name='current'\n globaldata%rgas=8.31451D0\n! more recent value not used as all TDB file used the old\n! globaldata%rgas=8.3144621D0\n! old value of gas constant\n globaldata%rgasuser=8.31451D0\n globaldata%pnorm=one\n! zero sysparam and sysreal\n globaldata%sysparam=0\n globaldata%sysreal=zero\n! write(*,*)'init_gtp: enter R and RTLNP'\n! enter R as TP function\n tpname='R'\n! write(tpfun,777)' 10 8.31451; 20000 N '\n!777 format(a)\n! call enter_tpfun(tpname,tpfun,lrot,.FALSE.)\n call store_tpconstant(tpname,globaldata%rgas)\n if(gx%bmperr.ne.0) goto 1000\n tpname='RTLNP'\n tpfun=' 1 R*T*LN(1.0D-5*P); 20000 N '\n! call store_tpfun(tpname,tpfun,lrot,.FALSE.)\n call store_tpfun(tpname,tpfun,lrot,-1)\n if(gx%bmperr.ne.0) goto 1000\n! default minimum fraction\n bmpymin=ymind\n! putfun error code .... should use buperr at least\n pfnerr=0\n!------------------------------------\n! allocate array for state variable function\n! write(*,*)'init_gtp: allocate array for state variable functions'\n allocate(svflista(maxsvfun))\n! number of state variable functions\n nsvfun=0\n! zero the array with equilibrium index for functions, not used aywhere??\n! pflocal=0\n! enter some useful state variable function\n tpfun=' R=8.31451;'\n ip=1\n! write(*,*)'init_gtp: entering function R'\n call enter_svfun(tpfun,ip,firsteq)\n! mark it cannot be amended\n svflista(1)%status=ibset(svflista(1)%status,SVNOAM)\n! mark it is a constant\n svflista(1)%status=ibset(svflista(1)%status,SVCONST)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error entering R',gx%bmperr\n! goto 1000\n! endif\n! write(*,*)'Entered symbol R'\n tpfun=' RT=R*T;'\n ip=1\n! write(*,*)'init_gtp: entering function RT'\n call enter_svfun(tpfun,ip,firsteq)\n! mark it cannot be amended\n svflista(2)%status=ibset(svflista(2)%status,SVNOAM)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error entering symbol RT'\n! goto 1000\n! endif\n! write(*,*)'Entered symbol RT'\n tpfun=' T_C=T-273.15;'\n ip=1\n! write(*,*)'init_gtp: entering function T_C'\n call enter_svfun(tpfun,ip,firsteq)\n! mark it cannot be amended\n svflista(3)%status=ibset(svflista(3)%status,SVNOAM)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error entering symbol T_C'\n! goto 1000\n! endif\n! we evaluate all symbols to avoid some problems ... no output\n! call meq_evaluate_all_svfun(-1,ceq) cannot be used as it is in minimizer ...\n call evaluate_all_svfun_old(-1,firsteq)\n! set working directory (decleared in metlib, used now and again ...)\n call getcwd(workingdir)\n! assessment initiallizing\n! write(*,*)'3A Initiallizing firstash', firstash is a pointer ...\n call assessmenthead(firstash)\n! firstash%status=0\n! write(*,*)'firstash allocated: ',firstash%status\n! nullify(firstash%prevash)\n! nullify(firstash%nextash)\n! create the beginnings of a circular list\n firstash%nextash=>firstash\n firstash%prevash=>firstash\n! set that dense grid used by default\n! globaldata%status=ibset(globaldata%status,GSXGRID)\n! removed line above as that caused crash in parallel2 WHY????\n! mqmqma exlevel=0 uses the old excess model implementation\n mqmqa_data%exlevel=0\n! to manually select debug output using LIST MQMQA DEBUG\n mqmqdebug=.false.\n mqmqdebug2=.false.\n! finished initiating\n1000 continue\n write(*,1001)\n1001 format(/'3A unfished preparations for XTDB'/)\n return\n END subroutine init_gtp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!CCI\n!\\addtotable subroutine initialize_default_global_parameters\n!\\begin{verbatim}\n subroutine initialize_default_global_parameters(firsteq)\n type(gtp_equilibrium_data), pointer :: firsteq\n!\\end{verbatim}\n firsteq%type_change_phase_amount = default_typechangephaseamount\n firsteq%scale_change_phase_amount= default_scalechangephaseamount\n firsteq%gmindif= default_mingridmin\n firsteq%precondsolver=default_precondsolver\n firsteq%splitsolver=default_splitsolver\n firsteq%xconv=default_xconv\n firsteq%maxiter=default_maxiter\n firsteq%gdconv(1)=default_gdconv1\n firsteq%gdconv(2)=default_gdconv2\n return\n end subroutine initialize_default_global_parameters\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n !\\addtotable subroutine assessmenthead\n!\\begin{verbatim}\n subroutine assessmenthead(ash)\n! create an assessment head record and do more (later)\n type(gtp_assessmenthead), pointer :: ash\n! type(gtp_assessmenthead), allocatable :: ash\n!\\end{verbatim}\n! it is not good to allocate a pointer, memory loss!!\n allocate(ash)\n ash%status=0\n return\n end subroutine assessmenthead\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\addtotable subroutine new_gtp\n!\\begin{verbatim}\n subroutine new_gtp\n!\n! DELETES ALL DATA so a new TDB file can be read\n!\n! this is needed before reading a new unformatted file (or same file again)\n! we must go through all records and delete and deallocate each\n! separately. Very similar to gtpread\n implicit none \n!\\end{verbatim}\n integer isp,j,nel,intv(10),k\n double precision dblv(10)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n type(gtp_phase_varres), pointer :: phdyn\n! TYPE(gtp_fraction_set) :: fslink\n! write(*,*)'3E Testing segmentation error in new_gtp'\n if(ocv()) write(*,*)'3E Removing current data'\n!---------- elementlist, no need to delete, just deallocate below\n!>>>>> 2:\n!---------- specieslist, we have to deallocate ?? maybe not ??\n!>>>>> 3:\n if(btest(globaldata%status,GSNODATA)) then\n if(ocv()) write(*,*)'3E No thermodynamic data to delete'\n goto 600\n endif\n if(gtp_species_version.ne.2) then\n write(*,17)'3E *** ERROR species',1,gtp_species_version\n17 format(a,' record version error: ',2i4)\n gx%bmperr=4300; goto 1000\n endif\n ceq=>firsteq\n! write(*,*)'3E No segmentation error A'\n do isp=1,noofsp\n nel=splista(isp)%noofel\n deallocate(splista(isp)%ellinks)\n deallocate(splista(isp)%stoichiometry)\n if(allocated(splista(isp)%spextra)) deallocate(splista(isp)%spextra)\n enddo\n!---------- phases, many records, here we travese all endmembers etc\n!>>>>> 4\n! write(*,*)'3E No segmentation error B'\n! if(gtp_phase_version.ne.1) then\n! write(*,17)'3E **** ERROR phase',1,gtp_phase_version\n! gx%bmperr=4302; goto 1000\n! endif\n! if(gtp_endmember_version.ne.1) then\n! write(*,17)'3E **** ERROR endmember',1,gtp_endmember_version\n! gx%bmperr=4302; goto 1000\n! endif\n! if(gtp_interaction_version.ne.1) then\n! write(*,17)'3E **** ERROR interaction',1,gtp_interaction_version\n! gx%bmperr=4302; goto 1000\n! endif\n! if(gtp_property_version.ne.1) then\n! write(*,17)'3E **** ERROR property',1,gtp_property_version\n! gx%bmperr=4302; goto 1000\n! endif\n do j=0,noofph\n call delphase(j)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! write(*,*)'3E No segmentation error C1'\n!----------- jump here if no thermodynamic data\n600 continue\n!---------- equilibrium records\n!>>>>> 50: equilibrium records\n! call delete_equil(ceq)\n! do j=1,noofeq\n! this loop was added in an attempt to get rid of an error occuring with\n! 64 bit version, the TP functions was not cleared correctly\n do j=1,eqfree-1\n ceq=>eqlista(j)\n deallocate(ceq%svfunres)\n! write(*,*)'3E No segmentation error C2',j\n deallocate(ceq%eq_tpres)\n! write(*,*)'3E No segmentation error C3',j\n deallocate(ceq%complist)\n! write(*,*)'3E No segmentation error C4',j\n deallocate(ceq%compstoi)\n! write(*,*)'3E No segmentation error C5',j\n deallocate(ceq%invcompstoi)\n! write(*,*)'3E No segmentation error C6',j\n! remove valgrind memory leak for conditions\n call delete_all_conditions(0,ceq)\n! clean upp phase_varres records\n do k=1,size(ceq%phase_varres)\n phdyn=>ceq%phase_varres(k)\n if(allocated(phdyn%gval)) then\n deallocate(phdyn%gval)\n deallocate(phdyn%dgval)\n deallocate(phdyn%d2gval)\n! write(*,*)'3E No segmentation error C7',j,k\n endif\n! deallocate mqmqa arrays\n if(allocated(phdyn%mqmqaf%yy1)) then\n write(*,*)'3E deallocating phase_varres%mqmqaf arrays'\n! these arrays allocated in gtp3X.F90\n deallocate(phdyn%mqmqaf%yy1)\n deallocate(phdyn%mqmqaf%dyy1)\n deallocate(phdyn%mqmqaf%d2yy1)\n deallocate(phdyn%mqmqaf%yy2)\n deallocate(phdyn%mqmqaf%dyy2)\n deallocate(phdyn%mqmqaf%d2yy2)\n deallocate(phdyn%mqmqaf%ceqf1)\n deallocate(phdyn%mqmqaf%dceqf1)\n deallocate(phdyn%mqmqaf%ceqf2)\n deallocate(phdyn%mqmqaf%dceqf2)\n deallocate(phdyn%mqmqaf%pair)\n deallocate(phdyn%mqmqaf%dpair)\n phdyn%mqmqaf%nquad=0\n! write(*,*)'3A cleaning up some mqmqa data'\n endif\n! set phstate and phlink to zero to avoid segmentation fault when plotting\n! after several MAP or STEP commands with different composition sets\n phdyn%phstate=0\n phdyn%phlink=0\n enddo\n! new implementation of MQMQA\n if(allocated(phdyn%mqmqaf%xquad)) then\n deallocate(phdyn%mqmqaf%xquad)\n deallocate(phdyn%mqmqaf%compvar)\n endif\n! write(*,*)'3E No segmentation error C8',j\n! deallocate(ceq%phase_varres)\n enddo\n! write(*,*)'3E No segmentation error D1'\n! I am not sure if this really releases all memory, how to check .... ???\n! call deallocate_gtp(intvar,dblvar)\n deallocate(eqlista)\n! write(*,*)'3E No segmentation error D2'\n!------- deallocate elements, species and phases, will be allocated in init_gtp\n deallocate(ellista)\n deallocate(elements)\n! do k=1,noofsp\n! deallocate(splista(k)%ellinks)\n! enddo\n deallocate(splista)\n deallocate(species)\n deallocate(phlista)\n deallocate(phases)\n deallocate(phasetuple)\n! write(*,*)'3E No segmentation error E'\n!------ tpfunction expressions and other lists\n!>>>>> 20: delete tpfuns\n! write(*,*)'3E Delete TP funs, just deallocate??',freetpfun\n! call delete_all_tpfuns\n! I do not think this deletes anything ... tpfuns is an array of pointers ...\n call tpfun_deallocate\n if(gx%bmperr.ne.0) then\n write(*,*)'3E **** ERROR deleting TP functions'\n endif\n! write(*,*)'3E Back from deleting all TP funs, this is fun!!'\n!------ tpfunction expressions and other lists\n!>>>>> 30: delete state variable functions\n deallocate(svflista)\n! write(*,*)'3E No segmentation error F'\n! call delete_svfuns\n!---------- delete bibliographic references\n!>>>>> 40: references\n deallocate(bibrefs)\n! call delete_biblio\n!------ parameter property records\n deallocate(propid)\n!------ other things such as mqmq_data arrays, I cannot deallocate here\n! probably many more mqmqa data must be deallocated\n if(allocated(mqmqa_data%contyp)) then\n deallocate(mqmqa_data%contyp)\n if(allocated(mqmqa_data%constoi)) deallocate(mqmqa_data%constoi)\n if(allocated(mqmqa_data%totstoi)) deallocate(mqmqa_data%totstoi)\n if(allocated(mqmqa_data%el2ancat)) deallocate(mqmqa_data%el2ancat)\n if(allocated(mqmqa_data%con2quad)) deallocate(mqmqa_data%con2quad)\n if(allocated(mqmqa_data%quad2compvar)) deallocate(mqmqa_data%quad2compvar)\n if(allocated(mqmqa_data%emquad)) deallocate(mqmqa_data%emquad)\n if(allocated(mqmqa_data%dy_ik)) deallocate(mqmqa_data%dy_ik)\n mqmqa_data%nconst=0\n mqmqa_data%ncon1=0\n mqmqa_data%ncon2=0\n mqmqa_data%npair=0\n! more to deallocate ......... see also at line 780 above\n if(allocated(tersys)) deallocate(tersys)\n! mqf=>phres%mqmqaf\n! write(*,*)'3A cleaning up some more mqmqa data'\n endif\n if(allocated(mqmqa_data%pinq)) then\n deallocate(mqmqa_data%pinq)\n endif\n! these are allocated here and there, if error reading database some may not be\n if(allocated(mqmqa_data%qfnnsnn)) then\n deallocate(mqmqa_data%qfnnsnn)\n deallocate(mqmqa_data%pp)\n endif\n if(allocated(mqmqa_data%con2quad)) deallocate(mqmqa_data%con2quad)\n! if(allocated(mqmqa_data%quad2con) deallocate(mqmqa_data%quad2con))\n!\n! write(*,*)'3E No segmentation error G'\n!------ map results are deleted separately\n! call delete_mapresults(maptop)\n! deallocate( .... any more ???\n!---------------------------\n! now initiate all lists and a little more\n if(ocv()) write(*,*)'3E All data structures will be reinitiated'\n! intv(1) negative means reinititate with same values as before\n! intv(1)=-1\n! write(*,*)'3E No segmentation error H', moved to pmon\n! call init_gtp(intv,dblv)\n! after return firsteq must be initiated ... maybe it should be done here ??\n!\n! Problem when adding EEC, initialization does not work, why?\n! Maybe these need initiating?\n globaldata%sysreal=zero\n globaldata%sysparam=0\n! For EEC sysreal(1) is set to a value of T\n! the MQMQA phase require reduced accuracy for a test in matsmin.F90 \n! around line 2223. Sysreal(2) is set to unity here\n globaldata%mqmqa1=1.0D0\n! globaldata%sysreal(2)=1.0D4\n! But if a MQMQA model phase involved it is set to 1.0D4\n!\n! write(*,*)'3E globaldata%encrypted: ',globaldata%encrypted\n! initiate Toop/Kohler record counter\n! uniqid=0\n!\n1000 continue\n return\n end subroutine new_gtp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine deallocate_gtp\n!\\begin{verbatim}\n subroutine deallocate_gtp(intvar,dblvar)\n! deallocate the data structure\n implicit none\n integer allocatestatus\n integer intvar(*)\n double precision dblvar(*)\n!\\end{verbatim}\n! integer jl\n write(*,*)'3A in deallocate_gtp'\n deallocate(ellista, STAT = allocateStatus)\n if (allocateStatus /= 0) then\n write(kou,*) 'Error during deallocation of ellista'\n goto 1000\n else\n write(kou,*) 'Deallocation of data ', allocateStatus\n endif\n! flush(6)\n deallocate(elements)\n! deallocate records for species\n deallocate(splista)\n deallocate(species)\n! deallocate records for phases\n deallocate(phlista)\n deallocate(phases)\n deallocate(phasetuple)\n deallocate(bibrefs)\n deallocate(propid)\n deallocate(eqlista)\n deallocate(svflista)\n write(*,*)'3A Deallocate TP funs'\n call tpfun_deallocate\n!CCI added this\n deallocate(firstash)\n1000 continue\n return\n END subroutine deallocate_gtp\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\addtotable subroutine delphase\n!\\begin{verbatim}\n subroutine delphase(lokph)\n! save data for phase at location lokph (except data in the equilibrium record)\n! For phases with disordered set of parameters we must access the number of\n! sublattices via firsteq\n implicit none\n integer lokph\n!\\end{verbatim}\n integer level,nsl,noendm\n type(gtp_endmember), pointer :: emrec,nextem\n type(gtp_interaction), pointer :: intrec,nextint\n type(gtp_property), pointer :: proprec,nextprop\n! to keep track of interaction records\n type saveint\n type(gtp_interaction), pointer :: p1\n end type saveint\n type(saveint), dimension(:), pointer :: stack\n type(gtp_phase_add), pointer :: addlink,nextadd\n! write(*,*)'3E In delphase',lokph\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n write(*,12)phlista(lokph)%name\n12 format('The phase ',a,' is present, reinitiate may fail')\n goto 1000\n endif\n allocate(stack(5))\n nsl=phlista(lokph)%noofsubl\n!>>>>> 6:\n! when failed reading database phlista may not be allocated!\n if(allocated(phlista)) then\n deallocate(phlista(lokph)%nooffr)\n deallocate(phlista(lokph)%constitlist)\n else\n write(*,*)'3A phlista not allocated!'\n gx%bmperr=4399; goto 1000\n endif\n emrec=>phlista(lokph)%ordered\n noendm=0\n!>>>>> 6: sublattice info\n! we come back here if there are disordered parameters\n200 continue\n! there can be phases without any parameters ...\n emlista: do while(associated(emrec))\n proprec=>emrec%propointer\n intrec=>emrec%intpointer\n nextem=>emrec%nextem\n!>>>>> 7: after saving links deallocate endmember record with all its content\n! write(*,*)'3E deallocate endmember record'\n deallocate(emrec)\n! nextem do not need to be declared as target??\n emrec=>nextem\n emproplista: do while(associated(proprec))\n nextprop=>proprec%nextpr\n!>>>>> 8: endmember property records\n! functions and references deallocated separately\n! write(*,*)'3E deallocate endmember property record'\n deallocate(proprec)\n proprec=>nextprop\n enddo emproplista\n! interaction tree\n level=0\n300 continue\n intlista: do while(associated(intrec))\n!>>>>> 9: interaction record\n level=level+1\n if(level.gt.5) then\n gx%bmperr=4164; goto 1000\n endif\n! write(*,*)'3E Pushing ',level\n stack(level)%p1=>intrec%nextlink\n nextint=>intrec%highlink\n proprec=>intrec%propointer\n! write(*,*)'3E deallocate interaction record'\n deallocate(intrec)\n intproplista: do while(associated(proprec))\n nextprop=>proprec%nextpr\n!>>>>> 10: interaction properties\n! write(*,*)'3E deallocate interaction property record'\n deallocate(proprec)\n proprec=>nextprop\n enddo intproplista\n intrec=>nextint\n enddo intlista\n! pop the link to next interaction if any\n pop: if(level.gt.0) then\n! write(*,*)'3E popping interaction record',level\n intrec=>stack(level)%p1\n nullify(stack(level)%p1)\n level=level-1\n goto 300\n endif pop\n!---- next endmember\n emrec=>nextem\n enddo emlista\n! no more endmembers, check if the disordered (if any) has been written\n if(noendm.eq.0) then\n! we do not have to care about that nsl is different ....\n!>>>>> 11: disordered endmembers\n! write(*,*)'3E disordered endmembers'\n emrec=>phlista(lokph)%disordered\n noendm=1\n goto 200\n endif\n! write(*,*)'3E finished parameter records'\n!------ additions list\n500 continue\n addlink=>phlista(lokph)%additions\n addition: do while(associated(addlink))\n!>>>>> 12: additions\n nextadd=>addlink%nextadd\n if(addlink%type.eq.1) then\n!>>>>> 12A: delete magnetic addition ...\n deallocate(addlink%explink)\n deallocate(addlink)\n elseif(addlink%type.eq.7) then\n!>>>>> 12A: delete volume addition ...\n deallocate(addlink)\n else\n write(*,'(\"3A Addition type \",i2,\" not deleted \")')addlink%type\n endif\n addlink=>nextadd\n enddo addition\n! write(*,*)'3E phase location: ',lokph,size(phlista(lokph)%nooffr),&\n! size(phlista(lokph)%constitlist)\n! if(lokph.ne.0) then\n! problem with phases, cannot deallocate these arrays, why??\n! deallocate(phlista(lokph)%nooffr)\n! deallocate(phlista(lokph)%constitlist)\n! endif\n phlista(lokph)%noofcs=0\n phlista(lokph)%nooffs=0\n! remove valgrind leak\n deallocate(stack)\n! write(*,*)'all done'\n1000 continue\n return\n end subroutine delphase\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 2. Section: number of things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function noel\n!\\begin{verbatim}\n integer function noel()\n! number of elements because noofel is private\n! should take care if elements are suspended\n!\\end{verbatim} %+\n noel=noofel\n end function noel\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function nosp\n!\\begin{verbatim} %-\n integer function nosp()\n! number of species because noofsp is private\n! should take care if species are suspended\n!\\end{verbatim} %+\n nosp=noofsp\n end function nosp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function noph\n!\\begin{verbatim} %-\n integer function noph()\n! number of phases because noofph is private\n! should take care if phases are hidden\n!\\end{verbatim} %+\n noph=noofph\n end function noph\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function noofcs\n!\\begin{verbatim} %-\n integer function noofcs(iph)\n! returns the number of compositions sets for phase iph\n implicit none\n integer iph\n!\\end{verbatim} %+\n if(iph.le.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n noofcs=phlista(phases(iph))%noofcs\n1000 continue\n return\n end function noofcs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function noconst\n!\\begin{verbatim} %-\n integer function noconst(iph,ics,ceq)\n! number of constituents for iph (include single constituents on a sublattice)\n! It tests if a constituent is suspended which can be different in each ics.\n implicit none\n integer iph,ics\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer lokph,lokcs,noc,jl\n if(iph.gt.0 .and. iph.le.noofph) then\n lokph=phases(iph)\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n! write(*,*)'noconst 1 error 4072'\n gx%bmperr=4072; goto 1000\n elseif(ics.eq.0) then\n ics=1\n endif\n lokcs=phlista(lokph)%linktocs(ics)\n if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then\n! some constituents suspended ?? NOT POSSIBLE as not implemented 190923 !!!\n! write(*,*)'3A suspended constituents!!',iph,ics,lokph,lokcs\n write(*,*)'3A suspended constituents: ',phlista(lokph)%tnooffr,&\n allocated(ceq%phase_varres(lokcs)%constat)\n if(.not.allocated(ceq%phase_varres(lokcs)%constat)) then\n noconst=phlista(lokph)%tnooffr\n else \n noc=phlista(lokph)%tnooffr\n do jl=1,phlista(lokph)%tnooffr\n if(btest(ceq%phase_varres(lokcs)%constat(jl),CONSUS)) then\n noc=noc-1\n endif\n enddo\n noconst=noc\n endif\n else\n noconst=phlista(lokph)%tnooffr\n endif\n else\n gx%bmperr=4050\n endif\n1000 continue\n return\n end function noconst\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function nooftup\n!\\begin{verbatim} %-\n integer function nooftup()\n! number of phase tuples\n!\\end{verbatim} %+\n implicit none\n nooftup=nooftuples\n return\n end function nooftup\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n!\\addtotable integer function noofphasetuples\n!\\begin{verbatim} %-\n! integer function noofphasetuples_old()\n! number of phase tuples REDUNDANT !!\n!\\end{verbatim}\n! noofphasetuples_old=nooftuples\n! return\n! end function noofphasetuples_old\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function nosvf\n!\\begin{verbatim}\n integer function nosvf()\n! number of state variable functions\n!\\end{verbatim}\n implicit none\n nosvf=nsvfun\n return\n end function nosvf\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable integer function noeq\n!\\begin{verbatim}\n integer function noeq()\n! returns the number of equilibria entered\n!\\end{verbatim}\n implicit none\n noeq=eqfree-1\n1000 continue\n return\n end function noeq\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable integer function nonsusphcs\n!\\begin{verbatim}\n integer function nonsusphcs(ceq)\n! returns the total number of unhidden phases+composition sets\n! in the system. Used for dimensioning work arrays and in loops\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer tphic,iph,ics,lokph\n double precision xxx\n tphic=0\n do iph=1,noofph\n lokph=phases(iph)\n ics=1\n if(test_phase_status(iph,ics,xxx,ceq).ne.PHHIDDEN) then\n! phase is not hidden\n do ics=1,phlista(lokph)%noofcs\n! if(test_phase_status(iph,ics,xxx,ceq).eq.4) goto 400\n if(test_phase_status(iph,ics,xxx,ceq).ne.PHSUS) then\n tphic=tphic+1\n endif\n! composition set not suspended\n! tphic=tphic+phlista(lokph)%noofcs\n enddo\n endif\n enddo\n1000 continue\n! write(*,*)'25 A nonsusphcs: ',tphic\n nonsusphcs=tphic\n return\n end function nonsusphcs\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 3. Section: find things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_element_by_name\n!\\begin{verbatim}\n subroutine find_element_by_name(name,iel)\n! find an element index by its name, exact fit required\n implicit none\n character name*(*)\n integer iel\n!\\end{verbatim} %+\n integer lokel\n character symbol*2\n symbol=name\n call capson(symbol)\n do lokel=-1,noofel\n! write(*,*)'find_element 1: ',lokel,symbol,' ',ellista(lokel)%symbol\n if(symbol.eq.ellista(lokel)%symbol) then\n iel=ellista(lokel)%alphaindex\n goto 1000\n endif\n enddo\n iel=-100\n gx%bmperr=4042\n1000 continue\n return\n end subroutine find_element_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_component_by_name\n!\\begin{verbatim} %-\n subroutine find_component_by_name(name,icomp,ceq)\n! BEWARE: one may in the future have different components in different\n! equilibria. components are a subset of the species\n implicit none\n character*(*) name\n integer icomp\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer loksp\n call find_species_record_noabbr(name,loksp)\n if(gx%bmperr.ne.0) then\n gx%bmperr=4052; goto 1000\n endif\n! check that species actually is component\n do icomp=1,noofel\n if(ceq%complist(icomp)%splink.eq.loksp) goto 1000\n enddo\n gx%bmperr=4052\n1000 continue\n return\n end subroutine find_component_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_species_by_name\n!\\begin{verbatim} %-\n subroutine find_species_by_name(name,isp)\n! locates a species index from its name, unique abbreviation \n! or exact match needed\n implicit none\n character name*(*)\n integer isp\n!\\end{verbatim} %+\n character symbol*24\n integer loksp,lensym\n logical exact\n exact=.FALSE.\n symbol=name\n call capson(symbol)\n isp=0\n do loksp=1,noofsp\n! write(*,*)'3A find species 2: ',symbol,splista(loksp)%symbol,loksp\n if(compare_abbrev(symbol,splista(loksp)%symbol)) then\n if(isp.eq.0) then\n isp=splista(loksp)%alphaindex\n lensym=len_trim(splista(loksp)%symbol)\n! write(*,*)'3A abbr match: ',lensym,' <',symbol(1:lensym),'><',&\n! splista(loksp)%symbol(1:lensym+1),'>'\n if(symbol(1:lensym+1).eq.splista(loksp)%symbol(1:lensym+1)) then\n! write(*,*)'3A exact match with species name'\n exact=.TRUE.\n goto 1000\n endif\n else\n! abbreviation is not unique\n isp=0\n exit\n endif\n endif\n enddo\n if(isp.eq.0) then\n! write(*,*)'in find_species_by_name'\n gx%bmperr=4051\n loksp=0\n endif\n1000 continue\n return\n end subroutine find_species_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_species_by_name_exact\n!\\begin{verbatim} %-\n subroutine find_species_by_name_exact(name,isp)\n! locates a species index from its name, exact match needed\n implicit none\n character name*(*)\n integer isp\n!\\end{verbatim} %+\n character symbol*24\n integer loksp,lensym\n logical exact\n symbol=name\n call capson(symbol)\n isp=0\n do loksp=1,noofsp\n! write(*,*)'3A find species exact: ',symbol,splista(loksp)%symbol,loksp\n lensym=len_trim(splista(loksp)%symbol)\n if(symbol(1:lensym+1).eq.splista(loksp)%symbol(1:lensym+1)) then\n isp=splista(loksp)%alphaindex\n endif\n enddo\n if(isp.eq.0) then\n! write(*,*)'in find_species_by_name'\n gx%bmperr=4051\n loksp=0\n endif\n1000 continue\n return\n end subroutine find_species_by_name_exact\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_species_record\n!\\begin{verbatim} %-\n subroutine find_species_record(name,loksp)\n! locates a species record allowing abbreviations\n implicit none\n character name*(*)\n integer loksp\n!\\end{verbatim} %+\n character symbol*24\n integer isp,lensp\n logical exact\n exact=.FALSE.\n symbol=name\n isp=0\n call capson(symbol)\n do loksp=1,noofsp\n! write(*,17)'3A find species: ',loksp,splista(loksp)%symbol,name\n17 format(a,i3,' \"',a,'\" \"',a,'\"')\n if(compare_abbrev(symbol,splista(loksp)%symbol)) then\n if(isp.eq.0) then\n isp=loksp\n! it would be enough to compare lengths of species ...\n lensp=len_trim(splista(loksp)%symbol)\n if(symbol(1:lensp+1).eq.splista(loksp)%symbol(1:lensp+1)) then\n! write(*,*)'3A exact match'\n exact=.TRUE.\n goto 1000\n endif\n else\n! ambiguous species name but we may find an exact later ...\n isp=-1\n endif\n endif\n enddo\n if(isp.le.0) then\n! write(*,*)'Error in find_species_record \"',name,'\"'\n gx%bmperr=4051\n loksp=0\n else\n loksp=isp\n endif\n1000 continue\n return\n end subroutine find_species_record\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_species_record_noabbr\n!\\begin{verbatim} %-\n subroutine find_species_record_noabbr(name,loksp)\n! locates a species record no abbreviations allowed\n implicit none\n character name*(*)\n integer loksp\n!\\end{verbatim} %+\n character symbol*24\n symbol=name\n call capson(symbol)\n! for MQMQA phases with final -Qij the \"ij\" is ignored\n! and no check if the phase is MQMQA\n do loksp=1,noofsp\n! write(*,17)'find species 17B: ',loksp,splista(loksp)%symbol,name\n!17 format(a,i3,' \"',a,'\" \"',a,'\"')\n if(symbol.eq.splista(loksp)%symbol) goto 1000\n enddo\n! write(*,*)'Error in find_species_record_noabbr \"',name,'\"'\n gx%bmperr=4051\n loksp=0\n1000 continue\n return\n end subroutine find_species_record_noabbr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_species_record_exact\n!\\begin{verbatim} %-\n subroutine find_species_record_exact(name,loksp)\n! locates a species record, exact match needed\n! for parameters, V must not be accepted as abbreviation of VA or C for CR\n implicit none\n integer loksp\n character name*(*)\n!\\end{verbatim}\n integer quad\n character symbol*24\n symbol=name\n call capson(symbol)\n! special for quadrupoles ... they can have a trailing -Qij which may be\n! different each time ...\n quad=index(symbol,'-Q')\n if(quad.gt.0) then\n quad=quad-1\n else\n quad=0\n endif\n do loksp=1,noofsp\n! write(*,17)'find species 17: ',loksp,splista(loksp)%symbol,name\n!17 format(a,i3,' \"',a,'\" \"',a,'\"')\n if(quad.gt.0) then\n if(symbol(1:quad).eq.splista(loksp)%symbol(1:quad)) goto 1000\n else\n! problem that V was not read from database ...\n if(symbol.eq.splista(loksp)%symbol) goto 1000\n endif\n enddo\n! This message cannot be written as it is used when reading a TDB file ...\n! write(kou,*)'Exact match to species name requited'\n gx%bmperr=4051\n loksp=0\n1000 continue\n return\n end subroutine find_species_record_exact\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_phasetuple_by_name\n!\\begin{verbatim}\n subroutine find_phasetuple_by_name(name,phcsx)\n! finds a phase with name \"name\", returns phase tuple index\n! handles composition sets either with prefix/suffix or #digit\n! When no pre/suffix nor # always return first composition set\n implicit none\n character name*(*)\n integer phcsx\n!\\end{verbatim} %+\n integer iph,ics\n iph=0\n ics=0\n phcsx=0\n call find_phasex_by_name(name,phcsx,iph,ics)\n1000 continue\n return\n end subroutine find_phasetuple_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_phase_by_name\n!\\begin{verbatim} %-\n subroutine find_phase_by_name(name,iph,ics)\n! finds a phase with name \"name\", returns address of phase, first fit accepted\n! handles composition sets either with prefix/suffix or #digit\n! When no pre/suffix nor # always return first composition set\n implicit none\n character name*(*)\n integer iph,ics\n!\\end{verbatim} %+\n integer phcsx\n phcsx=0\n call find_phasex_by_name(name,phcsx,iph,ics)\n1000 continue\n return\n end subroutine find_phase_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function find_phasetuple_by_indices\n!\\begin{verbatim} %-\n integer function find_phasetuple_by_indices(iph,ics)\n! subroutine find_phasetuple_by_indices(iph,ics)\n! find phase tuple index given phase index and composition set number\n integer iph,ics\n!\\end{verbatim} %+\n integer ij\n ij=iph\n if(ij.gt.0 .and. ij.le.nooftuples) then\n do while(ij.gt.0)\n if(ics.eq.phasetuple(ij)%compset) then\n find_phasetuple_by_indices=ij\n goto 1000\n else\n ij=phasetuple(ij)%nextcs\n endif\n enddo\n endif\n write(*,*)'Wrong arguments to find_phasetuple_by_indices: ',iph,ics,ij\n gx%bmperr=4073\n1000 continue\n return\nend function find_phasetuple_by_indices\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_phasex_by_name\n!\\begin{verbatim} %-\n subroutine find_phasex_by_name(name,phcsx,iph,zcs)\n! finds a phase with name \"name\", returns index and tuplet of phase.\n! All phases checked and error return if name is ambiguous\n! handles composition sets either with prefix/suffix or #digit or both\n! if no # check all composition sets for prefix/suffix\n! special if phcsx = -1 and there are several composition sets then\n! zcs is set to -(number of composition sets). Used when changing status\n! phcsx, iph and zcs are values to return!\n implicit none\n character name*(*)\n integer phcsx,iph,zcs\n!\\end{verbatim} %+\n character name1*36,csname*36,name2*24,name3*24,ambname*24\n TYPE(gtp_phase_varres), pointer :: csrec\n integer kp,kcs,lokph,jcs,lokcs,first1,fcs,lcs,ics,lenam,allsets\n! set ics to an illegal value\n ics=-1\n allsets=phcsx\n! convert to upper case locally\n name1=name\n call capson(name1)\n ambname=name1\n! composition set as #digit\n kp=index(name1,'#')\n if(kp.gt.0) then\n ics=ichar(name1(kp+1:kp+1))-ichar('0')\n! negative ics should give error, 0 should be the same as 1\n if(ics.eq.0) ics=1\n if(ics.lt.1 .or. ics.gt.9) then\n gx%bmperr=4093; goto 1000\n endif\n allsets=ics\n name1(kp:)=' '\n kcs=ics\n else\n ics=1\n kcs=0\n endif\n! write(*,17)trim(name),ics,kcs,kp,noofph\n17 format('3A find_phase 3: ',a,2x,10i4)\n first1=0\n loop1: do lokph=1,noofph\n if(kcs.eq.0) then\n! no composition set specified explicitly, all sets must be checked\n fcs=2; lcs=phlista(lokph)%noofcs\n! elseif(kcs.eq.1) then\n! fcs=1; lcs=1\n elseif(kcs.le.phlista(lokph)%noofcs) then\n! we shoud check pre and suffix ...\n fcs=max(2,kcs); lcs=kcs\n else\n! this phase does not have a composition set kcs\n cycle loop1\n endif\n name2=phlista(lokph)%name\n if(kcs.le.1) then\n if(compare_abbrev(name1,name2)) then\n if(first1.eq.0) then\n first1=lokph\n if(len_trim(name1).eq.len_trim(name2)) then\n! exact match, we already know there is a composition set\n! write(*,*)'3A exact match',name1(1:len_trim(name1)),lokph\n goto 300\n endif\n else\n! another phase with same abbreviation, phase name is ambiguous\n write(kou,4121)trim(name1),trim(name2),trim(ambname)\n4121 format('Phase abbreviation ambiguous: ',a,' and ',a,2x,a)\n gx%bmperr=4121\n goto 1000\n endif\n endif\n endif\n! if composition set specified check only that set, otherwise all from 2\n! write(*,*)'3A first1: ',first1,fcs,lcs\n loop2: do jcs=fcs,lcs\n lokcs=phlista(lokph)%linktocs(jcs)\n csrec=>firsteq%phase_varres(lokcs)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//name2\n else\n csname=name2\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//&\n csrec%suffix(1:kp)\n! write(*,244)ics,kcs,jcs,kp,fcs,lcs,first1,name1(1:len_trim(name1)),&\n! csname(1:len_trim(csname))\n244 format('3A: find_phase: ',7i3,'<',a,'>=?=<',a,'>')\n if(compare_abbrev(name1,csname)) then\n if(first1.eq.lokph) then\n! match already with first composition set, that is OK\n cycle loop2\n elseif(first1.eq.0) then\n first1=lokph\n ics=jcs\n allsets=ics\n else\n! ambiguous phase name\n write(kou,4121)1652,trim(name1),trim(csname)\n gx%bmperr=4121; goto 1000\n endif\n elseif(kcs.gt.1) then\n! No mach with phase name including pre/suffix but if user has specified #\n! accept also match with original name without pre/suffix\n if(compare_abbrev(name1,name2)) then\n if(first1.eq.0) then\n first1=lokph\n ics=jcs\n else\n! another phase with same abbreviation, phase name is ambiguous\n write(kou,4121)1664,trim(name1),trim(name2)\n gx%bmperr=4121\n goto 1000\n endif\n endif\n endif\n enddo loop2\n enddo loop1\n! write(*,*)'3A first1: ',first1\n if(first1.eq.0) then\n! no phase found\n gx%bmperr=4050\n goto 1000\n endif\n300 continue\n! first1 is lokph for phase\n iph=phlista(first1)%alphaindex\n if(allsets.eq.-1) then\n! special to set status: return -(number of composition sets) in zcs if >1\n! DO NOT CHANGE PHCSX\n lcs=phlista(first1)%noofcs\n if(lcs.gt.1) then\n ics=-lcs; zcs=-lcs\n else\n ics=1; zcs=1\n endif\n else\n! ics set above, return it in zcs\n zcs=ics\n phcsx=firsteq%phase_varres(phlista(first1)%linktocs(ics))%phtupx\n endif\n gx%bmperr=0\n1000 continue\n return\n1100 continue\n gx%bmperr=4073\n goto 1000\n END subroutine find_phasex_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_phase_by_name_exact\n!\\begin{verbatim} %-\n subroutine find_phase_by_name_exact(name,iph,ics)\n! finds a phase with name \"name\", returns address of phase. exact match req.\n! handles composition sets either with prefix/suffix or #digit\n! no pre/suffix nor # gives first composition set\n implicit none\n character name*(*)\n integer iph,ics\n!\\end{verbatim}\n character name1*36,csname*36,name2*24\n TYPE(gtp_phase_varres), pointer :: csrec\n integer kp,kcs,iphfound,lokph,jcs,lokcs\n! convert to upper case locally\n name1=name\n call capson(name1)\n! composition set as #digit\n kp=index(name1,'#')\n if(kp.gt.0) then\n ics=ichar(name1(kp+1:kp+1))-ichar('0')\n! negative ics should give error, 0 should be the same as 1\n if(ics.eq.0) ics=1\n if(ics.lt.1 .or. ics.gt.9) then\n gx%bmperr=4093; goto 1000\n endif\n name1(kp:)=' '\n kcs=ics\n else\n ics=1\n kcs=0\n endif\n! write(*,17)ics,kcs\n17 format('find_phase 3: ',2i4)\n! write(*,11)'fpbne 1: ',name,noofph\n11 format(a,a,'; ',2i3)\n iphfound=0\n loop1: do lokph=1,noofph\n name2=phlista(lokph)%name\n! write(*,*)'find_phase 2: ',name1,name2\n if(compare_abbrev(name1,name2)) then\n if(ics.le.phlista(lokph)%noofcs) then\n! possible phase, if exact match no more checks\n if(trim(name1).eq.trim(name2)) then\n iphfound=lokph\n goto 300\n endif\n if(iphfound.ne.0) then\n if(trim(name1).eq.trim(name2)) then\n iphfound=lokph\n goto 300\n else\n iphfound=-lokph\n endif\n else\n iphfound=lokph\n endif\n else\n! write(*,18)ics,phlista(lokph)%noofcs\n18 format('find_phase 4: ',2i4)\n gx%bmperr=4072; goto 1000\n endif\n endif\n enddo loop1\n! write(*,*)'find_phase ',iphfound\n if(iphfound.lt.0) then\n! several phases found\n write(kou,4121)trim(name1),trim(name2)\n4121 format('Several phases found: ',a,' and ',a)\n gx%bmperr=4121; goto 1000\n elseif(iphfound.le.0) then\n! no phase found\n gx%bmperr=4050; goto 1000\n else\n lokph=iphfound\n goto 300\n endif\n! if there are composition sets check name including prefix/suffix\n write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs\n do jcs=2,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(jcs)\n csrec=>firsteq%phase_varres(lokcs)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//name2\n else\n csname=name2\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//&\n csrec%suffix(1:kp)\n if(compare_abbrev(name1,csname)) then\n! if user has provided both # and pre/suffix these must be consistent\n if(kcs.gt.0 .and. kcs.ne.jcs) goto 1100\n ics=jcs\n goto 300\n endif\n enddo\n250 continue\n! no phase with this name\n gx%bmperr=4050\n goto 1000\n300 continue\n iph=phlista(lokph)%alphaindex\n gx%bmperr=0\n1000 continue\n return\n1100 continue\n! composition set index and pre/suffix does not match\n gx%bmperr=4073\n goto 1000\n END subroutine find_phase_by_name_exact\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_constituent\n!\\begin{verbatim}\n subroutine find_constituent(iph,spname,mass,icon)\n! find the constituent \"spname\" of a phase. spname can have a sublattice #digit\n! Return the index of the constituent in icon. Additionally the mass\n! of the species is returned.\n implicit none\n character*(*) spname\n double precision mass\n integer iph,icon\n!\\end{verbatim}\n! BUG found, asking for a constituent N it returned the constituent NB !!!\n! Must search for exact match!!!\n character spname1*24\n integer lokph,kp,ll,kk,loksp,ls,first,jabbr\n lokph=phases(iph)\n kp=index(spname,'#')\n if(kp.gt.0) then\n ls=ichar(spname(kp+1:kp+1))-ichar('0')\n spname1=spname(1:kp-1)\n else\n ls=0\n spname1=spname\n endif\n call capson(spname1)\n icon=0\n jabbr=0\n first=0\n lloop: do ll=1,phlista(lokph)%noofsubl\n sploop: do kk=1,phlista(lokph)%nooffr(ll)\n icon=icon+1\n if(ls.eq.0 .or. ls.eq.ll) then\n loksp=phlista(lokph)%constitlist(icon)\n! constituent icon is the requested one ??\n! write(*,55)ll,kk,icon,trim(spname1),trim(splista(loksp)%symbol)\n55 format('find_const 7: ',3i3,1x,a,2x,a)\n if(compare_abbrev(spname1,splista(loksp)%symbol)) then\n! write(*,*)'3A abbreviation OK: ',trim(spname1),'?',&\n! trim(splista(loksp)%symbol),icon\n if(trim(spname1).eq.trim(splista(loksp)%symbol)) then\n! if exact match accept\n first=loksp; goto 90\n elseif(first.eq.0) then\n! constituent name is an abbreviation, if only one accept\n first=loksp\n jabbr=icon\n else\n write(kou,4121)trim(spname1),trim(splista(loksp)%symbol)\n4121 format('Specie name abbreviation same ',a,' and ',a)\n gx%bmperr=4121\n goto 1000\n endif\n endif\n endif\n! write(*,*)'3A current: ',icon,first,loksp\n enddo sploop\n enddo lloop\n90 continue\n! write(*,*)'3A current: ',icon,first,loksp,' \"',trim(spname1),'\"'\n if(first.eq.0) then\n! no such constituent\n gx%bmperr=4096\n else\n if(jabbr.gt.0) then\n! accept unique abbreviation\n! write(*,*)'3A abbreviation: ',icon,jabbr,loksp\n icon=jabbr\n endif\n mass=splista(first)%mass\n endif\n1000 continue\n return\n end subroutine find_constituent\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine findconst\n!\\begin{verbatim}\n subroutine findconst(lokph,ll,spix,constix)\n! locates the constituent index of species with index spix in sublattice ll\n! and returns it in constix. For wildcards spix is -99; return -99\n! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK\n implicit none\n integer lokph,ll,spix,constix\n!\\end{verbatim}\n integer nc,l2,loksp\n if(spix.eq.-99) then\n constix=-99\n goto 1000\n endif\n nc=1\n do l2=1,ll-1\n! The number of constituents in each sublattice can vary, add together\n nc=nc+phlista(lokph)%nooffr(l2)\n enddo\n constix=0\n do l2=nc,nc+phlista(lokph)%nooffr(ll)-1\n loksp=phlista(lokph)%constitlist(l2)\n if(splista(loksp)%alphaindex.eq.spix) then\n constix=l2; exit\n endif\n enddo\n if(constix.eq.0) then\n! write(*,90)spix,nc\n90 format('3B No such constituent with index ',i5,' in sublattice',i3)\n gx%bmperr=4066; goto 1000\n endif\n1000 continue\n return\n end subroutine findconst\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine findeq\n!\\begin{verbatim}\n subroutine findeq(name,ieq)\n! finds the equilibrium with name \"name\" and returns its index\n! ieq should be the current equilibrium\n implicit none\n character name*(*)\n integer ieq\n!\\end{verbatim} %+\n character name2*64\n integer jeq\n name2=name\n call capson(name2)\n! Accept abbreviations of PREVIOUS and FIRST (DEFAULT is the same as the first)\n jeq=0\n if(compare_abbrev(name2,'PREVIOUS ')) then\n jeq=max(1,ieq-1); goto 200\n elseif(compare_abbrev(name2,'FIRST ')) then\n jeq=1; goto 200\n elseif(compare_abbrev(name2,'DEFAULT ')) then\n jeq=1; goto 200\n! elseif(compare_abbrev(name2,'LAST ')) then\n! jeq=1; goto 200\n endif\n100 jeq=jeq+1\n! write(*,*)'findeq 2: ',jeq,name2\n if(jeq.ge.eqfree) then\n gx%bmperr=4124\n goto 1000\n endif\n! write(*,*)'findeq 3: ',jeq,eqlista(jeq)%eqname\n if(.not.compare_abbrev(name2,eqlista(jeq)%eqname)) goto 100\n! if(eqlista(jeq)%eqname.ne.name2) goto 100\n200 continue\n ieq=jeq\n1000 continue\n end subroutine findeq\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine selecteq\n!\\begin{verbatim} %-\n subroutine selecteq(ieq,ceq)\n! checks if equilibrium ieq exists and if so set it as current\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer ieq\n!\\end{verbatim}\n if(ieq.lt.0 .or. ieq.ge.eqfree) then\n gx%bmperr=4124\n goto 1000\n endif\n ceq=>eqlista(ieq)\n1000 continue\n end subroutine selecteq\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 4. Section: get things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_record\n!\\begin{verbatim}\n subroutine get_phase_record(iph,lokph)\n! given phase index iph this returns the phase location lokph\n implicit none\n integer iph,lokph\n!\\end{verbatim} %+\n if(iph.lt.1 .or. iph.gt.noofph) then\n! write(*,*)'gpr: ',iph,noofph\n gx%bmperr=4050\n else\n lokph=phases(iph)\n endif\n return\n end subroutine get_phase_record\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_variance\n!\\begin{verbatim} %-\n subroutine get_phase_variance(iph,nv)\n! returns the number of independent variable fractions in phase iph\n implicit none\n integer iph,nv\n!\\end{verbatim} %+\n integer lokph\n call get_phase_record(iph,lokph)\n nv=phlista(lokph)%tnooffr-phlista(lokph)%noofsubl\n return\n end subroutine get_phase_variance\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_constituent_location\n!\\begin{verbatim} %-\n subroutine get_constituent_location(lokph,cno,loksp)\n! returns the location of the species record of a constituent\n! requred for ionic liquids as phlista is private\n implicit none\n integer lokph,loksp,cno\n!\\end{verbatim} %+\n loksp=phlista(lokph)%constitlist(cno)\n return\n end subroutine get_constituent_location\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_compset\n!\\begin{verbatim} %-\n subroutine get_phase_compset(iph,ics,lokph,lokcs)\n! Given iph and ics the phase and composition set locations are returned\n! Checks that ics and ics are not outside bounds.\n implicit none\n integer iph,ics,lokph,lokcs\n!\\end{verbatim} %+\n if(iph.le.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n lokph=phases(iph)\n! find composition set\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n elseif(ics.eq.0) then\n ics=1\n endif\n lokcs=phlista(lokph)%linktocs(ics)\n1000 continue\n return\n end subroutine get_phase_compset\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_constituent_name\n!\\begin{verbatim} %-\n subroutine get_constituent_name(iph,iseq,spname,mass)\n! find the constituent with sequential index iseq in phase iph\n! return name in \"spname\" and mass in mass\n implicit none\n character*(*) spname\n integer iph,iseq\n double precision mass\n!\\end{verbatim}\n integer lokph,loksp\n if(iph.gt.0 .and. iph.le.noofph) then\n lokph=phases(iph)\n else\n gx%bmperr=4050\n goto 1000\n endif\n if(iseq.gt.0 .and. iseq.le.phlista(lokph)%tnooffr) then\n loksp=phlista(lokph)%constitlist(iseq)\n spname=splista(loksp)%symbol\n mass=splista(loksp)%mass\n else\n! write(*,*)'No such constituent'\n gx%bmperr=4096\n endif\n! write(*,*)'3A get_constituent_name: ',iph,iseq,' \"',trim(spname),'\"'\n1000 continue\n return\n end subroutine get_constituent_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_element_data\n!\\begin{verbatim}\n subroutine get_element_data(iel,elsym,elname,refstat,mass,h298,s298)\n! return element data as that is stored as private in GTP\n implicit none\n character elsym*2, elname*(*),refstat*(*)\n double precision mass,h298,s298\n integer iel\n!\\end{verbatim}\n integer lokel\n if(iel.le.noofel) then\n lokel=elements(iel)\n elsym=ellista(lokel)%symbol\n elname=ellista(lokel)%name\n refstat=ellista(lokel)%ref_state\n mass=ellista(lokel)%mass\n h298=ellista(lokel)%h298_h0\n s298=ellista(lokel)%s298\n else\n gx%bmperr=4042\n endif\n end subroutine get_element_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine new_element_data\n!\\begin{verbatim}\n subroutine new_element_data(iel,elsym,elname,refstat,mass,h298,s298)\n! set new values in an element record, only mass allowed to change ...\n implicit none\n character elsym*2, elname*(*),refstat*(*)\n double precision mass,h298,s298\n integer iel\n!\\end{verbatim}\n integer lokel\n if(iel.gt.0 .and. iel.le.noofel) then\n lokel=elements(iel)\n! ellista(lokel)%symbol=elsym\n! ellista(lokel)%name)=elname\n! ellista(lokel)%ref_state=refstate\n ellista(lokel)%mass=mass\n! ellista(lokel)%h298_h0=h298\n! ellista(lokel)%s298=s298\n else\n gx%bmperr=4042\n endif\n end subroutine new_element_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_component_name\n!\\begin{verbatim}\n subroutine get_component_name(icomp,name,ceq)\n! return the name of component icomp\n implicit none\n character*(*) name\n integer icomp\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n if(icomp.gt.noofel) then\n gx%bmperr=4052\n else\n! strange error buperr set here when plotting q(phase) in step2.OCM ??\n if(buperr.ne.0) then\n write(*,*)'3A buperr set entering get_component_name',buperr\n buperr=0\n endif\n name=splista(ceq%complist(icomp)%splink)%symbol\n! no reason buperr should be set here\n! if(buperr.ne.0) then\n! write(*,*)'3A gcn buperr: ',trim(name),buperr\n! gx%bmperr=buperr\n! endif\n endif\n1000 continue\n return\n end subroutine get_component_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_species_name\n!\\begin{verbatim} %-\n subroutine get_species_name(isp,spsym)\n! return species name, isp is species number\n implicit none\n character spsym*(*)\n integer isp\n!\\end{verbatim} %+\n if(isp.le.0 .or. isp.gt.noofsp) then\n! write(*,*)'in get_species_name'\n gx%bmperr=4051; goto 1000\n endif\n! loksp=species(isp)\n! spsym=splista(loksp)%symbol\n spsym=splista(species(isp))%symbol\n1000 return\n end subroutine get_species_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_species_location\n!\\begin{verbatim} %-\n subroutine get_species_location(isp,loksp,spsym)\n! return species location and name, isp is species number\n implicit none\n character spsym*(*)\n integer isp,loksp\n!\\end{verbatim}\n if(isp.le.0 .or. isp.gt.noofsp) then\n! write(*,*)'in get_species_name'\n gx%bmperr=4051; goto 1000\n endif\n loksp=species(isp)\n spsym=splista(loksp)%symbol\n! spsym=splista(species(isp))%symbol\n1000 return\n end subroutine get_species_location\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_species_data\n!\\begin{verbatim}\n subroutine get_species_data(loksp,nspel,ielno,stoi,smass,qsp,nextra,extra)\n! return species data, loksp is from a call to find_species_record\n! nspel: integer, number of elements in species\n! ielno: integer array, element indices\n! stoi: double array, stoichiometric factors\n! smass: double, mass of species\n! qsp: double, charge of the species\n! nextra, integer, number of additional values\n! extra: double, some additional values like UNIQUAC volume and area\n implicit none\n integer, dimension(*) :: ielno\n double precision, dimension(*) :: stoi,extra\n integer loksp,nspel,nextra\n double precision smass,qsp\n!\\end{verbatim} %+\n integer jl,iel\n if(loksp.le.0 .or. loksp.gt.noofsp) then\n! write(*,*)'in get_species_data'\n gx%bmperr=4051; goto 1000\n endif\n nspel=splista(loksp)%noofel\n elements: do jl=1,nspel\n iel=splista(loksp)%ellinks(jl)\n ielno(jl)=ellista(iel)%alphaindex\n stoi(jl)=splista(loksp)%stoichiometry(jl)\n enddo elements\n smass=splista(loksp)%mass\n qsp=splista(loksp)%charge\n! extraproperties for UNIQUAC model (and maybe others)\n nextra=0\n if(allocated(splista(loksp)%spextra)) then\n nextra=size(splista(loksp)%spextra)\n do jl=1,nextra\n extra(jl)=splista(loksp)%spextra(jl)\n enddo\n endif\n1000 return\n end subroutine get_species_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_species_component_data\n!\\begin{verbatim} %-\n subroutine get_species_component_data(loksp,nspel,compnos,stoi,smass,qsp,ceq)\n! return species data, loksp is from a call to find_species_record\n! Here we return stoichiometry using components \n! nspel: integer, number of components in species\n! compno: integer array, component (species) indices\n! stoi: double array, stoichiometric factors\n! smass: double, mass of species\n! qsp: double, charge of the species\n implicit none\n integer, dimension(*) :: compnos\n double precision, dimension(*) :: stoi(*)\n integer loksp,nspel\n double precision smass,qsp\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jl,iel,jk,ncomp,locomp,nspx\n integer, allocatable :: components(:)\n double precision, allocatable :: compstoi(:)\n! this can be UNIQUAC parameters: area, volume\n double precision qextra(10)\n!\n! if the components are the elements then use get_species_data\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\n call get_species_data(loksp,nspel,compnos,stoi,smass,qsp,nspx,qextra)\n goto 1000\n! else\n! write(*,11)globaldata%status,GSNOTELCOMP\n!11 format('3A using other components than elements',Z8,i4)\n endif\n allocate(components(noofel))\n allocate(compstoi(noofel))\n components=0\n compstoi=zero\n if(loksp.le.0 .or. loksp.gt.noofsp) then\n! write(*,*)'in get_species_data'\n gx%bmperr=4051; goto 1000\n endif\n nspel=splista(loksp)%noofel\n elements: do jl=1,nspel\n! splista(loksp)%ellinks is the location of the element record in ellista\n! To find the element index in alphabetical order use the %alphaindex\n iel=ellista(splista(loksp)%ellinks(jl))%alphaindex\n! ignore vacancies\n if(iel.le.0) cycle elements\n allcomp: do jk=1,noofel\n! this is a loop for all components\n! locomp is the species record of the component\n if(abs(ceq%invcompstoi(jk,iel)).gt.1.0D-12) then\n! the stoichiometry of this component is nonzero for this element\n! add to compstoi(jk)\n! convert the element to components using the inverted stoichiometry matrix\n! for example elements Ca O Si\n! components CaO SiO2 O\n! matrix components/elemenets Ca O Si\n! CaO 1 1 0\n! SiO2 0 2 1\n! O 0 1 0\n! inverted matrix CaO SiO2 O\n! Ca 1 0 -1 invmat(1,1) (2,1) (3,1)\n! O 0 1 0\n! Si 0 1 -2\n! for Ca return 2 components, 1 * CaO -1 * O\n! for SiO return 2 components 1*SiO -1 * O\n compstoi(jk)=compstoi(jk)+&\n splista(loksp)%stoichiometry(jl)*ceq%invcompstoi(jk,iel)\n qsp=splista(loksp)%charge\n endif\n enddo allcomp\n enddo elements\n! return components with nonzero stoichiometry. \n! Note stoichiometry can be negative\n! There are always as many components as elements\n smass=zero\n nspel=0\n reduce: do jk=1,noofel\n if(abs(compstoi(jk)).gt.1.0D-12) then\n nspel=nspel+1\n compnos(nspel)=jk\n stoi(nspel)=compstoi(jk)\n smass=smass+stoi(nspel)*ceq%complist(jk)%mass\n! maybe save species charge in the component record??\n! the lines below needed only if a component is charged !! hopefully never ...\n locomp=ceq%complist(jk)%splink\n qsp=qsp+stoi(nspel)*splista(locomp)%charge\n if(splista(locomp)%charge.ne.zero) then\n write(*,*)'3A charge: ',loksp,qsp,stoi(nspel),splista(locomp)%charge\n endif\n endif\n enddo reduce\n1000 return\n end subroutine get_species_component_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!CCI\n!\\addtotable subroutine get_stoichiometry\n!\\begin{verbatim}\n subroutine get_stoichiometry(loksp, jl, el_name, stoi)\n! Get the stoichiometric coefficient and the name of the jl-th element\n! of the loksp-th species\n! loksp: index of the species (input integer)\n! el_name: name of the element (output character)\n! stoi: value of the stoichiometric coefficient (output double precision)\n implicit none\n integer, intent(in):: loksp,jl\n double precision, intent(inout):: stoi\n character*(*), intent(inout) :: el_name\n!\\end{verbatim}\n!\n el_name=ellista(splista(loksp)%ellinks(jl))%name\n stoi=splista(loksp)%stoichiometry(jl)\n!\n end subroutine get_stoichiometry\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_new_stoichiometry\n!\\begin{verbatim}\n subroutine set_new_stoichiometry(loksp, new_stoi, ispel)\n! provided by Clement Introini\n! Change the stoichiometric coefficient of the ispel-th element of loksp-th\n! species (the last one when ispel is not given)\n! loksp: index of the species (input integer)\n! new_stoi: new value of the stoichiometric coefficient (input double precision)\n! ispel: index of the element (optional, input integer)\n implicit none\n integer, intent(in):: loksp\n integer, intent(in), optional :: ispel\n double precision, intent(in):: new_stoi\n!\\end{verbatim}\n character el_name*12,spe_name*24\n integer iel,jl,nspel\n double precision :: old_stoi\n ! number of elements in species\n nspel=splista(loksp)%noofel\n spe_name = trim(splista(loksp)%symbol)\n!\n if( .not. present(ispel) ) then\n iel = nspel\n !change the stoichiometric coefficient of the last element\n old_stoi=splista(loksp)%stoichiometry(iel)\n splista(loksp)%stoichiometry(iel)=new_stoi\n else\n iel = ispel\n if (iel.gt.0) then\n ! Change the stoichiometric coefficient of the ispel-th element\n old_stoi=splista(loksp)%stoichiometry(iel)\n splista(loksp)%stoichiometry(iel)=new_stoi\n! else\n! nothing to be done\n end if\n end if\n el_name=ellista(splista(loksp)%ellinks(iel))%name\n! if(ocv()) then\n! write(*,*)\"set_new_stoichiometry: (species,element,old_stoi,new_stoi)',&\n! ' = (\",spe_name,\",\",el_name,\",\",old_stoi,\",\",new_stoi,\")\"\n! endif\n end subroutine set_new_stoichiometry\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable double precision function mass_of\n!\\begin{verbatim}\n double precision function mass_of(component,ceq)\n! return mass of component\n! smass: double, mass of species\n implicit none\n integer :: component\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n if(component.le.0 .or. component.gt.noofel) then\n write(*,*)'Calling mass_of with illegal component number: ',component\n gx%bmperr=4251; goto 1000\n endif\n! return in kg\n mass_of=ceq%complist(component)%mass\n1000 return\n end function mass_of\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_name\n!\\begin{verbatim} %\n subroutine get_phase_name(iph,ics,name)\n! Given the phase index and composition set number this subroutine returns\n! the name with pre- and suffix for composition sets added and also \n! a \\# followed by a digit 1-9 if there are more than one composition sets\n implicit none\n character name*(*)\n integer iph,ics\n!\\end{verbatim} %+\n character phname*36\n integer lokph,lokcs,kp\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n if(ics.eq.1) then\n name=phlista(lokph)%name\n if(phlista(lokph)%noofcs.ge.2) then\n! this was added 2020.04.02 because a call to change_many_phase_status\n! using a phase name returned from this routine will suspend all compsets\n kp=len_trim(name)+1\n name(kp:)='#1'\n endif\n else\n kp=len_trim(firsteq%phase_varres(lokcs)%prefix)\n if(kp.gt.0) then\n phname=firsteq%phase_varres(lokcs)%prefix(1:kp)//'_'//&\n phlista(lokph)%name\n else\n phname=phlista(lokph)%name\n endif\n kp=len_trim(firsteq%phase_varres(lokcs)%suffix)\n if(kp.gt.0) then\n phname(len_trim(phname)+1:)='_'//firsteq%phase_varres(lokcs)%suffix\n endif\n phname(len_trim(phname)+1:)='#'//char(ics+ichar('0'))\n name=phname\n endif\n1000 continue\n return\n end subroutine get_phase_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phasetup_name\n!\\begin{verbatim} %-\n subroutine get_phasetup_name(phtupx,name)\n! phasetuple(phtupx)%phase is index to phlista\n! the name has pre- and suffix for composition sets added and also \n! a \\# followed by a digit 2-9 for composition sets higher than 1.\n implicit none\n character name*(*)\n integer phtupx\n!\\end{verbatim} %+\n integer phx,phy\n! phx=phlista(phasetuple(phtupx)%phaseix)%alphaindex\n phx=phlista(phasetuple(phtupx)%lokph)%alphaindex\n call get_phase_name(phx,phasetuple(phtupx)%compset,name)\n1000 continue\n return\n end subroutine get_phasetup_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phasetuple_name\n!\\begin{verbatim} %-\n subroutine get_phasetuple_name(phtuple,name)\n! phtuple is a phase tuple\n! the name has pre- and suffix for composition sets added and also \n! a \\# followed by a digit 2-9 for composition sets higher than 1.\n implicit none\n character name*(*)\n type(gtp_phasetuple) :: phtuple\n!\\end{verbatim} %+\n! integer phx,phy\n call get_phase_name(phtuple%ixphase,phtuple%compset,name)\n1000 continue\n return\n end subroutine get_phasetuple_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phasetup_record\n!\\begin{verbatim} %-\n subroutine get_phasetup_record(phtx,lokcs,ceq)\n! return lokcs when phase tuple known\n implicit none\n integer phtx,lokcs\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n if(phtx.lt.1 .or. phtx.gt.nooftuples) then\n! write(*,*)'Wrong tuple index',phtx\n gx%bmperr=4252; goto 1000\n endif\n write(*,*)'Calling get_phasetup_record is redundant'\n stop\n! lokcs=phlista(phasetuple(phtx)%phaseix)%linktocs(phasetuple(phtx)%compset)\n1000 continue\n return\n end subroutine get_phasetup_record\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function gettupix\n!\\begin{verbatim}\n integer function gettupix(iph,ics)\n! convert phase and compset index to tuple index\n implicit none\n integer iph,ics\n!\\end{verbatim}\n integer ii,tupix\n ii=ics\n! default tupix is phase index\n tupix=iph\n loop: do while(ii.gt.1)\n tupix=phasetuple(tupix)%nextcs\n if(tupix.le.0) then\n gx%bmperr=4072; exit loop\n endif\n ii=ii-1\n enddo loop\n write(*,'(a,3i5)')'3X gettupix: ',iph,ics,tupix\n! gettupix never assigned a value. Is it used?/BoS\n gettupix=tupix\n return\n end function gettupix\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n !\\begin{verbatim}\n subroutine get_sublattice_number(iph,nsl,ceq)\n! return the number of sublattices for phase iph\n! nsl: integer, number of sublattices\n! ceq: pointer, to current gtp_equilibrium_data record\n implicit none\n integer iph,nsl\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer lokph\n nsl = 1\n if(iph.lt.1 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n else\n lokph=phases(iph)\n endif\n nsl=phlista(lokph)%noofsubl\n1000 continue\n return\n\n end subroutine get_sublattice_number\n\n !/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n !\\begin{verbatim}\n subroutine get_sublattice_structure(iph,ics,nsl,nkl,nsites,ceq)\n! return the structure of the sublattices for phase iph (ics composition set)\n! nsl: integer, number of sublattices\n! nkl: integer array, number of constituents in each sublattice\n! nsites: double array, number of sites in each sublattice\n! ceq: pointer, to current gtp_equilibrium_data record\n implicit none\n integer, intent (in) :: iph,ics,nsl\n integer, dimension(nsl), intent (out) :: nkl\n!CCI\n double precision, dimension(nsl), intent (out) :: nsites\n!CCI\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer :: i, lokph,lokcs, ncs\n!\n if(iph.lt.1 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n else\n lokph=phases(iph)\n endif\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n else\n ncs=max(ics,1)\n endif\n! extra check if using saved equilibria which may have less composition sets\n lokcs=phlista(lokph)%linktocs(ncs)\n if(lokcs.le.0) then\n write(*,*)'Index of composition set missing, maybe using a saved equil.'\n gx%bmperr=4072\n goto 1000\n endif\n do i=1,nsl\n nkl(i)=phlista(lokph)%nooffr(i)\n nsites(i)=ceq%phase_varres(lokcs)%sites(i)\n enddo\n1000 continue\n return\n\n end subroutine get_sublattice_structure\n\n !/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_constituent_data\n!CCI (adding ncel)\n!\\begin{verbatim}\n subroutine get_constituent_data(iph,ics,icons,yarr,charge,csname,ncel,ceq)\n!CCI\n ! return the constitution for phase iph (ics composition set)\n ! yarr: double, fraction of constituent\n ! charge: integer, charge of constituent\n ! ncel: integer, number of element in the constituant\n ! consname: name of the constituent\n ! ceq: pointer, to current gtp_equilibrium_data record\n implicit none\n integer, intent (in) :: iph,ics,icons\n double precision, intent (inout) :: yarr\n!CCI (adding ncel)\n integer, intent (inout) :: charge,ncel\n!CCI\n character*(*) , intent (inout) :: csname\n \n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer :: i, lokph,lokcs,ncs,loksp,jl\n!\n if(iph.lt.1 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n else\n lokph=phases(iph)\n endif\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n else\n ncs=max(ics,1)\n endif\n! extra check if using saved equilibria which may have less composition sets\n lokcs=phlista(lokph)%linktocs(ncs)\n if(lokcs.le.0) then\n write(*,*)'Index of composition set missing, maybe using a saved equil.'\n gx%bmperr=4072\n goto 1000\n endif\n\n yarr=ceq%phase_varres(lokcs)%yfr(icons)\n loksp=phlista(lokph)%constitlist(icons)\n csname=splista(loksp)%symbol\n if(loksp.gt.0) then\n charge = splista(loksp)%charge\n else\n charge=0.D0\n endif\n!CCI (adding ncel)\n ncel = splista(loksp)%noofel\n!CCI\n\n1000 continue\n return\n end subroutine get_constituent_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_data\n!\\begin{verbatim}\n subroutine get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq)\n! return the structure of phase iph and constituntion of comp.set ics\n! nsl: integer, number of sublattices\n! nkl: integer array, number of constituents in each sublattice\n! knr: integer array, species location (not index) of constituents (all subl)\n! yarr: double array, fraction of constituents (in all sublattices)\n! sites: double array, number of sites in each sublattice\n! qq: double array, (must be dimensioned at least 5) although only 2 used:\n! qq(1) is number of real atoms per formula unit for current constitution\n! qq(2) is net charge of phase for current constitution\n! ceq: pointer, to current gtp_equilibrium_data record\n implicit none\n integer, dimension(*) :: nkl,knr\n double precision, dimension(*) :: yarr,sites,qq\n integer iph,ics,nsl\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer lokph,lokcs,kkk,ll,jj,loksp\n double precision vsum,qsum,ql,vl,yz\n!\n if(iph.lt.1 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n else\n lokph=phases(iph)\n endif\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 1: ',iph,ics,lokph\n nsl=phlista(lokph)%noofsubl\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n elseif(ics.eq.0) then\n ics=1\n endif\n! extra check if using saved equilibria which may have less composition sets\n lokcs=phlista(lokph)%linktocs(ics)\n if(lokcs.le.0) then\n write(*,*)'Index of composition set missing, maybe using a saved equil.'\n gx%bmperr=4072\n goto 1000\n endif\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 10: ',lokcs\n! lokcs=phlista(lokph)%cslink\n! jcs=ics-1\n! do while(jcs.gt.0)\n! lokcs=ceq%phase_varres(lokcs)%next\n! if(lokcs.le.0) then\n! write(*,*)'get_phase_data error 4072'\n! gx%bmperr=4072; goto 1000\n! endif\n! jcs=jcs-1\n! enddo\n! >>>>> get_phase_data missing: for ionic liquid sites vary with composition \n vsum=zero\n qsum=zero\n kkk=0\n if(.not.btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then\n! CSCONSUS set if a constituent is suspended ... not implemented yet\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 20: ',lokph,nsl\n sublat: do ll=1,nsl\n nkl(ll)=phlista(lokph)%nooffr(ll)\n! if(gtpdebug.ne.0) then\n! write(*,*)'3A get_phase_data 21: ',lokcs,ll,nkl(ll),&\n! allocated(ceq%phase_varres(lokcs)%sites),&\n! size(ceq%phase_varres(lokcs)%sites)\n! endif\n if(.not.allocated(ceq%phase_varres(lokcs)%sites)) then\n! This can happen for plotting when different dynamic ceq\n! have different number of composition sets\n write(*,777)trim(phlista(lokph)%name),ics\n777 format('3A site array for phase: ',a,' set ',i2,' not allocated')\n gx%bmperr=4399; goto 1000\n endif\n! we get strange error \"index 1 or array ceq above bound of 0\"\n if(size(ceq%phase_varres(lokcs)%sites).lt.1) then\n! write(*,*)'Strange error when step: ',iph,ics,lokcs,ll\n gx%bmperr=4253; goto 1000\n endif\n! write(*,17)'3 A Strange error: ',iph,ics,lokcs,ll,&\n! size(ceq%phase_varres(lokcs)%sites)\n! another strange error \"below lower bound of 4 ...\"\n! I do not now how to check for a lower boundary ... \n17 format(a,10i6)\n sites(ll)=ceq%phase_varres(lokcs)%sites(ll)\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 25: ',sites(ll)\n ql=zero\n vl=zero\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 30: ',&\n! ll,nkl(ll),sites(ll)\n const: do jj=1,nkl(ll)\n kkk=kkk+1\n loksp=phlista(lokph)%constitlist(kkk)\n knr(kkk)=loksp\n yz=ceq%phase_varres(lokcs)%yfr(kkk)\n yarr(kkk)=yz\n if(loksp.gt.0) then\n! loksp is -99 for wildcards. ionic liquid can have that in first sublattice\n ql=ql+yz*splista(loksp)%charge\n if(btest(splista(loksp)%status,SPVA)) then\n vl=yz\n endif\n endif\n enddo const\n vsum=vsum+sites(ll)*(one-vl)\n qsum=qsum+sites(ll)*ql\n enddo sublat\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data 40: ',vsum\n qq(1)=vsum\n qq(2)=qsum\n! write(*,*)'get_phase_data: ',qq(1),qq(2)\n else\n! >>>> unfinished handle the case with suspended constituents\n! write(*,*)'get_phase_data with suspended constituents not implemented'\n gx%bmperr=4080; goto 1000\n endif\n!\n1000 continue\n! if(gtpdebug.ne.0) write(*,*)'3A get_phase_data exit: ',iph,ics\n return\n end subroutine get_phase_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_phase_structure\n!\\begin{verbatim} %-\n subroutine get_phase_structure(lokph,nsl,nkl)\n! return the number of sblattices and constituents in each.\n! nsl: integer, number of sublattices\n! nkl: integer array, number of constituents in each sublattice\n! USED when calculating derivatives of chemical potentials and diffusion coef\n implicit none\n integer, dimension(*) :: nkl\n integer lokph,nsl\n!\\end{verbatim}\n integer ii\n if(lokph.le.0 .or. lokph.gt.noofph) then\n! write(*,*)'You are way off your head'\n gx%bmperr=4050; goto 1000\n endif\n nsl=phlista(lokph)%noofsubl\n do ii=1,nsl\n nkl(ii)=phlista(lokph)%nooffr(ii)\n enddo\n1000 continue\n return\n end subroutine get_phase_structure\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function get_phtuplearray\n!\\begin{verbatim}\n integer function get_phtuplearray(phcs)\n! copies the internal phase tuple array to external software\n! function value set to number of tuples\n type(gtp_phasetuple), dimension(*) :: phcs\n!\\end{verbatim} %+\n integer iz\n do iz=1,nooftuples\n! phasetuple(iz)%phase is lokph!!! .... probably never used ...\n phcs(iz)=phasetuple(iz)\n! phcs(iz)%phase=phasetuple(iz)%phase\n! phcs(iz)%compset=phasetuple(iz)%compset\n enddo\n1000 continue\n get_phtuplearray=nooftuples\n return\n end function get_phtuplearray\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 5. Set things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_constitution\n!\\begin{verbatim}\n subroutine set_constitution(iph,ics,yfra,qq,ceq)\n! set the constituent fractions of a phase and composition set and the\n! number of real moles and mass per formula unit of phase\n! returns number of real atoms in qq(1), charge in qq(2) and mass in qq(3)\n! for ionic liquids sets the number of sites in the sublattices\n implicit none\n double precision, dimension(*) :: yfra,qq\n integer iph,ics\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokph,lokcs,ll,ml,ic,loksp,jl,locva,zl,zel\n double precision charge,spat,asite,bsite,badd,yz,yva,sumat,asum,bsum,csum\n! double precision charge1,bion1,ionsites(2)\n double precision charge1,bion1,compsum,comp1\n! The mass is not calculated correctly in version 2, attempt to fix\n double precision bliq1\n type(gtp_phase_varres), pointer :: phres\n! This is needed if we have other components than the elements\n double precision, allocatable :: compam(:),elam(:),iliqcats(:)\n! TYPE(gtp_fraction_set), pointer :: disrec\n logical ionicliq\n! write(*,*)'3A In set_constitution ...',ceq%eqno,iph,ics\n if(iph.le.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n lokph=phases(iph)\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n elseif(ics.eq.0) then\n ics=1\n endif\n lokcs=phlista(lokph)%linktocs(ics)\n! write(*,*)'3A segmentation fault 1',iph,ics,lokcs\n ionicliq=btest(phlista(lokph)%status1,PHIONLIQ)\n if(ionicliq) then\n! default values of i2slx\n phlista(lokph)%i2slx(1)=phlista(lokph)%tnooffr+1\n phlista(lokph)%i2slx(2)=phlista(lokph)%tnooffr+1\n yva=zero\n locva=0\n endif\n!----\n if(btest(globaldata%status,GSNOTELCOMP)) then\n allocate(elam(noofel))\n allocate(compam(noofel))\n elam=zero\n compam=zero\n if(ionicliq) then\n! we must save the amounts on sublattice 1 as we do not know the sites\n allocate(iliqcats(noofel))\n iliqcats=zero\n endif\n endif\n! write(*,*)'3A segmentation fault 10',lokcs\n if(ocv()) write(*,8)'3Ay:',iph,ics,&\n (yfra(ic),ic=1,phlista(lokph)%tnooffr)\n8 format(a,2i2,6(1pe11.3))\n nosuscon: if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then\n! >>>> unfinished: handle the case when some constituents are suspended\n! write(*,*)'set_constitution with suspended constituents not implemented'\n write(*,*)'suspended const in: ',lokph,lokcs\n gx%bmperr=4080; goto 1000\n else\n! no suspended constituents\n! As the application program may have errors first make sure than\n! the constituents fractions are correct:\n! - no negative fractions\n! - sum of fractions in each sublattice unity\n! if(ocv()) write(*,*)'3A 2: ',ionicliq\n ic=0\n! write(*,*)'3A segmentation fault 30',phlista(lokph)%noofsubl\n do ll=1,phlista(lokph)%noofsubl\n! write(*,*)'3A sumy 2: ',ll,ic,phlista(lokph)%noofsubl\n asite=zero\n do ml=1,phlista(lokph)%nooffr(ll)\n yz=yfra(ic+ml)\n if(yz.lt.bmpymin) yz=bmpymin\n ceq%phase_varres(lokcs)%yfr(ic+ml)=yz\n asite=asite+yz\n enddo\n! make sure sum of fractions is unity in each sublattice\n do ml=1,phlista(lokph)%nooffr(ll)\n ceq%phase_varres(lokcs)%yfr(ic+ml)=&\n ceq%phase_varres(lokcs)%yfr(ic+ml)/asite\n enddo\n! write(*,13)'3A y: ',ll,ic,asite,bmpymin,&\n! (ceq%phase_varres(lokcs)%yfr(ic+ml),&\n! ml=1,phlista(lokph)%nooffr(ll))\n13 format(a,2i2,2(1pe12.4),1x,4(1pe12.4))\n ic=ic+phlista(lokph)%nooffr(ll)\n enddo\n!--------\n ll=1; ml=0; asum=zero; bsum=zero; csum=zero; charge=zero\n! write(*,*)'3A segmentation fault 40'\n if(ionicliq) then\n! For ionic liquid we do not know the number of sites\n asite=one\n bion1=zero\n else\n asite=ceq%phase_varres(lokcs)%sites(ll)\n endif\n! what is bsite used for???\n bsite=asite; badd=zero\n spat=zero\n allcon: do ic=1,phlista(lokph)%tnooffr\n yz=ceq%phase_varres(lokcs)%yfr(ic)\n! if(ocv()) write(*,*)'3A 3: ',ic,yz\n notva: if(btest(ceq%phase_varres(lokcs)%constat(ic),CONVA)) then\n! the constituent is the vacancy\n! i2slx(1) should be set to the index of vacancies (if any)\n if(ionicliq) phlista(lokph)%i2slx(1)=ic\n locva=ic\n yva=yz\n else\n! sum charge and for constituents with several atoms spat sum number of atoms\n loksp=phlista(lokph)%constitlist(ic)\n charge=charge+bsite*yz*splista(loksp)%charge\n! derivates of sites for ionic liquid model\n! if(ocv()) write(*,*)'3A 4: ',loksp,charge\n if(ionicliq) then\n ceq%phase_varres(lokcs)%dpqdy(ic)=abs(splista(loksp)%charge)\n! if(ocv()) write(*,*)'3A dpqdy: ',&\n! ic,abs(splista(loksp)%charge)\n! i2slx(2) should be set to the index of the first neutral (if any)\n if(splista(loksp)%charge.eq.zero .and.&\n phlista(lokph)%i2slx(2).gt.ic) &\n phlista(lokph)%i2slx(2)=ic\n endif\n! add the mass of the constituents\n badd=badd+bsite*yz*splista(loksp)%mass\n! write(*,56)'3A badd: ',iph,loksp,splista(loksp)%mass,yz,bsite,badd\n56 format(a,2i3,6(1pe12.4))\n sumat=zero\n! This is summing atoms per formula unit of the phase\n do jl=1,splista(loksp)%noofel\n sumat=sumat+splista(loksp)%stoichiometry(jl)\n enddo\n!--------------------------------------------------------------\n if(btest(globaldata%status,GSNOTELCOMP)) then\n! When there are other components than the elements we must sum the number\n! of each atom, not just the total. elam was alloctated and zeroed above\n do jl=1,splista(loksp)%noofel\n! NOTE that the ellinks specify the location, not alphabetically!!\n! we must use %alphaindex to have the alphabetical index of the element ?? YES\n zel=ellista(splista(loksp)%ellinks(jl))%alphaindex\n! FOR IONIC LIQUID MODEL asite is unity and must be updatated below!!\n elam(zel)=elam(zel)+yz*splista(loksp)%stoichiometry(jl)*asite\n! write(*,14)'3A elam: ',zel,yz,&\n! splista(loksp)%stoichiometry(jl),(elam(zl),zl=1,noofel),&\n! trim(splista(loksp)%symbol)\n!14 format(a,i2,5(1pe11.3),2x,a)\n enddo\n! write(*,*)'3A NOTELCOMP: ',compsum,trim(splista(loksp)%symbol)\n! csum=csum+yz*compsum\n endif\n spat=spat+yz*sumat\n! check sum number of atoms for ionic liquid\n! if(sumat.gt.1) then\n! write(*,7)'spat: ',lokph,splista(loksp)%noofel,sumat,yz,spat\n!7 format(a,2i3,3F10.4)\n! endif\n! write(*,11)loksp,yz,splista(loksp)%mass,badd,bsum\n11 format('set_const 3: ',i3,4(1PE15.7))\n endif notva\n! ml is constituent number in this sublattice, ic for all sublattices\n ml=ml+1\n! if(ocv()) write(*,*)'3A 5: ',ml\n newsubl: if(ml.ge.phlista(lokph)%nooffr(ll)) then\n! next sublattice\n ionliq: if(ionicliq) then\n! for ioniq liquids the number of sites is the charge on opposite sublattice\n if(ll.eq.1) then\n! Q=\\sum_i v_i y_i = charge\n! write(*,88)'ionliq: ',ll,badd,bion1\n88 format(a,i3,6(1pe12.4))\n ceq%phase_varres(lokcs)%sites(2)=charge\n! write(*,*)'Ionic 2: ',ceq%phase_varres(lokcs)%sites(2)\n! bsite=one\n charge1=charge\n charge=zero\n! same the mass of the constituents on first sublattice\n bliq1=badd\n badd=zero\n! initiate vacancy and neutral indices beyond last index (already done??)\n phlista(lokph)%i2slx=phlista(lokph)%tnooffr+1\n if(btest(globaldata%status,GSNOTELCOMP)) then\n iliqcats=elam\n elam=zero\n endif\n elseif(ll.eq.2) then\n! P=\\sum_j (-v_j)y_j + Qy_Va. Note charge is total charge and valences \n! on 2nd sublattice is negative\n! Now we know number of sites on sublattice 1, update asum and bsum\n! Cryptic programming ... sumat is here set to sites on first sublattice\n sumat=-charge+charge1*yva\n ceq%phase_varres(lokcs)%sites(1)=sumat\n! write(*,*)'Ionic 1: ',ceq%phase_varres(lokcs)%sites(1)\n asum=asum*sumat\n bsum=bion1*sumat\n charge=zero\n if(btest(globaldata%status,GSNOTELCOMP)) then\n elam=elam+sumat*iliqcats\n endif\n! write(*,88)'3A iliq: ',ll,badd,bion1,bsum,sumat,yva\n! new way to calculate mass of ionic liquid\n bsum=sumat*bliq1+ceq%phase_varres(lokcs)%sites(2)*badd\n! write(*,66)'3A ilmass: ',ll,ceq%phase_varres(lokcs)%sites,&\n! bliq1,badd,bsum\n66 format(a,i3,6(1pe12.4))\n badd=zero\n else\n! write(*,*)'Ionic liquid must have two sublattices',ll\n gx%bmperr=4255; goto 1000\n endif\n endif ionliq\n! note: for ionic liquid previous values of asum and bsum are updated \n! when fractions in sublattice 2 have been set\n asum=asum+asite*spat\n bsum=bsum+badd\n! write(*,33)'3A g:',lokcs,ll,asum,asite,spat\n33 format(a,2i2,6(1pe12.4))\n! write(*,39)'set_con: ',ll,ml,asum,asite,spat\n!39 format(a,2i5,3(1pe12.4))\n! write(*,12)'set_const 12: ',ll,asum,asite,bsum,badd\n!12 format(a,i3,4(1pe12.4))\n if(ll.lt.phlista(lokph)%noofsubl) then\n ll=ll+1; ml=0\n! asite=phlista(lokph)%sites(ll); spat=zero\n asite=ceq%phase_varres(lokcs)%sites(ll)\n spat=zero; bion1=badd; badd=zero\n! if ionic liquid bsite must be 1.0 when summing second sublattice. Why???\n if(.not.ionicliq) bsite=asite\n endif\n endif newsubl\n enddo allcon\n! write(*,33)'3A h:',lokcs,ll,asum,asite,spat\n endif nosuscon\n! write(*,*)'3A NO segmentation fault 100'\n! save charge, number of moles and mass of real atoms per formula unit\n! write(*,33)'3A isum:',lokcs,0,charge,asum,bsum,asite,spat\n ceq%phase_varres(lokcs)%netcharge=charge\n ceq%phase_varres(lokcs)%abnorm(2)=bsum\n if(btest(globaldata%status,GSNOTELCOMP)) then\n! Now we can convert the amount of atoms to amount of components\n! use ceq%invcompstoi to convert to components\n! write(*,279)'3A elsm: ',iph,asum,(elam(zl),zl=1,noofel)\n279 format(a,i3,6(1pe12.4))\n csum=zero\n do zl=1,noofel\n comp1=zero\n! write(*,278)'3A inv: ',(ceq%invcompstoi(zl,zel),zel=1,noofel)\n278 format(a,6(1pe12.4))\n do zel=1,noofel\n comp1=comp1+ceq%invcompstoi(zl,zel)*elam(zel)\n enddo\n compam(zl)=comp1\n csum=csum+compam(zl)\n enddo\n! write(*,*)'3A segmentation fault 200'\n! write(*,277)'3A cpam: ',iph,csum,(compam(zl),zl=1,noofel)\n277 format(a,i3,6(1pe12.4))\n! abnorm(3) is the number of moles of user defined components\n! write(*,299)'3A comp/FU: ',iph,ics,asum,csum\n299 format(a,2i3,4(1pe12.4))\n ceq%phase_varres(lokcs)%abnorm(1)=csum\n ceq%phase_varres(lokcs)%abnorm(3)=asum\n else\n! if elements are constituents then set abnorm(3)=abnorm(1)\n ceq%phase_varres(lokcs)%abnorm(1)=asum\n ceq%phase_varres(lokcs)%abnorm(3)=asum\n endif\n! write(*,*)'3A sety: ',lokcs,ceq%phase_varres(lokcs)%abnorm(1)\n if(ionicliq .and. locva.gt.0) then\n! the ionic liquid vacancy charge is the number of sites on second subl.\n ceq%phase_varres(lokcs)%dpqdy(locva)=ceq%phase_varres(lokcs)%sites(2)\n! if(ocv()) write(*,*)'3A dpqdy(va): ',&\n! locva,ceq%phase_varres(lokcs)%sites(2)\n endif\n! if(ionicliq) then\n! write(*,301)'3A xsc:',lokcs,asum,bsum,ceq%phase_varres(lokcs)%sites,&\n! charge1\n!301 format(a,i3,6(1pe12.4))\n! write(*,301)'3A y: ',ic,ceq%phase_varres(lokcs)%yfr\n! endif\n! write(*,*)'3A NO segmentation fault 300'\n qq(1)=asum\n qq(2)=charge\n qq(3)=bsum\n! write(*,*)'3A segmentation fault 301'\n! set disordered fractions if any\n if(btest(phlista(lokph)%status1,phmfs)) then\n!now set disordered fractions if any\n! write(*,*)'3A call calc_disfrac for: ',lokph,lokcs\n call calc_disfrac(lokph,lokcs,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3A segmentation fault 311',lokph,lokcs\n endif\n314 format(a,8F8.3)\n! added for the new MQMQA asymmetrical excess\n! we must copy yfra to quad fractions and calculate some internal variables\n! this routine is in gtp3XQ\n! write(*,*)'Testing PHMQMQX bit'\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n if(mqmqa_data%exlevel.lt.100) mqmqa_data%exlevel=100\n if(mqmqxcess) write(*,*)'3A This phase has PHMQMQX set,',&\n ' calling set_quadfractions',lokcs\n phres=>ceq%phase_varres(lokcs)\n! the second argument means to list\n call set_quadfractions(phres,mqmqxcess,yfra)\n endif\n1000 continue\n! write(*,*)'3A no segmentation fault at exit'\n! if(ionicliq) write(*,*)'3A s_c: ',phlista(lokph)%i2slx\n return\n end subroutine set_constitution\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_reference_state\n!\\begin{verbatim}\n subroutine set_reference_state(icomp,iph,tpval,ceq)\n! set the reference state of a component to be \"iph\" at tpval\n implicit none\n integer icomp,iph\n double precision, dimension(2) :: tpval\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! NOTE if elements have mixed reference state EQMIXED is set and SER used\n! That applies to integral properties like G, S but not MU or AC\n integer nsl,nkl(maxsubl),knr(maxconst),splink,j1,ie,elink\n integer ll,jj,nrel,lokph,noendm,jerr,lokres,ny,endmemx,endmemxy,ics\n double precision sites(maxsubl),qq(5),yarrsave(maxconst),xsum,gmin,gval\n double precision, dimension(:), allocatable :: yarr,xcomp,xmol\n integer, dimension(:), allocatable :: maxjj,jend,jendsave\n double precision tpsave(2),molat,saveg(6)\n! iph negative means remove current reference state\n if(iph.lt.0) then\n if(allocated(ceq%complist(icomp)%endmember)) then\n! I do not understand the code here any longer but this gave error\n! as unallocated when I tried to ser reference state back to SER\n deallocate(ceq%complist(icomp)%endmember)\n! else\n! write(*,4)icomp,ceq%complist(icomp)%phlink\n!4 format('3A This component has no previous reference state: ',2i4)\n endif\n ceq%complist(icomp)%phlink=0\n ceq%complist(icomp)%tpref=zero\n ceq%complist(icomp)%refstate='SER (default)'\n goto 1000\n endif\n! calculate the composition of the component in mole fractions\n nrel=noel()\n allocate(xcomp(nrel))\n splink=ceq%complist(icomp)%splink\n xcomp=zero\n xsum=zero\n do j1=1,splista(splink)%noofel\n elink=splista(splink)%ellinks(j1)\n ie=ellista(elink)%alphaindex\n xcomp(ie)=splista(splink)%stoichiometry(j1)\n xsum=xsum+xcomp(ie)\n enddo\n! write(*,17)'3A srs x1: ',iph,xsum,(xcomp(ie),ie=1,nrel)\n! do ie=1,splista(splink)%noofel changed 190710/BoS\n do ie=1,nrel\n xcomp(ie)=xcomp(ie)/xsum\n enddo\n! write(*,17)'3A srs x2: ',iph,xsum,(xcomp(ie),ie=1,nrel)\n17 format(a,i3,15(f5.2))\n! find suitable endmember with correct composition and lowest G\n! Note that lowest G is calculated at current T, may be different at another T\n! WE CAN HAVE SEVERAL SUBLATTICES ...\n call get_phase_data(iph,1,nsl,nkl,knr,yarrsave,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n allocate(maxjj(0:nsl))\n allocate(jend(1:nsl))\n allocate(jendsave(1:nsl))\n! generate all endmembers, maybe there is a better way ...\n! and set unity fraction in yarr and check composition\n ny=0\n maxjj(0)=1\n do ll=1,nsl\n ny=ny+nkl(ll)\n maxjj(ll)=ny\n enddo\n allocate(yarr(ny))\n yarr=zero\n jj=1\n do ll=1,nsl\n yarr(jj)=one\n jend(ll)=jj\n jj=jj+nkl(ll)\n enddo\n allocate(xmol(nrel))\n! lokph=phases(iph)\n! we must save the gval for lokres (composition set 1)\n ics=1\n call get_phase_compset(iph,ics,lokph,lokres)\n if(gx%bmperr.ne.0) goto 1000\n gmin=1.0D5\n noendm=0\n tpsave=ceq%tpval\n if(tpval(1).gt.zero) then\n! negative tpval means current temperature, else use tpval(1)\n ceq%tpval(1)=tpval(1)\n endif\n! write(*,*)'3A tp: ',tpval(1),ceq%tpval(1)\n ceq%tpval(2)=tpval(2)\n do ie=1,6\n saveg(ie)=ceq%phase_varres(lokres)%gval(ie,1)\n enddo\n! write(*,912)'3G Saved G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),&\n! saveg(1)\n!----------------------------------------------\n! return here for each endmember\n endmemx=0\n200 continue\n! write(*,*)'3G endm: ',(jend(jj),jj=1,nsl)\n! write(*,17)'3G srs y: ',iph,(yarr(jj),jj=1,ny)\n call set_constitution(iph,1,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 900\n! this subroutine converts site fractions in phase iph, compset 1\n! to mole fractions of components (or elements ??? )\n endmemx=endmemx+1\n call calc_phase_mol(iph,xmol,ceq)\n if(gx%bmperr.ne.0) goto 900\n! write(*,202)'3A srs xem: ',iph,endmemx,(xmol(ie),ie=1,nrel)\n202 format(a,2i4,15(F5.2))\n do jj=1,nrel\n if(abs(xmol(jj)-xcomp(jj)).gt.1.0D-12) goto 250\n enddo\n!--------------------------------------------------\n! we have an endmember with the correct composition\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 900\n gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! write(*,222)'3A srs gval: ',iph,qq(1),gval,gmin,ceq%tpval(1)\n222 format(a,i3,F10.3,3(1pe12.4))\n if(gval.lt.gmin) then\n! we should check if electrically neutral ??\n noendm=noendm+1\n gmin=gval\n jendsave=jend\n molat=qq(1)\n endmemxy=endmemx\n! write(*,229)'3G min: ',gmin,jendsave\n229 format(a,1pe12.4,10i4)\n endif\n250 continue\n! change constitution .... quit when all endmembers done\n ll=nsl\n! should this always be 0?\n maxjj(0)=0\n260 continue\n! jend is the current endmember\n jj=jend(ll)\n yarr(jj)=zero\n jj=jj+1\n if(jj.gt.maxjj(ll)) then\n jend(ll)=maxjj(ll-1)+1\n yarr(jend(ll))=one\n ll=ll-1\n! if ll becomes zero here all endmemebrs have been generated (?)\n if(ll.ge.1) goto 260\n else\n jend(ll)=jj\n yarr(jj)=one\n goto 200\n endif\n!----------------------------------------------\n if(noendm.eq.0) then\n! if no endmember found this phase cannot be reference phase\n! write(*,*)'This phase cannot be reference state for for this component'\n gx%bmperr=4256; goto 900\n endif\n!-----------------------------------------------\n! Now we store the reference state and set some bits\n! mark that conditions and equilibrium may not be consistent\n ceq%status=ibset(ceq%status,EQINCON)\n! endmemx and endmemxy redundant\n! write(*,808)'3G reference state endmember',lokph,endmemxy,jendsave\n808 format(a,i3,2x,10i3)\n! If all OK then save phase location, endmember array, T and P\n ceq%complist(icomp)%phlink=lokph\n if(.not.allocated(ceq%complist(icomp)%endmember)) then\n! if the user changes reference state do not allocate again\n! write(*,*)'3A Allocating endmember for this reference state'\n allocate(ceq%complist(icomp)%endmember(nsl))\n endif\n! write(*,*)'3A refendm: ',icomp,size(ceq%complist),noofel\n ceq%complist(icomp)%endmember=jendsave\n! allocate(ceq%complist(icomp)%endmember(1))\n! ceq%complist(icomp)%endmember=endmemxy\n! molat is probably redundant as calcg_endmember returns for one mole component\n ceq%complist(icomp)%molat=molat\n! Note tpval(1) can be negative indicating current T\n ceq%complist(icomp)%tpref=tpval\n ceq%complist(icomp)%refstate=phlista(lokph)%name\n! NEW 2019.12.02 unless all elements have the same phase and T as reference\n! we must set the EQMIXED bit in the CEQ record to enforce use of SER \n! for integral properties like G, H etc. Element specific MU etc not affected\n allel: do ie=1,noofel\n if(ceq%complist(ie)%refstate.ne.ceq%complist(icomp)%refstate) exit allel\n if(ceq%complist(ie)%tpref(1).ne.ceq%complist(icomp)%tpref(1)) exit allel\n if(ceq%complist(ie)%tpref(2).ne.ceq%complist(icomp)%tpref(2)) exit allel\n! write(*,*)'3A mixed: ',ie,ceq%complist(ie)%tpref,&\n! ceq%complist(ie)%refstate\n enddo allel\n! if loop finishes without exit then ie=noofel+1 (Fortran standard)\n! and all elements have the same reference state\n if(ie.le.noofel) then\n! different phase or T in the elements\n! write(*,*)'3A setting mixed bit'\n ceq%status=ibset(ceq%status,EQMIXED)\n else\n! all elements have the same reference phase and T\n! write(*,*)'3A clearing mixed bit'\n ceq%status=ibclr(ceq%status,EQMIXED)\n endif\n!-------------------------------------------------------\n! restore original constitution of compset 1\n! write(*,*)'3A gval: ',gval\n900 continue\n ceq%tpval=tpsave\n jerr=gx%bmperr; gx%bmperr=0\n call set_constitution(iph,1,yarrsave,qq,ceq)\n if(jerr.ne.0) then\n gx%bmperr=jerr\n endif\n! restore original values of G and derivatives\n do ie=1,6\n ceq%phase_varres(lokres)%gval(ie,1)=saveg(ie)\n enddo\n! write(*,912)'3G Restored G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),&\n! saveg(1)\n912 format(a,i5,6(1pe12.4))\n1000 continue\n return\n end subroutine set_reference_state\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine amend_components\n!\\begin{verbatim}\n subroutine amend_components(line,ceq)\n! amend the set of components\n implicit none\n character line*(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer c1,c2,c3,i1,i2,nspel,ierr,lokph,lokcs,nspx\n integer, allocatable :: ielno(:),loksp(:)\n double precision, allocatable :: stoi(:),smass(:),yarr(:)\n double precision qsp,spextra(10),qq(5)\n double precision, allocatable :: matrix(:,:),imat(:,:)\n character name*24\n type(gtp_condition), pointer :: pcond,qcond,last\n type(gtp_equilibrium_data), pointer :: curceq\n!\n allocate(loksp(noofel))\n allocate(ielno(noofel))\n allocate(stoi(noofel))\n allocate(smass(noofel))\n allocate(matrix(noofel,noofel))\n matrix=zero\n c2=1\n do c1=1,noel()\n c3=c2+index(line(c2:),' ')\n name=line(c2:c3-1)\n! write(*,*)'3A name: \"',trim(name),'\"',c3,c1,' \"',trim(line(c3:)),'\"'\n c2=c3\n call find_species_record_exact(name,loksp(c1))\n if(gx%bmperr.ne.0) goto 1000\n call get_species_data(loksp(c1),nspel,ielno,stoi,&\n smass(c1),qsp,nspx,spextra)\n if(qsp.gt.zero) then\n write(*,*)'Charged species must not be components'\n gx%bmperr=4399; goto 1000\n endif\n do i1=1,nspel\n matrix(ielno(i1),c1)=stoi(i1)\n enddo\n! do i1=1,nspel\n! matrix(c1,ielno(i1))=stoi(i1)\n! enddo\n enddo\n! do c1=1,noofel\n! write(*,70)'3A mat: ',c1,(matrix(c2,c1),c2=1,noofel)\n! enddo\n70 format(a,i1,6(1pe12.4))\n! check that the matrix has an inverse\n allocate(imat(noofel,noofel))\n! removed second index as not used!\n! call mdinvold(noofel,noofel+1,matrix,imat,noofel,ierr)\n call mdinvold(noofel,matrix,imat,noofel,ierr)\n if(ierr.eq.0) then\n! write(*,*)'Error inverting component matrix, dependent components'\n gx%bmperr=4362; goto 1000\n endif\n! do c1=1,noofel\n! write(*,70)'3A imt: ',c1,(imat(c2,c1),c2=1,noofel)\n! enddo\n! gx%bmperr=4399\n! write(*,*)'3A *** All seems OK so far ... but only testing yet'\n! goto 1000\n!----------------------------------------------------------\n! We have a new set of components!!\n! At present (and maybe forever) use the same components in all equilibria ...\n do c1=1,noofel\n do c2=1,noofel\n ceq%compstoi(c2,c1)=matrix(c2,c1)\n ceq%invcompstoi(c2,c1)=imat(c2,c1)\n! set bit GSNOTELCOMP if there are non-zero off-diagonal terms in invcompstoi \n if(c1.ne.c2 .and. imat(c2,c1).ne.zero) then\n globaldata%status=ibset(globaldata%status,GSNOTELCOMP)\n endif\n enddo\n! enddo\n! enter the components, no alphabetical order ... ??\n! do c1=1,noofel\n ceq%complist(c1)%splink=loksp(c1)\n ceq%complist(c1)%phlink=0\n ceq%complist(c1)%tpref(1)=2.9815D2\n ceq%complist(c1)%tpref(2)=1.0D5\n ceq%complist(c1)%mass=smass(c1)\n enddo\n! delete all conditions and experiments in all equilibria\n! the argument 0 means only conditions and experiments deleted, \n! not the ceq itself\n! write(*,*)'3A deleting all conditions in all equilibria',eqfree-1\n do c1=1,eqfree-1\n curceq=>eqlista(c1)\n call delete_all_conditions(0,curceq)\n! delete if there are some extra things\n if(allocated(curceq%eqextra)) deallocate(curceq%eqextra)\n enddo\n! we must go through all (stoichiometric?) phases and set a new\n! value for abnorm(1) and (3)\n! write(*,*)'3A update asum and csum for all phases'\n do c1=1,noofph\n! the value stored in phases(i) is the location of phase record!!\n lokph=phases(c1)\n do c2=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(c2)\n c3=size(ceq%phase_varres(lokcs)%yfr)\n if(.not.allocated(yarr)) then\n allocate(yarr(c3))\n endif\n yarr=ceq%phase_varres(lokcs)%yfr\n! this will update abnorm(1) and (3) for THIS equilibrium ... loop for all??\n call set_constitution(c1,c2,yarr,qq,ceq)\n enddo\n deallocate(yarr)\n enddo\n1000 continue\n! deallocate temporary things (maybe default?)\n deallocate(loksp)\n deallocate(ielno)\n deallocate(stoi)\n deallocate(smass)\n deallocate(matrix)\n return\n end subroutine amend_components\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/models/gtp3B.F90", "content": "!\n! gtp3B included in gtp3.F90\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 6. Section: enter data\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine store_element\n!\\begin{verbatim}\n subroutine store_element(symb,name,refstate,mass,h298,s298)\n! Creates an element record after checks.\n! symb: character*2, symbol (it can be a single character like H or V)\n! name: character, free text name of the element\n! refstate: character, free text name of reference state.\n! mass: double, mass of element in g/mol\n! h298: double, enthalpy difference between 0 and 298.14 K\n! s298: double, entropy at 298.15 K\n implicit none\n CHARACTER*(*) symb,name,refstate\n DOUBLE PRECISION mass,h298,s298\n!\\end{verbatim}\n CHARACTER symb2*2,symb24*24\n integer knr(1),jl,jjj,kkk,nsl,loksp,lokph,nycomp,emodel\n double precision stoik(1)\n character ch1*1,model*24,phname*24,const(1)*24\n logical dummy\n if(.not.allowenter(1)) then\n gx%bmperr=4125\n goto 1000\n endif\n emodel=0\n! check input data\n100 continue\n call capson(symb)\n if(ucletter(symb(1:1))) then\n if(len(symb).ge.2) then\n if(ucletter(symb(2:2)) .or. symb(2:2).eq.' ') then\n goto 200\n endif\n else\n goto 200\n endif\n endif\n! element name error, must be only letters (except /- already entered)\n! write(6,*)'new element not allowed ',symb,gx%bmperr\n gx%bmperr=4033\n goto 1000\n200 continue\n! check if element already entered\n symb2=symb(1:2)\n! write(*,202)'3B new element 1: ',symb,symb2\n202 format(a,'\"',a,'\"',a,'\"')\n reallynew: do jl=0,noofel\n if(symb2.eq.ellista(jl)%symbol) then\n gx%bmperr=4034\n goto 1000\n endif\n enddo reallynew\n! element name is not really needed but must start with letter\n! write(*,12)symb,name,refstate,mass,h298,s298\n!12 format('3B new_el: \"',a,'\"',a,'\"',a,'\"',3(1PE12.4))\n call capson(name)\n if(name(1:1).ne.' ') then\n! allow empty element state\n if(.not.ucletter(name(1:1))) then\n gx%bmperr=4035\n goto 1000\n endif\n endif\n300 continue\n! reference state must start with letter, no other check\n call capson(refstate)\n if(refstate(1:1).ne.' ') then\n! allow empty reference state\n if(.not.ucletter(refstate(1:1))) then\n! error here when 1/2_MOLE_O2(G) etc ....\n model=refstate\n refstate='GAS_'//trim(model)\n! gx%bmperr=4036\n! goto 1000\n endif\n endif\n400 continue\n! mass, h298-h0 and s298 must not be negative\n if(mass.lt.zero) then\n gx%bmperr=4037\n goto 1000\n endif\n if(h298.lt.zero) then\n gx%bmperr=4038\n goto 1000\n endif\n if(s298.lt.zero) then\n gx%bmperr=4039\n goto 1000\n endif\n! All OK, increment noofel and store values in record noofel\n noofel=noofel+1\n if(noofel.gt.maxel) then\n gx%bmperr=4040\n goto 1000\n endif\n! ensure that symbol has no strange characters\n! write(*,202)'3B new element 1B: ',symb,symb2\n ellista(noofel)%symbol=' '\n ellista(noofel)%symbol=symb\n ellista(noofel)%name=name\n ellista(noofel)%ref_state=refstate\n ellista(noofel)%mass=mass\n ellista(noofel)%h298_h0=h298\n ellista(noofel)%s298=s298\n ellista(noofel)%status=0\n ellista(noofel)%alphaindex=noofel\n! value 0 is H298, 1 H0, 2 G\n ellista(noofel)%refstatesymbol=0\n! Now create corresponding species\n noofsp=noofsp+1\n if(noofel.gt.maxsp) then\n gx%bmperr=4041\n goto 1000\n endif\n ellista(noofel)%splink=noofsp\n! write(*,202)'3B new element 1C: ',symb,symb2\n symb24=' '\n symb24=symb2\n! write(*,77)symb,symb2,symb24\n!77 format('3B new element 77: ',a,'\"',a,'\"',a,'\"')\n splista(noofsp)%symbol=symb24\n splista(noofsp)%mass=mass\n splista(noofsp)%charge=zero\n splista(noofsp)%status=0\n splista(noofsp)%status=ibset(splista(noofsp)%status,SPEL)\n splista(noofsp)%alphaindex=noofsp\n splista(noofsp)%noofel=1\n! allocate\n allocate(splista(noofsp)%ellinks(1))\n allocate(splista(noofsp)%stoichiometry(1))\n splista(noofsp)%ellinks(1)=noofel\n splista(noofsp)%stoichiometry(1)=one\n! return with error code 0 i.e. no error\n! gx%bmperr=0\n! rearrange ELEMENTS and SPECIES to maintain these in alphabetical order\n elements(noofel)=noofel\n call alphaelorder\n species(noofsp)=noofsp\n splista(noofsp)%quadindex=0\n call alphasporder\n! As this is an element add the species to the component list of firsteq\n!------------------------------------------------\n! Beware that the alphabetical order may have changed. jjj used later\n jjj=ellista(noofel)%alphaindex\n if(jjj.lt.noofel) then\n! write(*,*)'3B TDB MUST HAVE ELEMENTS IN ALPHABETICAL ORDER!',jjj,noofel\n do kkk=noofel,jjj+1,-1\n firsteq%complist(kkk)%splink=firsteq%complist(kkk-1)%splink\n firsteq%complist(kkk)%phlink=firsteq%complist(kkk-1)%phlink\n firsteq%complist(kkk)%refstate=firsteq%complist(kkk-1)%refstate\n firsteq%complist(kkk)%tpref=firsteq%complist(kkk-1)%tpref\n firsteq%complist(kkk)%mass=firsteq%complist(kkk-1)%mass\n enddo\n else\n jjj=noofel\n endif\n! %splink is location of species\n firsteq%complist(jjj)%splink=noofsp\n firsteq%complist(jjj)%phlink=0\n! do not copy element reference state name here\n firsteq%complist(jjj)%refstate='SER (default)'\n firsteq%complist(jjj)%tpref(1)=2.9815D2\n firsteq%complist(jjj)%tpref(2)=1.0D5\n! copy mass of component from species record\n firsteq%complist(jjj)%mass=mass\n! check\n! call compmassbug(firsteq)\n! NOTE jjj is used below when adding this element to reference phase\n! also set the stoichiometry matrix, just the diagonal. Also the inverse\n firsteq%compstoi(noofel,noofel)=one\n firsteq%invcompstoi(noofel,noofel)=one\n! write(*,*)'3B new_el: ',noofel,name,symb24\n nycomp=noofel\n if(noofel.eq.1) then\n! create reference phase with index 0\n! phname='ELEMENT_REFERENCE_PHASE '\n! if preblems this may be created several times ...\n phname='SELECT_ELEMENT_REFERENCE'\n nsl=1\n knr(1)=1\n! const(1)=name\n const(1)=symb24\n stoik(1)=one\n model='NON_MIXING'\n ch1='Z'\n call enter_phase(phname,nsl,knr,const,stoik,model,ch1,dummy,emodel)\n if(gx%bmperr.ne.0) goto 1000\n! set phase hidden as it should never be included in calculations\n lokph=0\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid)\n! add all additions ??\n else\n! Add the element to the reference phase (phase 0) by extending the\n! constituent list (and many other arrays)\n loksp=firsteq%complist(jjj)%splink\n call add_to_reference_phase(loksp)\n if(gx%bmperr.ne.0) goto 1000\n endif\n if(noofel.gt.0) then\n! clear the nodata bit\n globaldata%status=ibclr(globaldata%status,GSNODATA)\n endif\n! if(gx%bmperr.ne.0) goto 1000\n1000 continue\n! write(*,*)'3B created new species: ',noofsp,splista(noofsp)%symbol\n return\n END subroutine store_element\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_species\n!\\begin{verbatim}\n subroutine enter_species(symb,noelx,ellist,stoik)\n! creates a new species\n! symb: character*24, name of species, often equal to stoichiometric formula\n! noelx: integer, number of elements in stoichiometric formula (incl charge)\n! ellist: character array, element names (electron is /-)\n! stoik: double array, must be positive except for electron.\n implicit none\n character symb*(*),ellist(*)*(*)\n integer noelx\n double precision stoik(*)\n!\\end{verbatim}\n double precision mass,charge\n integer elindex(10)\n integer loksp,noelxx,jl,jk\n if(.not.allowenter(1)) then\n! write(kou,11)\n11 format('3B entering species may create problems',&\n ' when there are phases entered')\n! gx%bmperr=4125\n! goto 1000\n endif\n call capson(symb)\n! write(*,*)'3B Entering ',symb,noelx\n if(.not.ucletter(symb(1:1))) then\n gx%bmperr=4044\n goto 1000\n endif\n if(noelx.le.0 .or. noelx.gt.10) then\n gx%bmperr=4045\n goto 1000\n endif\n! check if there is a period \".\" in the species, that is a common error!\n if(index(symb,'.').gt.0) then\n gx%bmperr=4044; goto 1000\n endif\n! check symb is unique\n! call find_species_record(symb,loksp)\n call find_species_record_noabbr(symb,loksp)\n if(gx%bmperr.eq.0) then\n! If we do not get error speces already entered !!\n! strange error reading cadarache database, what is this? BoS 2020-01-30\n! do jl=1,noofsp\n! write(*,*)'3B entered species ',jl,splista(jl)%symbol\n! enddo\n gx%bmperr=4049; goto 1000\n endif\n mass=zero\n charge=zero\n noelxx=noelx\n checkel: do jl=1,noelx\n loopel: do jk=-1,noofel\n if(ellist(jl).eq.ellista(jk)%symbol) goto 200\n enddo loopel\n! an unknown element\n gx%bmperr=4046\n goto 1000\n200 continue\n elindex(jl)=jk\n if(jk.ge.0) then\n!CCI : when GSVIRTUAL is added, negative stoichiometry is allowed (numerically) \n if( (stoik(jl).lt.zero) .and. &\n (.not.btest(globaldata%status,GSVIRTUAL))) then\n!CCI\n gx%bmperr=4047\n goto 1000\n else\n mass=mass+stoik(jl)*ellista(jk)%mass\n endif\n else\n! this is the electron, save negative of stoick as charge negative\n! the electron is not counted as \"element\" when storing\n charge=-stoik(jl)\n noelxx=noelxx-1\n if(jl.ne.noelx) then\n! this must be the last element .... otherwise problem storing stoik\n gx%bmperr=4048\n goto 1000\n endif\n endif\n! write(6,*)'enter_species 2: ',symb,jl,mass,charge\n enddo checkel\n noofsp=noofsp+1\n if(noofsp.gt.maxsp) then\n gx%bmperr=4125\n goto 1000\n endif\n! store species data\n splista(noofsp)%symbol=symb\n splista(noofsp)%mass=mass\n splista(noofsp)%charge=charge\n splista(noofsp)%alphaindex=noofsp\n splista(noofsp)%noofel=noelxx\n splista(noofsp)%status=0\n! with MQMQA model this links species to quad index\n splista(noofsp)%quadindex=0\n if(charge.ne.zero) then\n splista(noofsp)%status=ibset(splista(noofsp)%status,SPION)\n endif\n! allocate\n allocate(splista(noofsp)%ellinks(noelxx))\n allocate(splista(noofsp)%stoichiometry(noelxx))\n loop2: do jl=1,noelxx\n splista(noofsp)%ellinks(jl)=elindex(jl)\n splista(noofsp)%stoichiometry(jl)=stoik(jl)\n! write(*,12)noofsp,splista(noofsp)%ellinks(jl),&\n! splista(noofsp)%stoichiometry(jl)\n12 format('3B species: ',2i5,F7.4)\n enddo loop2\n! return with no error\n gx%bmperr=0\n! add species last and rearrange\n species(noofsp)=noofsp\n call alphasporder\n! NOTE the array spextra is allocated with AMEND SPECIES command\n! error: continue would be a nice use of non-digit labels ....\n1000 continue\n! write(*,*)'3B exit enter species: ',noofsp,splista(noofsp)%quadindex\n return\n END subroutine enter_species\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enterphase\n!\\begin{verbatim}\n subroutine enterphase(cline,last)\n! interactive entering of phase\n character cline*(*)\n integer last\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character name1*24,text*256,name3*24,model*72,phtype*1,ch1*1,cmodel*72\n integer nsl,defnsl,icon,ll,jp,loop,entropymodel,jj,nend\n double precision sites(9)\n character (len=34) :: quest1='Number of sites on sublattice xx: '\n! constituent indices in a phase\n integer, dimension(maxconst) :: knr\n! array with constituents in sublattices when entering a phase\n character, dimension(maxconst) :: const*24\n logical once,dummy\n!\n! this is called from pmon or TDB file\n call gparcx('Phase name: ',cline,last,1,name1,' ','?Enter phase')\n! ionic liquid require special sorting of constituents on anion sublattice\n call capson(name1)\n! check legal phase name allowed\n if(.not.proper_symbol_name(name1,0)) then\n write(*,*)'3B Illegal phase name'; goto 1000\n endif\n defnsl=1\n if(name1(1:4).eq.'GAS ') then\n phtype='G'\n model='IDEAL'\n elseif(name1(1:7).eq.'LIQUID ') then\n phtype='L'\n model='RKM'\n elseif(name1(1:9).eq.'IONIC_LIQ') then\n phtype='L'\n model='I2SL'\n defnsl=2\n else\n! default ....\n phtype='S'\n model='CEF'\n endif\n! NEW question about model, passed on to enter_phase\n call gparcdx('Model: ',cline,last,1,cmodel,model,'?Enter phase model')\n if(buperr.ne.0) goto 900\n model=cmodel\n entropymodel=0\n call capson(model)\n! defnsl is default number of sublattices\n if(model(1:5).eq.'I2SL ') then\n phtype='L'\n defnsl=2\n elseif(model(1:6).eq.'MQMQA ') then\n phtype='Q'\n entropymodel=2\n defnsl=1\n elseif(model(1:6).eq.'MQMQX ') then\n! attempt to add new variant of the MQMQA model with complete excess model\n phtype='X'\n entropymodel=2\n defnsl=1\n elseif(model(1:4).eq.'QCE ') then\n entropymodel=3\n defnsl=1\n elseif(model(1:5).eq.'TISR ') then\n entropymodel=5\n defnsl=1\n elseif(model(1:5).eq.'SROT ') then\n entropymodel=6\n defnsl=1\n elseif(model(1:6).eq.'CVMCE ') then\n entropymodel=4\n defnsl=1\n endif\n! We are here only when interactive entering of the model!\n! write(*,*)'gtp3B debug 1: ',trim(model),xtdbmqmqa\n sites=one\n! write(*,*)'3B model: ',trim(model),' ',phtype\n if(model(1:6).eq.'IDEAL ' .or. model(1:4).eq.'RKM ' .or. &\n model(1:5).eq.'SROT ' .or. &\n model(1:5).eq.'TISR ' .or. model(1:6).eq.'CVMCE ' .or. &\n model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ' .or. &\n model(1:6).eq.'MQMQX ') then\n! ideal, regular and quasichemical models have 1 sublattice with 1 site\n nsl=1\n elseif(model.eq.'I2SL ') then\n! I2SL has tw0 sublattices with variable number of sites\n nsl=2\n else\n call gparidx('Number of sublattices: ',cline,last,nsl,defnsl,&\n '?Enter phase subl')\n if(buperr.ne.0) goto 900\n endif\n if(nsl.le.0) then\n write(kou,*)'At least one configurational space!!!'\n goto 1000\n elseif(nsl.ge.10) then\n write(kou,*)'Maximum 9 sublattices'\n goto 1000\n endif\n! these checks are redundant?\n! if((model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ') .and. nsl.ne.1) then\n if((model(1:4).eq.'QCE ' .or. model(1:4).eq.'MQMQ') .and. nsl.ne.1) then\n write(*,*)'The liquid quasichemical model has two sites'\n gx%bmperr=4399; goto 1000\n elseif(model(1:5).eq.'I2SL ' .and. nsl.ne.2) then\n write(*,*)'A ionic liquid model must have two sublattices'\n gx%bmperr=4399; goto 1000\n endif\n icon=0\n sloop: do ll=1,nsl\n! 'Number of sites on sublattice xx: '\n! 123456789.123456789.123456789.123\n! write(*,*)'3B model5: \"',trim(model),'\"'\n if(model(1:4).eq.'RKM ' .or. model(1:6).eq.'IDEAL ') then\n! ideal and RKM models have one set of sites with 1 place ...\n sites(1)=one\n elseif(model(1:4).eq.'QCE ' .or. model(1:6).eq.'CVMCE ' .or. &\n model(1:5).eq.'SROT ') then\n call gparrdx('Number of bonds: ',cline,last,sites(1),6.0D0,&\n 'Enter phase bonds')\n if(buperr.ne.0) goto 900\n elseif(model(1:4).eq.'MQMQ') then\n! this model has quadruplets as independent fractions and use\n! excess models with asymmetric composition depdent variables\n sites(1)=1.0d0\n elseif(model(1:5).ne.'I2SL ') then\n! For all other models ask for sublattuces and sites\n once=.true.\n4042 continue\n write(quest1(31:32),4043)ll\n4043 format(i2)\n call gparrdx(quest1,cline,last,sites(ll),one,&\n '?Enter phase sites')\n if(buperr.ne.0) goto 900\n if(sites(ll).le.1.0D-6) then\n write(kou,*)'Number of sites must be larger than 1.0D-6'\n if(once) then\n once=.false.\n goto 4042\n else\n goto 1000\n endif\n endif\n endif\n! Now ask for constituents, special for MQMQA and MQMQX\n! All quadrupoles, each followed by bonds?\n! 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\n! write(*,*)'gtp3B debug 2: ',model,xtdbmqmqa\n! if((model(1:4).eq.'MQMQA ' .not.xtdbmqmqa) then\n if(model(1:4).eq.'MQMQ' .and. .not.xtdbmqmqa) then\n! entering MQMQA constituent with the phase no longer possible\n!\n write(*,*)'gtp3B error entering MQMQA constituents with phase'\n gx%bmperr=4399; goto 1000\n!\n! this code was used when MQMQA species were entered together with the phase\n! but this is no longer possible to enter interactively, only by database\n loop=0\n mqmqloop: do while(.true.)\n call gparcx('MQMQA quadrupoles: ',cline,last,5,text,' ',&\n 'Enter phase constit')\n if(text(1:1).eq.' ') exit mqmqloop\n write(*,*)' *** reading mqmqa_constituents',trim(text)\n! write(*,*)'3B mqmqa quads: ',trim(text)\n! clear any previous content in const\n const=' '\n! -nend set to 0 at first call, then incremented for each FNN endmember found\n call mqmqa_constituents(text,const,nend,loop)\n if(gx%bmperr.ne.0) goto 1000\n loop=1\n enddo mqmqloop\n if(gx%bmperr.ne.0) goto 1000\n if(nend.le.0) then\n write(*,*)'3B MQMQA phase has no constituents'\n gx%bmperr=4399; goto 1000\n endif\n! After entering all quadruplets\n! this replaces species locations in the quadrupoles by endemember indices\n! write(*,*)'3B const: ',trim(const(loop),loop=1,)\n! in mqmqa_rearrance const is an arry const(*)*24 .....\n call mqmqa_rearrange(const)\n if(gx%bmperr.ne.0) goto 1000\n knr=mqmqa_data%nconst\n goto 4100\n elseif(model(1:6).eq.'MQMQA ') then\n! this code used when MQMQA species are entered separately\n write(*,*)'MQMQA constituent entered explicitly'\n gx%bmperr=1000; goto 1000\n endif\n!\n! This can require several lines, to allow that use 4 which means up to ;\n once=.true.\n4045 continue\n if(nsl.eq.1) then\n call gparcx('Constituents: ',cline,last,4,text,';',&\n 'Enter phase constit')\n elseif(model(1:5).eq.'I2SL ') then\n if(ll.eq.1) then\n call gparcx('Cation constituents: ',&\n cline,last,4,text,';','?Enter phase constit')\n else\n call gparcx('Anions and neutals constituents: ',&\n cline,last,4,text,';','?Enter phase constit')\n endif\n else\n! write(*,'(a,i2)')'Give for sublattice ',ll\n write(*,'(a,i2)')'Constituents in sublattice ',ll\n call gparcx('Constituents: ',&\n cline,last,4,text,';','?Enter phase constit')\n endif\n if(buperr.ne.0) goto 900\n if(text(1:1).eq.';') then\n! the user has not specified any constituents \n if(once) then\n write(*,*)'3B No constituents? Try again'\n once=.false.; goto 4045\n else\n write(*,4057)\n4057 format('3B There must be at least one constituent in',&\n ' each sublattice')\n goto 1000\n endif\n endif\n knr(ll)=0\n jp=1\n4047 continue\n if(eolch(text,jp)) goto 4049\n if(model(1:5).eq.'I2SL ' .and. ll.eq.1 &\n .and. knr(1).eq.0) then\n! a very special case: a single \"*\" is allowed on 1st sublattice for ionic liq\n if(text(jp:jp).eq.'*') then\n icon=icon+1\n const(icon)='*'\n knr(1)=1\n cycle sloop\n endif\n endif\n call getname(text,jp,name3,1,ch1)\n if(buperr.eq.0) then\n icon=icon+1\n const(icon)=name3\n knr(ll)=knr(ll)+1\n! write(*,66)'constituent: ',knr(ll),icon,jp,const(icon)\n66 format(a,3i3,a)\n! increment jp to bypass a separating , \n jp=jp+1\n goto 4047\n elseif(once) then\n! write(kou,*)'Input error ',buperr,', at ',jp,', please reenter'\n buperr=0; once=.false.; goto 4045\n else\n goto 1000\n endif\n buperr=0\n4049 continue\n enddo sloop\n4100 continue\n call enter_phase(name1,nsl,knr,const,sites,model,phtype,dummy,entropymodel)\n if(gx%bmperr.ne.0) goto 1000\n900 continue\n if(buperr.ne.0) gx%bmperr=buperr\n1000 continue\n! write(*,*)'3B leave enterphase'\n return\n end subroutine enterphase\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine enter_phase\n!\\begin{verbatim}\n! NEW VERSION WITH MQMQA CONSTITUENTS ENTERED BEFORE PHASE INITIALLY\n subroutine enter_phase(name,nsl,knr,const,sites,model,phtype,warning,emodel)\n! creates the data structure for a new phase\n! name: character*24, name of phase\n! nsl: integer, number of sublattices (range 1-9)\n! knr: integer array, number of constituents in each sublattice\n! const: character array, constituent (species) names in sequential order\n! sites: double array, number of sites on the sublattices\n! model: character, some fixed parts, some free text\n! phtype: character*1, specifies G for gas, L for liquid, X for new MQMQA\n! emodel: for entropy model and maybe more\n! THING TO FIX: an I2SL phase with no cations should be accepted but\n! as a regular solution with 1 site for neutrals, no anions allowed!\n! When reading the database the first sublattice will be empty\n! Added nullifying toptoop\n implicit none\n character name*(*),model*(*),phtype*(*)\n integer nsl,emodel\n integer, dimension(*) :: knr\n double precision, dimension(*) :: sites\n character, dimension(*) :: const*(*)\n logical warning\n!\\end{verbatim}\n type(gtp_phase_add), pointer :: addrec\n character ch1*1,conname*24\n double precision formalunits,endch\n integer kconlok(maxconst),kalpha(maxconst),iord(maxconst),klok(maxconst)\n integer iva(maxconst),endm(maxsubl),endm0(maxsubl+1)\n logical externalchargebalance,tupix\n integer iph,kkk,lokph,ll,nk,jl,jk,mm,lokcs,nkk,nyfas,loksp,tuple,bothcharge\n integer s1,mqm1(20),mqm2(20),s2,s3,s4,s5,minus,s8,iq\n! logicals for models later stored in phase record\n logical i2sl,QCE,uniquac,mqm,clusterr,nocations,cvmtfs,cvmtfl\n! csfree and highcs for finding phase_varres record\n if(.not.allowenter(2)) then\n gx%bmperr=4125\n goto 1000\n endif\n! if I2SL phase with no cation\n! if(nsl.eq.2) write(*,'(i3,2x,2i3)')'3B phase: ',nsl,knr(1),knr(2)\n! if(emodel.ne.0) then\n! write(*,'(a,3i5,F7.3)')'3B emodel phase: ',emodel,nsl,knr(1),sites(1)\n! endif\n i2sl=.FALSE.\n QCE=.FALSE.\n mqm=.FALSE.\n uniquac=.FALSE.\n! write(*,4)trim(name),nsl,(const(jk),jk=1,nsl)\n4 format('3B In enter_phase: ',a,2x,i1,' \"',9a,'\"')\n! phase with tetrahedron CVM configurational entropy\n cvmtfs=.FALSE.\n cvmtfl=.FALSE.\n! this will be set to TRUE if no cations for the I2SL liquid.\n! changes are needed also when calculating with such a liquid\n nocations=.FALSE.\n! check input\n call capson(name)\n! if(.not.ucletter(name)) then\n if(.not.proper_symbol_name(name,0)) then\n write(*,*)'3B Error for phase name: ',name(1:min(24,len(name)))\n gx%bmperr=4053; goto 1000\n endif\n! name unique?\n call find_phase_by_name_exact(name,iph,kkk)\n! write(6,*)'new phase 1A ',name,nsl,gx%bmperr,const(1)\n if(gx%bmperr.eq.0) then\n! if phase found then error as name not unique ... but check explicitly\n lokph=phases(iph)\n if(name.eq.phlista(lokph)%name) then\n gx%bmperr=4054\n goto 1000\n endif\n! name was not exactly the same, accept this phase name also\n else\n gx%bmperr=0\n endif\n! Check above confirm new phase is not abbreviation of existing phases, now\n! add check that no existing phase is an abbreviation of the new phase name\n ambig2: do ll=1,noofph\n nk=len_trim(phlista(ll)%name)\n if(name(1:nk).eq.trim(phlista(ll)%name)) then\n write(*,63)trim(phlista(ll)%name),trim(name)\n63 format(/'3B WARNING: An existing phase \"',a,&\n '\" is short for new phase \"',a,'\"'/&\n 'Phase names should be unique')\n! This is for warning about when reading TDB files\n warning=.TRUE.\n! gx%bmperr=4054; goto 1000\n endif\n enddo ambig2\n if(nsl.lt.1 .or. nsl.gt.maxsubl) then\n gx%bmperr=4056\n goto 1000\n endif\n site1: do ll=1,nsl\n if(sites(ll).le.zero) then\n! write(6,*)' new phase 1B: ',name,ll,nsl,sites(ll)\n gx%bmperr=4057\n goto 1000\n endif\n enddo site1\n nk=0\n knrtest: do ll=1,nsl\n if(knr(ll).lt.1 .or. knr(ll).gt.maxconst) then\n write(*,*)'3B enter phase error:',ll,knr(ll),maxconst\n gx%bmperr=4058; goto 1000\n endif\n if(ll.ge.2 .and. knr(ll).gt.maxcons2) then\n gx%bmperr=4059; goto 1000\n endif\n nk=nk+knr(ll)\n enddo knrtest\n nkk=nk\n! write(6,*)' enter_phase 3: ',name,nsl,nkk,noofsp\n! set bit for quasichemical and ionic liquid model!\n call capson(model)\n! write(*,'(a,a,2x,a)')'gtp3B line 724 model7: ',trim(model),phtype\n if(model(1:5).eq.'I2SL ') then\n i2sl=.TRUE.\n elseif(model(1:4).eq.'QCE ') then\n QCE=.TRUE.\n elseif(model(1:6).eq.'MQMQA ' .or. phtype.eq.'X') then\n! FactSage modified quasichemical model\n! write(*,*)'3B entering MQMQA phase',nk\n mqm=.TRUE.\n! we must call mqmqa_rearrange to fix mqmqa constituents ...\n! const is an array with the names of all constituents of the mqmqa phase\n! write(*,13)(trim(const(ll)),ll=1,nk)\n13 format('3B MQMQA const: ',10(a,1x))\n call mqmqa_rearrange(const)\n! write(*,*)'3B in enter_phase, back from mqmqa_rearrange'\n if(gx%bmperr.ne.0) goto 1000\n elseif(model(1:8).eq.'UNIQUAC ') then\n uniquac=.TRUE.\n write(*,7)\n7 format('3B With this model some of the following questions'&\n ' are irrelevant'/'but kept for compatibility with other models')\n elseif(model(1:7).eq.'CVMTFS ') then\n! FCC tetrahedron model without LRO (ABBB, AABA, ABAA and BAAA same)\n cvmtfs=.TRUE.\n elseif(model(1:7).eq.'CVMTFL ') then\n! FCC tetrahedron model with LRO (max 2 elements)\n cvmtfl=.TRUE.\n endif\n externalchargebalance=.false.\n! CVMTFS creates its own set of constituents in a special subroutine\n if(cvmtfs) then\n! write(*,*)'3B creating CVMTFS constituents',knr(1)\n! This will create new set of constituents!\n call enter_cvmtfs_phase(name,nsl,knr,const)\n if(gx%bmperr.ne.0) goto 1000\n! sort the phase in its place, create varres record etc\n nkk=knr(1)\n sites(1)=one\n! set below\n! phlista(lokph)%status1=bset(phlista(lokph)%status1,PHSRO)\n! write(*,*)'3B exit cvmtfs: ',nsl,nkk,knr(1)\n! goto 370\n endif\n! check constituents\n constest: do jl=1,nkk\n if(jl.eq.1 .and. i2sl) then\n! in this case * is allowed on first sublattice!!\n if(const(1)(1:2).eq.'* ') then\n kalpha(jl)=-99\n kconlok(jl)=-99\n cycle constest\n endif\n endif\n call capson(const(jl))\n! write(6,297)'3B enter_phase constituent: ',jl,const(jl),nkk\n iq=index(const(jl),'-Q')\n if(iq.gt.0) then\n iq=iq+1\n else\n iq=min(len_trim(const(jl))+1,len(const(jl)))\n endif\n findspecies: do jk=1,noofsp\n! why not use any of the several find_species_xyz variants here???\n! write(*,*)'3B iq \"',const(jl)(1:iq),'\" = \"',&\n! splista(jk)%symbol(1:iq),'\" ',iq\n if(const(jl)(1:iq).eq.splista(jk)%symbol(1:iq)) then\n! write(*,*)'3B at new constituent 300: ',noofsp,jk,const(jl)\n goto 300\n endif\n enddo findspecies\n! write(6,297)' enter_phase constituent error: ',jl,const(jl),jk,nkk\n297 format(a,i3,'>',A,'<',2i3)\n write(kou,*)'Unknown constituent, name must be exact: ',trim(const(jl))\n gx%bmperr=4051\n goto 1000\n! found species,\n300 continue\n! write(*,*)'3B constituents entered '\n! check for duplicates in same sublattice\n kalpha(jl)=splista(jk)%alphaindex\n ll=1\n mm=1\n nk=knr(1)\n310 continue\n if(jl.gt.nk) then\n if(ll.lt.nsl) then\n ll=ll+1\n mm=nk+1\n nk=nk+knr(ll)\n goto 310\n else\n write(*,*)'3B Impossible: constituent index outside range!'\n gx%bmperr=4257; goto 1000\n endif\n else\n do mm=mm,jl-1\n! write(*,314)mm,jl,kalpha(mm),kalpha(jl),&\n! const(jl)(1:len_trim(const(jl))),name(1:len_trim(name))\n314 format('3B Species: ',4i4,' \"',a,'\" in ',a)\n if(kalpha(mm).eq.kalpha(jl)) then\n write(*,315)trim(name),trim(const(jl)),ll\n315 format(' *** Error, the ',a,' phase has constituent ',a,&\n ' twice in sublattice ',i2)\n gx%bmperr=4258; goto 1000\n endif\n enddo\n endif\n! for quasichemical model check that costituents with name 'QC_' has 2 elements\n if((QCE .or. mqm) .and. const(jl)(1:3).eq.'QC_') then\n if(splista(jk)%noofel.ne.2) then\n write(*,*)'Quasichemical mixing constituent must have 2 elements'\n gx%bmperr=4399; goto 1000\n endif\n endif\n kconlok(jl)=jk\n! write(6,73)'3B enter_phase 4B: ',jl,const(jl),jk,kconlok(jl),kalpha(jl)\n73 format(A,i3,1x,A6,3I3)\n! mark that PHEXCB bit must be set if species has variable charge \n if(splista(jk)%charge.ne.zero) then\n externalchargebalance=.true.\n endif\n enddo constest\n! we should have the check if the phase can be neutral here ....\n! a phase with net charge is automatically suspended later ...\n!--------------------------------------------------------------------------\n370 continue\n! the first phase entered is the reference phase created by init_gtp\n if(noofph.eq.0 .and. phtype(1:1).eq.'Z') then\n! phtyp=Z is the reference phase\n nyfas=0\n else\n! sort the phase in alphabetical order but always gas (if any) first\n! then liquids specified by the phtype letter (G, L, etc)\n noofph=noofph+1\n! if(nyfas.gt.size(phlista)) then\n if(noofph.gt.size(phlista)) then\n! write(*,*)'3B Too many phases: ',noofph\n gx%bmperr=4259; goto 1000\n endif\n nyfas=noofph\n endif\n! inititate all data in phlista to try to remove problems with step1\n if(nyfas.gt.0) call init_phlista(nyfas)\n phlista(nyfas)%name=name\n phlista(nyfas)%status1=0\n! write(*,*)'3B i2sl?',i2sl\n ionliq: if(i2sl) then\n! the external charge balance set above, not needed\n! write(*,*)'3B *** ionic liquid entered!!!'\n externalchargebalance=.FALSE.\n! ionic liquid may have phtype='Y', change that to L\n if(phtype(1:1).eq.'Y') phtype(1:1)='L'\n if(nsl.ne.2) then\n! if entered with only one sublattice then no cations and only neutrals!!\n write(*,*)'3B Ionic liquid must have 2 sublattices'\n gx%bmperr=4255; goto 1000\n endif\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHIONLIQ)\n! constituents in ionic liquid must be sorted in a special way\n call sort_ionliqconst(lokph,0,knr,kconlok,klok)\n if(gx%bmperr.ne.0) goto 1000\n else ! else link is for all other phases except ionic liquid\n! external chargebalance THIS SET BELOW\n! if(externalchargebalance) &\n! phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB)\n! sort the constituents in each sublattice according to alphaspindex\n! write(6,70)5,(kalpha(i),i=1,nkk)\n! write(6,70)5,(kconlok(i),i=1,nkk)\n!70 format('enter_phase ',I2,': ',20I3)\n nk=1\n sort1: do ll=1,nsl\n call sortin(kalpha(nk),knr(ll),iord(nk))\n if(buperr.ne.0) then\n gx%bmperr=buperr\n goto 1000\n endif\n! iord(nk+1:nk+knr(ll)) has numbers 1..knr(ll), add on nk-1 to these\n! to be in parity with index of kalpha(nk+1:nk+knr(ll))\n adjust: do mm=0,knr(ll)-1\n iord(nk+mm)=iord(nk+mm)+nk-1\n enddo adjust\n nk=nk+knr(ll)\n enddo sort1\n! write(6,70)6,(kalpha(i),i=1,nkk)\n! write(6,70)6,(kconlok(iord(i)),i=1,nkk)\n! in constituent record store kconlok(iord(i))\n! verify we can find species name ...\n! test7: do kk=1,nkk\n! write(6,71)kk,iord(kk),kconlok(iord(kk)),splista(kconlok(iord(kk)))%symbol\n!71 format('enter_phase 7: ',3I3,1x,A)\n! enddo test7\n do jl=1,nkk\n klok(jl)=kconlok(iord(jl))\n enddo\n endif ionliq\n!----------------------------------------\n! write(6,79)8,name,(klok(kk),kk=1,nkk)\n79 format('enter_phase ',I2,': ',A6,10I3)\n ch1=phtype(1:1)\n call capson(ch1)\n! sort the phase in alphabetical but order but first gas, then liquid etc\n! legal values of ch1 is G, L, S and C (gas, liquid, solution, compound)\n! write(*,*)'3B phase byte: ',ch1\n if(ch1.eq.'G') then\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHGAS)\n model='ideal'\n elseif(ch1.eq.'L' .or. ch1.eq.'Q' .or. ch1.eq.'X') then\n! i2sl had phtype changed to L above, Q and X is the MQMQA model ??\n phtype(1:1)='L'\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ)\n endif\n! Handle option F and B for permutations\n if(ch1.eq.'F') then\n! write(*,*)'3B Setting PHFORD bit'\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHFORD)\n! call set_phase_status_bit(lokph,PHFORD)\n elseif(ch1.eq.'B') then\n! write(*,*)'3B Setting PHBORD bit'\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHBORD)\n! call set_phase_status_bit(lokph,PHBORD)\n endif\n! :I is used by TC to indicate charge balance needed, ignore\n if(ch1.eq.' ' .or. ch1.eq.'I') ch1='S'\n! ch1='S'\n phlista(nyfas)%phletter=ch1\n phlista(nyfas)%models=model\n! if(nyfas.eq.0) then\n! continue\n! else\n! to force the MQMQA phase be treated as liquid in the alphabetical order ,,,\n! write(*,*)'3B line 953 enter phase: \"',ch1,'\" ',mqm\n if(mqm) then\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQA)\n if(ch1.eq.'X') then\n! if ch1=X then set PHMQMQX for a more advanced excess model \n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQX)\n endif\n! write(*,960)ch1,mqm\n960 format('gtp3B line 960: \"',a,'\" ',l2)\n endif\n if(nyfas.gt.0) then\n call alphaphorder(tuple)\n phlista(nyfas)%nooffs=1\n else\n! uninitiated below for reference phase\n tuple=0\n endif\n phlista(nyfas)%noofsubl=nsl\n allocate(phlista(nyfas)%nooffr(nsl))\n! sites stored in phase_varres\n! allocate(phlista(nyfas)%sites(nsl))\n formalunits=zero\n do ll=1,nsl\n phlista(nyfas)%nooffr(ll)=knr(ll)\n formalunits=formalunits+sites(ll)\n enddo\n! write(*,*)'3B enter_phase 8x: ',nyfas,nkk,sites(1)\n phlista(nyfas)%tnooffr=nkk\n! write(*,*)'3B enter_phase 8y: ',nyfas,phlista(nyfas)%tnooffr\n! create constituent record\n! write(*,*)'gtp3B line 981 creating constituent list: \"',ch1,'\"'\n call create_constitlist(phlista(nyfas)%constitlist,nkk,klok)\n! write(*,*)'gtp3B back from creating constituent list: \"',ch1,'\"'\n! in phase_varres we will indicate the VA constituent, indicate in iva\n valoop: do jl=1,nkk\n iva(jl)=0\n loksp=phlista(nyfas)%constitlist(jl)\n if(loksp.gt.0) then\n! ionic liquid can have a wildcard */-99 as constituent in first sublattice\n if(btest(splista(loksp)%status,SPVA)) iva(jl)=ibset(iva(jl),CONVA)\n endif\n enddo valoop\n! write(*,32)'3B phase 14A: ',nyfas,(phlista(nyfas)%constitlist(ll),ll=1,nkk)\n32 format(a,i3,50(i3))\n! write(*,33)nkk,(iva(i),i=1,nkk)\n!33 format('3B enter_phase 14B: ',i3,2x,10i3)\n! nprop=10\n! write(*,*)'3B enter_phase parrecords: ',lokcs,nkk,trim(name)\n call create_parrecords(nyfas,lokcs,nsl,nkk,maxcalcprop,iva,firsteq)\n! write(*,*)'3B enter_phase 15: ',nyfas,lokcs,&\n! size(firsteq%phase_varres(lokcs)%yfr)\n if(gx%bmperr.ne.0) goto 1000\n! zero array of pointer to phase_varres record, then set first\n phlista(nyfas)%linktocs=0\n phlista(nyfas)%linktocs(1)=lokcs\n phlista(nyfas)%noofcs=1\n firsteq%phase_varres(lokcs)%phlink=nyfas\n firsteq%phase_varres(lokcs)%prefix=' '\n firsteq%phase_varres(lokcs)%suffix=' '\n! nullify toopfirst and tooplast, set if there are ternary Toop/Kohler models\n nullify(phlista(nyfas)%tooplast)\n nullify(phlista(nyfas)%toopfirst)\n! Initiated to total number of sites, will be updated in set_condition\n firsteq%phase_varres(lokcs)%abnorm(1)=formalunits\n! ncc no longer part of this record\n! firsteq%phase_varres%ncc=nkk\n! zero the phstate (means entered and not known (unknown) if stable)\n firsteq%phase_varres(lokcs)%phstate=0\n! sites must be stored in phase_varres\n! if(QCE) then\n if(model(1:5).eq.'TISR ' .or. model(1:6).eq.'CVMCE ' .or. &\n model(1:5).eq.'SROT ' .or. &\n model(1:4).eq.'QCE ' .or. model(1:6).eq.'MQMQA ' .or. &\n model(1:6).eq.'MQMQX ') then\n! very special, we have a quasichemical model, the bonds are in sites(1)\n! copy them also to qcbonds\n! HM, confusion ... now I store bonds in sites(1) ....2021/02/17\n firsteq%phase_varres(lokcs)%qcbonds=sites(1)\n! firsteq%phase_varres(lokcs)%qcbonds=one\n! in MQMQA all quads share a single set of sites although quad species\n! are formally mixing on a two sublattices with one site each\n! firsteq%phase_varres(lokcs)%sites(1)=2.0D0\n firsteq%phase_varres(lokcs)%sites(1)=one\n! Maybe also set %abnorm ??a?\n! %abnorm is moles of atoms per formula units (varies with composition)\n! NOTE %amfu is moles of formula unit of the phase\n firsteq%phase_varres(lokcs)%abnorm(1)=one\n! write(*,*)'3B MQMQA special abnorm: ',sites(1),one\n! write(*,'(a,a,\": \",2F7.3)')'3B qcbonds ',model(1:5),sites(1),&\n! firsteq%phase_varres(lokcs)%qcbonds\n else\n do ll=1,nsl\n firsteq%phase_varres(lokcs)%sites(ll)=sites(ll)\n enddo\n! this is the model for tetrahedron FCC with just SRO (reduced set of clusters)\n if(model(1:7).eq.'CVMTFS ') then\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHSSRO)\n endif\n if(model(1:7).eq.'CVMTFL ') then\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHCVMTFL)\n endif\n endif\n! make sure status word and some other links are set\n firsteq%phase_varres(lokcs)%status2=0\n firsteq%phase_varres(lokcs)%phtupx=tuple\n! set link to lokcs in phase tuple!\n! phasetuple(tuple)%lokvares=lokcs\n! write(*,*)'3B new phase tuple: ',nyfas,lokcs,tuple\n! If one has made NEW the links are not always zero\n! set some phase bits (PHGAS and PHLIQ set above)\n! external charge balance etc.\n! goto 600\n! ------------------------------------------------------------\n! code below moved here to avoid entring phases with net charge\n bothcharge=0\n! write(*,*)'3B external charge balance? ',externalchargebalance\n if(externalchargebalance) then\n kkk=0\n bothcharge=-100\n! do not set PHEXCB if all endmembers have zero charge m2o3(Ce+3,La+3)2(O-2)3\n jl=1\n endch=zero\n do ll=1,nsl\n endm0(ll)=jl\n endm(ll)=jl\n jk=phlista(nyfas)%constitlist(jl)\n endch=endch+splista(jk)%charge*sites(ll)\n jl=jl+phlista(nyfas)%nooffr(ll)\n enddo\n endm0(nsl+1)=phlista(nyfas)%tnooffr+1\n500 continue\n! write(*,*)'3B checking external chargebalance for: ',trim(name),&\n! btest(phlista(nyfas)%status1,PHEXCB)\n if(abs(endch).gt.1.0D-6) then\n! A clumsy check, with ZRO2_TETR we may have (U+4)1(O-2,VA)2\n! with one neutral and one charged (+4) endmember. It should be allowed ...\n! We will set this bit any time but we have to check if the phase have\n! endmembers with both charges\n! write(*,*)'3B charge balance needed for ',trim(name),endch\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB)\n if(bothcharge.eq.-100) then\n if(endch.lt.zero) then\n bothcharge=-1\n else\n bothcharge=1\n endif\n elseif(bothcharge.lt.0) then\n if(endch.gt.zero) bothcharge=0\n else\n if(endch.lt.zero) bothcharge=0\n endif\n else\n! kkk counts number of neutral endmembers\n kkk=kkk+1\n endif\n ll=nsl\n510 continue\n if(endm(ll).lt.endm0(ll+1)-1) then\n jk=phlista(nyfas)%constitlist(endm(ll))\n endch=endch-splista(jk)%charge*sites(ll)\n endm(ll)=endm(ll)+1\n jk=phlista(nyfas)%constitlist(endm(ll))\n endch=endch+splista(jk)%charge*sites(ll)\n goto 500\n elseif(ll.gt.1) then\n jk=phlista(nyfas)%constitlist(endm(ll))\n endch=endch-splista(jk)%charge*sites(ll)\n endm(ll)=endm0(ll)\n jk=phlista(nyfas)%constitlist(endm(ll))\n endch=endch+splista(jk)%charge*sites(ll)\n ll=ll-1\n goto 510\n endif\n! write(*,*)'3B charge balance not needed for ',trim(name)\n! goto 530\n! jump here if any endmember has a net charge\n!520 continue\n! jump here if all neutral\n!530 continue\n endif\n! if a phase with charged constituents cannot be neutral suspend it\n! If bothcharge=0 no charged endmember or there are both + and - charges,\n! do not suspend\n! If bothcharge=-100 there are no charged endmember, do not suspend\n! If kkk>0 there is at least one neutral, do not suspend\n if(bothcharge.ne.0) then\n if(kkk.eq.0) then\n write(*,531)trim(name),bothcharge,nkk\n531 format('3B *** WARNING: the phase ',a,2i5,' suspended'/&\n 14x,'as it cannot be electrically neutral')\n firsteq%phase_varres(lokcs)%phstate=PHSUS\n endif\n endif\n!--------------------------------------- end moved\n600 continue\n! set net charge to zero\n firsteq%phase_varres(lokcs)%netcharge=zero\n if(nsl.eq.1) then\n if(.not.uniquac) then\n! if no sublattices set ideal bit. Will be cleared if excess parameter entered\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHID)\n endif\n endif\n if(nkk.eq.nsl) then\n! as many constiuents as sublattice, compound with fix composition\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHNOCV)\n endif\n! quasichemical liquid: indicate status bit for bond clusters in phase_varres \n\n! write(*,*)'3B line 1168 code needed to initiallaze MQMQA, test variable mqm?',&\n! mqm,btest(phlista(lokph)%status1,PHMQMQX)\n\n if(QCE) then\n! clear the ideal bit, the corrected quasichemical model (Hillert et al)\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n clusterr=.TRUE.\n do jk=1,size(phlista(nyfas)%constitlist)\n! indexing is tricky ...\n ll=phlista(nyfas)%constitlist(jk)\n if(splista(ll)%symbol(1:3).eq.'QC_') then\n firsteq%phase_varres(lokcs)%constat(jk)=&\n ibset(firsteq%phase_varres(lokcs)%constat(jk),CONQCBOND)\n write(*,*)'3B setting bond cluster bit',jk,CONQCBOND\n clusterr=.FALSE.\n endif\n enddo\n if(clusterr) then\n write(*,*)'3B Phase with QCE model without any clusters \"CQ_\" !'\n gx%bmperr=4399\n endif\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHQCE)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ)\n elseif(mqm) then\n!============================= start of MQMQA constituents\n write(*,*)'3B entering MQMQA phase',mqm,mqmqa_data%nconst\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n! set the globaldata$mqmqa1 if MQMQX\n globaldata%mqmqa1=1.0D4\n write(kou,*)'3B setting mqmqa1',globaldata%mqmqa1\n! phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHFACTCE)\n! write(*,*)'gtp3B line 1186: \"',model(1:6),'\" ',ch1\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQA)\n if(model(1:6).eq.'MQMQX ') then\n! set also excess bit it will be tested below to create new structures\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHMQMQX)\n endif\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ)\n! code below moved to rearrange_mqmqa\n! goto 888\n! we must set correct fraction index in mqmqa_data%contyp(10,i)\n! and also set %contyp(11,i) to %contyp(14,i) to sequalial index in sublattice\n! The order does not matter but same element should have same index\n! mqmqa_data%contyp(10,i) set to order in fraction array\n ll=0\n mqm1=0; mqm2=0\n contyp1: do kkk=1,mqmqa_data%nconst\n loksp=abs(mqmqa_data%contyp(10,kkk))\n! write(*,*)'3B index: ',loksp\n! mqmqa_data%contyp(10,kkk) already set here ....\n mqmqa_data%contyp(10,kkk)=kkk\n do jk=1,size(phlista(nyfas)%constitlist)\n if(loksp.eq.phlista(nyfas)%constitlist(jk)) then\n! just skip this .... only check we have correct number of species ...\n! mqmqa_data%contyp(10,kkk)=jk\n ll=ll+1\n endif\n enddo\n! write(*,555)'todo ',kkk,(mqmqa_data%contyp(jk,kkk),jk=1,14),&\n! trim(splista(phlista(nyfas)%constitlist(kkk))%symbol)\n if(mqmqa_data%contyp(5,kkk).gt.0) then\n! fix sublattice index for pair constituents\n s1=1\n sub1: do while(mqm1(s1).gt.0 .and. &\n mqm1(s1).ne.mqmqa_data%contyp(6,kkk))\n s1=s1+1\n enddo sub1\n mqm1(s1)=mqmqa_data%contyp(6,kkk)\n! save original index in 13\n mqmqa_data%contyp(13,kkk)=mqmqa_data%contyp(11,kkk)\n mqmqa_data%contyp(11,kkk)=s1\n s1=1\n sub2: do while(mqm2(s1).gt.0 .and. &\n mqm2(s1).ne.mqmqa_data%contyp(7,kkk))\n s1=s1+1\n enddo sub2\n mqm2(s1)=mqmqa_data%contyp(7,kkk)\n! save original index in 14\n mqmqa_data%contyp(14,kkk)=mqmqa_data%contyp(12,kkk)\n! set constituent in second sublattice as negative\n mqmqa_data%contyp(12,kkk)=-s1\n! else\n! for all other quadrpoles these contain species index for bonds\n! mqmqa_data%contyp(11,kkk)=0\n! mqmqa_data%contyp(12,kkk)=0\n endif\n! write(*,555)'done ',kkk,(mqmqa_data%contyp(jk,kkk),jk=1,14)\n555 format('3B mqmqa ',a,i2,4i3,2i4,3i3,i4,2x,4i3,1x,a)\n enddo contyp1\n if(ll.ne.size(phlista(nyfas)%constitlist)) then\n write(*,*)'3B MQMQA constituent fractions problems',ll,&\n size(phlista(nyfas)%constitlist)\n gx%bmperr=4399; goto 1000\n endif\n! finally list constitents\n! do s1=1,mqmqa_data%nconst\n! conname=splista(phrec%constitlist(mqmqa_data%contyp(10,s1)))%symbol\n! conname=mqmqa_data%contyp(10,s1)))%symbol\n! connames(s1)=conname\n! write(*,3)s1,(mqmqa_data%contyp(ll,s1),ll=1,14),&\n! (mqmqa_data%constoi(ll,s1),ll=1,4),&\n! trim(splista(phlista(nyfas)%constitlist(s1))%symbol)\n3 format('3B mq:',i2,4i3,1x,i3,1x,4i2,1x,i3,1x,4i2,4F5.1,1x,a)\n! enddo\n!888 continue\n! write(*,*)'3B mqmqa constituents OK: ',mqmqa_data%nconst\n!--------------------- code originally in rearrange_mqmqa\n! Replace species indices in SNN quadruplets by sublattice fraction order\n! do s1=1,mqmqa_data%nconst\n! write(*,34)'3B before: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14)\n34 format(a,i2,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,2x,a)\n! enddo\n!\n! BIG BUG IN THIS LOOP, NOT INITIATED WHEN QUADS ENTERED\n! \n do s1=1,mqmqa_data%nconst\n! write(*,3434)s1,(mqmqa_data%contyp(jk,s1),jk=1,14)\n3434 format('3B contyp2: ',i3,': ',4i3,1x,i4,1x,4i3,1x,i3,1x,4i3)\n if(mqmqa_data%contyp(5,s1).eq.0) then\n! type(gtp_mqmqa) declared in gtp3_dd2.F90\n! this is a SNN quadruplet with 2 or 4 pair links in %contyp(6..9,s1)\n! and species indices in %contyp(11..14,s1)\n! replace the species index in 11..14 by sublattuce fraction index in\n! %contyp(11..12,pair). The original species indices in %contyp(13..14,pair)\n! det galler att halla tungan ratt i mun ... (swedish saying)\n! NOTE: indices in 2nd sublattice set as negative!!!\n! minus=1\n allsubsp: do s2=11,14\n s3=mqmqa_data%contyp(s2,s1)\n! at index s2 in s2 replace species index s3 with sublattice index, if 0 done\n if(s3.le.0) exit allsubsp\n! if second sublattice set minus=-1\n! if(mqmqa_data%contyp(s2-10,s1).lt.0) minus=-1\n! write(*,*)'3B replace ',s1,' species ',s3,' in position ',s2\n do s4=6,9\n! loop all pairs, s4, connected to this SNN for sublattice index of s3\n s8=mqmqa_data%contyp(s4,s1)\n! write(*,'(a,3i3)')'3B looking in pair: ',s5\n if(s8.eq.0) then\n! failed to find species s3 in any pair\n write(*,*)'3B Cannot find a sublattice index order!'\n gx%bmperr=4399; goto 1000\n endif\n! s5 is now index of a pair, the index of the pair in %contyp is in pinq(s8)\n! and finally in %contyp(13..14,s5) are species indices\n s5=mqmqa_data%pinq(s8)\n! write(*,'(a,3i3)')'3B taking s5 from s8: ',s5\n if(s3.eq.mqmqa_data%contyp(13,s5)) then\n mqmqa_data%contyp(s2,s1)=mqmqa_data%contyp(11,s5)\n! write(*,35)'3B sublattice 1 index ',&\n! mqmqa_data%contyp(11,s4),' inserted in ',&\n! mqmqa_data%contyp(s2,s1)\n35 format(a,i3,a,i3)\n cycle allsubsp\n elseif(s3.eq.mqmqa_data%contyp(14,s5)) then\n mqmqa_data%contyp(s2,s1)=mqmqa_data%contyp(12,s5)\n! write(*,35)'3B sublattice 2 index ',&\n! mqmqa_data%contyp(12,s4),' inserted in ',&\n! mqmqa_data%contyp(s2,s1)\n cycle allsubsp\n endif\n enddo\n enddo allsubsp\n endif\n enddo\n!\n! ******************************** initiating allinone here\n! write(*,69)btest(phlista(nyfas)%status1,PHMQMQA),&\n! btest(phlista(nyfas)%status1,PHMQMQX)\n!69 format('gtp3B line 1319 ',2l2)\n if(btest(phlista(nyfas)%status1,PHMQMQX)) then\n! creating excess structures for allinone for MQMQX here? \n! write(*,*)'gtp3B line 1322 >>>>>>>> initiate allonone <<<<<<<<<<< '\n! write(*,66)nyfas,phtype\n66 format('3B Calling create_asymmetry from enter_phase',i5,2x,a)\n! \n call create_asymmetry(nyfas,knr,const,phtype)\n!\n! In this routine we create xquad with indices to constituents\n! create ternary asymmetric records\n! create the binary allinone and initiate varkappa etc.\n! \n endif\n! ******************************** initiating done ... some listing?\n!\n! write(*,*)'3B segmentation fault above ... suck'\n!\n! do s1=1,mqmqa_data%nconst\n! s2=phlista(nyfas)%constitlist(mqmqa_data%contyp(10,s1))\n! conname=splista(s2)%symbol\n! write(*,34)'3B final: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! conname\n! enddo\n! stop 'testing'\n!============================= end of MQMQA constituents\n elseif(uniquac) then\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHUNIQUAC)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ)\n elseif(emodel.eq.4) then\n! this is the CVM or QC model with LRO\n! NOTE emodel 2 and 3 are treaded with different IFs above\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHCVMCE)\n write(*,*)'3B PHCVMCE bit set'\n elseif(emodel.eq.5) then\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHTISR)\n write(*,*)'3B PHTISR bit set'\n elseif(emodel.eq.6) then\n phlista(nyfas)%status1=ibclr(phlista(nyfas)%status1,PHID)\n phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHSROT)\n write(*,*)'3B PHSROT bit set'\n endif\n! nullify links, added tooprec 241012/BoS\n nullify(phlista(nyfas)%additions)\n nullify(phlista(nyfas)%ordered)\n nullify(phlista(nyfas)%disordered)\n nullify(phlista(nyfas)%toopfirst)\n nullify(phlista(nyfas)%tooplast)\n! initiate phcs, the phase composition set counter for nyfas redundant ??\n! (not for reference phase 0) \n! if(nyfas.gt.0) phcs(nyfas)=1\n if(noofph.gt.0) then\n! clear the nophase bit\n globaldata%status=ibclr(globaldata%status,GSNOPHASE)\n!---------------------- new code to generate phase tuple array here\n! NOTE nooftuples updated in alphaphorder ... for old times sake\n! write(*,*)'3B number of phases: ',noofph\n do ll=1,noofph\n! this is index in phlista\n! phasetuple(ll)%phaseix=phases(ll)\n phasetuple(ll)%lokph=phases(ll)\n phasetuple(ll)%compset=1\n! this is alphabetical index\n phasetuple(ll)%ixphase=ll\n! this is link to higher tuple of same phase\n phasetuple(ll)%nextcs=0\n! this is the link to phase tuple from the phase\n jl=phlista(phases(ll))%linktocs(1)\n firsteq%phase_varres(jl)%phtupx=ll\n phasetuple(ll)%lokvares=jl\n enddo\n!---------------------- new code end\n endif\n! almost always enter volume model1, nyfas is lokph, use alphabetical index\n if(nyfas.gt.0) then\n if(.not.(btest(phlista(nyfas)%status1,PHUNIQUAC) .or.&\n btest(phlista(nyfas)%status1,PHGAS))) then\n! write(*,*)'3B enter_phase adding volume model: ',trim(name),nyfas\n call add_addrecord(nyfas,' ',volmod1)\n endif\n endif\n1000 continue\n! write(*,*)'3B leaving enter_phase'\n return\n END subroutine enter_phase\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine create_asymmetry\n!\\begin{verbatim}\n subroutine create_asymmetry(lokph,knr,const,phtype)\n! creates the data structure for asymmetric excess for MQMQA phase\n! called from enter_phase when the MQMQX phase is entered\n! lokph phase location\n! knr: integer array, number of constituents\n! const: character array, constituent (species) names in sequential order\n! phtype: character*1, specifies G for gas, L for liquid X for MQMQX\n implicit none\n integer lokph\n character phtype*(*)\n! type(phase_varres), pointer :: phres\n integer, dimension(*) :: knr\n character, dimension(*) :: const*(*)\n!\\end{verbatim}\n! integer ncat,nan,nquad these are global variables\n double precision x,y\n integer iva,jva,nva,ivb,ivc\n!\n! BoS 2025.11.12: when we are here the mqmqa_data already initiated\n! that is done in ?? , mqmqa_species, around line 7062\n! for example mqmqa_data%nconst and mqmqa_data%contyp\n! but I do not want to fiddle with that routine\n! The global variables nquad etc are redundant but kept for the moment\n! because I have forgotten most of what I did in 2020-2021 \n!\n! This routine can probably be integrated in correlate_const_and_quads\n!\n! write(*,*)'3B start of create_asymmetry phase',lokph\n!\n! write(*,5)'first',mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,&\n! mqmqa_data%lcat,mqmqa_data%nquad,mqmqa_data%ncat,&\n! mqmqa_data%nan\n5 format('3B in create_asymmetry ',a,' check: ',4i4,2x,4i4)\n! Make sure these variables are set !!\n! write(*,*)'3B calling init_excess_asymm'\n!\n mqmqa_data%nquad=mqmqa_data%nconst\n mqmqa_data%ncat=mqmqa_data%ncon1\n mqmqa_data%nan=mqmqa_data%ncon2\n mqmqa_data%lcat=mqmqa_data%ncat*(mqmqa_data%ncat+1)/2\n if(mqmqa_data%ncat.gt.9) then\n write(*,6)mqmqa_data%ncat,10\n6 format('3B **** Warning, too many cations: ',i2,' code assume max ',i2)\n endif\n!\n! write(*,5)'second',mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,&\n! mqmqa_data%lcat,mqmqa_data%nquad,mqmqa_data%ncat,&\n! mqmqa_data%nan\n! nquad=mqmqa_data%nconst\n! ncat=mqmqa_data%ncon1\n! nan=mqmqa_data%ncon2\n! lcat=ncat*(ncat+1)/2\n!\n! write(*,*)'3B inside create_asymmetry calling correlate_const_and_quads'\n!\n call correlate_const_and_quads(lokph)\n!\n! phlista is TYPE gtp_phaserecord\n! we assume only one anion, WHICH? it is set in mqmqa_data%contyp\n! nquad=phlista(lokph)%nooffr(1); x=nquad+0.1; y=0.5*(sqrt(x**2+1.0d0)-1.0d0)\n! ncat=y; nan=1\n! write(*,10)trim(phlista(lokph)%name),phlista(lokph)%phletter,nquad,x,y,ncat\n!10 format('Phase name: ',a,' letter: ',a,' no of const: ',i3,2(1pe12.4),i3)\n! There are some data in the mqmqa_data record?\n! write(*,20)mqmqa_data%nconst,mqmqa_data%ncon1,mqmqa_data%ncon2,&\n! mqmqa_data%exlevel\n!20 format('3B Some mqmqa_data record data: ',4i4)\n!\n! these global values are duplicates but may be useful\n!\n! we have to set mqmqa_data%exlevel to a nonzero value !!!!!!!!!!!\n\n mqmqa_data%exlevel=100\n\n! The values above already set in mqmqa_species, copied here\n! write(*,25)mqmqa_data%nconst,nquad,ncat,nan\n25 format('3B In create_asymmetry ',5i3)\n!\n! double precision, allocatable ::qfnnsnn(:)\n! write(*,30)size(mqmqa_data%qfnnsnn),(mqmqa_data%qfnnsnn(iva),iva=1,ncat)\n30 format('FNN/SNN: ',i3,10(1pe10.2))\n! write(*,*)'3B line 1449 some lines may be needed for ternary asymmetry'\n! The code below needed to read TERNARY asymmetry data\n! skip code below, done in 3XQ <<<<<<<<<< may be needed for TERNARY asymmetry\n! goto 500\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> not used below\n! We have to make sure the quads are arranged in cation order !!\n! 1 2 3 4 ... n | n+1 ... 2n-1 | 2n | ... | n(n+1)/2\n! 1,1 1,2 1,3 1,4 1,n | 2,2 2,3 .. 2,n | 3,3 3,4 | ... | n,n\n! we have the cations in mqmqa_data%contyp(1..4)\n! do iva=1,mqmqa_data%nconst\n! 11-14 gives element indices but a single cation only once\n! write(*,40)iva,(mqmqa_data%contyp(jva,iva),jva=11,14)\n!40 format('3B: Quad elements: ',i3,2x,4i3)\n! enddo\n! create a cross reference to make element 1 part of the first n quads\n! and the other elements in order\n! then element 2 part of the second n-1 quads\n! then element 3 part of the third set of n-2 quads\n! use ijklx to calculate the index of constituent in xquad\n! these allocated (also) in gtp3XQ ....\n! allocate(mqmqa_data%con2quad(nquad))\n! allocate(mqmqa_data%quad2con(nquad))\n! maybe quad2con is also needed ??\n do nva=1,mqmqa_data%nquad\n iva=mqmqa_data%contyp(11,nva)\n ivb=mqmqa_data%contyp(12,nva)\n! write(*,*)'contyp: ',nva,iva,ivb\n if(ivb.gt.0) then\n ivc=ijklx(iva,ivb,1,1)\n else\n ivc=ijklx(iva,iva,1,1)\n endif\n! write(*,*)'contyp: ',nva,iva,ivb,ivc\n! mqmqa_data%con2quad(nva)=ivc\n! mqmqa_data%quad2con(ivc)=nva\n enddo\n!\n500 continue\n!\n! write(*,510)ncat,nan\n510 format(//'3B Calling init_excess_asymm',2i5//)\n!\n! we need to identify cations and anions\n! cations are Cl, F, ?\n! call init_excess_asymm(lokph,ncat,nan)\n call init_excess_asymm(lokph)\n!\n! write(*,*)'3B Back from init_excess_asymm'\n! \n1000 continue\n return\n end subroutine create_asymmetry\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine enter_cvmtfs_phase\n!\\begin{verbatim}\n subroutine enter_cvmtfs_phase(name,nsl,knr,const)\n! enter an CVMTFS phase, tetrahedron FCC with just SRO\n! name phase name\n! nsl sublattices, must be 1\n! knr number of elements, constituents are generated here\n! const array of element namees\n implicit none\n integer nsl,knr(*)\n character name*24,const(*)*24\n!\\end{verbatim}\n integer ia,ib,ic,id,nq,ne,nn,la,lb,lc,ld\n integer, allocatable :: lenel(:)\n character*24, allocatable :: conel(:)\n character prefix*4,sroname*24,srosp(4)*24\n double precision stoisp(4)\n!\n! write(*,*)'3B creating CVMTFS constituents with ',knr(1),' elements'\n if(nsl.ne.1) then\n write(*,*)'The CVMTFS phase has a single set of sites.'\n gx%bmperr=4399; goto 1000\n endif\n if(knr(1).le.1 .or. knr(1).gt.10) then\n write(*,*)'The CVMTFS phase has too few or too many elements',knr(1)\n gx%bmperr=4399; goto 1000\n endif\n! save names of elements and check they exist!\n ne=knr(1)\n allocate(conel(ne))\n allocate(lenel(ne))\n do ia=1,ne\n call find_species_record_noabbr(const(ia),ib)\n if(gx%bmperr.ne.0) goto 1000\n conel(ia)=const(ia)\n lenel(ia)=len_trim(const(ia))\n enddo\n! create all SRO constituents in a sungle set of sites\n! Note duplictates with the different elements on different sites only once\n! This means LRO cannot be modeled but reduces the number of constituents\n! They must be in a fixed order \n prefix='Q000'\n nn=0\n do ia=1,ne\n! species Q001_AAAA and Q00x_BBBB and Q0xy_CCCC etc\n if(nn.gt.maxconst) then\n write(*,*)'3B overflow of SRO constituents',nn\n gx%bmperr=4399; goto 1000\n endif\n srosp(1)=conel(ia)\n la=lenel(ia)\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//&\n srosp(1)(1:la)//srosp(1)(1:la)\n stoisp(1)=one\n call enter_species(sroname,1,srosp,stoisp)\n if(gx%bmperr.ne.0) goto 1100\n const(nn)=sroname\n do ib=ia+1,ne\n! species Qxyz_AAAB, Qxyz_AABB, Qxyz_ABBB and Qxyz_BBBC etc\n srosp(2)=conel(ib)\n lb=lenel(ib)\n! AAAB\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//&\n srosp(1)(1:la)//srosp(2)(1:lb)\n stoisp(1)=0.75D0\n stoisp(2)=0.25D0\n call enter_species(sroname,2,srosp,stoisp)\n const(nn)=sroname\n! AABB\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//&\n srosp(2)(1:lb)//srosp(2)(1:lb)\n stoisp(1)=0.5D0\n stoisp(2)=0.5D0\n call enter_species(sroname,2,srosp,stoisp)\n const(nn)=sroname\n! ABBB\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//&\n srosp(2)(1:lb)//srosp(2)(1:lb)\n stoisp(1)=0.25D0\n stoisp(2)=0.75D0\n call enter_species(sroname,2,srosp,stoisp)\n if(gx%bmperr.ne.0) goto 1100\n const(nn)=sroname\n do ic=ib+1,ne\n! this only if 3 elements or more\n! species Qxyz_AABC, Qxyz_ABBC, Qxyz_ABCC and Qxyz_BBBC etc\n srosp(3)=conel(ic)\n lc=lenel(ic)\n! AABC\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(1)(1:la)//&\n srosp(2)(1:lb)//srosp(3)(1:lc)\n stoisp(1)=0.5D0\n stoisp(2)=0.25D0\n stoisp(3)=0.25D0\n call enter_species(sroname,3,srosp,stoisp)\n const(nn)=sroname\n! ABBC\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//&\n srosp(2)(1:lb)//srosp(3)(1:lc)\n stoisp(1)=0.25D0\n stoisp(2)=0.5D0\n stoisp(3)=0.25D0\n call enter_species(sroname,3,srosp,stoisp)\n const(nn)=sroname\n! ABCC\n nn=nn+1\n call incnum(prefix)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//&\n srosp(3)(1:lc)//srosp(3)(1:lc)\n stoisp(1)=0.25D0\n stoisp(2)=0.25D0\n stoisp(3)=0.5D0\n call enter_species(sroname,3,srosp,stoisp)\n if(gx%bmperr.ne.0) goto 1100\n const(nn)=sroname\n do id=ic+1,ne\n! this only if 4 elements or more\n srosp(4)=conel(id)\n ld=lenel(id)\n! ABCD\n nn=nn+1\n call incnum(prefix)\n! sroname=prefix//'_'//srosp(ia)(1:la)//srosp(ib)(1:lb)//&\n! srosp(ic)(1:lc)//srosp(id)(1:ld)\n sroname=prefix//'_'//srosp(1)(1:la)//srosp(2)(1:lb)//&\n srosp(3)(1:lc)//srosp(4)(1:ld)\n stoisp(1)=0.25D0\n stoisp(2)=0.25D0\n stoisp(3)=0.25D0\n stoisp(4)=0.25D0\n call enter_species(sroname,4,srosp,stoisp)\n if(gx%bmperr.ne.0) goto 1100\n const(nn)=sroname\n enddo\n enddo\n enddo\n enddo\n knr(1)=nn\n! write(*,*)'3B leaving enter_cvmtfs, constituents: ',knr(1)\n! update the number of constituents and their names ...\n1000 continue\n return\n1100 continue\n write(*,1110)'3B error entering cvmtfs species ',nn,trim(sroname),&\n (trim(srosp(ia)),ia=1,4),stoisp\n1110 format(a,i4,1x,a,': ',4(1x,a),4(1pe12.2))\n goto 1000\n end subroutine enter_cvmtfs_phase\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine sort_ionliqconst\n!\\begin{verbatim}\n subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok)\n! sorts constituents in ionic liquid, both when entering phase\n! and decoding parameter constituents\n! order: 1st sublattice only cations\n! 2nd: anions, VA, neutrals\n! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va\n! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1)\n! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check!\n implicit none\n integer lokph,knr(*),kconlok(*),klok(*),mode\n!\\end{verbatim}\n integer nk,jl,jk,mm,kkk,ionva,byte\n integer, dimension(:), allocatable :: kalpha,iord,iva,anion\n!\n allocate(kalpha(knr(1)+knr(2)))\n allocate(iord(knr(1)+knr(2)))\n allocate(iva(knr(1)+knr(2)))\n allocate(anion(knr(1)+knr(2)))\n! check1: constituents in sublattice 1 must all have positive charge\n! if(mode.eq.1) then\n! write(*,17)'3B sl2: ',knr(1),knr(2),(kconlok(mm),mm=1,knr(1)+knr(2))\n!17 format(a,2i3,2x,10i3)\n! endif\n do nk=1,knr(1)\n if(kconlok(nk).lt.0) then\n! wildcard give index -99. If mode=0 more checks later\n kalpha(nk)=-99\n elseif(splista(kconlok(nk))%charge.le.zero) then\n write(*,*)'3B In ionic_liquid only cations on first sublattice'\n gx%bmperr=4260; goto 1000\n else\n kalpha(nk)=splista(kconlok(nk))%alphaindex\n endif\n enddo\n! write(*,69)'3B In 1: ',knr(1),(kconlok(mm),mm=1,knr(1))\n if(knr(1).gt.1) then\n call sortin(kalpha,knr(1),iord)\n if(buperr.ne.0) then\n gx%bmperr=buperr\n goto 1000\n endif\n if(mode.eq.0 .and. kalpha(1).lt.0) then\n! when entering phase a single wildcard allowed in first sublattice\n write(*,*)'3B Illegal parameter with wildcard mixed with cations'\n gx%bmperr=4261; goto 1000\n endif\n do jl=1,knr(1)\n klok(jl)=kconlok(iord(jl))\n enddo\n else\n klok(1)=kconlok(1)\n endif\n! write(*,69)'3B 1st: ',knr(1),(kalpha(mm),mm=1,knr(1))\n! check2: constituents in sublattice 1 must be ANIONS, VA and NEUTRALS\n! in that order\n kkk=knr(1)\n jl=0\n jk=0\n ionva=0\n do nk=1,knr(2)\n if(mode.eq.0 .and. kconlok(nk+kkk).lt.0) then\n! when entering phase no wildcards allowed in second sublattice\n write(*,*)'3B You cannot enter phase with wildcard on 2nd sublattice'\n gx%bmperr=4262; goto 1000\n elseif(kconlok(nk+kkk).lt.0) then\n! wildcard, treat as anion ?? DO NOT ALLOW, what stoichiometry??\n write(*,*)'3B Ionic_liq parameter with wildcard on 2nd sublat. illegal'\n gx%bmperr=4262; goto 1000\n! jk=jk+1\n! anion(jk)=nk\n elseif(splista(kconlok(nk+kkk))%charge.gt.zero) then\n write(*,*)'3B No cations allowed on second sublattice'\n gx%bmperr=4263; goto 1000\n elseif(btest(splista(kconlok(nk+kkk))%status,SPVA)) then\n! this is the hypothetical vacancy\n ionva=nk\n elseif(splista(kconlok(nk+kkk))%charge.eq.zero) then\n! neutral species allowed, use iva, must be sorted after all anions and Va\n jl=jl+1\n iva(jl)=nk\n else\n! anion\n jk=jk+1\n anion(jk)=nk\n endif\n enddo\n! write(*,88)'3B at 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2))\n88 format(a,i4,2x,20i3)\n! There are jl neutrals and jk anions, if vacancies set it as jk+1\n! if wildcard on first sublattice neither ainons nor Va allowed on 2nd\n if(klok(1).lt.0 .and. (jk.gt.0 .or. ionva.ne.0)) then\n write(*,*)'3B Only neutrals on second sublattice if wildcard on first'\n gx%bmperr=4264; goto 1000\n endif\n do nk=1,jk\n if(anion(nk).gt.nk) then\n! shift the anion to position nk, kconlok must be updated\n if(ionva.eq.nk) then\n byte=kconlok(kkk+nk)\n kconlok(kkk+nk)=kconlok(kkk+anion(nk))\n ionva=anion(nk)\n kconlok(kkk+ionva)=byte\n! write(*,88)'3B byt 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2))\n else\n do mm=1,jl\n if(iva(mm).eq.nk) exit\n enddo\n if(mm.gt.jl) stop 'big bug'\n byte=kconlok(kkk+nk)\n kconlok(kkk+nk)=kconlok(kkk+anion(nk))\n iva(mm)=anion(nk)\n kconlok(kkk+iva(mm))=byte\n! write(*,88)'3B byt 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2))\n endif\n anion(nk)=nk\n endif\n enddo\n! write(*,88)'3B at 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2))\n! now all ions should be in positions 1..jk. Fix position of vacancy\n! by moving neiutrals\n if(ionva.gt.jk+1) then\n byte=kconlok(kkk+jk+1)\n kconlok(kkk+jk+1)=kconlok(kkk+ionva)\n kconlok(kkk+ionva)=byte\n iva(ionva)=ionva\n ionva=jk+1\n endif\n! write(*,88)'3B at 3: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2))\n! write(*,69)'3B 2nda: ',jk,&\n! (splista(kconlok(kkk+anion(mm)))%alphaindex,mm=1,jk)\n! if(ionva.gt.0) &\n! write(*,69)'3B 2ndv: ',1,splista(kconlok(kkk+ionva))%alphaindex\n! write(*,69)'3B 2ndn: ',jl,&\n! (splista(kconlok(kkk+iva(mm)))%alphaindex,mm=1,jl)\n69 format(a,i3,2x,10i3,i5,10i3)\n do mm=1,knr(2)\n if(kconlok(kkk+mm).lt.0) then\n kalpha(mm+kkk)=-99\n else\n kalpha(mm+kkk)=splista(kconlok(kkk+mm))%alphaindex\n endif\n enddo\n kkk=knr(1)+1\n! write(*,69)'3B 2ndx: ',knr(2),(kalpha(mm+kkk-1),mm=1,knr(2))\n if(jk.gt.1) then\n! write(*,69)'3B kalpha: ',jk,(kalpha(kkk+mm-1),mm=1,jk)\n call sortin(kalpha(kkk),jk,iord)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n! write(*,69)'3B sort jk: ',jk,(iord(kkk+mm-1),mm=1,jk)\n do mm=1,jk\n klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1)\n enddo\n elseif(jk.gt.0) then\n klok(kkk)=kconlok(kkk)\n endif\n kkk=kkk+jk\n if(ionva.gt.0) then\n klok(kkk)=kconlok(kkk)\n kkk=kkk+1\n endif\n if(jl.gt.1) then\n call sortin(kalpha(kkk),jl,iord)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n do mm=1,jl\n klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1)\n enddo\n elseif(jl.gt.0) then\n klok(kkk)=kconlok(kkk)\n endif\n if(mode.eq.1) then\n! final check for parameters:\n! if only neutrals on sublatice 2 no interaction allowed on sublattice 1\n if(jk.eq.0 .and. ionva.eq.0) then\n if(knr(1).gt.1) then\n write(*,*)'3B Illegal interaction parameter'\n gx%bmperr=4265; goto 1000\n else\n! replace whatever constituent specified in sublattice 1 by wildcard\n klok(1)=-99\n endif\n endif\n endif\n! write(*,69)'3B al1: ',knr(1)+knr(2),&\n! (klok(mm),mm=1,knr(1)+knr(2))\n! write(*,69)'3B al2: ',knr(1)+knr(2),&\n! (splista(klok(mm))%alphaindex,mm=1,knr(1)+knr(2))\n!----------------------------------------------------------\n1000 continue\n return\n end subroutine sort_ionliqconst\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_composition_set\n!\\begin{verbatim}\n subroutine enter_composition_set(iph,prefix,suffix,icsno)\n! adds a composition set to a phase.\n! iph: integer, phase index\n! prefix: character*4, optional prefix to original phase name\n! suffix: character*4, optional suffix to original phase name\n! icsno: integer, returned composition set index (value 2-9)\n! ceq: pointer, to current gtp_equilibrium_data\n!\n! BEWARE this must be done in all equilibria (also during parallel processes)\n! There may still be problems with equilibria saved during STEP and MAP\n!\n implicit none\n integer iph,icsno\n character*(*) prefix,suffix\n! TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! also update phasetuple array !! csfree,highcs\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer lokph,ncs,nsl,nkk,lokcs,lokcs1,nprop,lastcs,jl,nyttcs\n integer leq,nydis,tuple,nz,jz\n character*4 pfix,sfix\n integer iva(maxconst)\n TYPE(gtp_phase_varres), pointer :: peq,neq,ndeq\n logical once\n!\n! write(*,*)'3B in enter_composition set',iph,phases(iph),nooftuples\n once=.TRUE.\n if(iph.le.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n! not implemented \n lokph=phases(iph)\n ncs=phlista(lokph)%noofcs\n if(ncs.gt.8) then\n! max 9 composition sets\n gx%bmperr=4092; goto 1000\n endif\n! not available for PHMQMQX phase\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n write(*,*)'3B phases with MQMQX model cannot have extra composition sets'\n gx%bmperr=4399; goto 1000\n endif\n ceq=>firsteq\n icsno=ncs+1\n\n! test if mmy is correct in all existing compsets\n! OK here\n! do jl=1,ncs\n! lokcs=phlista(lokph)%linktocs(jl)\n! write(*,7)lokcs,firsteq%phase_varres(lokcs)%mmyfr\n7 format('3B mmy: ',i4,10(F6.2))\n! enddo\n! collect some data needed\n nsl=phlista(lokph)%noofsubl\n nkk=phlista(lokph)%tnooffr\n lokcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs)\n lokcs1=lokcs\n nprop=ceq%phase_varres(lokcs)%nprop\n lastcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs)\n! one must set the VA bit in the constituent status array\n ivaloop: do jl=1,nkk\n iva(jl)=ceq%phase_varres(lastcs)%constat(jl)\n enddo ivaloop\n! check that prefix is empty or start with a letter\n if(biglet(prefix(1:1)).ne.' ' .and. &\n (biglet(prefix(1:1)).lt.'A' .or. biglet(prefix(1:1)).gt.'Z')) then\n write(kou,*)'Prefix of composition set must start with a letter'\n gx%bmperr=4167; goto 1000\n endif\n if(biglet(suffix(1:1)).ne.' ' .and. &\n (biglet(suffix(1:1)).lt.'A' .or. biglet(suffix(1:1)).gt.'Z')) then\n write(kou,*)'Suffix of composition set must start with a letter'\n gx%bmperr=4167; goto 1000\n endif\n!------------------------------------------------------------------\n! begin threadprotected code >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! composition sets must be created in all equilibria\n! note that indices to phase_varres same in all equilibria\n! >>> beware not tested created composition sets with several equilibria \n! maybe this call can be replaced by a simple assignment????\n! create_parrecord in GTP3G.F90 update csfree etc \n! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,ceq)\n! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq)\n call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3B added composition set: ',nyttcs,csfree\n! add new tuple at the end and save tuple index\n tuple=nooftuples+1\n! phasetuple(tuple)%phaseix=phases(iph)\n phasetuple(tuple)%lokph=phases(iph)\n phasetuple(tuple)%compset=icsno\n! New variables in phase tuple!, phase index and phase_varrres\n phasetuple(tuple)%ixphase=iph\n phasetuple(tuple)%lokvares=nyttcs\n! nextcs is the index of next phasetuple for same phase\n leq=iph\n! why upper bound error??\n do while(leq.le.nooftuples .and. phasetuple(leq)%nextcs.gt.0)\n leq=phasetuple(leq)%nextcs\n enddo\n! write(*,56)'3B setting nextcs in tuple: ',iph,phases(iph),nyttcs,leq,tuple\n!56 format(a,10i5)\n phasetuple(leq)%nextcs=tuple\n nooftuples=tuple\n! write(*,*)'3B Adding phase tuple: ',tuple,iph,phases(iph)\n! save index of tuple in new phase_varres record\n firsteq%phase_varres(nyttcs)%phtupx=tuple\n! write(*,31)'3B Phase tuple: ',nyttcs,tuple,iph,icsno,phases(iph)\n31 format(a,10i5)\n! firsteq%phase_varres(lastcs)%phtupx=tuple\n! peq=>eqlista(1)%phase_varres(lastcs)\n peq=>firsteq%phase_varres(lastcs)\n! sum up number of constituents!!\n nz=phlista(lokph)%tnooffr\n! write(*,*)'3B check: ',phlista(lokph)%nooffr,size(peq%yfr)\n! write(*,*)'3B added compset: ',iph,icsno,noeq()\n!-------------------------------------------------------------------\n! loop for all equilibria\n! write(*,*)'3B allocate composition set in all equilibria',noeq()\n alleq: do leq=1,noeq()\n! LOOP for all equilibria records to add this composition set to phase lokph\n! lastcs is the previously last composition set, nyttcs is the new,\n! same in all equilibria, also for firsteq (eqlista(1))!!\n neq=>eqlista(leq)%phase_varres(nyttcs)\n! write(*,19)'3B equil loop 1: ',leq,eqlista(leq)%eqno,lokph,icsno,&\n! phlista(lokph)%linktocs(icsno),nyttcs,tuple,neq%phlink\n19 format(a,10i4)\n! why is phlista updated here? It is outside the equilibrium record ...\n! phlista(lokph)%linktocs(icsno)=nyttcs\n neq%phlink=lokph\n! write(*,19)'3B equil loop 2: ',phlista(lokph)%linktocs(icsno),neq%phlink\n! prefix and suffix, only letters and digits allowed but not checked ...\n pfix=prefix; sfix=suffix; call capson(pfix); call capson(sfix)\n neq%prefix=pfix\n neq%suffix=sfix\n! tuple index\n neq%phtupx=tuple\n! initiate the phstate as entered (value 0)\n neq%phstate=PHENTERED\n! increment composition set counter when leq=1, phlista same in all equilibria\n if(leq.eq.1) then\n phlista(lokph)%linktocs(icsno)=nyttcs\n phlista(lokph)%noofcs=phlista(lokph)%noofcs+1\n endif\n! write(*,19)'3B add tupple: ',leq,nooftuples,tuple,neq%phtupx,icsno,&\n! nyttcs,phlista(lokph)%linktocs(icsno),&\n! firsteq%phase_varres(nyttcs)%phtupx\n! write(*,311)'3B sites: ',leq,iph,icsno,neq%sites\n! sites, abnorm and amount formula units \n if(.not.allocated(neq%sites)) then\n! write(*,*)'3B allocation 1: ',nsl\n allocate(neq%sites(nsl))\n endif\n neq%sites=peq%sites\n neq%abnorm=peq%abnorm\n neq%amfu=zero\n! copy quasichemical bonds (if any)!!\n neq%qcbonds=peq%qcbonds\n! write(*,311)'3B amfu: ',leq,iph,icsno,neq%amfu,neq%abnorm,peq%abnorm\n311 format(a,3i3,6(1pe12.4))\n! NOTE: these allocations below because create_parrecords does not work ...\n! fractions and related\n! NOTE: peq%yfr in firsteq is allocated maxconst=1000 as it is done\n! before any elements entered!!! nz set above!!\n! nz=size(peq%yfr)\n! write(*,*)'3B allocate yfr: ',allocated(neq%yfr),nz,&\n! btest(phlista(lokph)%status1,phmfs)\n if(.not.allocated(neq%yfr)) then\n! write(*,*)'3B ********** 2039 allocate and copy yfr: ',nyttcs,nz\n allocate(neq%yfr(nz))\n neq%yfr=peq%yfr\n endif\n! mmyfr is allocated here ...\n! write(*,*)'3B enter_compset: ',allocated(peq%mmyfr)\n if(allocated(peq%mmyfr)) then\n if(.not.allocated(neq%mmyfr)) then\n! write(*,*)'3B allocation 3: ',nz\n allocate(neq%mmyfr(nz))\n neq%mmyfr=peq%mmyfr\n endif\n endif\n if(allocated(peq%dpqdy)) then\n! for ionic liquid, emergency bugfix 2017/02/16 Bo+Karl\n if(.not.allocated(neq%dpqdy)) then\n jz=size(peq%dpqdy)\n allocate(neq%dpqdy(jz))\n neq%dpqdy=peq%dpqdy\n jz=size(peq%d2pqdvay)\n allocate(neq%d2pqdvay(jz))\n neq%d2pqdvay=peq%d2pqdvay\n endif\n endif\n! end bugfix\n if(.not.allocated(neq%constat)) then\n! important!! constat has identification of the vacancy constituent !!\n! write(*,*)'3B allocation 4: ',nz\n allocate(neq%constat(nz))\n neq%constat=peq%constat\n endif\n! copy status word but clear some bits CSDEFCON means default constitution\n neq%status2=peq%status2\n neq%status2=ibclr(neq%status2,CSDEFCON)\n! set duplicate bit for auto in all equilibria\n if(len(suffix).ge.4) then\n if(suffix.eq.'AUTO') then\n! write(*,*)'3B setting bit CSTEMPAR in ',leq,nyttcs\n neq%status2=ibset(neq%status2,CSTEMPAR)\n endif\n endif\n!\n if(.not.allocated(neq%gval)) then\n! result arrays should have been allocated in create_parrecords ...\n! but I do not call create_parrecords !!\n! write(*,83)'3B gval: ',leq,lokph,nyttcs,nprop,nz\n83 format(a,10i5)\n allocate(neq%gval(6,nprop))\n allocate(neq%dgval(3,nz,nprop))\n allocate(neq%d2gval(nz*(nz+1)/2,nprop))\n allocate(neq%listprop(nprop))\n endif\n!------------------- add addg ...\n if(btest(neq%status2,CSADDG)) then\n if(.not.allocated(neq%addg)) then\n! write(*,*)'3B allocation 6: ',1\n allocate(neq%addg(1))\n neq%addg(1)=peq%addg(1)\n endif\n endif\n!--------------------\n! write(*,88)'3B cs: ',nz,neq%status2,neq%constat\n88 format(a,i2,2x,Z16,2x,10(1x,i3))\n! if there is a disordered fraction set one must copy the fraction set record\n! and add a new parrecords to this. lokcs1 is first composition set\n! do not forget to increment novarres and highcs\n disordered: if(btest(phlista(lokph)%status1,phmfs)) then\n! copy the old fraction set record to the new\n!------------------------ does this work??? disfra has a lot of data\n neq%disfra=peq%disfra\n!------------------------- yes it works!!\n! write(*,*)'3B disfra 1: ',peq%disfra%ndd,neq%disfra%ndd\n! write(*,*)'disfra 2: ',peq%disfra%dxidyj(2),neq%disfra%dxidyj(2)\n!--------------------------------------\n nsl=peq%disfra%ndd\n nkk=peq%disfra%tnoofxfr\n! write(*,*)'3B Creating disordered fraction set 1',lokcs1,nyttcs,nkk\n do jl=1,nkk\n iva(jl)=ceq%phase_varres(lokcs1)%constat(jl)\n enddo\n if(leq.eq.1) then\n! allocate a parrecord for DISORDERED FRACTION SET for first equilibrium.\n! Then use the same index: nydis, for all other equilibria.\n! Maybe this can be made by a simple assignement???? NO !!!\n call create_parrecords(lokph,nydis,nsl,nkk,maxcalcprop,iva,firsteq)\n if(gx%bmperr.ne.0) goto 1000\n elseif(once) then\n write(kou,*)'3B creates a composition set in all equilibria'\n once=.FALSE.\n! write(kou,170)trim(eqlista(leq)%eqname),leq,lokcs1,nydis\n!170 format('3B New composition set in equilibrium ',a,i4,&\n! ' with lokcs and nydis index: ',2i4)\n! ??????????? but the disordered fraction set is empty??\n endif\n! write(*,*)'3B disordered phase_varres: ',leq,nydis,csfree\n ndeq=>eqlista(leq)%phase_varres(nydis)\n ndeq%phlink=lokph\n ndeq%prefix=' '\n ndeq%suffix=' '\n! sites must be copied to disordered phase_varres\n! write(*,*)'3B dsites: ',size(neq%disfra%dsites),size(neq%sites)\n ndeq%disfra%dsites=peq%disfra%dsites\n! some status bits must be set\n ndeq%status2=ibset(ndeq%status2,CSDFS)\n neq%status2=ibset(neq%status2,CSDLNK)\n! set the link from ordered disfra record to the disordered phase_varres record\n neq%disfra%varreslink=nydis\n! allocate disordered fractions!!\n! write(*,*)'3B allocate disordered yfr?',allocated(ndeq%yfr),nkk\n if(.not.allocated(ndeq%yfr)) then\n allocate(ndeq%yfr(nkk))\n endif\n! write(*,*)'3B allocated disordered yfr?',allocated(ndeq%yfr)\n endif disordered\n enddo alleq\n! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< dpqdy\n!-------------------------------------------------\n! write(*,*)'3B Link from ordred ',lastcs,&\n! ' to disordered ',ceq%phase_varres(lastcs)%disfra%varreslink\n! next=ceq%phase_varres(lastcs)%next\n! write(*,*)'3B Link from ordred ',next,&\n! ' to disordered ',ceq%phase_varres(next)%disfra%varreslink\n1000 continue\n! test if mmy is correct in all existing compsets\n! OK here also ...\n! do jl=1,icsno\n! lokcs=phlista(lokph)%linktocs(jl)\n! write(*,7)lokcs,firsteq%phase_varres(lokcs)%mmyfr\n! enddo\n! write(*,*)'3B value of csfree,highcs: ',csfree,highcs\n return\n end subroutine enter_composition_set\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine suspend_composition_set\n!\\begin{verbatim}\n subroutine suspend_composition_set(iph,parallel,ceq)\n! the last composition set is suspended in all equilibria\n!\n! If parallel is TRUE then execution is not in parallel (threaded)\n!\n implicit none\n integer iph\n logical parallel\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n TYPE(gtp_phase_varres), pointer :: varres,disvarres\n integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq\n lokph=phases(iph)\n ncs=phlista(lokph)%noofcs\n! cannot remove composition set 1 or a nonexisting one\n if(ncs.le.1) goto 1000\n lokcs=phlista(lokph)%linktocs(ncs)\n! write(*,*)'3B suspend compset ',parallel\n if(parallel) then\n! we have to stop all threads to do anyting with other equilibria, to\n! suspend composition sets in other threads, skip that just suspend the\n! last composition set of iph in this equilibrium, ceq\n!$ if(omp_get_num_threads().eq.1) then\n!$ write(*,*)'3B suspend ',iph,ncs\n!$ if(btest(ceq%phase_varres(lokcs)%status2,CSTEMPAR)) then\n!$ ceq%phase_varres(lokcs)%phstate=PHSUS\n!$ endif\n!-$ else\n!-$ write(*,*)' *** Cannot suspend_composition_set in parallel'\n!$ endif\n goto 1000\n endif\n! we have many equilibria but is not running parallel\n! suspend last composition set of iph in all equilibria where it is not stable\n do leq=1,noeq()\n! write(*,*)'3B suspend ',iph,ncs,&\n! eqlista(leq)%phase_varres(lokcs)%phstate,&\n! btest(eqlista(leq)%phase_varres(lokcs)%status2,CSAUTO),&\n! btest(eqlista(leq)%phase_varres(lokcs)%status2,CSTEMPAR)\n if(btest(eqlista(leq)%phase_varres(lokcs)%status2,CSTEMPAR) .and. &\n eqlista(leq)%phase_varres(lokcs)%phstate.le.PHENTERED) then\n eqlista(leq)%phase_varres(lokcs)%phstate=PHSUS\n endif\n enddo\n! \n1000 continue\n end subroutine suspend_composition_set\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine suspend_unstable_sets\n!\\begin{verbatim}\n subroutine suspend_unstable_sets(mode,ceq)\n! suspend extra composition sets that are not stable\n implicit none\n integer mode\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokph,ics,lokcs\n! loop for all phases\n phases: do lokph=1,noofph\n if(phlista(lokph)%noofcs.eq.1) cycle phases\n sets: do ics=2,phlista(lokph)%noofcs\n! never change first composition set, even if not stable\n lokcs=phlista(lokph)%linktocs(ics)\n if(ceq%phase_varres(lokcs)%phstate.gt.0) cycle sets\n ceq%phase_varres(lokcs)%phstate=PHSUS\n enddo sets\n enddo phases\n1000 continue\n return\n end subroutine suspend_unstable_sets\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine remove_composition_set\n!\\begin{verbatim} %-\n subroutine remove_composition_set(iph,force)\n! subroutine delete_composition_set(iph,force)\n! the last composition set of phase iph is deleted, update csfree and highcs\n! SPURIOUS ERRORS OCCUR IN THIS SUBROUTINE\n!\n! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< !\n! Not safe to remove composition sets when more than one equilibrium !\n! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< !\n!\n! If force is TRUE delete anyway ... very dangerous ...\n!\n implicit none\n!\n! BEWARE must be for all equilibria but maybe not allowed when threaded\n!\n integer iph,jl,tuple\n logical force\n!\\end{verbatim}\n TYPE(gtp_phase_varres), pointer :: varres,disvarres\n integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq\n!\n! write(*,*)'3B In remove_compsets',iph,csfree,highcs\n if(iph.le.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n lokph=phases(iph)\n ncs=phlista(lokph)%noofcs\n if(ncs.eq.1) then\n! cannot remove composition set 1 or a nonexisting one\n gx%bmperr=4093; goto 1000\n else\n ics=ncs\n endif\n if(btest(globaldata%status,GSNOREMCS)) then\n write(*,*)'3B Not allowed to delete composition sets'\n gx%bmperr=4211; goto 1000\n endif\n! write(*,*)'3B Delete highest composition set: ',iph,lokph,ics\n if(noeq().gt.1) then\n! the deletion of composition sets when many equilibia not allowed until\n! further testing\n write(*,*)' Warning, attempt to delete composition set',&\n ' with many equilibria ignored'\n goto 1000\n if(force) then\n write(*,*)' *** WARNING: deleting composition sets',&\n ' in many equilibria may cause errors'\n else\n write(*,*)'Attempt to delete composition sets when many equilibria'\n gx%bmperr=4211; goto 1000\n endif\n endif\n!$ if(.TRUE.) then\n! write(*,*)'Deleting composition sets impossible when running parallel'\n! write(*,*)'This subroutine must be executed in sequential'\n!$ goto 1000\n!$ endif\n! find the tuple for this phase+compset\n!CCI\n tuple = 0\n!CCI\n loop: do jl=1,nooftuples\n! write(*,*)'3B tuple compset: ',jl,ics,phasetuple(jl)%compset\n! if(phasetuple(jl)%phaseix.eq.lokph) then\n if(phasetuple(jl)%lokph.eq.lokph) then\n if(phasetuple(jl)%compset.eq.ics) then\n tuple=jl; exit loop\n endif\n endif\n enddo loop\n! write(*,*)'3B remove composition set: ',iph,ics,lokph,tuple\n if(tuple.le.0) then\n! write(*,*)'No such tuple!!'\n gx%bmperr=4252; goto 1000\n endif\n! collect some data\n nsl=phlista(lokph)%noofsubl\n nkk=phlista(lokph)%tnooffr\n lokcs=phlista(lokph)%linktocs(ics)\n lastcs=lokcs\n nprop=firsteq%phase_varres(lokcs)%nprop\n! write(*,*)'3B Removing varres record: ',lastcs\n!-------------------------------------\n! begin threadprotected code to remove lastcs >>>>>>>>>>>>>>>>>>>\n! delete compset ics, shift higher down (not necessary)\n! deallocate data in lokcs and return records to free list\n!-------------------------------------\n! We must remove the composition set in all equilibria\n! the index to phase_varres is the same in all equilibria!!!!\n alleq: do leq=1,noeq()\n varres=>eqlista(leq)%phase_varres(lastcs)\n! there can be unallocated phase_varres records below lastcs\n if(.not.allocated(varres%sites)) cycle alleq\n deallocate(varres%constat)\n deallocate(varres%yfr)\n if(allocated(varres%mmyfr)) then\n! this is not allways allocated, clear CSDEFCON bit also\n varres%status2=ibclr(varres%status2,CSDEFCON)\n deallocate(varres%mmyfr)\n endif\n deallocate(varres%sites)\n! these may not be allocated ...\n! write(*,*)'3B delete varres dsitesdy: ',leq,lokcs,size(varres%dsitesdy)\n! if(size(varres%dsitesdy).gt.1) deallocate(varres%dsitesdy)\n! if(size(varres%d2sitesdy2).gt.1) deallocate(varres%d2sitesdy2)\n deallocate(varres%listprop)\n deallocate(varres%gval)\n deallocate(varres%dgval)\n deallocate(varres%d2gval)\n! There is a disordered fraction record .... more to deallocate\n disordered: if(allocated(varres%disfra%y2x)) then\n deallocate(varres%disfra%dsites)\n deallocate(varres%disfra%nooffr)\n deallocate(varres%disfra%splink)\n deallocate(varres%disfra%y2x)\n deallocate(varres%disfra%dxidyj)\n! now deallocate and release the phase_varres record with disordered fractions\n idisvarres=varres%disfra%varreslink\n disvarres=>eqlista(leq)%phase_varres(idisvarres)\n! write(*,*)'3B Deallocationg disordered varres record ',idisvarres\n deallocate(disvarres%constat)\n deallocate(disvarres%yfr)\n if(allocated(disvarres%mmyfr)) then\n disvarres%status2=ibclr(disvarres%status2,CSDEFCON)\n deallocate(disvarres%mmyfr)\n endif\n deallocate(disvarres%sites)\n! these may not be allocated ...\n! write(*,*)'3B delete cs dsitesdy: ',leq,size(disvarres%dsitesdy)\n! if(size(disvarres%dsitesdy).gt.1) deallocate(disvarres%dsitesdy)\n! if(size(disvarres%d2sitesdy2).gt.1) deallocate(disvarres%d2sitesdy2)\n deallocate(disvarres%listprop)\n deallocate(disvarres%gval)\n deallocate(disvarres%dgval)\n deallocate(disvarres%d2gval)\n! BOS 1401227: I do not think this is an error, just ignore ...\n! if(size(disvarres%disfra%dsites).gt.0) then\n! write(*,*)'ERROR, only one level of disordering allowed',leq,&\n! size(disvarres%disfra%dsites)\n! stop\n! endif\n else\n idisvarres=0\n endif disordered\n enddo alleq\n! write(*,*)'3B Done all equilibrium records'\n! decrement the composition set counter for this phase\n! the phlista record is global, not part of the equilibria\n phlista(lokph)%noofcs=phlista(lokph)%noofcs-1\n! link the released phase_varres record back to free list,\n! maintained in firsteq only\n if(idisvarres.ne.0) then\n! there was a disordered phase_varres record, link it into free list\n! write(*,*)'3B Free list 2: ',csfree,idisvarres\n firsteq%phase_varres(idisvarres)%nextfree=csfree\n csfree=idisvarres\n! make used but released\n firsteq%phase_varres(idisvarres)%status2=&\n ibset(firsteq%phase_varres(idisvarres)%status2,CSDEL)\n! UNFINISHED this is not correct ....\n idisvarres=newhighcs(.false.)\n if(idisvarres.eq.highcs) highcs=idisvarres-1\n! write(*,*)'3B removed varres: ',idisvarres,csfree,highcs\n endif\n! link the free phase_varres into the free list\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! UNFINISHED: the free list for phase_varres is not updated correctly\n! The use of csfree is DANGEROUS, there can be unallocated varres recored\n! before the record indiceted by csfree\n! and allocated after!!!\n! write(*,*)'3B Free list 1: ',csfree,lastcs\n firsteq%phase_varres(lastcs)%nextfree=csfree\n csfree=lastcs\n! mark this record used but deleted\n firsteq%phase_varres(lastcs)%status2=&\n ibset(firsteq%phase_varres(lastcs)%status2,CSDEL)\n! UNFINISHED this is not correct\n idisvarres=newhighcs(.false.)\n if(highcs.eq.lastcs) highcs=lastcs-1\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! finally shift all composition sets in phlista(lokph)%linktocs\n! if last deleted then ics>phlista(lokph)%noofcs\n do kcs=ics,phlista(lokph)%noofcs\n phlista(lokph)%linktocs(kcs)=phlista(lokph)%linktocs(kcs+1)\n enddo\n! and zero the last pointer to composition set.\n phlista(lokph)%linktocs(phlista(lokph)%noofcs+1)=0\n!\n! cleaning up phasetuple\n jl=phasetuple(tuple)%ixphase\n! write(*,*)\n! write(*,*)'3B cleaning up phase tuple when removing tuple: ',tuple,jl\n if(phasetuple(tuple)%compset.eq.2) then\n! if the removed phasetuple has compset index 2 then zero the link in\n! the original phase tuple ...\n! write(*,*)'3B link to tuple for compset 2 set to zero: ',tuple\n phasetuple(jl)%nextcs=0\n else\n jl=phasetuple(jl)%nextcs\n! zero the nextcs pointer in the phase tuple pointing to tuple\n eternity: do while(phasetuple(jl)%nextcs.ne.tuple)\n if(jl.eq.phasetuple(tuple)%nextcs) then\n exit eternity\n endif\n if(phasetuple(jl)%nextcs.eq.0) then\n! write(*,*)'3B No such tuple: ',phasetuple(tuple)%compset,tuple\n gx%bmperr=4252; goto 1000\n endif\n jl=phasetuple(jl)%nextcs\n enddo eternity\n phasetuple(jl)%nextcs=0\n endif\n!\n!>>>>>>>>>>>>>>>>> THINK <<<<<<<<<<<<<<<<<<<<<<<\n!\n! The assumption is that phase tuples are always ordered in increasing\n! composition set number. One will always delete the highest number.\n! The main problem is to ensure that %nextcs is correct and that the\n! nextcs from the first composition set is updated correctly, also when\n! phase tuples from other phases are deleted.\n!\n! write(*,*)'3B Free list 1: ',csfree,highcs,lokcs\n! update phasetuple array, overwrite tuple. This means tuples may change phase\n! NOTE the first tuple for a phase+compset=1 will never change position. Only\n! those created later may be shifted ... but that may be complicated enough ...\n! write(*,*)'3B Shifting phase tuples above deleted: ',tuple,nooftuples\n! write(*,770)'3B1:',(jl,phasetuple(jl),jl=tuple-1,nooftuples)\n770 format(a,3(6i4,';'),(/4x,6i4,';',6i4,';',6i4,';'))\n! It is always the last compset of a phase that is removed,\n! all nextcs links goes to higher tuples\n do jl=tuple+1,nooftuples\n! phasetuple(jl-1)%phaseix=phasetuple(jl)%phaseix\n phasetuple(jl-1)%lokph=phasetuple(jl)%lokph\n phasetuple(jl-1)%compset=phasetuple(jl)%compset\n phasetuple(jl-1)%ixphase=phasetuple(jl)%ixphase\n phasetuple(jl-1)%lokvares=phasetuple(jl)%lokvares\n! all tuples have moved down one position ... thus nextcs decremented by one\n if(phasetuple(jl)%nextcs.gt.0) then\n phasetuple(jl-1)%nextcs=phasetuple(jl)%nextcs-1\n else\n! unless it is zero in which case it keeps its value\n phasetuple(jl-1)%nextcs=0\n endif\n! we must change the link to this tuple starting from ixphase ??\n if(phasetuple(jl-1)%compset.eq.2) then\n! write(*,*)'3B Changing link to compset 2: ',&\n! phasetuple(jl-1)%ixphase,jl-1\n phasetuple(phasetuple(jl-1)%ixphase)%nextcs=jl-1\n endif\n!\n! THERE IS SOME ERROR HERE ... macro Nestor-800 with 21 elements returned\n! sometimes that a tuple did not exist.\n!\n! we must change the link in the phase_varres records also!!\n! lokph=phasetuple(jl-1)%phaseix\n lokph=phasetuple(jl-1)%lokph\n lokcs=phlista(lokph)%linktocs(phasetuple(jl-1)%compset)\n if(lokcs.le.0) then\n write(*,*)'3B index pf phase_varres <=0',jl-1,lokph\n gx%bmperr=4399; goto 1000\n endif\n! write(*,771)'3B Shifting down ',jl,nooftuples,phasetuple(jl-1)%phaseix,&\n! phasetuple(jl-1)%compset,lokph,lokcs\n!771 format(a,10i5)\n! in all equilibrium records, luckily the phase_varres record the same in all!!\n do leq=1,noeq()\n eqlista(leq)%phase_varres(lokcs)%phtupx=jl-1\n enddo\n enddo\n! write(*,770)'3B2:',(jl,phasetuple(jl),jl=tuple-1,nooftuples)\n nooftuples=nooftuples-1\n! the last tuple must explicitly have its link set to zero ?? done\n! phasetuple(nooftuples)%nextcs=0\n! write(*,*)'3B Warning: phase tuples may have changed phase ...'\n! write(*,770)'3B 2: ',(phasetuple(jl),jl=tuple-4,nooftuples)\n! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<<\n!-------------------------\n1000 continue\n return\n end subroutine remove_composition_set\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine suspend_somephases\n!\\begin{verbatim}\n subroutine suspend_somephases(mode,invph,dim1,dim2,ceq)\n! This was added to handle calculating restricted equilibria during mapping\n! to suspend (mode=1) or restore (mode=0) phases not involved\n! in an invariant equilibrium.\n! invph is array with phases that are involved, it has dimension (dim1,*)\n! the current status is saved and restored \n implicit none\n integer mode,dim1,dim2,invph(dim1,*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer, save, allocatable, dimension(:) :: phtupixstatus\n integer, save :: ntup\n integer ii,jj,kk,lokcs,lokph\n character phname*24\n ii=nooftup()\n kk=0\n if(mode.eq.1) then\n! after saving current status suspend all phases not included in invph\n! write(*,*)'3B suspending some phases',ii\n ntup=ii\n if(allocated(phtupixstatus)) then\n write(*,*)'3B calls to suspend_somephases cannot be nested'\n gx%bmperr=4399; goto 1000\n else\n allocate(phtupixstatus(ntup))\n endif\n loop1: do ii=1,ntup\n lokcs=phasetuple(ii)%lokvares\n phtupixstatus(ii)=ceq%phase_varres(lokcs)%phstate\n do jj=1,dim2\n! write(*,*)'3B suspend? ',jj,lokcs,&\n! phlista(invph(1,jj))%linktocs(invph(2,jj)),phtupixstatus(ii)\n! invph(1,jj) is index in phases (phase and alphabetcal order)\n! lokph is the order the phase were entered into phlista (arbitrary)\n lokph=phases(invph(1,jj))\n if(lokcs.eq.phlista(lokph)%linktocs(invph(2,jj))) then\n! write(*,'(a,6i5)')'3B not suspending',jj,invph(1,jj),&\n! invph(2,jj),phlista(lokph)%linktocs(invph(2,jj))\n cycle loop1\n endif\n enddo\n! this phase should be suspended\n kk=kk+1\n ceq%phase_varres(lokcs)%phstate=PHSUS\n enddo loop1\n! write(*,'(a,i3,a,i3)')'3B suspededed ',kk,' phases out of ',ntup\n elseif(mode.eq.0) then\n! restore status of all phases except those in invph\n! write(*,*)'3B restoring some phases',ii\n if(ii.ne.ntup) then\n write(*,*)'3B number of phases and compsets changed!',ntup,ii\n stop\n endif\n do ii=1,ntup\n ceq%phase_varres(phasetuple(ii)%lokvares)%phstate=phtupixstatus(ii)\n enddo\n! write(*,'(a,i3,a)')'3B restored phase status for ',ntup,' phases'\n deallocate(phtupixstatus)\n else\n write(*,*)'3B mode must be 0 or 1'\n gx%bmperr=4399\n endif\n1000 continue\n return\n end subroutine suspend_somephases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine delete_unstable_compsets\n!\\begin{verbatim}\n subroutine delete_unstable_compsets(lokph,ceq)\n! This was added to explictly delete unstable composition sets with AUTO set\n! Compsets will be shifted down if a stable compset is after an unstable\n! See subroutine TOTO_AFTER in gtp3Y.F90\n!\n implicit none\n integer lokph\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ii,iph,lokcs\n write(*,*)'3B delete unstable compsets for phase: ',&\n trim(phlista(lokph)%name),phlista(lokph)%noofcs\n! the first composition sets cannot be deleted even if unstable\n do ii=phlista(lokph)%noofcs,2,-1\n lokcs=phlista(lokph)%linktocs(ii)\n write(*,100)ii,btest(ceq%phase_varres(lokcs)%status2,CSAUTO),&\n btest(ceq%phase_varres(lokcs)%status2,CSTEMPAR)\n100 format('3A compset: ',i2,' bits: ',2l2)\n enddo\n! call remove_composition_set(iph,.FALSE.)\n write(*,*)'Not implemented yet'\n1000 continue\n return\n end subroutine delete_unstable_compsets\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_parameter\n!\\begin{verbatim}\n subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,&\n lfun,refx)\n! enter a parameter for a phase from database or interactivly\n! enter_parameter_inter(activly) is in gtp3D for some unknown reason ...\n! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl\n! for MQMQA it is parameter type and powers >1000 !!\n! fractyp is fraction type, 1 is site fractions, 2 disordered fractions\n! FRACTYPE no longer supported, has to be determined by sublattices...\n! nsl is number of sublattices\n! endm has one constituent index for each sublattice\n! constituents in endm and lint should be ordered so endm has lowest\n! (done by decode_constarr)\n! nint is number of interacting constituents (can be zero)\n! lint(1,..) is array of sublattice for interactions\n! lint(2,..) is array of constituent indices for interactions\n! ideg is degree\n! lfun is link to function (integer index) if -1 used for listing\n! refx is reference (text) ... maybe use this also for MQMQA excess??\n! if this is a phase with permutations all interactions should be in\n! the first or the first two identical sublattices (except interstitals)\n! a value in endm can be negative to indicate wildcard\n! for ionic liquid constituents must be sorted specially\n implicit none\n integer, dimension(*) :: endm\n character refx*(*)\n integer lokph,fractyp,typty,nsl,nint,ideg,lfun\n integer, dimension(2,*) :: lint\n!\\end{verbatim}\n character notext*20,funexp*1024\n integer iord(maxsubl),jord(2,maxsubl)\n integer again,kkk,ll,kk1,mint,kk,lokint,iz,it,kint,ib,jl,zz,highint,sem\n integer lj,i1,i2,i3,newint,ifri,lokcs,noperm,firstint,listfun,ii,iq,jq\n integer, dimension(24) :: intperm\n integer, dimension(:,:), allocatable :: elinks\n integer, dimension(:,:), allocatable :: intlinks\n type(gtp_endmember), pointer :: newem,endmemrec,lastem\n type(gtp_interaction), pointer :: intrec,lastint,newintrec,donotforget\n type(gtp_interaction), pointer :: linktohigh\n! type(gtp_interaction), allocatable, target :: newintrec\n type(gtp_property), pointer :: proprec,lastprop,savedproplink\n TYPE(gtp_fraction_set) :: disfra\n TYPE(gtp_phase_add), pointer :: addrec\n logical ionliq\n!\n if(gx%bmperr.ne.0) then\n write(*,*)'3B Error ',gx%bmperr,' set calling enter_parameter, cleared!'\n gx%bmperr=0\n endif\n fractyp=1\n! write(*,*)'3B In enter_parameter ',typty,nint,ideg\n if(btest(phlista(lokph)%status1,PHMFS)) then\n! for phases with diordered set the number of sublattices can vary ....\n if(nsl.ne.phlista(lokph)%noofsubl) fractyp=2\n! fractyp=2 has been used to indicate disordered set, that has to be fixed\n! write(*,3)trim(phlista(lokph)%name),typty,nsl,nint,fractyp\n!3 format('Disordered fraction set error for ',a,' value ',4i4/&\n! 'Please correct or report to support')\n! gx%bmperr=4069; goto 1000\n endif\n! write(*,'(a,10i5)')'3B param: ',typty,fractyp,lokph,nsl,nint,lfun\n! listfun used when calling this routine just to list a parameter\n listfun=0\n if(nsl.ne.phlista(lokph)%noofsubl) then\n! check if the phase has a disordered fraction set\n! nothing is associated until the forst parameter added!!!\n! write(*,7)trim(phlista(lokph)%name),nsl,&\n! btest(phlista(lokph)%status1,PHMFS)\n7 format('3B Parameter for ',a,' with ',i2,' sublattices ',&\n 'is part of disordered fraction set: ',l2)\n if(btest(phlista(lokph)%status1,PHMFS)) then\n goto 50\n else\n write(*,8)trim(phlista(lokph)%name),nsl\n8 format('Parameter fo phase ',a,' has wrong number of sublattice ',i2)\n! gx%bmperr=4065; goto 1000\n gx%bmperr=4065; goto 2000\n endif\n endif\n! this is for site fractions\n! write(*,6)'enter_parameter 1: ',lokph,nsl,phlista(lokph)%noofsubl,nint,ideg\n6 format(a,10i5)\n! if(nsl.ne.phlista(lokph)%noofsubl) then\n! parameter may belong to \n! if(associated(phlista(lokph)%disordered)) goto 50\n! write(*,9)trim(phlista(lokph)%name),nsl,&\n! associated(phlista(lokph)%disordered)\n! gx%bmperr=4065; goto 1000\n9 format('Wrong number of sublattices in parameter for ',a,i4,l3)\n! endif\n kkk=0\n jord=0\n sublloop: do ll=1,nsl\n emloop: do kk=1,phlista(lokph)%nooffr(ll)\n kk1=kkk+kk\n! write(*,12)lokph,nsl,ll,endm(ll),kk1,phlista(lokph)%constitlist(kk1)\n!12 format('3B enter_parameter 2A: '4I4,5x,2i5)\n if(endm(ll).eq.phlista(lokph)%constitlist(kk1)) then\n iord(ll)=kk1\n goto 17\n endif\n enddo emloop\n if(endm(ll).eq.-99) then\n! wildcard, sorted at the end\n iord(ll)=-99\n else\n write(*,1211)trim(phlista(lokph)%name),ll\n1211 format('3B error in enter_parameter ',a,i5)\n! gx%bmperr=4096; goto 1000\n gx%bmperr=4096; goto 2000\n endif\n17 continue\n kkk=kkk+phlista(lokph)%nooffr(ll)\n enddo sublloop\n! write(*,13)'3B enter_parameter 2B: ',(iord(ll),ll=1,nsl)\n13 format(a,10i4)\n! if(nint.eq.2) write(*,*)'enter_parameter 2C: ************************ '\n! end member constituents found, check interaction\n! interactions are in sublattice order in lint\n!80 continue\n mint=1\n23 continue\n kkk=0\n if(mint.le.nint) then\n do ll=1,nsl\n if(lint(1,mint).eq.ll) then\n intloop: do kk=1,phlista(lokph)%nooffr(ll)\n kkk=kkk+1\n! write(*,15)mint,lint(2,mint),kkk,phlista(lokph)%constitlist(kkk)\n if(lint(2,mint).eq.phlista(lokph)%constitlist(kkk)) then\n! write(*,*)'enter_parameter jord: ',mint,ll,kkk\n! write(*,*)'3B Int no, subl, const: ',mint,ll,kkk\n jord(1,mint)=ll\n jord(2,mint)=kkk\n mint=mint+1\n! write(*,*)'3B enter_parameter mint1: ',mint,ll,kkk,nint\n if(mint.gt.nint) goto 28\n goto 23\n endif\n enddo intloop\n! a constituent does not exist in sublattice ll\n! write(*,16)ll,mint,lint(1,mint),lint(2,mint)\n! gx%bmperr=4066; goto 1000\n gx%bmperr=4066; goto 2000\n endif\n kkk=kkk+phlista(lokph)%nooffr(ll)\n enddo\n endif\n28 continue\n! write(*,*)'3B enter_parameter mint2: ',mint,nint\n15 format('enter_parameter x: ',4I4)\n16 format('enter_parameter y: ',4I4)\n if(mint.lt.nint) then\n! write(*,*)'3B enter_param error: ',nint,mint,lint(1,mint),lint(2,mint)\n gx%bmperr=4067; goto 1000\n endif\n! write(*,33)'3B epar 1: ',nint,((lint(iq,jq),iq=1,2),jq=1,nint)\n33 format(a,i3,' : ',3(2i4,3x))\n goto 90\n!----------------\n! code below is for disordered fraction types, use fractset record\n! one could try to handle both fraction types in the same code but\n! that would just make it very very messy\n50 continue\n if(.not.btest(phlista(lokph)%status1,PHMFS)) then\n! there are no disordered fraction sets for this phase\n! gx%bmperr=4068; goto 1000\n gx%bmperr=4068; goto 2000\n endif\n! write(*,*)'3B adding disordered parameter to ',trim(phlista(lokph)%name)\n lokcs=phlista(lokph)%linktocs(1)\n disfra=firsteq%phase_varres(lokcs)%disfra\n! number of sublattices in the disordered set\n! write(*,*)'3B disordered ',nsl,disfra%ndd\n if(nsl.ne.disfra%ndd) then\n! gx%bmperr=4069; goto 1000\n gx%bmperr=4069; goto 2000\n endif\n kkk=0\n! write(*,*)'3B: disordered parameter: ',nsl\n do ll=1,nsl\n do kk=1,disfra%nooffr(ll)\n kk1=kkk+kk\n! write(*,12)ll,endm(ll),kk1,disfra%splink(kk1)\n if(endm(ll).eq.disfra%splink(kk1)) then\n iord(ll)=kk1\n goto 67\n endif\n enddo\n if(endm(ll).eq.-99) then\n! wildcard\n iord(ll)=-99\n else\n! write(*,*)'3B in enter_parameter'\n! gx%bmperr=4051; goto 1000\n gx%bmperr=4051; goto 2000\n endif\n67 continue\n kkk=kkk+disfra%nooffr(ll)\n enddo\n! check interaction constituents\n mint=1\n73 continue\n kkk=0\n if(mint.le.nint) then\n do ll=1,nsl\n if(lint(1,mint).eq.ll) then\n do kk=1,disfra%nooffr(ll)\n kkk=kkk+1\n if(lint(2,mint).eq.disfra%splink(kkk)) then\n jord(1,mint)=ll\n jord(2,mint)=kkk\n! write(*,75)mint,lint(1,mint),lint(2,mint),kkk,ll,jord(1,mint),jord(2,mint)\n75 format('ep 75: ',8i4)\n mint=mint+1\n if(mint.gt.nint) goto 78\n goto 73\n endif\n enddo\n! a constituent does not exist in sublattice ll\n! gx%bmperr=4066; goto 1000\n gx%bmperr=4066; goto 2000\n endif\n kkk=kkk+disfra%nooffr(ll)\n enddo\n endif\n78 continue\n if(mint.lt.nint) then\n! gx%bmperr=4067; goto 1000\n gx%bmperr=4067; goto 2000\n endif\n!---------------------------------------------------\n! we have found all constituents for the end member and interactions\n! now look if there are parameter records, otherwise create them\n! try to keep end member records in some order of constituents ...\n90 continue\n! if(fractyp.eq.2) then\n! looking for bug entering 4 sublattice interaction parammeters ...\n! write(*,116)'3B: endm & int: ',(iord(ii),ii=1,nsl),&\n! (jord(1,ii),jord(2,ii),ii=1,nint)\n116 format(a,4i3,' : ',2i3,2x,2i3)\n! endif\n nullify(lastem)\n!---------------------------------------------\n! check that interactions are in sublattice and alphabetical order!!\n again=0\n intcheck: do lokint=2,nint\n if(jord(1,lokint).lt.jord(1,lokint-1)) then\n corrsubl: do iz=1,2\n it=jord(iz,lokint)\n jord(iz,lokint)=jord(iz,lokint-1)\n jord(iz,lokint-1)=it\n enddo corrsubl\n again=1\n elseif(jord(1,lokint).eq.jord(1,lokint-1)) then\n if(jord(2,lokint).lt.jord(2,lokint-1)) then\n it=jord(2,lokint)\n jord(2,lokint)=jord(2,lokint-1)\n jord(2,lokint-1)=it\n! write(*,*)'3B interactions: ',jord(2,lokint),jord(2,lokint-1)\n again=1\n elseif(jord(2,lokint).eq.jord(2,lokint-1)) then\n! write(*,656)'3B Illegal with same interaction constituent twice',&\n! phlista(lokph)%name\n656 format(a/' phase: ',a)\n! gx%bmperr=4266; goto 1000\n gx%bmperr=4266; goto 2000\n endif\n endif\n enddo intcheck\n! write(*,*)'3B Again: ',again\n if(again.eq.1) goto 90\n!---------------------------------------------\n! Make sure the endmember has the alphabetically lowest constituent\n! and that the interaction is not the same as the endmember\n! write(*,92)'3B endmembers 1: ',(iord(iq),iq=1,nsl)\n92 format(a,10i4)\n! write(*,93)'3B interaction 1: ',(jord(1,iq),jord(2,iq),iq=1,nint)\n93 format(a,5(i6,i4))\n placeibloop: do kint=1,nint\n! ll is the sublattice with interaction\n ll=jord(1,kint)\n placeib: if(jord(2,kint).eq.iord(ll)) then\n! write(*,*)'pmod3B: Illegal with interaction with same constituent'\n! subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,&\n! lfun,refx)\n! write(*,97)lokph,typty,fractyp,nsl,(endm(zz),zz=1,nsl),&\n! ideg,nint,(lint(1,zz),lint(2,zz),zz=1,nint)\n97 format('pmod3B: Illegal with interaction with same constituent:'/&\n 3i3,i4,2x,15(i5))\n! gx%bmperr=4266; goto 1000\n gx%bmperr=4266; goto 2000\n elseif(jord(2,kint).lt.iord(ll)) then\n! constituent in iord higher than that in jord, exchange jord and iord. \n ib=iord(ll)\n iord(ll)=jord(2,kint)\n if(kint.eq.nint) then\n! there are no more interactions, just put ib in the place of jord(2,kint)\n jord(2,kint)=ib\n else\n! a bit problematic, we may have to shift constituents in jord\n moreint: do mint=kint+1,nint\n if(jord(1,mint).gt.ll) then\n! next interaction in another sublattice, put ib in jord(2,mint-1)\n jord(2,mint-1)=ib\n else\n shiftint: if(ib.lt.jord(2,mint)) then\n! next interaction is higher, put ib in jord(2,mint-1)\n jord(2,mint-1)=ib\n else\n! interacting constituent is lower, we must shift constituents down in jord\n! It can be done one at a time?? Example: user enter:\n! L(fcc,D,E,C,A,B): iord(1)='D', jord(2,*)='A', 'B', 'C', 'E' (ordered above)\n! kint=1 replaces iord(1)='A'; look for the place for 'D'; ninit=4\n! loop mint=2 but 'D' is higher than 'B' so shift jord one step making\n! jord(2,*)='B', 'C', 'C', 'E'; \n! loop mint=3 but D is higher than 'C' so shift jord(2,*)='B', 'C', 'E', 'E'; \n! Now 'D' is lesser than 'E' so place it in jord(2,3):\n! jord(2,*)='B', 'C', 'D', 'E'; \n jord(2,mint-1)=jord(2,mint)\n if(mint.lt.nint .and. jord(1,mint+1).eq.ll) then\n jord(2,mint)=jord(2,mint+1)\n else\n jord(2,mint)=ib\n endif\n endif shiftint\n endif\n enddo moreint\n endif\n endif placeib\n enddo placeibloop\n! write(*,92)'3B endmembers 2: ',(iord(iq),iq=1,nsl)\n! write(*,93)'3B interaction 2: ',(jord(1,iq),jord(2,iq),iq=1,nint)\n!---------------------------------------------\n! there may be permutations for ordered phases ... implemented for fcc only\n! probably also for BCC ...\n intperm=0\n ftyp1: if(fractyp.eq.1) then\n if(btest(phlista(lokph)%status1,PHFORD)) then\n! These permutations may require 2 interaction records created ...\n call fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,&\n intperm,intlinks)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! make sure iord is alphabtically ordered to find the correct parameter\n! iord(*) and elinks(*,1) are constituent indices, not species indices\n do jl=1,nsl\n iord(jl)=elinks(jl,1)\n enddo\n elseif(btest(phlista(lokph)%status1,PHBORD)) then\n call bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,&\n intperm,intlinks)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! make sure iord is alphabtically ordered to find the correct parameter\n! iord(*) and elinks(*,1) are constituent indices, not species indices\n! write(*,76)'3B iord ',(iord(jl),jl=1,nsl)\n! write(*,76)'3B elinks ',(elinks(jl,1),jl=1,nsl)\n76 format(a,9i4)\n do jl=1,nsl\n iord(jl)=elinks(jl,1)\n enddo\n else\n noperm=1\n endif\n else\n! fraction type 2 has no permutations\n noperm=1\n endif ftyp1\n! parameters for site fractions\n if(fractyp.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n endmemrec=>phlista(lokph)%disordered\n endif\n! write(*,91)'3B enter_param 90: ',fractyp,nsl,(iord(ii),ii=1,nsl)\n91 format(a,i2,i3,10i4)\n!---------------------------------------------\n! find endmember record, maybe create\n ionliq=btest(phlista(lokph)%status1,PHIONLIQ)\n findem: do while(associated(endmemrec))\n if(.NOT.ionliq) then\n lika:do lj=1,nsl\n! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end\n i1=iord(lj)\n if(.not.allocated(endmemrec%fraclinks)) then\n write(*,*)'3B Phase data structure error'\n! gx%bmperr=4399; goto 1000\n gx%bmperr=4399; goto 2000\n endif\n i2=endmemrec%fraclinks(lj,1)\n if(i1.gt.0) then\n if(i2.lt.0 .or. i1.lt.i2) then\n! The new end member record should be inserted before this record\n goto 100\n elseif(i1.gt.i2) then\n! continue searching for the end member or place to create it\n lastem=>endmemrec\n endmemrec=>endmemrec%nextem\n cycle findem\n endif\n! here i1<0\n elseif(i2.gt.0) then\n! continue searching for the end member or place to create it\n lastem=>endmemrec\n endmemrec=>endmemrec%nextem\n cycle findem\n endif\n! It is the same \"wildcard\" value if both i1 and i2 are negative\n enddo lika\n else\n! for ionic liquids insert endmembers in order of second sublattice ...\n! This is important as we want to calculate all parameters with anions\n! before we come to vacancy and neutrals which should be multiplied with Q\n illika:do lj=nsl,1,-1\n! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end\n i1=iord(lj)\n i2=endmemrec%fraclinks(lj,1)\n if(i1.gt.0) then\n if(i2.lt.0 .or. i1.lt.i2) then\n! The new end member record should be inserted before this record\n goto 100\n elseif(i1.gt.i2) then\n! continue searching for the end member or place to create it\n lastem=>endmemrec\n endmemrec=>endmemrec%nextem\n cycle findem\n endif\n! here i1<0\n elseif(i2.gt.0) then\n! continue searching for the end member or place to create it\n lastem=>endmemrec\n endmemrec=>endmemrec%nextem\n cycle findem\n endif\n! It is the same \"wildcard\" value if both i1 and i2 are negative\n enddo illika\n endif\n!-------------------------------------------------\n! found end member record with same constituents\n goto 200\n enddo findem\n!\n! if lfun=-1 we want to list the function and not create anything\n if(lfun.lt.0) goto 900\n!\n!---------------------------------------------\n! create endmember record\n100 continue\n! we have not found any endmember record so we have to insert a record here\n! lokem may be nonzero if we exited from findem loop to this label\n! this subroutine is in gtp3G (why?)\n! elinks is allocated in bccpermut or fccpermut. If no permutation it is not\n! allocated which may cause segentation faults\n if(noperm.gt.1) then\n if(.not.allocated(elinks)) then\n write(*,*)'3B permutations but no elinks!'\n! gx%bmperr=4399; goto 1000\n gx%bmperr=4399; goto 2000\n endif\n elseif(.not.allocated(elinks)) then\n! allocate a dummy elinks to avoid segmentation fault compiling with -lefence\n allocate(elinks(1,1))\n endif\n! Special for MQMQA, we must store index in mqmqa_data%contyp for the\n! endmember !! use %antalem, it is not used anywhere else\n! if(btest(phlista(lokph)%status1,PHMQMQA)) then\n! write(*,*)'3B creating endmember for MQMQA'\n! do i1=1,mqmqa_data%nconst\n! write(*,599)i1,(mqmqa_data%contyp(i2,i1),i2=1,14)\n!599 format('3X contyp: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3)\n! enddo\n! write(*,*)'3B MQMQA index: ',iord(1)\n! endif\n! this subroutine is in gtp3G.F90\n call create_endmember(lokph,newem,noperm,nsl,iord,elinks)\n! write(*,*)'3B created endmember, value of nsl: ',nsl,elinks(1)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n if(btest(phlista(lokph)%status1,PHMQMQA)) then\n newem%antalem=iord(1)\n! write(*,*)'3B enter_par: created MQMQA endmember ',lokph,newem%antalem\n endif\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! insert link to new from last end member record, lastem.\n if(.not.associated(lastem)) then\n if(fractyp.eq.1) then\n phlista(lokph)%ordered=>newem\n else\n phlista(lokph)%disordered=>newem\n endif\n else\n! emlista(lastem)%next=new\n lastem%nextem=>newem\n endif\n! insert link from new to next (if lokem=0 this record is the last)\n newem%nextem=>endmemrec\n endmemrec=>newem\n!---------------------------------------------------\n! Here we have found or created the endmember record\n! look for or create interaction record, NO WILDCARDS IN INTERACTIONS\n! Interacting elements should be in sublattice and alphabetical order!!\n200 continue\n! write(*,*)'3B enter_parameter mint3: ',mint,nint\n nullify(linktohigh)\n lokint=0\n!\n! this indicates an MQMQA excess parameter\n! if(ideg.ge.1000) write(*,201)lokph,endmemrec%fraclinks(1,1),lfun\n201 format(/'3B line 3187 adding MQMQA excess from: ',3i5)\n!\n mqmq: if(btest(phlista(lokph)%status1,PHMQMQX)) then\n! mark the phase is not ideal\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID)\n if(nint.eq.0) exit mqmq\n!\n! only for excess parameters\n! write(*,*)'3B Enter MQMQA excess special routine',associated(endmemrec)\n! MQMQX has a very special way of handling interactions do not mess with OC\n call enter_mqmqa_excess_param(lokph,endmemrec,typty,nint,jord,&\n ideg,lfun,refx)\n! ignore the rest if this subroutine, \n if(mqmqtdb) write(*,*)'3B Back from mqmqa_excess ',&\n associated(endmemrec%intpointer)\n goto 2000\n endif mqmq\n!\n! below is the excess for normal phases\n!=============================================================\n! most MQMQA specific below should be removed or commented away\n!\n someint: if(nint.gt.0) then\n! when there are interaction records the ideal bit must be cleared\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID)\n! to locate interaction record,\n nullify(lastint)\n mint=1\n intrec=>endmemrec%intpointer\n! some excess parameters in wrong order for MQMQA, what is lint?\n! write(*,202)lokph,nsl,typty,ideg,nint,(lint(2,i3),i3=1,nint)\n! fraclinks is fraction index of constituent of MQMQA endmember OUI!!!\n sem=endmemrec%fraclinks(1,1)\n! write(*,202)lokph,nsl,typty,ideg,nint,sem,(jord(2,i3),i3=1,nint)\n202 format(/'3B excess parameters:',5i4,', endmem:',i3,' jord: ',10i4)\n if(.not.associated(intrec)) then\n! no interaction record for this endmember, create one unless lfun=-1\n! It seems this record is created but never used so it remains empty\n! create_interaction routine is in gtp3G.F90\n if(lfun.eq.-1) goto 900\n if(intperm(1).gt.0) then\n if(.not.allocated(intlinks)) then\n write(*,*)'3B permutations but no intlinks!'\n! gx%bmperr=4399; goto 1000\n gx%bmperr=4399; goto 2000\n endif\n elseif(.not.allocated(intlinks)) then\n! allocate a dummy intlinks to avoid segmentation fault compiling with -lefence\n allocate(intlinks(1,1))\n endif\n! this subroutine is in gtp3G.F90\n! write(*,*)'3B calling create_interaction 1'\n call create_interaction(newintrec,mint,jord,intperm,intlinks)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! clear phpalm as it is needed to handle FCC and BCC permutations\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHPALM)\n endmemrec%intpointer=>newintrec\n intrec=>newintrec\n lastint=>intrec\n newint=1\n else\n! problem with MQMQA excess, ordering of ternary parameter not working\n! If new excess constituent lower than current this must replace\n! current\n! write(*,298)intrec%status,intrec%fraclink(1),sem,(jord(2,i3),i3=1,nint)\n298 format('3B **** existing interaction: ',i3,5x,10i3)\n newint=0\n firstint=0\n endif\n300 continue\n! write(*,303)'3B at 300A: ',lokph,newint,nint,mint,intrec%status,gx%bmperr\n303 format(a,10i3)\n!\n! interaction records should be ordered according to the sublattice\n! with the interaction. For interaction with permutations use the \n! sublattice of the first permutation\n! WE MUST store interactions in sublattice order and in constituent order\n! highint eventually not used ...\n highint=0\n nullify(linktohigh)\n findint: do while(mint.le.nint)\n! write(*,307)'3B At findint: ',mint,nint,newint,highint,&\n! intrec%sublattice(1),intrec%fraclink(1),jord(1,mint),jord(2,mint)\n307 format(a,4i4,2x,2i3,2x,2i3)\n if(intrec%sublattice(1).eq.jord(1,mint) .and. &\n intrec%fraclink(1).eq.jord(2,mint)) then\n! write(*,*)'3B interaction levels: ',mint,nint\n! found an interaction with same constituent (maybe just created)\n! if(mint.eq.nint) then\n! This was modified 251128 for MQMQA parameters. First change nint.ge.nint \n! created problems for ternary parameters with different degrees\n! if(mint.ge.nint) then\n if(nint.eq.mint) then\n! write(*,*)'3B same or higher interaction, level: ',nint,mint\n nullify(linktohigh)\n goto 400\n elseif(nint.gt.mint) then\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n! special for the crazy excess parameters in MQMQA\n! write(*,*)'3B for MQMQA ceazy excess? '\n! The MQMQA parameters does not use the degree for identical constitutions\n goto 310\n endif\n! for ternary composition dependent excess parameters just continue ...\n! write(*,*)'3B what to do when nint>mint? ',mint,nint\n endif\n lastint=>intrec\n linktohigh=>intrec\n intrec=>intrec%highlink\n! write(*,*)'3B linktohigh: ',linktohigh%sublattice(1),&\n! linktohigh%fraclink(1)\n! BUG!! This creates problem entering L(liquid,c,cr,v;0/1/2)\n! highint=1\n! BUG !! but it is necessary to create 24 SRO parameter for 4 sublattice FCC\n mint=mint+1\n newint=1\n if(.not.associated(intrec)) then\n! write(*,*)'3B exit findint here'\n exit findint\n endif\n else\n! nint is parameter interaction level, mint is ?\n! Problems here when entering 24 reciprocal parameter for SRO in FCC\n if(mint.eq.nint) then\n! error when storing permutations because newint=0 below. Moved it to the end\n! but that gave error L(liq,C,Cr,V) was stored as L(Liq,C,Cr,Fe,V)\n! Add a check on mint, if mint=nint one cannot store it as higher\n newint=0\n endif\n! we must store interactions in sublattice order and in order of constituent\n! in jord(2,mint) otherwise we will never be able to find a permutation. \n if(intrec%sublattice(1).gt.jord(1,mint)) then\n write(*,*)'3B insering interaction before existing',&\n associated(linktohigh)\n exit findint\n endif\n nullify(linktohigh)\n lastint=>intrec\n intrec=>intrec%nextlink\n! write(*,*)'3B exit? ',associated(intrec),associated(linktohigh)\n if(.not.associated(intrec)) exit findint\n firstint=1\n! more records on this interaction level ?\n! this worked for permutations but gave other errors, see above\n! newint=0\n endif\n enddo findint\n! we can be here either because mint>nint or no more interaction records\n! we must create at least one interactionrecord, newint=0 if same level\n! If intrec is associated the nextint link should be set to this\n310 continue\n! write(*,*)'3B At 310',mint,nint,newint,highint,associated(intrec)\n if(mint.le.nint) then\n! if lfun=-1 and parameter does not exist just skip away\n if(lfun.eq.-1) goto 900\n! write(*,303)'3B create at 310:',mint,nint,newint,firstint,highint,&\n! jord(1,mint),jord(2,mint)\n if(intperm(1).gt.0) then\n if(.not.allocated(intlinks)) then\n write(*,*)'3B permutations but no intlinks!'\n! gx%bmperr=4399; goto 1000\n gx%bmperr=4399; goto 2000\n endif\n elseif(.not.allocated(intlinks)) then\n! allocate a dummy intlinks to avoid segmentation fault compiling with -lefence\n allocate(intlinks(1,1))\n endif\n! write(*,*)'3B calling create_interaction in gtp3G'\n call create_interaction(newintrec,mint,jord,intperm,intlinks)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! write(*,312)intperm(1),mint,jord(2,mint)\n312 format('3B created expty interaction for',3i3) \n! clear PHPALM as calling palmtree is needed to handle FCC and BCC permutations\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHPALM)\n if(newint.eq.1) then\n! write(*,*)'3B Linking as higher',mint,highint,associated(linktohigh)\n! We may have a high link already! Set it as nextlink!\n! write(*,*)'3B Using lastint'\n donotforget=>lastint%highlink\n lastint%highlink=>newintrec\n newintrec%nextlink=>donotforget\n elseif(associated(linktohigh)) then\n! write(*,*)'3B Using linktohigh'\n! write(*,*)'3B low: ',linktohigh%sublattice(1),linktohigh%fraclink(1)\n! write(*,*)'3B low: ',newintrec%sublattice(1),newintrec%fraclink(1)\n donotforget=>linktohigh%highlink\n! write(*,*)'3B low: ',donotforget%sublattice(1),&\n! donotforget%fraclink(1)\n linktohigh%highlink=>newintrec\n newintrec%nextlink=>donotforget\n nullify(linktohigh)\n elseif(associated(intrec)) then\n! write(*,*)'3B Linking as previous',mint,highint\n newintrec%nextlink=>intrec\n! write(*,*)'3B Ho ho said the sixth'\n if(associated(lastint)) then\n lastint%nextlink=>newintrec\n else\n! this should be linked from the endmember or lower order interaction\n! write(*,*)'3B No previous interaction on this level'\n endmemrec%intpointer=>newintrec\n endif\n! write(*,*)'3B Ha ha said the seventh'\n else\n! write(*,*)'3B Linking as next',mint\n lastint%nextlink=>newintrec\n endif\n! redundant as newint set to 1 below ...\n! newint=0\n intrec=>newintrec\n lastint=>intrec\n mint=mint+1\n! there may be more interaction records .... but they must all be created\n! write(*,*)'gtp3B maybe create more records ...',associated(linktohigh)\n newint=1\n goto 310\n endif\n! Now we should have found or created the interaction record,\n! We may have found the record it should be linked from if nint>mint\n! check property list\n400 continue\n! if(nint.gt.mint) then\n! this has higher interaction than current, take %next link.\n! write(*,403)sem,(jord(2,ii),ii=1,nont)\n!403 format('3B looking place of excess:',6i3)\n! intrec=>intrec%nextlink\n! endif\n proprec=>intrec%propointer\n if(.not.associated(proprec)) then\n! do not create anything if lfun=-1\n if(lfun.eq.-1) goto 900 \n if(ideg.gt.9) then\n typty=ideg; ideg=0\n! write(*,*)'3B create excess proprec for MQMQA 1: ',typty,ideg,lfun\n endif\n! write(*,*)'3B create_proprec 1:',typty,ideg,lfun\n! create_proprec is in gtp3G.F90\n call create_proprec(intrec%propointer,typty,ideg,lfun,refx)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! if this is an MQMQA parameter some information in intrec%propinter%asymdata\n! must be added here. typty is 34, 35 or 36\n if(typty.ge.34 .and. typty.le.36) then\n! sem is fraclink of endmember constiuent\n call create_mqmqa_excessprop(intrec%propointer%asymdata,&\n sem,nint,jord)\n endif\n else\n! write(*,*)'3B create additional proprecord for same constituents!'\n goto 800\n endif\n! write(*,*)'3B enter_parameter 17: ',lokint,lokem,link\n else\n! Found endmember and there is no interaction\n! search the property list, there may not be the correct property!\n proprec=>endmemrec%propointer\n if(.not.associated(proprec)) then\n! if no property record and lfun=-1 just list parameter equal to zero\n! in MQMQA some endmembers have no Gibbs energy of formation!!!\n if(lfun.lt.0) goto 900\n if(ideg.gt.9) then\n typty=ideg; ideg=0\n! write(*,*)'3B create excess proprec for MQMQA 2: ',typty,ideg,lfun\n endif\n! write(*,*)'3B create_proprec 2: ',typty,ideg,lfun\n call create_proprec(endmemrec%propointer,typty,ideg,lfun,refx)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n else\n goto 800\n endif\n endif someint\n! all not done !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n goto 1000\n!--------------------------------------------------------\n! we found correct parameter record WITH A PROPERTY, now search property list\n! This loop both for endmembers and interactions\n800 continue\n do while(associated(proprec))\n lastprop=>proprec\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n if(proprec%proptype.eq.typty) then\n write(*,803)proprec%proptype,typty\n803 format('3B adding one more property',2i5)\n endif\n elseif(proprec%proptype.eq.typty) then\n! With MQMQA one cannot change the expression of a property\n! found property record, one should delete old and insert new function\n! one must alse change the reference !!! And add the reference if new.\n! mode=0 means no change of reference text if reference already exists\n call capson(refx)\n notext='*** Not set by user'\n call tdbrefs(refx,notext,0,ifri)\n! write(*,*)'3B value of ideg: ',ideg,proprec%degree\n if(ideg.le.proprec%degree) then\n if(lfun.eq.-1) then\n listfun=proprec%degreelink(ideg)\n else\n proprec%degreelink(ideg)=lfun\n proprec%reference=refx\n endif\n elseif(lfun.ge.0) then\n call extend_proprec(proprec,ideg,lfun)\n proprec%reference=refx\n endif\n if(lfun.eq.-1) goto 900\n goto 1000\n endif\n proprec=>proprec%nextpr\n enddo\n! if lfun=-1 we just want to list a the parameter which is zero\n if(lfun.lt.0) goto 900\n! no record for this property at present, add a new property record\n if(ideg.gt.9) then\n! this is probably an MQMQA parameter\n typty=ideg; ideg=0\n! write(*,*)'3B create excess proprec for MQMQA 3: ',typty,ideg,lfun\n endif\n!\n! ----------------------------------------------------------------------\n!\n! write(*,*)'3B create_proprec 3:',typty,ideg,lfun\n! lastprop%nextpr will be allocated insde create_proprec\n savedproplink=>lastprop\n call create_proprec(lastprop%nextpr,typty,ideg,lfun,refx)\n! if(gx%bmperr.ne.0) goto 1000\n if(gx%bmperr.ne.0) goto 2000\n! In create_proprec the lastprop%nextpr has been allocated\n!\n! lastprop=>proprec\n!\n! if(associated(savedproplink,lastprop)) then\n! write(*,*)'3B complicated'\n! else\n! write(*,*)'3B new record created'\n! endif\n! intrec%propointer=>savedproplink%nextpr\n! if(.not.associated(intrec%propointer)) then\n! write(*,*)'3B fundamental illusion lost'\n! stop 100\n! endif\n! ----------------------------------------------------------------------\n!\n! Special for a second MQMQA parameter with same constituents ....\n! must be added here. typty is 34, 35 or 36\n if(typty.ge.34 .and. typty.le.36) then\n! sem is fraclink of endmember constiuent\n call create_mqmqa_excessprop(intrec%propointer%asymdata,&\n sem,nint,jord)\n if(gx%bmperr.ne.0) then\n write(*,*)'3B error creating a next MQMQA excess parameter'\n goto 2000\n endif\n endif\n! all done and go home ........ not quite ..........\n goto 1000\n!--------------------------------------------------------\n! this is for listing parameter\n900 continue\n write(*,*)'3B list parameter ',lfun,listfun\n if(listfun.gt.0) then\n call list_tpfun(listfun,0,funexp)\n! for the moment use the TPFUN symbol ...\n call wrice2(kou,0,12,78,1,funexp)\n else\n write(kou,*)'Parameter is zero'\n endif\n!----------------------------------------------------------\n1000 continue\n lastcheck: if(gx%bmperr.eq.0) then\n! mark that the phase has at least one parameter\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHHASP)\n! if typty not equal 1 check there is an appropriate addition\n! skip also typty<=0 .... although that should have created an error ...\n if(typty.le.1) exit lastcheck\n! write(*,*)'3B found parameter id: ',typty\n if(typty.gt.100) then\n! typty>100 means property for a component, remove lower two digits\n i1=typty/100; zz=i1*100\n else\n zz=typty\n endif\n! write(*,*)'3B searching addition for parameter type: ',zz,typty\n addrec=>phlista(lokph)%additions\n addloop: do while(associated(addrec))\n checkprop: if(allocated(addrec%need_property)) then\n do i1=1,size(addrec%need_property)\n if(addrec%need_property(i1).eq.zz) then\n! set the bit that this addition has at least one parameter \n! write(*,*)'3B Found addition: ',trim(additioname(addrec%type))\n addrec%status=ibset(addrec%status,ADDHAVEPAR)\n goto 1005\n endif\n enddo\n endif checkprop\n addrec=>addrec%nextadd\n enddo addloop\n! propid is an array initiated in gtp3A.F90, zz>100 means component unique\n! VERY SPECIAL typty=26ij, zz=26 means UNIQUAC parameter, has no addition!!\n if(zz.gt.100 .and. i1.eq.26) then\n if(propid(i1)%symbol.ne.'UQT ') then\n write(*,*)'3B *** WARNING model parameter identifers confused!'\n stop\n endif\n endif\n! we found no addition for this parameter!!\n if(zz.gt.100) zz=zz/100\n!\n mpiwarning: if(zz.ne.26) then\n! give warning first time only!\n do i2=1,nundefmpi\n if(propid(zz)%symbol.eq.undefmpi(i2)) exit mpiwarning\n enddo\n! these are MQMQA excess parameters\n if(zz.ge.34 .and. zz.le.36) goto 1005\n if(nundefmpi.lt.mundefmpi) then\n nundefmpi=nundefmpi+1\n undefmpi(nundefmpi)=propid(zz)%symbol\n else\n write(*,*)'3B too many model parameter identifier errors',mundefmpi\n endif\n!\n write(*,1002)propid(zz)%symbol,trim(phlista(lokph)%name)\n1002 format('3B *** Warning parameter ',a,&\n ' has no addition in ',a,' (or other phases)')\n endif mpiwarning\n1005 continue\n endif lastcheck\n if(allocated(intlinks)) deallocate(intlinks)\n if(allocated(elinks)) deallocate(elinks)\n! write(*,*)'3B enter_parameter deallocated: ',gx%bmperr\n! write(*,1010)'enter_parameter 77: ',(phlista(lokph)%constitlist(i),i=1,6)\n!1010 format(A,6I3)\n2000 continue\n! if(associated(endmemrec%intpointer)) then\n! write(*,*)'3B line 3625 Leaving enter_parameter with an excess link',&\n! endmemrec%intpointer%antalint\n! crash here means the interaction record is there but its property is gone\n! write(*,*)'3B line 3625 Value of typty ',&\n! (endmemrec%intpointer%propointer%extra\n! write(*,*)'without properties',associated(endmemrec%intpointer%propointer)\n! endif\n if(gx%bmperr.ne.0) then\n write(*,*)'3B Leaving enter_parameter with error ',gx%bmperr\n endif\n return\n end subroutine enter_parameter\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_mqmqa_excess_param\n!\\begin{verbatim}\n subroutine enter_mqmqa_excess_param(lokph,endmemrec,typty,nint,jord,&\n ideg,lfun,refx)\n! enter an mqmqa excess property linked from an endmember\n implicit none\n type(gtp_endmember), pointer :: endmemrec,extraem\n integer :: lokph, typty, nint, jord(2,*),lfun,ideg\n character refx*(*)\n! nint is number of interaction constituents, lfun is function link\n!\\end{verbatim} %+\n! to avoid messing aruond with the OC normal excess\n integer, dimension(24) :: intperm\n integer, dimension(:,:), allocatable :: elinks\n integer, dimension(:,:), allocatable :: intlinks\n type(gtp_interaction), pointer :: intrec,lastint,newintrec,linktohigh\n type(gtp_interaction), pointer :: temp\n type(gtp_property), pointer :: proprec,lastprop,savedproplink\n integer ii,ij,mint,sem,level,first,parquad(5)\n! The mqmqa excess has no degree and minimum 3 constituents in addition\n! to the enemember. Two or 3 of these are A/X type and one AB/X type\n! there can be several property records to a single excess record\n!\n! jord(1,...) are sublattices, MQMQA has only one sublattice\n! jord(2,...) are constituents nint is number of interactions\n!\n mint=0\n sem=endmemrec%fraclinks(1,1)\n intrec=>endmemrec%intpointer\n if(mqmqtdb) then\n if(associated(intrec)) then\n write(*,10)mint,nint,lfun,intrec%fraclink(1),sem,(jord(2,ii),ii=1,nint)\n else\n write(*,10)mint,nint,lfun,1000,sem,(jord(2,ii),ii=1,nint)\n endif\n10 format(/'3B At ENDMEMBER: ',2i3,i5,5x,i2,5x,i2,2x,6i3)\n endif\n! \n! intperm, elinks and intlinks not needed here, used for FCC/BCC permutations\n intperm(1)=0\n allocate(intlinks(1,1))\n! note: endmemrec%intpointer must be nullified when endmember is created\n!\n! --------------------------------------------------------------------\n!\n level=-1\n! level -1 means intrec record linked from endmember and\n! intrec%nextlin from current endmember%intpointer\n! 0 means intrec record is on lower level set %nextlink\n! 1 means intrec record is on same level set %highlink\n nullify(lastint)\n! level1 is the first level below endmembers\n! newintrec is allocated and mint index and jord fractions\n! nint is the number of interactions that must be found or created\n mint=1\n100 continue\n findint: if(.not.associated(intrec)) then\n! there is no record, create one ======================================\n! This can be the first interaction for this endmember or it can be\n! added at the end or in the middle of the intrec tree or\n! at a level above the previous record\n! It must be linked from a previous record or the endmember \n! if(associated(lastint)) then\n! write(*,150)1,level,mint,nint,lfun,jord(2,mint),&\n! lastint%fraclink(1),associated(lastint%nextlink),&\n! associated(lastint%highlink)\n!150 format('3B creating intrec at ',i1,':',4i3,5x,i5,', lastint:',i3,2l2)\n! else\n! write(*,150)1,level,mint,nint,lfun,jord(2,mint)\n! endif\n call create_interaction(newintrec,mint,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,155)level,mint,nint,jord(2,mint)\n!155 format('3B created interaction ',3i3,', for constituent: ',i3)\n! set the links to this new interaction record \n tohere: if(level.eq.-1) then\n! if level=-1 this is the first interaction or replaces the previous first\n! if(associated(endmemrec%intpointer)) then\n! write(*,*)'3B are we here 44?'\n! write(*,156)endmemrec%intpointer%fraclink(1)\n!156 format('3B Inserting at endmember before interaction to ',i3)\n! else\n! write(*,157)endmemrec%fraclinks(1,1)\n!157 format('3B First interaction at endmember',i3)\n! endif\n! write(*,*)'3B are we here 17?'\n! write(*,*)'3B bug? ',associated(newintrec)\n newintrec%nextlink=>endmemrec%intpointer\n endmemrec%intpointer=>newintrec\n level=0\n! write(*,*)'3B endmember interaction set to',jord(2,mint)\n elseif(level.eq.0) then\n! we have added a record on a higher level than previous record\n! if level=0 the previous record on lower level. set lastint%highlink\n if(associated(lastint%highlink)) then\n write(*,*)'3B highlink already set 2',intrec%fraclink(1)\n stop\n endif\n! write(*,158)lastint%fraclink(1)\n!158 format('3B Above an interaction to ',i3)\n lastint%highlink=>newintrec\n else\n! if level=1 we have already found records on this level, set lastint%nextlink\n! evidently that link was empty otherwise we had found a record\n! write(*,158)lastint%fraclink(1)\n!159 format('3B After interaction on same level as ',i3)\n lastint%nextlink=>newintrec\n endif tohere\n! we have a new record which is linked to previous records\n! maybe add some data or continue searching up or on same level\n intrec=>newintrec\n lastint=>intrec\n! write(*,*)'3B do we need more interaction records?',mint,nint\n data1: if(mint.lt.nint) then\n! mint < nint, we need higher order intrec -----------------------------------\n! there are more constituents for this parameter, create higher level\n mint=mint+1\n! the link back will be to a lower level\n level=0\n! the highlink should already be nullified and record will be created above\n nullify(intrec%highlink)\n intrec=>intrec%highlink\n goto 100\n elseif(mint.eq.nint) then\n! If mint=nint this is the last, add property data --------------------------\n! we must save data, there can not be any previous property record\n typty=ideg; ideg=0\n proprec=>intrec%propointer\n if(associated(proprec)) then\n do while(associated(proprec%nextpr))\n! there can be several property records\n proprec=>proprec%nextpr\n enddo\n! this routine is in gtp3G.F90\n! write(*,120)typty,lfun,associated(intrec)\n!120 format('3B creating property record 1A',2i5,l2)\n call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx)\n else\n! write(*,121)typty,lfun,associated(intrec)\n!121 format('3B creating property record 1B:',2i5,l2)\n call create_mqmqa_proprec(intrec%propointer,typty,ideg,lfun,refx)\n endif\n if(gx%bmperr.ne.0) then\n write(*,*)'3B error creating property',gx%bmperr\n goto 1000\n endif\n! write(*,*)'3B Back from create propery record',associated(proprec)\n proprec=>intrec%propointer\n do while(associated(proprec%nextpr))\n! there can be several property records\n proprec=>proprec%nextpr\n enddo\n! write(*,*)'3B associated? ',associated(proprec)\n! For a MQMQA excess parameter we need to store the index of the AB/X quad\n! and which the index of the A/X and B/X (and sometices C/X) quads\n! A/X and B/X in alphabetical order, the C/X last\n! write(*,334)'yfrac',sem,(jord(2,ii),ii=1,nint)\n334 format('3B call convert for constituent ',a,i3,' interactions: ',10i3)\n call convert_y2quadx(sem,nint,jord,parquad)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,334)'quad',(parquad(ii),ii=1,nint)\n! these are the indices for quad and aymmetric compvar ...\n! write(*,*)'3B back from convert_y2quadx 1'\n proprec%asymdata%quad=parquad(1)\n proprec%asymdata%alpha=parquad(2)\n proprec%asymdata%beta=parquad(3)\n proprec%asymdata%ternary=parquad(4)\n! write(*,335)parquad\n!335 format('3B saved in propery quad mm:',5i3)\n exit findint\n else !-----------------------------------------------------------------\n! we should never have mint lesser than nint !!!\n write(*,*)'3B serious error in algorithm mintintrec\n intrec=>intrec%nextlink\n level=1\n goto 100\n elseif(intrec%fraclink(1).eq.jord(2,mint)) then\n! we have found an interaction record with correct constituent on this level\n! write(*,344)intrec%fraclink(1),jord(2,mint),mint,nint\n!344 format('3B we have same the constituents',2i3,5x,2i3)\n if(mint.eq.nint) then\n! we have to add a second property!!\n proprec=>intrec%propointer\n do while(associated(proprec%nextpr))\n! there can be several property records\n proprec=>proprec%nextpr\n enddo\n typty=ideg; ideg=0\n! add a property record\n! write(*,*)'3B adding a second property record 2'\n call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx)\n if(gx%bmperr.ne.0) then\n write(*,*)'3B error code',gx%bmperr\n goto 1000\n endif\n! add particular MQMQA data TO LAST proprec\n proprec=>intrec%propointer\n do while(associated(proprec%nextpr))\n! we need to find the last property record\n! THIS WAS TRICKY TO UNDERSTAND!!!\n proprec=>proprec%nextpr\n enddo\n call convert_y2quadx(sem,nint,jord,parquad)\n if(gx%bmperr.ne.0) goto 1000\n proprec%asymdata%quad=parquad(1)\n proprec%asymdata%alpha=parquad(2)\n proprec%asymdata%beta=parquad(3)\n proprec%asymdata%ternary=parquad(4)\n exit findint\n else\n!--------------------------------------------------------------------------\n! go to higher level, %highlink can be empty \n! write(*,234)intrec%fraclink(1),mint,nint,associated(intrec%highlink)\n!234 format('3B goto higher level',3i3,l2)\n mint=mint+1; level=0\n lastint=>intrec\n intrec=>intrec%highlink\n goto 100\n endif\n elseif(intrec%fraclink(1).gt.jord(2,mint)) then\n! insert new interaction before this one ======================================\n! Maybe also change link from endmember if level=-1\n! write(*,150)2,level,mint,nint,lun,jord(2,mint)\n call create_interaction(newintrec,mint,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n if(level.eq.-1) then\n! this should be the record linked from the endmember\n newintrec%nextlink=>endmemrec%intpointer\n endmemrec%intpointer=>newintrec ! here it is needed !!!!\n! write(*,*)'3B endmember interaction set to',jord(2,mint)\n elseif(level.eq.0) then\n! we found this from a lower level, this whould replace highlink in lastint\n! and insert that as nextlink in new record\n! write(*,370)intrec%fraclink(1),mint,nint\n!370 format('3B inserting a constituent ',i3,' before current',2i3)\n if(associated(lastint%highlink)) then\n newintrec%nextlink=>lastint%highlink\n lastint%highlink=>newintrec\n endif\n else\n! just save the link to the new record in lastint%nextlink\n lastint%nextlink=>newintrec\n endif\n intrec=>newintrec\n lastint=>intrec\n data2: if(mint.lt.nint) then\n level=0\n goto 100\n elseif(mint.eq.nint) then\n! write(*,*)'3B create property record 3',mint,nint,lfun\n! there can be several property records, this will be added last\n proprec=>intrec%propointer\n if(associated(proprec%nextpr)) then\n do while(associated(proprec%nextpr))\n! there can be several property records\n proprec=>proprec%nextpr\n enddo\n call create_mqmqa_proprec(proprec%nextpr,typty,ideg,lfun,refx)\n else\n call create_mqmqa_proprec(intrec%propointer,typty,ideg,lfun,refx)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! add particular MQMQA data TO THE LAST RECORD\n proprec=>intrec%propointer\n do while(associated(proprec%nextpr))\n! there can be several property records\n proprec=>proprec%nextpr\n enddo\n call convert_y2quadx(sem,nint,jord,parquad)\n if(gx%bmperr.ne.0) goto 1000\n proprec%asymdata%quad=parquad(1)\n proprec%asymdata%alpha=parquad(2)\n proprec%asymdata%beta=parquad(3)\n proprec%asymdata%ternary=parquad(4)\n exit findint\n else\n write(*,*)'3B Algorithm is wrong'\n stop\n endif data2\n endif order\n endif findint\n! write(*,*)'3B we are here!',associated(intrec),mint,nint,jord(2,1:nint)\n!\n1000 continue\n return\n end subroutine enter_mqmqa_excess_param\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_mqmqa_excessprop\n!\\begin{verbatim}\n subroutine create_mqmqa_excessprop(asymdata,sem,nint,jord)\n! creates a particular mqmqa excess property record\n implicit none\n type(gtp_asymprop) :: asymdata\n integer :: sem, nint, jord(2,*)\n!\\end{verbatim} %+\n integer ii,jj,pair\n! we may have to find species records to find the mixed quad and alphabetical \n! write(*,100)asymdata%ppow,asymdata%qpow,asymdata%rpow,sem,&\n! (jord(2,ii),ii=1,nint)\n100 format('3B in mqmqa_excessprop: powers:',3i2,', const: ',10i3)\n! the values needed here have been collected in the path up to here\n! Two other emquads should have the same elements as in the quad outside enquads\n! They whould be ordered alphabetically in quad_ii and quad_jj\n! pair=0\n! semloop: do ii=1,mqmqa_data%ncat\n! if(mqmqa_data%emquad(ii).eq.sem) exit semloop\n! enddo semloop\n! sem is the mixed quad AB/X\n! pair=sem\n! goto 180\n!110 contiinue\n! int: do jj=1,nint\n! do ii=1,mqmqa_data%ncat\n! if(mqmqa_data%emquad(ii).eq.jord(jj)) cycle int\n! enddo\n! goto 110\n! enddo int\n! this interaction constituent is the pair quad\n!110 pair=jord(jj)\n! the pair quad is among jord(1..nint)\n!120 continue\n!\n! The quad is the index to the fraction to quads\n asymdata%quad=1\n! the index to ij and ji composition in allonone\n asymdata%alpha=1\n! if there is a ternary c/X quad this is the index to the y_ik fraction\n asymdata%ternary=1\n! powers already set ??\n! write(*,200)asymdata%ppow,asymdata%qpow,asymdata%rpow\n200 format('3B powers: ',3i3)\n!\n1000 continue\n return\n end subroutine create_mqmqa_excessprop\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccpermuts\n!\\begin{verbatim}\n subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks)\n! finds all fcc/hcp permutations needed for this parameter\n! The order of elements in the sublattices is irrelevant when one has F or B\n! ordering as all permutations are stored in one place (with some exceptions)\n! Thus the endmembers are ordered alphabetically in the sublattices and also\n! the interaction parameters. Max 2 levels of interactions allowed.\n implicit none\n integer, dimension(*) :: iord,intperm\n integer, dimension(2,*) :: jord\n integer lokph,nsl,noperm,nint\n!\\end{verbatim} %+\n integer l2,ll,ib,again,clink,lshift,mshift,a211\n integer odd,inz,ip,iqq1,iqq2,isp,jb,jp,jsp,l3,level1,level2,isp2\n integer level2perm,lj,loksp,lsp,niqq1,nl1,nl2,nll,np,nq,nz,iz,jz,kz\n integer ls,mint\n character pch*64\n integer, dimension(4) :: elal,esame\n integer, dimension(:,:), allocatable :: elinks\n integer, dimension(:,:), allocatable :: intlinks\n logical notsame\n character carr*64\n! integer, dimension(3) :: esame\n!\n!-------------------------------------------------------------------\n!\n! This is a very long and messy subroutine and it calls others that are\n! equally complicated. It is important it is understandable and correct,\n! all possible cases has not been tested. Do not try to simplify it by making\n! it more messy, this subroutine is not important for calculating speed\n! but the structure it creates is important for speed.\n! The corresponing routine for bcc permutations is even worse ... unfinished ...\n!\n!-------------------------------------------------------------------\n!\n! write(*,7)lokph,nsl,nint,noperm\n7 format('3B In fccpermuts: ',4i4)\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts1: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n! I assume the ordering is in the first 4 sublattices, that could be changed\n if(nsl.lt.4) then\n write(*,*)'3B There must be at least 4 sublattices for fcc/hcp option'\n gx%bmperr=4267; goto 1000\n endif\n if(nint.gt.2) then\n write(*,*)'3B Maximum 2nd level interaction with option F'\n gx%bmperr=4268; goto 1000\n endif\n! rearrange constituents in alphabetcal order in the sublattices,\n! change interactions also!\n! write(*,11)'3B fp1: ',(iord(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint)\n11 format(a,4i4,' interactions: ',i2,4i4)\n do l2=1,4\n if(iord(l2).gt.0) then\n loksp=phlista(lokph)%constitlist(iord(l2))\n elal(l2)=splista(loksp)%alphaindex\n else\n elal(l2)=iord(l2)\n endif\n enddo\n! write(*,11)'3B fp2: ',(elal(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint)\n again=1\n lagain: do while(again.ne.0)\n! yet another messy sorting \n again=0\n do l2=1,3\n do ll=l2+1,4\n equal: if(elal(ll).lt.elal(ll-1)) then\n again=1\n ib=elal(ll)\n elal(ll)=elal(ll-1)\n elal(ll-1)=ib\n! write(*,*)'3B call 1',ll-1,elal(ll-1)\n call findconst(lokph,ll-1,elal(ll-1),iord(ll-1))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3B call 2',ll,elal(ll)\n call findconst(lokph,ll,elal(ll),iord(ll))\n if(gx%bmperr.ne.0) goto 1000\n! if there are interacting constituents in ll or ll-1 shift them also\n do lj=1,nint\n if(jord(1,lj).eq.ll) then\n! write(*,21)'3B fpi1: ',lj,jord(1,lj),jord(2,lj)\n21 format(a,i2,2i4)\n jord(1,lj)=ll-1\n loksp=phlista(lokph)%constitlist(jord(2,lj))\n ib=splista(loksp)%alphaindex\n! write(*,*)'3B call 3',ll-1,ib\n call findconst(lokph,ll-1,ib,jord(2,lj))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,21)'3B fpi2: ',lj,jord(1,lj),jord(2,lj)\n elseif(jord(1,lj).eq.ll-1) then\n! write(*,21)'3B fpi3: ',lj,jord(1,lj),jord(2,lj)\n jord(1,lj)=ll\n loksp=phlista(lokph)%constitlist(jord(2,lj))\n ib=splista(loksp)%alphaindex\n! write(*,*)'33B call 4',ll,ib\n call findconst(lokph,ll,ib,jord(2,lj))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,21)'3B fpi4: ',lj,jord(1,lj),jord(2,lj)\n else\n! write(*,23)'3B No interactions in sublattice: ',jord(1,lj)\n23 format(a,2i3)\n endif\n enddo\n endif equal\n enddo\n enddo\n enddo lagain\n! elements are now ordered in alphabetical order over the sublattices\n! find how many equal\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts2A: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n esame=0\n ib=1\n esame(ib)=1\n do ll=2,4\n if(elal(ll).eq.elal(ll-1)) then\n esame(ib)=esame(ib)+1\n else\n ib=ib+1\n esame(ib)=1\n endif\n enddo\n if(jord(1,1).ne.jord(1,2)) then\n! we can have a case AX:AY:A:A and it should not be changed to AXY:A:A:A !!!\n notsame=.true.\n else\n notsame=.false.\n endif\n! we must rearrange interactions so they are in the first sublattice with\n! the same endmember element for each level separately\n! This is probably redundant as decode_constarr also sorts\n do l2=1,nint\n ib=elal(jord(1,l2))\n do ll=1,jord(1,l2)-1\n if(elal(ll).eq.ib) then\n! write(*,*)'3B Shifting interacting constituent to sublattice: ',ll\n nll=ll\n if(l2.eq.2 .and. notsame) then\n! if interactions should not be in same sublattice but with the same element\n! in the endmember, increment ll to interact in next sublattice. It should\n! be the same endmember constituent there!\n if(ll.eq.jord(1,1)) nll=ll+1\n! write(*,*)'3B nll: ',ll,nll\n endif\n jord(1,l2)=nll\n loksp=phlista(lokph)%constitlist(jord(2,l2))\n ib=splista(loksp)%alphaindex\n! write(*,*)'3B call 5',nll,ib\n call findconst(lokph,nll,ib,jord(2,l2))\n if(gx%bmperr.ne.0) goto 1000\n endif\n enddo\n enddo\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts2B: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n! write(*,11)'3B fp3: ',(elal(iz),iz=1,4),nint,((jord(jz,kz),jz=1,2),kz=1,nint)\n! write(*,11)'3B fp4: ',(iord(iz),iz=1,4)\n! make sure that any interaction is connected to the first possible endmember\n! for example A:A,B:B:B should be changed to A,B:A:B:B\n! Also A,C:A,B:A:A should be A,B:A,C:A:A to have a unique record\n do l2=1,nint\n lj=jord(1,l2)\n do ll=1,lj-1\n! ll must be less than 4 in this loop\n equalem: if(elal(ll).eq.elal(lj)) then\n if(l2.eq.1 .or. .not.notsame) then\n jord(1,l2)=ll\n loksp=phlista(lokph)%constitlist(jord(2,l2))\n ib=splista(loksp)%alphaindex\n! write(*,*)'3B call 6',ll,ib\n call findconst(lokph,ll,ib,jord(2,l2))\n if(gx%bmperr.ne.0) goto 1000\n else\n! l2 must be 2 here, i.e. second order interaction\n loksp=phlista(lokph)%constitlist(jord(2,1))\n ib=splista(loksp)%alphaindex\n loksp=phlista(lokph)%constitlist(jord(2,2))\n jb=splista(loksp)%alphaindex\n if(jb.lt.ib) then\n! change them so the lowest constituent comes first in sublattice order\n! write(*,*)'3B call 7',ll,jb\n call findconst(lokph,ll,jb,jord(2,1))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3B call 8',lj,ib\n call findconst(lokph,lj,ib,jord(2,2))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3B exchange: ',ib,jb,jord(2,1),jord(2,2)\n else\n! The interactions should not be in same sublattice, the next sublattice\n! must have the same endmember constituent as jord(1,1), put it there\n if(ll.eq.jord(1,1)) then\n nll=ll+1\n else\n nll=ll\n endif\n jord(1,l2)=nll\n loksp=phlista(lokph)%constitlist(jord(2,l2))\n ib=splista(loksp)%alphaindex\n! write(*,*)'3B call 9',nll,ib\n call findconst(lokph,nll,ib,jord(2,l2))\n if(gx%bmperr.ne.0) goto 1000\n endif\n endif\n endif equalem\n enddo\n enddo\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts2C: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n!--------------------------------\n! now we can calculate the number of endmember permutations\n! Generate also all endmember links in elinks to be stored in endmember record\n lshift=phlista(lokph)%nooffr(1)\n if(esame(1).eq.4) then\n! all 4 equal\n noperm=1\n allocate(elinks(nsl,noperm))\n do ll=1,nsl\n elinks(ll,1)=iord(ll)\n enddo\n elseif(esame(1).eq.3) then\n! first 3 equal, one different: A:A:A:B; A:A:B:A; A:B:A:A; B:A:A:A\n noperm=4\n allocate(elinks(nsl,noperm))\n do np=1,noperm\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n if(np.lt.4) then\n! shift the single different element forward step by step\n ib=iord(4-np)+lshift\n iord(4-np)=iord(5-np)-lshift\n iord(5-np)=ib\n endif\n enddo\n elseif(esame(1).eq.2) then\n if(esame(2).eq.2) then\n! the two first equal and also last two: A:A:B:B\n! A:B:A:B; A:B:B:A; B:A:B:A; B:B;A:A; B:A:A:B\n! I have no idea how to make this into a loop so I handle each separately\n noperm=6\n allocate(elinks(nsl,noperm))\n np=1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n! shift sublattice 2 and 3: A:B:A:B\n ib=iord(2)+lshift\n iord(2)=iord(3)-lshift\n iord(3)=ib\n np=np+1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n! shift sublattice 3 and 4: A:B:B:A\n ib=iord(3)+lshift\n iord(3)=iord(4)-lshift\n iord(4)=ib\n np=np+1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n! shift sublattice 1 and 2: B:A:B:A\n ib=iord(1)+lshift\n iord(1)=iord(2)-lshift\n iord(2)=ib\n np=np+1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n! shift sublattice 2 and 3: B:B:A:A\n ib=iord(2)+lshift\n iord(2)=iord(3)-lshift\n iord(3)=ib\n np=np+1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n! shift sublattice 2 and 4 (double lenght): B:A:A:B\n ib=iord(2)+2*lshift\n iord(2)=iord(4)-2*lshift\n iord(4)=ib\n np=np+1\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n else\n! the first two equal and last 2 different: A:A:B:C\n a211=1\n noperm=12\n allocate(elinks(nsl,noperm))\n call fccpe211(1,elinks,nsl,lshift,iord)\n endif\n elseif(esame(2).eq.3) then\n! first different and last 3 equal: A:B:B:B; B:A:B:B; B:B:A:B; B:B:B:A\n noperm=4\n allocate(elinks(nsl,noperm))\n do np=1,noperm\n do ll=1,nsl\n elinks(ll,np)=iord(ll)\n enddo\n if(np.lt.4) then\n! shift the single different element backward step by step\n ib=iord(np)+lshift\n iord(np)=iord(np+1)-lshift\n iord(np+1)=ib\n endif\n enddo\n elseif(esame(2).eq.2) then\n! two equal but first and last different\n a211=2\n noperm=12\n allocate(elinks(nsl,noperm))\n call fccpe211(2,elinks,nsl,lshift,iord)\n elseif(esame(3).eq.2) then\n! first two different but last two equal\n a211=3\n noperm=12\n allocate(elinks(nsl,noperm))\n call fccpe211(3,elinks,nsl,lshift,iord)\n else\n! all 4 different\n noperm=24\n allocate(elinks(nsl,noperm))\n call fccpe1111(elinks,nsl,lshift,iord)\n endif\n! always skip debug output of endmembers for interaction parameters\n intperm(1)=0\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts3D: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n if(nint.eq.0) goto 200\n! uncomment next line to have debug output\n goto 200\n!--------------------\n! debug output of endmembers after rearranging\n carr='fp6: '\n ib=6\n l3=1\n do ll=1,4\n if(elal(ll).gt.0) then\n l2=len_trim(splista(species(elal(ll)))%symbol)\n write(carr(ib:),16)splista(species(elal(ll)))%symbol(1:l2)\n16 format(a)\n ib=ib+l2\n else\n carr(ib:)='*'\n ib=ib+1\n endif\n17 continue\n if(l3.le.nint) then\n if(jord(1,l3).eq.ll) then\n loksp=phlista(lokph)%constitlist(jord(2,l3))\n l2=len_trim(splista(loksp)%symbol)\n write(carr(ib:),18)splista(loksp)%symbol(1:l2)\n18 format(',',a)\n ib=ib+l2+1\n l3=l3+1\n goto 17\n endif\n endif\n if(ll.lt.4) carr(ib:ib)=':'\n ib=ib+1\n enddo\n write(*,19)carr(1:ib)\n write(*,19)' fp7: ',esame,noperm\n19 format('3B ',a,4i3,i5)\n! More debug output: all endmember permutations\n do np=1,noperm\n! listing indices in constituent list (stored in endmember record)\n write(*,31)np,(elinks(ll,np),ll=1,nsl)\n31 format('3B elinks: ',i3,3x,10i4)\n enddo\n do np=1,noperm\n! Easier to check listing of permutations using constituent names\n carr=' '\n ib=1\n do ll=1,nsl\n if(elinks(ll,np).gt.0) then\n loksp=phlista(lokph)%constitlist(elinks(ll,np))\n l2=len_trim(splista(loksp)%symbol)\n write(carr(ib:),32)splista(loksp)%symbol(1:l2)\n32 format(a,':')\n ib=ib+l2+1\n else\n carr(ib:)='*:'\n ib=ib+2\n endif\n enddo\n write(*,33)np,carr\n33 format('3B emperm ',i3,': ',a)\n enddo\n! debug output of endmembers end\n!--------------------\n200 continue\n! done arranging component array and permutations of endmembers\n if(nint.eq.0) then\n goto 1000\n endif\n!===============================================\n! Now the 1st level interactions ... store in intlinks(1..2)\n allocate(intlinks(2,100))\n! intperm(1)=number of interaction permutations on level 1 for each endmember\n! on level 1 each endmember permutation has the same\n! intperm(2)=total number of permutation links for level 1\n! intperm(3..) used for 2nd level\n select case(noperm)\n case default ! error\n! write(*,*)'3B Unknown case for endmemeber permutations: ',noperm\n gx%bmperr=4269\n!----------\n case(1) ! A:A:A:A\n! if(nint.eq.2) then\n! write(*,501)'3B fccpermuts4: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! endif\n if(jord(1,1).ne.1) then\n! write(*,*)'3B Interaction must be in sublattice 1'\n gx%bmperr=4270; goto 1000\n endif\n intperm(1)=4\n intperm(2)=4\n clink=jord(2,1)\n! set links to interaction with same element in all 4 sublattices\n do l2=1,4\n intlinks(1,l2)=l2\n intlinks(2,l2)=clink\n clink=clink+lshift\n enddo\n level1=1\n!----------\n case(4) ! A:A:A:B and A:B:B:B\n if(esame(1).eq.3) then\n if(jord(1,1).eq.1) then\n! the interaction must be AX:A:A:B\n call fccint31(jord,lshift,intperm,intlinks)\n level1=2\n else\n! the interaction must be A:A:A:BX\n intperm(1)=1\n intperm(2)=4\n intlinks(1,1)=4\n intlinks(2,1)=jord(2,1)\n do ll=2,4\n intlinks(1,ll)=5-ll\n intlinks(2,ll)=intlinks(2,ll-1)-lshift\n enddo\n level1=3\n endif\n elseif(jord(1,1).eq.2) then\n! the interaction must be A:BX:B:B\n call fccint31(jord,lshift,intperm,intlinks)\n level1=4\n else\n! the interaction must be AX:B:B:B\n intperm(1)=1\n intperm(2)=4\n intlinks(1,1)=1\n intlinks(2,1)=jord(2,1)\n do ll=2,4\n intlinks(1,ll)=ll\n intlinks(2,ll)=intlinks(2,ll-1)+lshift\n enddo\n level1=5\n endif\n!----------\n case(6) ! A:A:B:B\n call fccint22(jord,lshift,intperm,intlinks)\n level1=6\n!----------\n case(12) ! A:A:B:C; A:B:B:C; A:B:C:C\n if(a211.eq.jord(1,1)) then\n call fccint211(a211,jord,lshift,intperm,intlinks)\n level1=7\n else\n! 2017.03.15, looking for bug and had some difficulties to understand\n! here we set the first interaction with one of the single constituents\n! we have to find the permutation of the endmember component in 4 sublattices\n! starting from sublattice 1. There are 12 endemember permutations\n! write(*,666)a211,lshift,jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n666 format('3B jord mm: ',2i4,2x,2i4,2x,2i4,' <<<<<<<<<<<<<<<<<<<<<<<<<<')\n! jord(1,1) is first interacting sublattice\n! jord(2,1) is first interacting constituent index counted from first sublattice\n intperm(1)=1\n intperm(2)=noperm\n l2=jord(1,1)\n! This is the endmember component of the interaction parameter\n ib=phlista(lokph)%constitlist(elinks(l2,1))\n intlinks(1,1)=jord(1,1)\n intlinks(2,1)=jord(2,1)\n do ll=2,noperm\n do l3=1,4\n! search all sublattices for the endmember constituent, ib, skipping wildcards\n if(elinks(l3,ll).gt.0) then\n jb=phlista(lokph)%constitlist(elinks(l3,ll))\n! Here is the endmember componenent, add the interaction to same sublattice\n if(jb.eq.ib) goto 410\n endif\n enddo\n write(*,*)'3B Cannot find endmember element for premutation ',ll,ib\n gx%bmperr=4271; goto 1000\n410 continue\n intlinks(1,ll)=l3\n mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift\n! we have to calculate the index of the intreraction component in yarr \n intlinks(2,ll)=intlinks(2,ll-1)+mshift\n! write(*,422)'X',ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll)\n enddo\n! This is used to insert the second interaction (if any)\n level1=8\n endif\n!----------\n case(24) ! A:B:C:D\n write(*,77)\n77 format(' *** CONGRATULATIONS, '/&\n ' You may be the first to enter a parameter like this!!!')\n intperm(1)=1\n intperm(2)=noperm\n l2=jord(1,1)\n! species number in endmember of interacting sublattice\n ib=phlista(lokph)%constitlist(elinks(l2,1))\n intlinks(1,1)=l2\n intlinks(2,1)=jord(2,1)\n do ll=2,24\n do l3=1,4\n jb=phlista(lokph)%constitlist(elinks(l3,ll))\n if(jb.eq.ib) goto 420\n! write(*,419)'3B elinks,ib: ',ll,l3,ib,jb,elinks(l3,ll)\n!419 format(a,2i4,2x,3i4)\n enddo\n write(*,*)'3B Cannot find endmember element for premutation ',ll,ib\n gx%bmperr=4271; goto 1000\n420 continue\n intlinks(1,ll)=l3\n mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift\n intlinks(2,ll)=intlinks(2,ll-1)+mshift\n! write(*,422)'Y',ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll)\n422 format('3B option F spec ',a,': ',3i3,2x,i7,2x,2i7)\n enddo\n! level1=9 means not implemented\n level1=9\n end select\n500 continue\n if(nint.eq.1) goto 900\n!================================================================\n! 2nd level interaction permutations\n! write(*,*)'3B First level interaction type: ',level1\n! write(*,502)'3B elinks and jord: ',elal,((jord(i,j),i=1,2),j=1,2)\n501 format(a,2(2i4,2x))\n502 format(a,4(i4),' : ',2(2i4,2x))\n!\n! The simplest 2nd level interaction is in the same sublattice as first\n if(jord(1,2).eq.jord(1,1)) then\n! AXY:B:C:D where X and Y are two different constituents (not A) and B, C, D\n! can be any constituents. There are no new permutations, just add Y\n! write(*,*)'3B shortcut'\n intperm(3)=1\n intperm(4)=1\n! intperm(4+intperm(3)) should be total number of permutations!!\n! intperm(2) is number of endmeber+first interaction permutations\n intperm(5)=2*intperm(2)\n nz=intperm(2)\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n do np=1,intperm(2)\n intlinks(1,nz+np)=intlinks(1,np)\n call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! for debug output\n goto 900\n endif\n!-----------------------------------------------------------\n select case(level1)\n case default !error\n write(*,*)'3B Unknown case for permutations on level 1: ',level1\n gx%bmperr=4272\n!-----------------------------------------------------------\n case(1) ! AXY:A:A:A or AX:AX:A:A or AX:AY:A:A\n call fccip2A(lokph,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n!-----------------------------------------------------------\n case(2) ! AXY:A:A:B or AX:AY:A:B or AX:A:A:BY\n! write(*,*)'3B case 2: ',jord(1,2),jord(2,2)\n if(jord(1,2).eq.4) then\n! AX:A:A:BY, there should be 12 permutations, no new on second level\n intperm(3)=1\n intperm(4)=1\n intperm(5)=12\n nz=intperm(2)\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n do np=1,4\n! sublattice for B the same for 3 permutations\n do nq=1,3\n nz=nz+1\n intlinks(1,nz)=5-np\n call findconst(lokph,5-np,isp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n enddo\n else\n! AX:AY:A:B\n call fccip2B(1,lokph,lshift,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n endif\n!-----------------------------------------------------------\n case(3) ! A:A:A:BXY\n! never here as taken care by shortcut above ??\n if(jord(1,2).ne.jord(1,1)) then\n! write(*,*)'3B Thinking error, restructure!'\n gx%bmperr=4273; goto 1000\n endif\n!-----------------------------------------------------------\n case(4) ! A:BXY:B:B or A:BX:BY:B; no AY:BX:B:B as that would be case 5\n! A:BX:BY:B\n call fccip2B(2,lokph,lshift,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n!-----------------------------------------------------------\n case(5) ! AX:BY:B:B\n! This parameter has just 4 endmember permutations. On this level 3 more\n! AX:B:B:B AX:BY:B:B AX:B:BY:B AX:B:B:BY\n! B:AX:B:B B:AX:BY:B B:AX:B:BY BY:AX:B:B etc\n intperm(3)=1\n intperm(4)=3\n intperm(5)=12\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n nz=intperm(2)\n do np=1,4\n nll=intlinks(1,np)\n do ip=1,3\n nz=nz+1\n nll=nll+1\n if(nll.gt.4) nll=1\n intlinks(1,nz)=nll\n call findconst(lokph,nll,isp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n enddo\n! endif\n!-----------------------------------------------------------\n! This is the important the BINARY reciprocal excess parameter\n case(6) ! AX:A:B:B or A:A:BX:B, 6 endmem and 2 level 1 permutations = 12\n! AX:A:B:B: AX:AX:B:B: 1; 0 totally 6 permutations\n! AX:A:B:B: AX:AY:B:B and AY:AX:B:B; 2 additional permutations, totally 24\n loksp=phlista(lokph)%constitlist(jord(2,2))\n jsp=splista(loksp)%alphaindex\n if(abs(jord(1,2)-jord(1,1)).gt.1) then\n! level 2 interaction with another endmember constituent than level 1\n! AX:A:BY:B; 2 additional permutations, totally 24\n! The endmember permutations will put element B in sublattices:\n! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; If that changes this must be changed too ...\n intperm(3)=1\n intperm(4)=2\n intperm(5)=24\n nz=intperm(2)\n nl1=3\n nl2=4\n do ip=1,6\n nz=nz+1\n intlinks(1,nz)=nl1\n call findconst(lokph,nl1,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=nl2\n call findconst(lokph,nl2,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=nl1\n call findconst(lokph,nl1,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=nl2\n call findconst(lokph,nl2,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n select case(nl1)\n case default\n! write(*,*)'3B Error in fccpermut, case(lavel1=6), case(nl1)'\n gx%bmperr=4274; goto 1000\n case(1) ! change nl2 to 2 or 4, nl1 should be 1\n if(nl2.eq.2) nl2=4 \n if(nl2.eq.3) nl2=2\n case(2) ! change nl2 to 3\n if(nl2.eq.3) then\n nl1=1\n nl2=3\n else\n nl2=3\n endif\n case(3) ! change nl1 to 2\n nl1=2\n end select\n enddo\n else\n! interaction with same endmember element in 2 different sublattices\n! write(*,*)'3B smart?'\n loksp=phlista(lokph)%constitlist(jord(2,1))\n isp=splista(loksp)%alphaindex\n if(isp.eq.jsp) then\n! AX:AX:B:B or A:A:BX:BX, there are 12 permutations of AX:A:B:B on level 1\n! but there are only 6 second level interactions\n! The endmember permutations will put element A in sublattices:\n! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices:\n! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; \n intperm(3)=2\n intperm(4)=1\n intperm(5)=0\n intperm(6)=6\n nz=intperm(2)\n if(jord(1,1).eq.1) then\n nll=2\n else\n nll=4\n endif\n odd=1\n do np=1,12\n odd=1-odd\n do jp=1,intperm(4+odd)\n! this loop is done 1 or 0 times twice; nll=2,3,4; 4,4,3 // 4,4,3; 3,2,4\n nz=nz+1\n intlinks(1,nz)=nll\n call findconst(lokph,nll,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n! nz= 13,14,15,16,17,18,19\n! nll= 2, 3, 4, 4, 4, 3, - if jord(1,1)=1\n! nll= 4, 4, 3, 3, 2, 4, - if jord(1,1)=2\n select case(nz)\n case default\n write(*,*)'3B Error in fccpermut, case(lavel1=6), nz=',nz\n gx%bmperr=4274; goto 1000\n case(13) ! change nll to 3 if 2, else same\n if(nll.eq.2) nll=3 ! 3 or same\n case(14)\n! the if ..,\n! if(nll.eq.4) then\n! nll=3\n! else\n! nll=4\n! endif\n! is same as nll=7-nll\n nll=7-nll\n case(15,18) ! no change!!\n continue\n case(16)\n if(nll.eq.3) nll=2\n case(17)\n if(nll.eq.4) nll=3\n if(nll.eq.2) nll=4\n end select\n enddo\n enddo\n! if the case and loops above works they are smart and easy to understand ???\n else\n! AX:AY:B:B or A:A:BX:BY\n! In this case we have the sume number of level2 permutations as level1\n! Just add an interaction on the other sublattice with same endmember\n! The endmember permutations will put element A in sublattices:\n! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices:\n! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; \n! The first interaction will be with the first of the sublattices, the\n! second in the second, just switch\n intperm(3)=1\n intperm(4)=1\n intperm(5)=intperm(2)\n nz=intperm(2)\n do np=1,6\n! Here AX:AY:B:B and AY:AX:B:B\n nz=nz+1\n nll=intlinks(1,nz-11)\n nl2=intlinks(1,nz-12)\n intlinks(1,nz)=nll\n! write(*,73)'3B loop 6B: ',np,nll,nl2,nz\n73 format(a,10i4)\n call findconst(lokph,nll,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n! set the second interaction in sublattice with level 1 interaction\n nz=nz+1\n intlinks(1,nz)=nl2\n call findconst(lokph,nl2,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! if the case and loops above works they are smart and easy to understand ???\n endif\n endif\n!-----------------------------------------------------------\n! Maybe this can wait a little ...\n case(7) ! AX:A:B:C or A:BX:B:C or A:B:CX:C\n write(*,*)'3B FCC permutation not yet implemented 7'\n gx%bmperr=4275\n!-----------------------------------------------------------\n! Maybe this can wait a little ... NO\n! trying to understand what I did 3 years ago ....\n! Parameter is actually a reciprocal one ... A:A:BX:CY\n case(8) ! A:A:BX:C or similar, 12 endmember permutations\n! write(*,*)'3B noperm, intperm(1..2): ',noperm,intperm(1),intperm(2)\n! do mint=1,noperm\n! write(*,661)mint,(elinks(ls,mint),ls=1,4)\n! enddo\n661 format('3B em permutation: ',i4,(i6,3i4))\n! permutations: 12\n! endmember 1st order 2nd order\n! A:A:B:C A:A:BX:C A:A:BX:CY\n! A:A:C:B A:A:C:BX A:A:CY:BX\n! A:C:A:B A:C:A:BX A:CY:A:BX\n! A:C:B:A A:C:BX:A A:CY:BX:A\n! A:B:C:A A:BX:C:A A:BX;CY:A\n! A:B:A:C etc\n! B:A:A:C\n! B:A:C:A\n! B:C:A:A\n! C:B:A:A\n! C:A:B:A\n! C:A:A:B \n! The good news: there are no new permutations!!\n intperm(3)=1\n intperm(4)=1\n intperm(5)=12\n nz=intperm(2)\n! loksp=phlista(lokph)%constitlist(jord(2,2))\n! isp=splista(loksp)%alphaindex\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp2=splista(loksp)%alphaindex\n! jord(2,*) are constituent indices, must be converted to species\n! write(*,*)'3B jord: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2)\n! B moves as 3, 4, 4, 3, 2, 2, 1, 1, 1, 2, 3, 4\n! C moves as 4, 3, 2, 2, 3, 4, 4, 3, 2, 1, 1, 1\n! do it the hard way ...\n nz=nz+1\n intlinks(1,nz)=4\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=3\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=2\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=2\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=3\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=4\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n!\n nz=nz+1\n intlinks(1,nz)=4\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=3\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=2\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=1\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=1\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n nz=nz+1\n intlinks(1,nz)=1\n call findconst(lokph,intlinks(1,nz),isp2,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n! Code below is just to check the constituents are correctly sorted\n! NOTE jord(2,*) is phase constituent index, not species index\n pch='G('//trim(phlista(lokph)%name)//','\n ip=len_trim(pch)+1\n mint=1\n do ls=1,4\n if(elal(ls).lt.0) then\n pch(ip:)='*:'\n else\n pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':'\n endif\n ip=len_trim(pch)+1\n if(mint.le.nint .and. jord(1,mint).eq.ls) then\n loksp=phlista(lokph)%constitlist(jord(2,mint))\n isp=splista(loksp)%alphaindex\n! write(*,*)'3B test 1: ',mint,jord(1,mint),jord(2,mint),isp\n! write(*,*)'3B test 2: ',species(jord(2,mint))\n pch(ip-1:)=','//trim(splista(species(isp))%symbol)//':'\n ip=len_trim(pch)+1\n mint=mint+1\n endif\n enddo\n!\n pch(ip-1:)=';0)'\n! write(*,503)trim(pch)\n503 format(/'3B *** This parameter ',a,' just implemented 8')\n! write(*,*)'3B FCC permutation not yet implemented 8'\n! gx%bmperr=4275\n!-----------------------------------------------------------\n! Maybe this can wait a little ...\n case(9) ! AX:B:C:D or similar\n write(*,*)'3B FCC permutation not yet implemented 9'\n gx%bmperr=4275\n end select\n!-----------------------------------------------------------\n! done permutations of interactions\n! write(*,510)'3B 510: ',(intperm(j),j=1,7)\n510 format(a,10i4)\n!------- debug output of first level interaction permutations\n900 continue\n! to skip remove comment on next line\n! goto 1000\n if(nint.eq.2) then\n! write(*,905)'3B Permutations of endmem and intlevel 1: ',noperm,&\n! intperm(1),intperm(2)\n! write(*,905)'3B Permutations of intlevel 2: ',intperm(3),&\n! (intperm(3+i),i=1,intperm(3))\n905 format(a,i5,2x,10i4)\n endif\n! these are the base pointers to first and second level permutations\n iqq1=0\n iqq2=intperm(2)+1\n inz=0\n emdmem: do np=1,noperm\n! for each endmember permutation there are intperm(1) level 1 permutations\n intlev1: do niqq1=1,intperm(1)\n iqq1=iqq1+1\n if(nint.eq.2) then\n level2=1\n if(intperm(3).eq.1) then\n! there is a fixed number of 2nd level permutations\n level2perm=intperm(4)\n else\n! the number of 2nd level interaction varies with the first level, it can be 0\n level2perm=intperm(3+niqq1)\n if(level2perm.eq.0) cycle intlev1\n endif\n else\n! no 2nd level interaction\n iqq2=0\n endif\n910 continue\n carr=' '\n ib=1\n subl: do ll=1,nsl\n! endmember constituent, can be wildcard\n loksp=elinks(ll,np)\n if(loksp.gt.0) then\n loksp=phlista(lokph)%constitlist(loksp)\n lsp=len_trim(splista(loksp)%symbol)\n carr(ib:)=splista(loksp)%symbol(1:lsp)\n ib=ib+lsp\n else\n carr(ib:ib)='*'\n ib=ib+1\n endif\n920 continue\n if(intlinks(1,iqq1).eq.ll) then\n! level 1 interaction constituent\n! NOTE: For error checks output of intlinks is more important than the\n! constituent name in carr as the link also indicates the sublattice!!!\n! if(nint.eq.2) &\n! write(*,922)1,iqq1,intlinks(1,iqq1),intlinks(2,iqq1)\n922 format('3B intlinks: ',2i5,2x,2i5,2x,3i5)\n loksp=phlista(lokph)%constitlist(intlinks(2,iqq1))\n lsp=len_trim(splista(loksp)%symbol)\n carr(ib:)=','//splista(loksp)%symbol(1:lsp)\n ib=ib+lsp+1\n endif\n if(iqq2.gt.0) then\n if(intlinks(1,iqq2).eq.ll) then\n! level 2 interaction constituent\n! NOTE: For error checks output of intlinks is more important than the\n! constituent name in carr as the link also indicates the sublattice!!!\n! write(*,922)2,iqq2,intlinks(1,iqq2),intlinks(2,iqq2),jord(2,2)\n loksp=phlista(lokph)%constitlist(intlinks(2,iqq2))\n lsp=len_trim(splista(loksp)%symbol)\n carr(ib:)=','//splista(loksp)%symbol(1:lsp)\n ib=ib+lsp+1\n endif\n endif\n if(ll.lt.nsl) then\n carr(ib:)=': '\n ib=ib+2\n endif\n enddo subl\n inz=inz+1\n! write(*,925)inz,carr(1:len_trim(carr))\n925 format('3B inter perm ',i3,': ',a)\n if(iqq2.gt.0) then\n! there are level2perm number of 2nd order permutations\n level2=level2+1\n iqq2=iqq2+1\n if(level2.le.level2perm) goto 910\n endif\n enddo intlev1\n enddo emdmem\n!------- debug output end\n1000 continue\n return\n end subroutine fccpermuts\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccip2A\n!\\begin{verbatim} %-\n subroutine fccip2A(lokph,jord,intperm,intlinks)\n! 2nd level interaction permutations for fcc\n implicit none\n integer, dimension(*) :: intperm\n integer, dimension(2,*) :: jord,intlinks\n integer lokph\n!\\end{verbatim} %+\n integer loksp,isp,jsp,ij,nll,ll,iqq,nz,ik\n! AX:A:A:A, 2nd level can be AXY:A:A:A, AX:AX:A:A or AX:AY:A:A\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n! write(*,2)'3B fccip2A1: ',((jord(i,j),i=1,2),j=1,2)\n!2 format(a,2(2i3,2x))\n! 2nd level interaction in another sublattice, AX:AX:A:A or AX:AY:A:A\n loksp=phlista(lokph)%constitlist(jord(2,1))\n jsp=splista(loksp)%alphaindex\n! write(*,*)'3B fccip2A2: ',isp,jsp\n if(isp.eq.jsp) then\n! 2nd level interacting constituent same as first level constituent:\n! Level 1: Level2:\n! AX:A:A:A; AX:AX:A:A; AX:A:AX:A; AX:A:A:AX 3 permutations\n! A:AX:A:A; A:AX:AX:A; A:AX:A:AX 2 permutations\n! A:A:AX:A; A:A:AX:AX 1 permutations\n! A:A:A:AX; none 0 permutations\n! write(*,*)'3B same interaction constituent in different sublattices'\n intperm(3)=4\n intperm(4)=3\n intperm(5)=2\n intperm(6)=1\n intperm(7)=0\n intperm(8)=24\n iqq=intperm(2)\n do ij=1,3\n! loop only to 3 as there is no 2nd level permutation for ij=4\n nll=intlinks(1,ij)\n do ll=1,intperm(3+ij)\n iqq=iqq+1\n nll=nll+1\n intlinks(1,iqq)=nll\n if(nll.gt.4) then\n! write(*,*)'3B Error in 2nd level interaction of AX:AX:A:A'\n gx%bmperr=4276; goto 1000\n endif\n call findconst(lokph,intlinks(1,iqq),isp,intlinks(2,iqq))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,76)'3B loop:',ij,nll,iqq,intlinks(1,iqq),intlinks(2,iqq)\n76 format(a,3i3,2x,2i4)\n enddo\n enddo\n! debug output\n! nc=0\n! nc1=0\n! nc2=intperm(2)\n! do lj=1,4\n! do ljj=1,intperm(3+lj)\n! nc=nc+1\n! nc1=nc1+1\n! nc2=nc2+1\n! write(*,77)nc,lj,ljj,&\n! (intlinks(i,nc1),i=1,2),(intlinks(i,nc2),i=1,2)\n77 format('3B AX:AX:A:A: ',i3,2x,2i3,2x,2(2i4,2x))\n! enddo\n! enddo\n else\n! If 2nd level interacting element different\n! Level 1: Level2:\n! AX:A:A:A; AX:AY:A:A; AX:A:AY:A; AX:A:A:AY 3 permutations\n! A:AX:A:A; AY:AX:A:A; A:AX:AY:A; A:AX:A:AY 3 permutations\n! A:A:AX:A; AY:A:AX:A; A:AY:AX:A; A:A:AX:AY 3 permutations\n! A:A:A:AX; AY:A:A:AX; A:AY:A:AX; A:A:AY:AX 3 permutations\n! write(*,*)'3B different interaction constituent in different sublattices'\n intperm(3)=1\n intperm(4)=3\n intperm(5)=12\n nz=intperm(2)\n do ik=1,4\n! Note that these permutations include AY:AX:A:A linked from AX:A:A:A\n! A first level interaction AY:A:A:A is stored in another interaction record\n! with no link to this 2nd level interaction.\n nll=intlinks(1,ik)\n do ll=1,3\n nll=nll+1\n if(nll.gt.4) nll=1\n nz=nz+1\n intlinks(1,nz)=nll\n call findconst(lokph,nll,isp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n! write(*,88)nz,ik,ll,intlinks(1,nz),intlinks(2,nz)\n88 format('3B loop: ',3i3,2x,2i5)\n enddo\n enddo\n endif\n1000 continue\n return\n end subroutine fccip2A\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccip2B\n!\\begin{verbatim} %-\n subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks)\n! 2nd level interaction permutations for fcc\n implicit none\n integer lq,lokph,lshift\n integer, dimension(*) :: intperm\n integer, dimension(2,*) :: jord,intlinks\n!\\end{verbatim} %+\n integer loksp,isp,jsp,ny,nz,mp,isub2,nll,ip,np\n! lq=1 means AX:AY:A:B or AX:AX:A:B\n! lq=2 means A:BX:BY:B or A:BX:BX:B\n! This parameter has 4 endmember permuts each with 3 permuts on level 1\n! if X is same as Y only 2; 1; 0\n loksp=phlista(lokph)%constitlist(jord(2,1))\n isp=splista(loksp)%alphaindex\n loksp=phlista(lokph)%constitlist(jord(2,2))\n jsp=splista(loksp)%alphaindex\n! write(*,*)'3B fccip2B3: ',isp,jsp\n if(isp.eq.jsp) then\n! Endmember Level 1 Level 2 2; 1; 0;\n! A:A:A:B AX:A:A:B AX:AX:A:B AX:A:AX:B\n! A:AX:A:B A:AX:AX:B\n! A:A:AX:B none\n! A:A:B:A AX:A:B:A AX:AX:B:A AX:A:B:AX\n! A:AX:B:A A:AX:B:AX\n! A:A:B:AX none\n! A:B:A:A AX:B:A:A AX:B:AX:A AX:B:A:AX\n! A:B:AX:A A:B:AX:AX\n! A:B:A:AX none\n! B:A:A:A B:AX:A:A B:AX:AX:A B:AX:A:AX\n! B:A:AX:A B:A:AX:AX\n! B:A:A:AX none\n! or the same for endmember A:B:B:B\n intperm(3)=3\n intperm(4)=2\n intperm(5)=1\n intperm(6)=0\n intperm(7)=intperm(2)\n ny=0\n nz=intperm(2)\n mp=3\n! these loops are frustratingly messy .... but they seem to work ...\n nploop: do np=1,intperm(2)\n mp=mp+1\n if(lq.eq.1) then\n! isub2 is the endmember sublattice occupied by the \"different\" constituent\n! isub2=(20-np)/4\n isub2=(15-np)/3\n else\n! isub2=(3+np)/4\n isub2=(2+np)/3\n endif\n! nll is the sublattice with 1st level interaction\n ny=ny+1\n nll=intlinks(1,ny)\n! np = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12\n! mp = 4, 5, 6, 4, 5, 6, 4, ...\n! intperm(mp) = 2, 1, 0, 2, 1, 0, 2, 1, 0, 2, 1, 0 \n do ip=1,intperm(mp)\n nll=nll+1\n if(nll.eq.isub2) nll=nll+1\n nz=nz+1\n intlinks(1,nz)=nll\n! write(*,13)'3B AX:AX:A:B: ',np,mp,ip,isub2,nz,nll,jsp\n13 format(a,4i3,2x,i3,2i5)\n call findconst(lokph,nll,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n if(mod(np,3).eq.0) mp=3\n enddo nploop\n else\n! Endmember Level 1 Level 2 2;\n! A:A:A:B AX:A:A:B AX:AY:A:B AX:A:AY:B\n! A:AX:A:B A:AX:AY:B AY:AX:A:B\n! A:A:AX:B AY:A:AX:B A:AY:AX:B\n! A:A:B:A AX:A:B:A AX:AY:B:A AX:A:B:AY etc\n! There are 2 additional permutations for each of the 12 existing, the problem\n! is mainly to know in which sublattice to add the interaction\n intperm(3)=1\n intperm(4)=2\n intperm(5)=2*intperm(2)\n ny=0\n nz=intperm(2)\n do np=1,intperm(2)\n if(lq.eq.1) then\n! isub2 is the endmember sublattice occupied by the \"different\" constituent\n isub2=(15-np)/3\n else\n! isub2 should be 1 for np=1..4, 2 for np=4..7 etc\n isub2=(np+2)/3\n endif\n! nll is the sublattice with 1st level interaction\n ny=ny+1\n nll=intlinks(1,ny)\n do ip=1,2\n! set 2nd interaction in sublattice after first interaction. If that\n! sublattice is >4 set it in first. If the endmember is the single other\n! constituent set it in next. If that is >4 set it in first\n nll=nll+1\n if(nll.gt.4) nll=1\n if(nll.eq.isub2) nll=nll+1\n if(nll.gt.4) nll=1\n nz=nz+1\n intlinks(1,nz)=nll\n! write(*,13)'3B AX:AY:A:B: ',np,ip,0,isub2,nz,nll,jsp\n call findconst(lokph,nll,jsp,intlinks(2,nz))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n enddo\n endif\n1000 continue\n return\n end subroutine fccip2B\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccint31\n!\\begin{verbatim} %-\n subroutine fccint31(jord,lshift,intperm,intlinks)\n! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B\n! set the sublattice and link to constituent for each endmember permutation\n! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2\n! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3\n! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3\n! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3\n! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2\n! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2\n! 3rd -1 0 2 ; -1 0 1\n! suck\n implicit none\n integer lshift\n integer, dimension(2,*) :: jord,intlinks\n integer, dimension(*) :: intperm\n!\\end{verbatim} %+\n integer l2,shift0,shift1,shift2,clink,idis,np\n!\n intperm(1)=3\n intperm(2)=12\n l2=jord(1,1)\n clink=jord(2,1)\n idis=0\n shift0=0\n shift1=1\n shift2=2\n do np=1,4\n intlinks(1,idis+1)=l2+shift0\n intlinks(2,idis+1)=clink+shift0*lshift\n intlinks(1,idis+2)=l2+shift1\n intlinks(2,idis+2)=clink+shift1*lshift\n intlinks(1,idis+3)=l2+shift2\n intlinks(2,idis+3)=clink+shift2*lshift\n idis=idis+3\n subl: if(l2.eq.1) then\n if(np.eq.1) then\n shift2=3\n elseif(np.eq.2) then\n shift1=2\n elseif(np.eq.3) then\n shift0=1\n endif\n else\n if(np.eq.1) then\n shift0=-1\n elseif(np.eq.2) then\n shift1=0\n else\n shift2=1\n endif\n endif subl\n enddo\n1000 return\n end subroutine fccint31\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccint22\n!\\begin{verbatim} %-\n subroutine fccint22(jord,lshift,intperm,intlinks)\n! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) \n! 6 permutations of endmember, 2 permutations of interactions, 12 in total\n! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1\n! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2\n! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3\n! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3\n! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3\n! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2\n! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1\n! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1\n! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0\n! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0\n! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1\n! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1\n implicit none\n integer lshift\n integer, dimension(2,*) :: jord,intlinks\n integer, dimension(*) :: intperm\n!\\end{verbatim} %+\n integer shift0,shift1,l2,clink,idis,np\n!\n intperm(1)=2\n intperm(2)=12\n l2=jord(1,1)\n clink=jord(2,1)\n idis=0\n shift0=0\n shift1=1\n do np=1,6\n intlinks(1,idis+1)=l2+shift0\n intlinks(2,idis+1)=clink+shift0*lshift\n intlinks(1,idis+2)=l2+shift1\n intlinks(2,idis+2)=clink+shift1*lshift\n idis=idis+2\n subl: if(l2.eq.1) then\n select case(np)\n case default\n write(*,*)'3B Case error in fccint22: ',np\n case(1) !A:B:A:B is next endmember\n shift1=2\n case(2) !A:B:B:A\n shift1=3\n case(3) !B:A:B:A\n shift0=1\n case(4) !B:B:A:A\n shift0=2\n case(5) !B:A:A:B\n shift0=1\n shift1=2\n case(6) ! no more\n end select\n else\n select case(np)\n case default\n write(*,*)'3B Case error in fccint22: ',np\n case(1) !A:B:A:B is next endmember\n shift0=-1\n case(2) !A:B:B:A\n shift1=0\n case(3) !B:A:B:A\n shift0=-2\n case(4) !B:B:A:A\n shift1=-1\n case(5) !B:A:A:B\n shift1=1\n case(6) ! no more\n end select\n endif subl\n enddo\n1000 continue\n return\n end subroutine fccint22\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccint211\n!\\begin{verbatim} %-\n subroutine fccint211(a211,jord,lshift,intperm,intlinks)\n! 1st level interaction in sublattice l1 with endmember like A:A:B:C\n! 12 endmember permutations of AABC; ABBC; or ABCC\n! 2 interaction permutations for each, 24 in total\n implicit none\n integer a211,lshift\n integer, dimension(2,*) :: jord,intlinks\n integer, dimension(*) :: intperm\n!\\end{verbatim} %+\n integer l2,clink,idis,shift0,shift1,np\n intperm(1)=2\n intperm(2)=24\n l2=jord(1,1)\n if(l2.ne.a211) then\n! write(*,*)'3B Error calling fccint211',a211,l2\n gx%bmperr=4276; goto 1000\n endif\n clink=jord(2,1)\n idis=0\n shift0=0\n shift1=1\n! endmemeber A:A:B:C; first permutation interactions: AX:A:B:C; A:AX:B:C\n! endmemeber A:B:B:C; first permutation interactions: A:BX:B:C; A;B:BX:C\n! endmemeber A:B:C:C; first permutation interactions: A:B:CX:C; A:B:C:CX\n do np=1,12\n intlinks(1,idis+1)=l2+shift0\n intlinks(2,idis+1)=clink+shift0*lshift\n intlinks(1,idis+2)=l2+shift1\n intlinks(2,idis+2)=clink+shift1*lshift\n idis=idis+2\n subl: if(l2.eq.1) then\n! endmember A:A:B:C\n select case(np)\n case default\n write(*,*)'3B Case error in fccint211: ',np,a211\n case(1) !A:A:C:B is next endmember \n continue\n case(2) !A:C:A:B\n shift1=2\n case(3) !A:C:B:A\n shift1=3\n case(4) !A:B:C:A\n continue\n case(5) !A:B:A:C\n shift1=2\n case(6) !B:A:A:C\n shift0=1\n case(7) !B:A:C:A\n shift1=3\n case(8) !B:C:A:A\n shift0=2\n case(9) !C:B:A:A\n continue\n case(10) !C:A:B:A\n shift0=1\n case(11) !C:A:A:B\n shift1=2\n case(12) ! no more\n end select\n elseif(l2.eq.2) then\n! endmember A:B:B:C\n select case(np)\n case default\n write(*,*)'3B Case error in fccint211: ',np,a211\n case(1) !A:B:C:B is next endmember\n shift1=2\n case(2) !C:B:A;B\n continue\n case(3) !C:B:B:A\n shift1=1\n case(4) !B:B:C:A\n shift0=-1\n shift1=0\n case(5) !B:B:A:C\n continue\n case(6) !B:A:B:C\n shift1=1\n case(7) !B:A:C:B\n shift1=2\n case(8) !C:A:B:B\n shift0=1\n case(9) !A:C:B:B\n continue\n case(10) !B:C:A:B\n shift0=-1\n case(11) !B:C:B:A\n shift1=1\n case(12) ! no more\n end select\n else\n! endmember A:B:C:C\n select case(np)\n case default\n write(*,*)'3B Case error in fccint211: ',np,a211\n case(1) !A:C:B:C is next endmember\n shift0=-1\n case(2) !C:A:B:C\n shift1=0\n case(3) !C:B:A:C\n shift0=-2\n case(4) !B:C:A:C\n shift1=-1\n case(5) !B:A:C:C\n shift1=1\n case(6) !B:C:C:A\n shift1=1\n case(7) !C:B:C:A\n shift1=1\n case(8) !C:C:B:A\n shift1=1\n case(9) !C:C:A:B\n shift1=1\n case(10) !C:A:C:B\n shift1=1\n case(11) !A:C:C:B\n shift1=1\n case(12) ! no more\n end select\n endif subl\n enddo\n1000 continue\n return\n end subroutine fccint211\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccpe211\n!\\begin{verbatim} %-\n subroutine fccpe211(l1,elinks,nsl,lshift,iord)\n! sets appropriate links to constituents for the 12 perumations of\n! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3)\n implicit none\n integer l1,nsl,lshift\n integer, dimension(nsl,*) :: elinks\n integer, dimension(*) :: iord\n!\\end{verbatim} %+\n integer odd,np,ll,ib\n! l1=1; keep 1 and change 3o4 and 2o3 6 times; then change 1o2 and\n! loop 2 times\n! changing 3o4 and 2o3; then change 1o2 and loop 2 times changing 2o3\n! and 3o4\n! AABC; AACB; ACAB; ACBA; ABCA; ABAC; ! BAAC; BACA; BCAA; ! CBAA;\n! CABA; CAAB;\n! l1=2; keep 2 and change 3o4 and 1o3 6 times; then change 2o3 and\n! loop 2 times\n! changing 3o4 and 1o3; then change \n! ABBC; ABCB; CBAB; CBBA; BBCA; BBAC; ! BABC; BACB; CABB; ! ACBB;\n! BCAB; BCBA;\n! l1=3; keep 4 and change 2o3 and 1o2 6 times; then change\n! ABCC; ACBC; CABC; CBAC; BCAC; BACC; ! \n! write(*,*)'3B fccpe211: ',l1\n odd=0\n loop12: do np=0,11\n do ll=1,nsl\n if(iord(ll).lt.0) iord(ll)=-99\n elinks(ll,np+1)=iord(ll)\n enddo\n! note l1 and ll are different !!!\n if(l1.eq.1) then\n! AABC. Keep constituent in sublattice 1 first 6 loops; then for 3 and 3\n if(np.eq.5) then\n ib=iord(1)+lshift\n iord(1)=iord(2)-lshift\n iord(2)=ib\n odd=1-odd\n elseif(np.eq.8) then\n ib=iord(1)+lshift\n iord(1)=iord(2)-lshift\n iord(2)=ib\n odd=1-odd\n elseif(odd.eq.0) then\n ib=iord(3)+lshift\n iord(3)=iord(4)-lshift\n iord(4)=ib\n odd=1-odd\n else\n ib=iord(2)+lshift\n iord(2)=iord(3)-lshift\n iord(3)=ib\n odd=1-odd\n endif\n elseif(l1.eq.2) then\n! ABBC. Keep constituent in sublattice 2 for first 6; then for 3 and 3\n if(np.eq.5) then\n ib=iord(2)+lshift\n iord(2)=iord(3)-lshift\n iord(3)=ib\n odd=1-odd\n elseif(np.eq.8) then\n ib=iord(1)+lshift\n iord(1)=iord(2)-lshift\n iord(2)=ib\n odd=1-odd\n elseif(odd.eq.0) then\n ib=iord(3)+lshift\n iord(3)=iord(4)-lshift\n iord(4)=ib\n odd=1-odd\n else\n ib=iord(1)+2*lshift\n iord(1)=iord(3)-2*lshift\n iord(3)=ib\n odd=1-odd\n endif\n else\n! ABCC. Keep constituent in sublattice 4 for first 6; then for 3 and 3\n if(np.eq.5) then\n ib=iord(2)+2*lshift\n iord(2)=iord(4)-2*lshift\n iord(4)=ib\n elseif(np.eq.8) then\n ib=iord(3)+lshift\n iord(3)=iord(4)-lshift\n iord(4)=ib\n odd=1-odd\n elseif(odd.eq.0) then\n ib=iord(2)+lshift\n iord(2)=iord(3)-lshift\n iord(3)=ib\n odd=1-odd\n else\n ib=iord(1)+lshift\n iord(1)=iord(2)-lshift\n iord(2)=ib\n odd=1-odd\n endif\n endif\n enddo loop12\n1000 continue\n return\n end subroutine fccpe211\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine fccpe1111\n!\\begin{verbatim} %-\n subroutine fccpe1111(elinks,nsl,lshift,iord)\n! sets appropriate links to 24 permutations when all 4 constituents different\n! A:B:C:D\n! The do loop keeps the same constituent in first sublattice 6 times, changing\n! the other 3 sublattice, then changes the constituent in the first sublattice\n! and goes on changing in the other 3 until all configurations done\n implicit none\n integer nsl,lshift\n integer, dimension(nsl,*) :: elinks\n integer, dimension(*) :: iord\n!\\end{verbatim}\n integer np,ll,odd,ib\n! odd is either 0 or 1\n odd=1\n loop24: do np=0,23\n do ll=1,nsl\n if(iord(ll).lt.0) iord(ll)=-99\n elinks(ll,np+1)=iord(ll)\n enddo\n! keep the same constituent in sublattice 1 for 6 endmembers, then shift\n if(np.eq.5) then\n! shift 1 and 2, change odd\n ib=iord(2)-lshift\n iord(2)=iord(1)+lshift\n iord(1)=ib\n odd=1-odd\n elseif(np.eq.11) then\n! shift 1 and 4, keep odd\n ib=iord(3)-2*lshift\n iord(3)=iord(1)+2*lshift\n iord(1)=ib\n elseif(np.eq.17) then\n! shift 1 and 4, change odd\n ib=iord(4)-3*lshift\n iord(4)=iord(1)+3*lshift\n iord(1)=ib\n odd=1-odd\n elseif(odd.eq.0) then\n odd=1-odd\n! shift 3 and 4\n ib=iord(4)-lshift\n iord(4)=iord(3)+lshift\n iord(3)=ib\n else\n odd=1-odd\n! shift 2 and 3\n ib=iord(3)-lshift\n iord(3)=iord(2)+lshift\n iord(2)=ib\n endif\n enddo loop24\n1000 continue\n return\n end subroutine fccpe1111\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function check_minimal_ford\n!\\begin{verbatim}\n logical function check_minimal_ford(lokph)\n! some tests if the fcc/bcc permutation model can be applied to this phase\n! The function returns FALSE if the user may set the FORD or BORD bit of lokph\n implicit none\n integer lokph\n!\\end{verbatim}\n integer nsl,nc,jl,ll,j2,loksp,lokcs\n logical notallowed\n integer, dimension(:), allocatable :: const\n double precision ss\n notallowed=.true.\n nsl=phlista(lokph)%noofsubl\n if(btest(phlista(lokph)%status1,PHHASP)) then\n! The PHASP bit is set if a parameter has been entered (never cleared)\n write(kou,*)'Permutation must be set before parameters are entered'\n goto 1000\n endif\n if(nsl.lt.4) then\n write(kou,*)'Phase with permutation must have 4 or more sublattices'\n goto 1000\n else\n! ordering assumed in first 4 sublattices, that is not really necessary\n! ss=phlista(lokph)%sites(1)\n lokcs=phlista(lokph)%linktocs(1)\n ss=firsteq%phase_varres(lokcs)%sites(1)\n nc=phlista(lokph)%nooffr(1)\n allocate(const(nc))\n do jl=1,nc\n loksp=phlista(lokph)%constitlist(jl)\n const(jl)=splista(loksp)%alphaindex\n enddo\n jl=nc\n do ll=2,4\n! if(abs(phlista(lokph)%sites(ll)-ss).gt.1.0D-12) then\n if(abs(firsteq%phase_varres(lokcs)%sites(ll)-ss).gt.1.0D-12) then\n write(kou,12)\n12 format(' Permutation requires the same number of',&\n ' sites in first 4 sublattices')\n goto 1000\n endif\n if(phlista(lokph)%nooffr(ll).ne.nc) then\n write(kou,13)\n13 format(' Permutation requires that the number of constituents',&\n ' are equal'/' in all 4 sublattices for ordering')\n goto 1000\n endif\n! one must also check the constituents are identical\n do j2=1,nc\n loksp=phlista(lokph)%constitlist(jl+j2)\n if(splista(loksp)%alphaindex.ne.const(j2)) then\n write(kou,14)\n14 format(' Permutation requires that the constituents in the',&\n ' 4 sublattices for'/' ordering are identical')\n goto 1000\n endif\n enddo\n jl=jl+nc\n enddo\n endif\n notallowed=.false.\n1000 continue\n check_minimal_ford=notallowed\n return\n end function check_minimal_ford\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bccpermuts\n!\\begin{verbatim}\n subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks)\n! finds all bcc permutations needed for this parameter\n implicit none\n integer lokph,nsl,noperm,nint\n! iord are the endmember constituent indices\n! intperm has dimension 24 and contain propagation of interactions ?? \n integer, dimension(*) :: iord,intperm\n! jord(1,int) is the interaction subl. and jord(2,int) the constituent index\n integer, dimension(2,*) :: jord\n! these must be allocated here and will be stored in the parameter records\n! giving the constituent indices for permutations of endmembers and interactions\n integer, dimension(:,:), allocatable :: elinks\n integer, dimension(:,:), allocatable :: intlinks\n!\\end{verbatim} %+\n integer ls,l1,l2,l3,loksp,c1,c2,c3,mint,ip,nsame\n integer elal(9),unshift(9),orgem(4),esame(4)\n character pch*64\n logical notdone\n! I assume the ordering is in the first 4 sublattices, that could be changed\n if(nsl.lt.4) then\n write(*,*)'3B There must be at least 4 sublattices for bcc option'\n gx%bmperr=4267; goto 1000\n endif\n! unifinished\n! write(*,*)'3B implementation of BCC permutations not finished'\n! gx%bmperr=4277\n! In BCC the tetrahedron is unsymmetrical, I assume sublattice 1 and 2\n! are NEXT-nearest neighbours and also sublattice 3 and 4, i.e.\n! G_A:B:C:D = u_AC + u_AD + u_BC + u_BD + v_AB + v_CD where\n! u_ij is the nearest neighbour bond (nnb) energy and v_ij the nnnb energy\n! NOTE that endmember permutations are different from FCC/HCP\n! NOTE that reciprocal parameters have their permutation in its own record\n! (not propagated from the first order interaction)\n!\n! we must rearrange constituents in alphabetcal order in the sublattices\n! and change interactions also! Note we can exchange between sublattice 1&2\n! and 3&4 but not between 1&3 for example.\n if(nint.gt.2) then\n write(*,*)'3B Maximum 2nd level interaction with option F'\n gx%bmperr=4268; goto 1000\n endif\n! list elal and jord on entering\n! write(*,10)'3B bccperm 1: ',(iord(l2),l2=1,4),(jord(1,l2),jord(2,l2),l2=1,2)\n10 format(a,4i4,5x,2i3,3x,2i3)\n! rearrange constituents in alphabetical order in the sublattices,\n! change interactions also!\n! iord is the lowest constituent index in each sublattice (incl interactions)\n! rearrange to make have the lowest index in sublattice 1\n! NOTE: wildcards have index -99, they should come last!\n c1=10000\n do ls=1,nsl\n if(iord(ls).gt.0) then\n loksp=phlista(lokph)%constitlist(iord(ls))\n elal(ls)=splista(loksp)%alphaindex\n if(elal(ls).lt.c1) then\n c1=elal(ls)\n l1=ls\n endif\n else\n! this branch if wildcard, iord(ls)=-99\n elal(ls)=iord(ls)\n endif\n enddo\n! save origional sublattice of endmember constituent in orgem\n! in order to shift interactions!!\n orgem=0\n unshift=elal\n! c1 in sublattice l1 is lowest component index, if l1>1 shift c1 to subl. 1\n if(l1.eq.1) then\n! sublattice 1&2 OK but we may have to rearrange sublattice 3&4\n c2=elal(3)\n c3=elal(4)\n if(c3.gt.0) then\n! c3 negative means wildcard and do nothing\n if(c2.eq.c1 .and. c3.eq.c1) then\n if(elal(2).ne.c1) then\n! elements in subl 1,3 and 4 same, move 2 last\n elal(4)=elal(2)\n elal(2)=c3\n orgem(2)=4\n orgem(4)=2\n endif\n elseif(c2.eq.c1) then\n! element in 1 and 3 same, if 4 lower than 2 shift!\n if(c3.lt.elal(2)) then\n elal(4)=elal(2)\n elal(2)=c3\n orgem(4)=2\n orgem(2)=4\n endif\n elseif(c3.lt.c2) then\n elal(4)=c2\n elal(3)=c3\n orgem(3)=4\n orgem(4)=3\n endif\n endif\n elseif(l1.eq.2) then\n! if l1=2 then just shift constituents in sublattice 1 and 2\n c2=elal(1)\n elal(1)=c1\n elal(l1)=c2\n orgem(1)=2\n orgem(2)=1\n! we may have to rearrange sublattice 3&4\n c2=elal(3)\n c3=elal(4)\n if(c3.gt.0 .and. c3.lt.c2) then\n! c3 negative means wildcard\n elal(4)=c2\n elal(3)=c3\n orgem(3)=4\n orgem(4)=3\n endif\n elseif(l1.gt.2) then\n! if l1=3 or 4 we must move the constituent in position (7-l1) also\n! note if l1=3 then 7-l1=4; l1=4 then 7-l1=3\n c2=elal(1)\n elal(1)=elal(l1)\n c3=elal(2)\n elal(2)=elal(7-l1)\n orgem(1)=l1\n orgem(2)=7-l1\n if(c3.gt.0 .and. c3.lt.c2) then\n! c3 negative means wildcard\n elal(3)=c3\n elal(4)=c2\n orgem(3)=2\n orgem(4)=1\n else\n elal(3)=c2\n elal(4)=c3\n orgem(3)=1\n orgem(4)=2\n endif\n endif\n! write(*,9)'3B sorted 1: ',(unshift(ls),ls=1,4),(elal(ls),ls=1,4),l1\n! Now the alphabetically first constituent is in sublattice 1\n! If 3 elements are equal they should be ordered A:A:A:B or A:B:B:B \n! in all other cases the alphabetical order is OK ??\n! ?? if 2 pairs are equal they should be ordered A:A:B:B or A:B:A:B\n! ?? if 2 or less equal the alphabetical order is OK\n nsame=0\n! problem with NI:FE:NI:FE becomes FE:NI:NI:NI !!\n if(elal(2).eq.elal(1)) then\n if(elal(3).eq.elal(1)) then\n! all is OK. We should have correct alphabetical order in sublattice 3&4\n continue\n endif\n elseif(elal(3).eq.elal(1)) then\n! elal(2) =/= elal(1), if elal(3)=elal(4)=elal(1) shift elal(2) to elal(4)\n if(elal(4).eq.elal(1)) then\n! change A:B:A:A to A:A:A:B\n c2=elal(2)\n elal(2)=elal(4)\n elal(4)=c2\n orgem(4)=2\n nsame=1\n elseif(elal(4).lt.elal(2)) then\n! change A:C:A:B to A:B:A:C\n c2=elal(2)\n elal(2)=elal(4)\n elal(4)=c2\n orgem(4)=2\n nsame=2\n endif\n endif\n! shift interactions also!!! orgem(ls) is original sublattice of endmember\n! interactions must not be wildcard\n! write(*,9)'3B sorted 2: ',(unshift(ls),ls=1,4),(elal(ls),ls=1,4),nsame\n9 format(a,4i4,5x,9i4)\n! write(*,12)'3B orgem: ',orgem,(jord(1,mint),jord(2,mint),mint=1,nint)\n12 format(a,4i4,5x,4i4)\n do mint=1,nint\n latloop2: do ls=1,4\n if(jord(1,mint).eq.orgem(ls)) then\n! interaction has changed to sublattice ls\n! write(*,13)'3B noshift: ',mint,ls,jord(1,mint),jord(2,mint)\n jord(1,mint)=ls\n loksp=phlista(lokph)%constitlist(jord(2,mint))\n jord(2,mint)=splista(loksp)%alphaindex\n! write(*,13)'3B shifted: ',mint,ls,jord(1,mint),jord(2,mint)\n exit latloop2\n endif\n! we come here if interaction in same sublattice but we must change jord(2,mint)\n loksp=phlista(lokph)%constitlist(jord(2,mint))\n jord(2,mint)=splista(loksp)%alphaindex\n! write(*,13)'3B changed: ',mint,ls,jord(1,mint),jord(2,mint)\n enddo latloop2\n enddo\n! write(*,13)'3B interactions: ',(jord(1,mint),jord(2,mint),mint=1,nint)\n13 format(a,2(2i5,5x))\n! make sure jord are in sublattice order\n if(nint.gt.1) then\n if(jord(1,1).gt.jord(1,2)) then\n l1=jord(1,1)\n jord(1,1)=jord(1,2)\n jord(1,2)=l1\n c1=jord(2,1)\n jord(2,1)=jord(2,2)\n jord(2,2)=c1\n endif\n endif\n if(nint.eq.2) then\n! we have two interactions\n if(jord(1,1).ne.jord(1,2) .and. elal(jord(1,1)).eq.elal(jord(1,2))) then\n! the interactions are not in the same sublattice but we have the same\n! endmember component for the interactions!\n if(jord(2,2).lt.jord(2,1)) then\n! The second interacting component is lower alphabetically, in some cases\n! we should shift the alphabetical lowest interacting component first\n if(jord(1,1)+jord(1,2).eq.3 .or. jord(1,1)+jord(1,2).eq.7) then\n! 1) if both interactions are in sublattice 1&2 or 3&4: A,C:A,B => A,B:A,C\n l1=jord(2,1)\n jord(2,1)=jord(2,2)\n jord(2,2)=l1\n! write(*,*)'3B shifting 1 interaction component to first'\n elseif(elal(3-jord(1,1)).eq.elal(7-jord(1,2))) then\n! 2) if the endmember constituents in the other sublattices the same\n! A,C:D:A,B:D => A,B:D:A,C:D\n l1=jord(2,1)\n jord(2,1)=jord(2,2)\n jord(2,2)=l1\n! write(*,*)'3B shifting 2 interaction component to first'\n endif\n endif\n endif\n endif\n! write(*,10)'3B bccperm 4: ',(elal(l2),l2=1,4),(jord(1,l2),jord(2,l2),l2=1,2)\n!-------------------------------------------------------------------------\n! now we can start generating permutations <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n! elal(1..4) are now species in alphabetical order (>4 not changed)\n! jord(1,int) is sublattice and jord(2,int) is species of interaction int=0,1,2\n! wildcards always at the end\n! Always generate the endmember permutations\n call bccendmem(lokph,nsl,elal,noperm,elinks)\n if(gx%bmperr.ne.0) goto 1000\n if(nint.ge.1) then\n! if first level interaction generate the necessary permutations\n call bccint1(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks)\n if(gx%bmperr.ne.0) goto 1000\n if(nint.ge.2) then\n! if second level interaction generate the necessary permutations\n! write(*,*)'3B calling bccint2',jord(1,2),jord(2,2)\n call bccint2(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks)\n! write(*,*)'3B back from bccint2',gx%bmperr\n if(gx%bmperr.ne.0) goto 1000\n if(nint.gt.2) then\n write(*,*)'3B Max two level of interactions for BCC permutations'\n gx%bmperr=4275\n endif\n endif\n endif\n! if(gx%bmperr.ne.0) goto 1000\n1000 continue\n! unifinished\n return\n end subroutine bccpermuts\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bccendmem\n!\\begin{verbatim} %-\n subroutine bccendmem(lokph,nsl,elal,noperm,elinks)\n! generate an bcc endmember with all permutations\n implicit none\n integer lokph,nsl,noperm\n! elal are the endmember species indices\n integer, dimension(*) :: elal\n! these must be allocated here and will be stored in the parameter records\n! giving the sublattice and constituent indices for each permutation\n! of an endmembers\n integer, dimension(:,:), allocatable :: elinks\n! integer, dimension(:,:), allocatable :: intlinks\n!\\end{verbatim} %+\n! endmember perm\n! A:A:A:A 1\n! A:A:A:B 4 \n! A:A:B:B B2 2 A:A:B:B B:B:A:A \n! A:B:A:B B32 4 A:B:A:B A:B:B:A B:A:A:B B:A:B:A\n! A:B:B:B 4\n! A:A:B:C 4 A:A:B:C A:A:C:B B:C:A:A C:B:A:A\n! 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\n! Note the parameter below requires 3 sets of permutations\n! 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\n! G(BCC,A:B:C:D) = u_AC+u_AD+u_BC+u_BD+v_AB+v_CD, u nn bond, v nnn bond\n! A:C:B:D 8\n! G(BCC,A:C:B:D) = u_AB+u_AD+u_CB+u_CD+v_AC+v_BD\n! A:D:B:C 8\n! G(BCC,A:D:B:C) = u_AB+u_AC+u_DB+u_DC+v_AD+v_BC\n integer ls,ip,mperm,cix\n integer, parameter, dimension(16) :: prm4=[1,2,3,4,4,3,1,2,2,1,4,3,3,4,2,1]\n integer, parameter, dimension(32) :: prm8=[1,2,3,4,1,2,4,3,2,1,3,4,2,1,4,3,&\n 3,4,1,2,3,4,2,1,4,3,1,2,4,3,2,1]\n character pch*64\n!\n! nperm=0\n! elal(i) ordered c1<=c2 and c1<=c3 and c3<=c4 and c2<=c4 but maybe c3<=c2\n! if(elal(2).ne.elal(1)) then\n! 2 different elements in sublattice 1&2: A:B\n! if(elal(3).ne.elal(4)) then\n! 2 different elements in sublattice 3&4: X:Y\n! if(elal(3).ne.elal(1)) then\n! if(elal(3).ne.elal(2)) then\n! 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\n! nperm=8\n! else\n! 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\n! nperm=8\n! endif\n! elseif(elal(4).ne.elal(2)) then\n! 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\n! nperm=8\n! else\n! A:B:A:B = A:B:A:B A:B:B:A B:A:A:B B:A:B:A\n! nperm=4\n! endif\n! elseif(elal(3).eq.elal(2)) then\n! same constituents in sublattice 2\n! A:B:B:B = A:B:B:B B:A:B:B B:B:A:B B:B:B:A\n! nperm=4\n! else\n! A:B:C:C = A:B:C:C B:A:C:C C:C:A:B C:C:B:A\n! nperm=4\n! endif\n! elseif(elal(3).eq.elal(4)) then\n! same elements in sublattice 1&2: A:A, and in sublattice 3&4: X:Y\n! if(elal(3).eq.elal(1)) then\n! A:A:A:A\n! nperm=1\n! else\n! A:A:B:B = A:A:B:B, B:B:A:A\n! nperm=2\n! endif\n! else\n! A:A:B:C = A:A:B:C A:A:C:B B:C:A:A C:B:A:A\n! nperm=4\n! endif\n!------------------------------- same in simpler way\n mperm=0\n! find the number of permutations\n if(elal(1).eq.elal(2)) then\n if(elal(3).eq.elal(4)) then\n if(elal(3).eq.elal(1)) then\n! A:A:A:A\n mperm=1\n else\n! A:A:B:B\n mperm=2\n endif\n else\n! A:A:A:B = ...\n! A:A:B:C = A:A:B:C A:A:C:B B:C:A:A C:B:A:A\n mperm=4\n endif\n elseif(elal(3).eq.elal(4)) then\n! if(elal(3).eq.elal(2)) then\n! A:B:B:B = A:B:B:B B:A:B:B B:B:A:B B:B:B:A\n mperm=4\n! else\n! A:B:C:C = A:B:C:C B:A:C:C C:C:A:B C:C:B:A\n! mperm=4\n! endif\n elseif(elal(3).eq.elal(1) .and. elal(4).eq.elal(2)) then\n! A:B:A:B =\n mperm=4\n else\n! A:B:A:C =\n! A:B:B:C =\n! A:B:C:D =\n mperm=8\n endif\n! Code below is just to check the constituents are correctly sorted\n pch='G(BORD,'\n ip=8\n do ls=1,4\n if(elal(ls).lt.0) then\n pch(ip:)='*:'\n else\n! splista is ordered as the species are entered, thus splista(1) is VA\n! species(i) is the index in splista of elements in alphabetcal order\n pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':'\n endif\n ip=len_trim(pch)+1\n! when we are here there are no interactions\n! if(mint.le.nint .and. jord(1,mint).eq.ls) then\n! pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':'\n! ip=len_trim(pch)+1\n! mint=mint+1\n! endif\n enddo\n!\n pch(ip-1:)=';0)'\n! write(*,14)'3B sorted endmember: ',trim(pch),mperm\n14 format(a,a,i6)\n! now generate values in elinks\n noperm=mperm\n allocate(elinks(nsl,noperm))\n! elal is species index, it has to be converted to constituent index\n select case(noperm)\n case default\n write(*,*)'3B unknown permutation for bcc endmember: ',noperm\n gx%bmperr=4269\n!------------\n case(1) ! A:A:A:A\n do ls=1,4\n! findconst find the constituent index of species elal(ls) in sublattice ls\n! for wildcards elal(ls)=-99 that is propagated\n call findconst(lokph,ls,elal(ls),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,1)=cix\n enddo\n!---------------\n case(2) ! A:A:B:B B:B:A:A\n do ls=1,4\n call findconst(lokph,ls,elal(ls),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,1)=cix\n enddo\n do ls=1,2\n call findconst(lokph,ls,elal(ls+2),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,2)=cix\n enddo\n do ls=3,4\n call findconst(lokph,ls,elal(ls-2),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,2)=cix\n enddo\n!--------------\n case(4) ! several different cases but can be treated the same ???\n! A:B:A:B B:A:A:B B:A:B:A A:B:B:A 1234 4312 2143 3421\n! A:B:C:C C:C:A:B B:A:C:C C:C:B:A 1234 4312 2143 3421 \n! A:B:B:B B:B:A:B B:A:B:B B:B:B:A 1234 4312 2143 3421 \n! prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1]\n do mperm=0,noperm-1\n do ls=1,4\n call findconst(lokph,ls,elal(prm4(ls+4*mperm)),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,mperm+1)=cix\n enddo\n! write(*,66)mperm,(elinks(ls,mperm+1),ls=1,4)\n66 format('3B bccperm: ',i2,5x,4i4)\n enddo\n!--------------\n case(8) ! several cases all treated the same\n! 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\n! 1234 1243 2134 2143 3412 ...\n! 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\n! 1234 1243 2134 2134\n! 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\n! 1234 1243 2134\n! prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,&\n! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1]\n do mperm=0,7\n do ls=1,4\n call findconst(lokph,ls,elal(prm8(4*mperm+ls)),cix)\n if(gx%bmperr.ne.0) goto 1000\n elinks(ls,mperm+1)=cix\n enddo\n enddo\n end select\n!--------------------\n! constiuents in sublattice 5 to nsl are the same in all permutations\n! write(*,77)((elinks(ls,mperm),ls=1,4),mperm=1,noperm)\n77 format('3B perm:',4(4i4,2x))\n! write(*,*)'3B adding constituents: ',nsl,noperm\n do mperm=1,noperm\n do ls=5,nsl\n! these constituents are the same for all permutations\n call findconst(lokph,ls,elal(ls),cix)\n if(gx%bmperr.ne.0) goto 1000\n! elinks(ls,mperm)=elal(ls)\n elinks(ls,mperm)=cix\n! write(*,*)'3B notperm: ',elal(ls),cix\n enddo\n enddo\n!-----------------------\n1000 continue\n return\n end subroutine bccendmem\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bccint1\n!\\begin{verbatim}\n subroutine bccint1(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks)\n! generate all bcc permutations for a first order interaction\n implicit none\n! on entry noperm is the number of permutation of the endmember\n! on exit noperm is the number of permutation of the interaction\n integer lokph,nsl,noperm,nint\n! elal are the endmember species indices\n integer, dimension(*) :: elal\n! intperm has dimension 24 and contain propagation of interactions ?? \n integer, dimension(*) :: intperm\n! jord(1,int) is the interaction subl. and jord(2,int) the constituent index\n integer, dimension(2,*) :: jord\n! these contain the already allocated permutation of the endmember\n! integer, dimension(:,:), allocatable :: elinks\n integer, dimension(nsl,*) :: elinks\n! intlinks will be allocated here and will be stored in the parameter records\n! giving the constituent indices for permutations of the interactions\n! It may be reallocated if the interaction is second level\n integer, dimension(:,:), allocatable :: intlinks\n!\\end{verbatim} %+\n integer mint,ls,ip,nperm,mperm,cix,incperm,intem,lq,mq,subint(4)\n character pch*64\n! this is quite simple, the species jord(1,2) in sublattice jord(1,1) should\n! be repeated for all permutations of the endmember in jord(1,1)\n! noperm=1: 1,1,1,1\n! noperm=2: 1,1,2,2, 2,2,1,1\n! nopermg=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1]\n! noperm=8: prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,&\n! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1]\n integer, parameter :: prm4(16)=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1]\n integer, parameter :: prm8(32)=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,&\n 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1]\n! This is related to the order in prm4\n! WOW, comment 2023: I have completely forgotten how shape/reshape works ....\n integer, parameter :: &\n prmint4(4,4)=reshape([1,3,2,4,2,4,1,3,3,2,4,1,4,1,3,2],shape(prmint4))\n!\n! integer, parameter :: prmint4(4,4)=[[1,3,2,4],[2,4,1,3],[3,2,4,1],[4,1,3,2]]\n integer, parameter, dimension(8,4) :: &\n prmint8=reshape([1,1,2,2,3,4,3,4, 2,2,1,1,4,3,4,3,&\n 3,4,3,4,1,1,2,2, 4,3,4,3,2,2,1,1], shape(prmint8))\n! intperm(1)=number of interaction permutations on level 1 for each endmember\n! on level 1 each endmember permutation has the same\n! intperm(2)=total number of permutation links for level 1\n! intperm(3..) used for 2nd level\n! intlinks(1,iperm) is sublattice with interaction for permutation iperm\n! intlinks(2,iperm) is constituent index for permutation iperm\n!\n! noperm will be updated!!\n nperm=noperm\n! write(*,*)'3B in bccint1: ',jord(1,1),jord(2,1)\n! allocate sufficient number of sublattice/constituent pairs for permutations\n allocate(intlinks(2,100))\n! incperm is incremented for each permutation stored in intlinks\n incperm=0\n!\n select case(nperm)\n case default\n write(*,*)'illegal endmember permutation in bccint1',nperm\n gx%bmperr=4269\n!-------------------------\n case(1) ! same component and interaction in all 4 sublattices\n! this is the number of interaction permutation for each endmember\n intperm(1)=4\n! intperm(2) is intperm(1) multiplied with number of endmember permutation, 1\n intperm(2)=4\n do ls=1,4\n call findconst(lokph,ls,jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=ls\n intlinks(2,incperm)=cix\n enddo\n if(incperm.ne.intperm(2)) stop 'internal error 3B:17'\n!-------------------------\n case(2) ! A:A:B:B and B:B:A:A, two endmembers\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=2\n! intperm(2) depends on the number of endmember permutations, here 2, thus 4 ??\n intperm(2)=4\n if(jord(1,1).eq.1) then\n! for first endmember 2 permutations of interaction with A\n do ls=1,2\n call findconst(lokph,ls,jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=ls\n intlinks(2,incperm)=cix\n enddo\n! for second endmember 2 permutations of interaction with A\n do ls=3,4\n call findconst(lokph,ls,jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=ls\n intlinks(2,incperm)=cix\n enddo\n elseif(jord(1,1).eq.3) then\n! for first endmember 2 permutations of interaction with B\n do ls=3,4\n call findconst(lokph,ls,jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=ls\n intlinks(2,incperm)=cix\n enddo\n! for second endmember 2 permutations of interaction with B\n do ls=1,2\n call findconst(lokph,ls,jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=ls\n intlinks(2,incperm)=cix\n enddo\n else\n write(*,*)'3B interaction on wrong sublattice in BCC',jord(1,1)\n gx%bmperr=4399; goto 1000\n endif\n if(incperm.ne.intperm(2)) stop 'internal error 3B:18'\n!-------------------------\n case(4) ! many different permutations,\n! there are at least 2 identical species\n! A:B:A:B B:A:A:B B:A:B:A A:B:B:A 1234 4312 2143 3421\n! A:B:C:C C:C:A:B B:A:C:C C:C:B:A 1234 4312 2143 3421 \n! A:B:B:B B:B:A:B B:A:B:B B:B:B:A 1234 4312 2143 3421 \n! A:A:B:C C:B:A:A A:A:C:B B:C:A:A \n! set intem to the endmember species index of the sublattice with interaction\n intem=elal(jord(1,1))\n subint=0\n ip=0\n do ls=1,4\n if(elal(ls).eq.intem) then\n subint(ls)=1; ip=ip+1\n endif\n enddo\n! ip can be 1, 2 or 3\n select case(ip)\n case default\n write(*,*)'3B illegal case for interaction',ip\n gx%bmperr=4269; goto 1000\n!..................\n case(1) ! interaction with a component that appears only once: AX:B:B:B\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=1\n! intperm(2) depends on the number of endmember permutations, here 4, thus 4 ??\n intperm(2)=4\n incperm=0\n! find the sublattice with the endmember\n do ip=1,4\n if(subint(ip).eq.1) lq=ip\n enddo\n! if ls=1 the endmember varies 1, 3, 2, 4\n! 2 2, 4, 1, 3\n! 3 3, 2, 4, 1\n! 4 4, 1, 3, 2\n! probably one can permute the endmembers in a smarter way ....\n! noperm=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1]\n! A:B:C:D D:C:A:B B:A:D:C C:D:B:A\n! prmint4(1..4,1) = 1, 3, 2, 4 etc.\n do ls=1,4\n call findconst(lokph,prmint4(ls,lq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,lq)\n intlinks(2,incperm)=cix\n enddo\n!..................\n case(2) ! interaction with a component that appears twice: AX:B:A:B\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=2\n! intperm(2) depends on the number of endmember permutations, here 4, thus 8 ??\n intperm(2)=8\n! noperm=4: prm4=[1,2,3,4, 4,3,1,2, 2,1,4,3, 3,4,2,1]\n! A:B:A:B B:A:A:B B:A:B;A A;B;B;A\n! find the sublattice with the endmember\n lq=0; mq=0\n do ip=1,4\n if(subint(ip).eq.1) then\n if(lq.eq.0) then\n lq=ip\n else\n mq=ip\n endif\n endif\n enddo\n! create 2 links for each endmember permutation\n do ls=1,4\n call findconst(lokph,prmint4(ls,lq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,lq)\n intlinks(2,incperm)=cix\n call findconst(lokph,prmint4(ls,mq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,mq)\n intlinks(2,incperm)=cix\n enddo\n!..................\n case(3) ! interaction with a component that appears 3 times: A:BX:B:B\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=3\n! intperm(2) depends on the number of endmember permutations, here 4, thus 12??\n intperm(2)=12\n! create 3 links for each endmember permutation\n do ls=1,4\n do lq=1,4\n! subint(lq) is zero for the sublattice with endmember without interaction\n if(subint(lq).ne.0) then\n call findconst(lokph,prmint4(ls,lq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,lq)\n intlinks(2,incperm)=cix\n endif\n enddo\n enddo\n end select\n if(incperm.ne.intperm(2)) stop 'internal error 3B:20'\n!----------------------------------------\n case(8) ! many different permutations\n! 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\n! 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\n! 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\n! noperm=8: prm8=[1,2,3,4, 1,2,4,3, 2,1,3,4, 2,1,4,3,&\n! 3,4,1,2, 3,4,2,1, 4,3,1,2, 4,3,2,1]\n! integer, parameter, dimension(4,8) :: prmint8=[1,1,2,2,3,4,3,4,&\n! 2,2,1,1,4,3,4,3,&\n! 3,4,3,4,1,1,2,2,&\n! 4,3,4,3,2,2,1,1]\n intem=elal(jord(1,1))\n subint=0\n ip=0\n do ls=1,4\n if(elal(ls).eq.intem) then\n subint(ls)=1; ip=ip+1\n endif\n enddo\n! ip can be 1 or 2\n select case(ip)\n case default\n write(*,*)'3B illegal case for interaction',ip\n gx%bmperr=4269; goto 1000\n!..................\n case(1)\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=1\n! intperm(2) depends on the number of endmember permutations, here 8, thus 4 ??\n intperm(2)=8\n incperm=0\n! find the sublattice with the odd endmember (other 3 same)\n do ip=1,4\n if(subint(ip).eq.0) lq=ip\n enddo\n! create 1 link for each endmember permutation\n do ls=1,8\n call findconst(lokph,prmint8(ls,lq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,lq)\n intlinks(2,incperm)=cix\n enddo\n!..................\n case(2)\n! intperm(1) is the number of permutations for each endmember\n intperm(1)=2\n! intperm(2) depends on the number of endmember permutations, here 8, thus 16??\n intperm(2)=16\n incperm=0\n! create 1 link for each endmember permutation\n do ls=1,8\n do lq=1,4\n if(subint(lq).ne.0) then\n call findconst(lokph,prmint4(ls,lq),jord(2,1),cix)\n if(gx%bmperr.ne.0) goto 1000\n incperm=incperm+1\n intlinks(1,incperm)=prmint4(ls,lq)\n intlinks(2,incperm)=cix\n endif\n enddo\n enddo\n end select\n if(incperm.ne.intperm(2)) stop 'internal error 3B:21'\n end select\n! The interacting sublattice may have changed: correct jord(1,1)\n! write(*,*)'3B correct interacting sublattice: ',jord(1,1),intlinks(1,1)\n if(jord(1,1).ne.intlinks(1,1)) then\n! important!! if jord(1,2) same as jord(1,1) that must be changed too!!\n if(jord(1,2).eq.jord(1,1)) then\n jord(1,2)=intlinks(1,1)\n endif\n jord(1,1)=intlinks(1,1)\n endif\n!----------------------------------------\n! Just a check output\n mperm=1\n mint=1\n pch='G(BORD,'\n ip=8\n do ls=1,4\n if(elal(ls).lt.0) then\n pch(ip:)='*:'\n else\n! splista is ordered as the species are entered, thus splista(1) is VA\n! species(i) is the index in splista of elements in alphabetcal order\n pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':'\n endif\n ip=len_trim(pch)+1\n if(mint.le.1 .and. jord(1,mint).eq.ls) then\n pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':'\n ip=len_trim(pch)+1\n mint=mint+1\n endif\n enddo\n pch(ip-1:)=';0)'\n! write(*,14)'3B sorted interaction 1: ',trim(pch),&\n! intperm(1),intperm(2),incperm\n14 format(a,a,3i5)\n1000 continue\n return\n end subroutine bccint1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bccint2\n!\\begin{verbatim}\n subroutine bccint2(lokph,nsl,elal,noperm,elinks,nint,jord,intperm,intlinks)\n! generate all bcc permutations needed for a ternary or reciprocal parameter\n implicit none\n! on entry noperm is the number of permutations of the first interaction\n! on exit noperm is the number of permutations of the second interaction\n integer lokph,nsl,noperm,nint\n! elal are the endmember species indices\n integer, dimension(*) :: elal\n! intperm has dimension 24 and contain propagation of interactions ?? \n integer, dimension(*) :: intperm\n! jord(1,int) is the interaction subl. and jord(2,int) the constituent index\n integer, dimension(2,*) :: jord\n! elinks are the permutations of the endmember\n! integer, dimension(:,:), allocatable :: elinks\n integer, dimension(nsl,*) :: elinks\n! on entry intlinks are the permutations of the first interaction\n! on exit intlinks are the permutations of the second interaction\n! it must be deallocated and reallocated using int1links\n integer, dimension(:,:), allocatable :: int1links\n integer, dimension(:,:), allocatable :: intlinks\n!\\end{verbatim}\n integer mint,ls,ip,nperm,mperm,cix,incperm,intem,lq,mq,subint(4)\n integer loksp,np,nz,isp,sub1,shift\n character pch*64\n! when we are here we have already generated endmember permutations\n! and permutations for the first interaction.\n! elal are the constituent indices for the first (ordered) endmember\n! elinks are constituent indices for endmember permutations\n! jord(1,*) are sublattices, jord(2,*) are species indices of interactions\n! intperm(1) is the number of permutations for first interaction\n! intperm(2) is total number of interaction links for first interaction\n! intperm(3..) should be set here:\n! intperm(3) to number of different sets of permutations of 2nd interaction\n! this can be 1 if all equal, otherwise same as intperm(2) (??)\n! intperm(3+i) to number of permutation for set i of second interaction\n! intperm(4+intperm(2)) to total number of permutations\n! intlinks are pairs of sublattice/constituent for permutations \n! intlinks(1:2,1..intperm(2)) already set\n! noperm should be set to the number of permutations of this interaction ??\n! \n write(*,7)'3B entering bccint2',jord(1,1),jord(1,2),jord(2,2),&\n nint,noperm,intperm(1),intperm(2),(elal(ls),ls=1,4)\n7 format(a,3i4,2x,4i4,2x,4i4,2x,5i4)\n mperm=0\n notternary: if(jord(1,1).ne.jord(1,2)) then\n! reciprocal parameter, suck, complicated, noperm is endmember permuations\n! elal(*) are species indices of endmembers\n! jord(2,*) are species indices of interactions\n if(elal(jord(1,1)).eq.elal(jord(1,2)) .and. &\n jord(2,1).eq.jord(2,2)) then\n! we have interaction between the same two elements in two subl A,B:A,B:C:D\n! the endmember permutation determine what is C and D and sublattices\n!----------------------\n select case(noperm)\n case default\n write(*,*)'3B illegal value of noperm in bccint2'\n gx%bmperr=4277; goto 1000\n!----------------------\n! BCC permutations, \n case(1) ! A:A:A:A interaction AX:AX:A:A or AX:A:AX:A\n! Trying to understand this in December 2023/BoS\n! this is recipocal parameter for B32, it is binary and should be implemented!!\n! There are 4 permutations AX:A:AX:A, A:AX:AX:A, AX:A:A:AX and A:AX:A:AX \n! int1: AX:A:A:A A:AX:A:A A:A:AX:A \n! int2: AX:AX:A:A A:AX:AX:A A:A:AX:AX\n! AX:A:AX:A A:AX:A:AX -\n! AX:A:A:AX - - maybe not important\n write(*,*)'3B BCC reciprocal AX:AX:A:A not implemented case1'\n gx%bmperr=4277; goto 1000\n!----------------------\n case(2) ! A:A:B:B interaction AX:AX:B:B or A:A:BX:BX\n! This is reciprocal parameter in B2 ordering\n! int1: AX:A:B:B A:AX:B:B B:B:AX:A B:B:A:AX\n! int2: AX:AX:B:B none B:B:AX:AX none\n! This can handle A,B:A,B:*:*\n intperm(3)=2\n intperm(4)=1\n intperm(5)=0\n intperm(6)=2\n nz=intperm(2)\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n write(*,*)'3B reciprocal AB:AB:C:C',intperm(5),jord(1,2)\n if(jord(1,2).eq.2) then\n intlinks(1,nz+1)=2\n call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+2)=4\n call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2))\n if(gx%bmperr.ne.0) goto 1000\n else\n intlinks(1,nz+1)=4\n call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+2)=2\n call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2))\n if(gx%bmperr.ne.0) goto 1000\n endif\n!----------------------\n case(4) ! A:B:A:B and a ternary interaction, B can be wildcard\n! this is also the B32 binary reciprocal parameter such as A,B:*:A,B:*\n! int1: AB:*:A:* *:AB:A:* \n! int2: AB:*:AB:* *:AB:AB:*\n! AB:*:*:AB *:AB:*:AB\n! Trying to understand argument ... 2023/BoS\n write(*,11)'3B reciprocal AB:C:AB:C',noperm,(intperm(nz),nz=1,8)\n write(*,12)nint,(jord(1,nz),nz=1,nint),(jord(2,nz),nz=1,nint)\n11 format(a,i7,7i3)\n12 format(i3,5x,2i3,5x,2i3)\n write(*,*)'3B BCC B32 reciprocal interaction not implemented case4'\n gx%bmperr=4277\n!----------------------\n case(8) ! several other ternary excess parameters ignored\n write(*,*)'3B BCC reciprocal interaction not implemented case8'\n gx%bmperr=4277\n end select\n!----------------------\n elseif(elal(jord(1,1)).eq.elal(jord(1,2)) .or. &\n jord(2,1).eq.jord(2,2)) then\n! in interacting sublattices the endmembers or interactions are the same\n! common case 2: A,B:A,C:D:D (where D can be wildcard, A, B or C)\n! common case 3: A,C:B,C:D:D (where D can be wildcard, A, B or C)\n! 4 permutations: AB:AC:D:D AC:AB:D:D D:D:AB:AC D:D:AC:AB or\n! 8 permutations: AB:D:AC:D D:AB:AC:D AB:D:D:AC D:AB:D:AC \n! AC:D:AB:D D:AC:D:AB AC:D:D:AB D:AC:D:AB\n select case(noperm)\n case default\n write(*,*)'3B illegal value of noperm in bccint2'\n gx%bmperr=4277; goto 1000\n!----------------------\n case(1) ! A:A:A:A interaction AX:AY:A:A or AX:A:AY:A\n write(*,*)'3B BCC reciprocal AX:AY:A:A not implemented case1B'\n gx%bmperr=4277; goto 1000\n!----------------------\n case(2) ! A:A:B:B interaction AX:AY:B:B or A:A:BX:BY\n! int1: AX:A:B:B A:AX:B:B B:B:AX:A B:B:A:AX\n! int2: AX:AY:B:B AY:AX:B:B B:B:AX:AY B:B:AY:AX \n intperm(3)=1\n intperm(4)=1\n intperm(5)=4\n nz=intperm(2)\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n write(*,*)'3B reciprocal AB;AB:C:C',intperm(5),jord(1,2)\n if(jord(1,2).eq.2) then\n intlinks(1,nz+1)=2\n call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+2)=1\n call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+3)=4\n call findconst(lokph,intlinks(1,nz+3),isp,intlinks(2,nz+3))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+4)=3\n call findconst(lokph,intlinks(1,nz+4),isp,intlinks(2,nz+4))\n if(gx%bmperr.ne.0) goto 1000\n else\n intlinks(1,nz+1)=4\n call findconst(lokph,intlinks(1,nz+1),isp,intlinks(2,nz+1))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+2)=3\n call findconst(lokph,intlinks(1,nz+2),isp,intlinks(2,nz+2))\n intlinks(1,nz+3)=2\n if(gx%bmperr.ne.0) goto 1000\n call findconst(lokph,intlinks(1,nz+3),isp,intlinks(2,nz+3))\n if(gx%bmperr.ne.0) goto 1000\n intlinks(1,nz+4)=1\n call findconst(lokph,intlinks(1,nz+4),isp,intlinks(2,nz+4))\n if(gx%bmperr.ne.0) goto 1000\n endif\n!----------------------\n case(4) ! A:B:A:B not much used ??\n! This is the B32 reciprocal AB:*:AB:*\n write(*,*)'3B BCC interaction not implemented case 4B'\n gx%bmperr=4277\n!----------------------\n case(8) ! several\n write(*,*)'3B BCC interaction not implemented case 8B'\n gx%bmperr=4277\n end select\n!----------------------\n else\n! in subl with interactions neither interaction elements nor endmember sames\n! like A,B:B,C:D:E\n write(*,*)'3B BCC reciprocal interaction not implemented 20'\n gx%bmperr=4277\n endif\n!-------------------------------------------------------------\n else ! this is the ternary permutation\n! if second interaction in same sublattice as first it is simple!!\n! A,B,C:X:Y:Z has exactly the same permutations as A,B:X:Y:Z \n! NOT STORED CORRECTLY, bug when listing, also for option F!!! (never tested)\n intperm(3)=1\n intperm(4)=1\n! intperm(4+intperm(3)) should be total number of permutations!!\n! intperm(2) is number of endmeber+first interaction permutations\n intperm(5)=2*intperm(2)\n nz=intperm(2)\n loksp=phlista(lokph)%constitlist(jord(2,2))\n isp=splista(loksp)%alphaindex\n write(*,*)'3B ternary: ',trim(splista(species(jord(2,2)))%symbol),&\n nz,intlinks(1,1),isp\n do np=1,intperm(2)\n intlinks(1,nz+np)=intlinks(1,np)\n call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np))\n if(gx%bmperr.ne.0) goto 1000\n enddo\n endif notternary\n! Code below is just to check the constituents are correctly sorted\n900 continue\n mint=1\n pch='G(BORD,'\n ip=8\n do ls=1,4\n if(elal(ls).lt.0) then\n pch(ip:)='*:'\n else\n! splista is ordered as the species are entered, thus splista(1) is VA\n! species(i) is the index in splista of elements in alphabetcal order\n pch(ip:)=trim(splista(species(elal(ls)))%symbol)//':'\n endif\n ip=len_trim(pch)+1\n910 continue\n if(mint.le.nint .and. jord(1,mint).eq.ls) then\n pch(ip-1:)=','//trim(splista(species(jord(2,mint)))%symbol)//':'\n ip=len_trim(pch)+1\n mint=mint+1\n goto 910\n endif\n enddo\n pch(ip-1:)=';0)'\n write(*,14)'3B sorted interaction 2: ',trim(pch),intperm(4+intperm(3))\n14 format(a,a,4i5)\n1000 continue\n return\n end subroutine bccint2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tdbrefs\n!\\begin{verbatim}\n subroutine tdbrefs(refid,line,mode,iref)\n! store a reference from a TDB file or given interactivly\n! If refid already exist and mode=1 then amend the reference text\n implicit none\n character*(*) refid,line\n integer mode,iref\n!\\end{verbatim}\n integer ip,ml,nr,mc,nc,jl\n! make sure refid is left adjusted\n ip=0\n10 ip=ip+1\n if(ip.gt.len(refid)) then\n gx%bmperr=4154; goto 1000\n endif\n if(refid(ip:ip).eq.' ') goto 10\n if(ip.gt.1) refid=refid(ip:)\n! make it upper case\n call capson(refid)\n! look if refid already exist\n do iref=1,reffree-1\n if(refid.eq.bibrefs(iref)%reference) then\n if(mode.eq.1) then\n! write(*,70)i,refid,bibrefs(i)%refspec\n!70 format('3B tdbrefs: ',i4,a,a)\n! deallocate(bibrefs(iref)%refspec)\n! deallocate(bibrefs(iref)%nyrefspec)\n deallocate(bibrefs(iref)%wprefspec)\n goto 200\n else\n! reference already exist and no changes needed\n goto 1000\n endif\n endif\n enddo\n! if bibliographic reference does not exist do not create\n if(mode.eq.1) goto 1000\n iref=reffree\n reffree=reffree+1\n bibrefs(iref)%reference=refid\n200 continue\n ml=len_trim(line)\n! nr=(ml+63)/64\n! allocate(bibrefs(iref)%refspec(nr))\n if(ml.gt.1024) then\n write(*,*)'Bibliographic references longer than 1024 will be truncated'\n mc=nwch(1024)+1\n else\n mc=nwch(ml)+1\n endif\n allocate(bibrefs(iref)%wprefspec(mc))\n! This requires Fortran 2003/2008 standard\n! allocate(character(len=mc) :: bibrefs(iref)%nyrefspec)\n! mc=1\n! nc=0\n! bibrefs(iref)%nyrefspec=line(1:mc)\n bibrefs(iref)%wprefspec(1)=ml\n call storc(2,bibrefs(iref)%wprefspec,line(1:ml))\n! write(*,202)'3B newref: ',iref,refid,nr,line(1:min(32,len_trim(line)))\n!202 format(a,i4,1x,a,i3,1x,a)\n! do jl=1,nr\n! 1-64 mc=1, nc=64\n! 65-122\n! bibrefs(iref)%refspec(jl)=' '\n! nc=nc+min(ml,64)\n! bibrefs(iref)%refspec(jl)=line(mc:nc)\n! mc=nc+1\n! ml=ml-64\n! enddo\n1000 continue\n return\n end subroutine tdbrefs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_equilibrium\n!\\begin{verbatim}\n subroutine enter_equilibrium(name,number)\n! creates a new equilibrium. Allocates arrayes for conditions\n! components, phase data and results etc.\n! returns index to new equilibrium record\n! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be\n! copied as a whole, not each record structure separately ... ???\n implicit none\n character name*(*)\n integer number\n!\\end{verbatim} %+\n! allocate\n TYPE(gtp_phase_varres), pointer :: cpv,cp1\n character name2*64\n integer ieq,ipv,nc,jz,iz,jl,jk,novarres,lokdis,needcs,lokph\n if(.not.allowenter(3)) then\n write(*,*)'3B: not allowed enter equilibrium: ',name\n gx%bmperr=4153; goto 1000\n endif\n! if name is empty or has a non-alphabetical letter first generate a name ??\n name2=name\n call capson(name2)\n! write(*,3)'3B In enter equilibria: ',name,noofph,eqfree,csfree,highcs\n3 format(a,1x,a,6i5)\n if(.not.proper_symbol_name(name2,0)) then\n! the name must start with a letter A-Z and contain letters, numbers and _\n gx%bmperr=4122\n goto 1000\n endif\n call findeq(name2,ieq)\n if(gx%bmperr.eq.0) then\n! error as equilibrium with this name already exists\n gx%bmperr=4123\n goto 1000\n else\n! Error code 4124 means no such equilibrium, OK as we are creating it!\n! Any other error code will cause error return\n if(gx%bmperr.ne.4124) goto 1000\n gx%bmperr=0\n endif\n if(eqfree.le.maxeq) then\n ieq=eqfree\n eqfree=eqfree+1\n endif\n number=ieq\n if(ocv()) write(*,*)'3B create eq',eqfree,maxeq,ieq\n! allocate data arrayes in equilibrium record\n eqlista(ieq)%nexteq=0\n eqlista(ieq)%eqname=name2\n eqlista(ieq)%eqno=ieq\n eqlista(ieq)%weight=-one\n eqlista(ieq)%comment=' '\n! component list and matrix, if second or higher equilibrium copy content\n if(ocv()) write(*,*)'3B: entereq 1: ',maxel,ieq,noofel\n if(ieq.eq.1) then\n! allocate large arrays as we do not know what system will be calculated\n allocate(eqlista(ieq)%complist(maxel))\n allocate(eqlista(ieq)%compstoi(maxel,maxel))\n allocate(eqlista(ieq)%invcompstoi(maxel,maxel))\n allocate(eqlista(ieq)%cmuval(maxel))\n eqlista(ieq)%cmuval=zero\n! this is a bit meaningless but skipping it has given raise to strange errors\n eqlista(ieq)%compstoi=zero\n eqlista(ieq)%invcompstoi=zero\n do jl=1,maxel\n eqlista(ieq)%compstoi(jl,jl)=one\n eqlista(ieq)%invcompstoi(jl,jl)=one\n! valgrind complained this was not set !!\n eqlista(ieq)%complist(jl)%chempot=zero\n enddo\n! Maybe valgrind complained of this ... it can have to do with -finit-local-zero\n eqlista(ieq)%status=0\n eqlista(ieq)%status=ibset(eqlista(ieq)%status,EQNOEQCAL)\n else\n eqlista(ieq)%status=0\n! we should set some status bits ...\n eqlista(ieq)%status=ibset(eqlista(ieq)%status,EQNOEQCAL)\n allocate(eqlista(ieq)%complist(noofel))\n! copy mass of components, maybe other components?\n do jl=1,noofel\n eqlista(ieq)%complist(jl)%mass=firsteq%complist(jl)%mass\n enddo\n allocate(eqlista(ieq)%compstoi(noofel,noofel))\n allocate(eqlista(ieq)%invcompstoi(noofel,noofel))\n allocate(eqlista(ieq)%cmuval(noofel))\n! this is a bit meaningless but skipping it has given raise to strange errors\n eqlista(ieq)%compstoi=zero\n eqlista(ieq)%invcompstoi=zero\n do jl=1,noofel\n eqlista(ieq)%compstoi(jl,jl)=one\n eqlista(ieq)%invcompstoi(jl,jl)=one\n enddo\n eqlista(ieq)%cmuval=zero\n if(ocv()) write(*,*)'3B: entereq 1B: '\n do jl=1,noofel\n eqlista(ieq)%complist(jl)%splink=firsteq%complist(jl)%splink\n eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink\n eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status\n! if(firsteq%complist(jl)%phlink.gt.0) then\n! only if there is a defined reference state\n eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate\n eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref\n eqlista(ieq)%complist(jl)%chempot=zero\n do jk=1,noofel\n eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk)\n eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk)\n enddo\n if(allocated(firsteq%complist(jl)%endmember)) then\n iz=size(firsteq%complist(jl)%endmember)\n if(ocv()) write(*,*)'3B: entereq 1E: ',iz\n allocate(eqlista(ieq)%complist(jl)%endmember(iz))\n eqlista(ieq)%complist(jl)%endmember=&\n firsteq%complist(jl)%endmember\n endif\n! endif\n enddo\n endif\n! write(*,*)'3B enter_eq 2, after this segmentation fault'\n! these records keep calculated values of G and derivatives for each phase\n! For phase lokph the index to phase_varres is in phlista(lokph)%cslink\n! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics)\n if(ocv()) write(*,*)'3B: entereq 2: ',maxph\n alleq: if(ieq.eq.1) then\n needcs=2*maxph\n allocate(eqlista(ieq)%phase_varres(needcs))\n firsteq=>eqlista(ieq)\n! %multiuse is used for axis and direction of a start equilibrium\n firsteq%multiuse=0\n! we should also set phstate in all phase_varres to 0 to avoid uninitiated\n! test of phase status in test_phase_status!!\n do ipv=1,needcs\n firsteq%phase_varres(ipv)%phstate=0\n enddo\n! endif is at label 900, no need for goto\n! goto 900\n else\n eqlista(ieq)%multiuse=0\n! UNFINISHED vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! this is not good, csfree is not the last used phase_varres\n! there may be allocated records after and unallocated before !!\n! if(highcs.ne.csfree-1) then\n! write(*,*)'3B Beware, problems with varres records!',csfree,highcs\n! endif\n novarres=highcs\n! the next line should be removed when highcs correctly implemented\n novarres=csfree-1\n iz=noofph\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! for ieq>1 allocate an estimated number of phase_varres records\n! for extra composition sets added later\n! allocate(eqlista(ieq)%phase_varres(iz+10))\n! I had a case with 4 components, 1 phase+disordered fraction set\n! and with 4 compositon sets!!\n needcs=2*noofph+2*noofel+10\n if(csfree.gt.needcs .or. highcs.gt.needcs) then\n write(*,*)'3B Error allocating phase_varres: ',needcs,csfree,highcs\n needcs=max(csfree,highcs)+10\n endif\n! the +10 should cater for compostion sets created due to miscibility gaps\n! and also disordered fractions sets\n allocate(eqlista(ieq)%phase_varres(needcs))\n! write(*,*)'3B enter_eq 2B, after this segmentation fault'\n! write(*,*)'3B varres: ',ieq,size(eqlista(ieq)%phase_varres),iz\n if(ocv()) write(*,*)'3B varres: ',ieq,size(eqlista(ieq)%phase_varres)\n! now copy the current content of firsteq%phase_varres to this equilibrium\n! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0\n! and phase_varres index 1, the number of phase_varres records is not the\n! same as number of phases ....\n novarres=needcs\n! copy also unused varres records, we do not really how many is used ...\n copypv: do ipv=1,novarres\n! note eqlista(1) is identical to firsteq\n if(.not.allocated(firsteq%phase_varres(ipv)%yfr)) then\n! UNFINISHED this handels unallocated records below novarres\n! write(*,*)'3B problem creating varres record',ipv\n! BUT what about allocated after !!! no problem so far but .............\n cycle copypv\n endif\n cp1=>eqlista(1)%phase_varres(ipv)\n cpv=>eqlista(ieq)%phase_varres(ipv)\n cpv%nextfree=cp1%nextfree\n cpv%phlink=cp1%phlink\n cpv%phstate=cp1%phstate\n cpv%status2=cp1%status2\n cpv%abnorm=cp1%abnorm\n cpv%prefix=cp1%prefix\n cpv%suffix=cp1%suffix\n cpv%phtupx=cp1%phtupx\n! Be careful, in first equilibrium these arrays are dimentioned very large\n! allocate and copy arrays\n lokph=cp1%phlink\n if(lokph.le.0) then\n! maybe problem here for SELECT_ELEMENT_REFERENCE ??\n! write(*,*)'No phase? ',ipv\n nc=noofel\n else\n nc=phlista(lokph)%tnooffr\n endif\n! note SIZE gives rubbish unless array is allocated\n if(ocv()) write(*,*)'3B copy yfr 1: ',nc\n! yfr may be allocated if this composition set is a disordered fraction set\n if(allocated(cpv%yfr)) then\n write(*,*)'3B fractions already allocated: ',ieq,ipv\n cycle copypv\n endif\n allocate(cpv%yfr(nc))\n cpv%yfr=cp1%yfr\n! problems with phase_varres in equilibrium 2 ...\n! write(*,46)'3B 1: ',cp1%yfr\n! write(*,46)'3B v: ',cpv%yfr\n46 format('yfr ',a,10(F7.3))\n allocate(cpv%constat(nc))\n cpv%constat=cp1%constat\n! write(*,*)'3B enter_eq 2C, after this segmentation fault'\n if(allocated(cp1%mmyfr)) then\n! problem with mmyfr??? .... no\n! if(ocv()) write(*,*)'3B mmyfr 1: ',ipv,cpv%phlink,nc\n allocate(cpv%mmyfr(nc))\n cpv%mmyfr=cp1%mmyfr\n! write(*,34)'3B mmyfr 2: ',(cpv%mmyfr(jz),jz=1,nc)\n34 format(1x,a,10(F7.3))\n! else\n! write(*,*)'3B mmyfr not allocated'\n endif\n jz=size(cp1%sites)\n allocate(cpv%sites(jz))\n cpv%sites=cp1%sites\n! these are currently not allocated (ionic liquid model) Maybe not needed??\n if(allocated(cp1%dpqdy)) then\n jz=size(cp1%dpqdy)\n allocate(cpv%dpqdy(jz))\n cpv%dpqdy=cp1%dpqdy\n jz=size(cp1%d2pqdvay)\n allocate(cpv%d2pqdvay(jz))\n cpv%d2pqdvay=cp1%d2pqdvay\n endif\n! the values in the following arrays are irrelevant, just allocate and zero\n! write(*,*)'3B enter_eq 2D, after this segmentation fault',ipv,novarres\n cpv%nprop=cp1%nprop\n allocate(cpv%listprop(cp1%nprop))\n allocate(cpv%gval(6,cp1%nprop))\n allocate(cpv%dgval(3,nc,cp1%nprop))\n allocate(cpv%d2gval(nc*(nc+1)/2,cp1%nprop))\n cpv%listprop=0\n cpv%amfu=zero\n cpv%dgm=zero\n cpv%phstate=PHENTERED\n cpv%netcharge=zero\n cpv%gval=zero\n cpv%dgval=zero\n cpv%d2gval=zero\n! copy the disordered fraction record, that should take care of all\n! array allocations inside the disfra record ???\n cpv%disfra=cp1%disfra\n!-------------------------------------------------------------------\n! attempt to correct segmentation fault 2017.12.09/BoS\n! This is correct but the varres records for the disordered fraction sets\n! will be copied in this loop anyway\n! disordered: if(cpv%disfra%varreslink.gt.0) then\n! if there is a disordered phase_varres record that must be taken care of\n! lokdis=cpv%disfra%varreslink\n! eqlista(ieq)%phase_varres(lokdis)%abnorm=&\n! eqlista(1)%phase_varres(lokdis)%abnorm\n! !!!! WOW it really seems to copy a whole phase_varres record just by = !!!\n! eqlista(ieq)%phase_varres(lokdis)=eqlista(1)%phase_varres(lokdis)\n! !!! NO!!! an assignment = will only copy local data in the record\n! records accessed by pointers (such as conditions !!!)\n! are not copied and point at at the same records as\n! in the old phase_varres record\n! endif disordered\n!-------------------------------------------------------------------\n enddo copypv\n! write(*,*)'3B enter_eq 2E, after this segmentation fault'\n endif alleq\n! From here also for first equilibria\n900 continue\n! write(*,*)'3B enter_eq 3'\n if(ocv()) write(*,*)'3B: entereq 3: '\n! nullify condition links, otherwise \"if(associated(..)\" does not work\n nullify(eqlista(ieq)%lastcondition)\n nullify(eqlista(ieq)%lastexperiment)\n if(ocv()) write(*,*)'3B set T and P',ieq\n! also set default local values of T and P (not conditions)\n eqlista(ieq)%tpval(1)=1.0D3; eqlista(ieq)%tpval(2)=1.0D5\n! allocate and copy tpfun result array also for first equilibria\n! jz=size(firsteq%eq_tpres)\n jz=maxtpf\n! write(*,*)'3B enter_eq 4',jz,maxsvfun\n if(ocv()) write(*,*)'3B: entereq 4: ',jz,maxsvfun\n! write(*,*)'3B create equil tpres size ',jz,notpf()\n! Valgrind wants us to initiate eq_tpres%forcenewcalc !!!\n! This is probably quite messy as eq_pres are pointers???\n!! eq_tpres already allocated in gtp_init???\n! allocate(eqlista(ieq)%eq_tpres(jz))\n if(.not.allocated(eqlista(ieq)%eq_tpres)) then\n! if(ieq.ne.1) then\n! write(*,*)'3B Allocating eq_tpres for equil: ',ieq,jz,freetpfun\n allocate(eqlista(ieq)%eq_tpres(jz))\n! endif\n endif\n! this should be done in init_tpfun (gtp3Z.F90) ??\n do iz=1,jz\n eqlista(ieq)%eq_tpres(iz)%forcenewcalc=0\n enddo\n! allocate result array for state variable functions (svfunres)\n if(ocv()) write(*,*)'3B maxsvfun: ',ieq,maxsvfun,jz\n! write(*,*)'3B Allocating svfunres for equilibrium: ',name(1:len_trim(name))\n allocate(eqlista(ieq)%svfunres(maxsvfun))\n! convergence criteria PHTUPX\n eqlista(ieq)%xconv=firsteq%xconv\n eqlista(ieq)%gdconv(1)=firsteq%gdconv(1)\n eqlista(ieq)%gdconv(2)=firsteq%gdconv(2)\n eqlista(ieq)%maxiter=firsteq%maxiter\n1000 continue\n if(ocv()) write(*,*)'3B finished enter equilibrium',ieq\n return\n end subroutine enter_equilibrium !allocate\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine geneqname\n!\\begin{verbatim}\n subroutine geneqname(text)\n! creates a equilibrium name like EQ_x where x is the freeq in text\n implicit none\n character text*(*)\n!\\end{verbatim}\n integer ip\n text='EQ_'\n ip=4\n call wriint(text,ip,eqfree)\n! write(*,*)'3B eqname: ',trim(text),len_trim(text),eqfree\n1000 continue\n end subroutine geneqname\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine enter_many_equil\n!\\begin{verbatim}\n subroutine enter_many_equil(cline,last,pun)\n! executes an enter many_equilibria command\n! and creates many similar equilibria from a table\n! pun is file units for storing experimental dataset, pun(i)>0 if i is open\n implicit none\n character*(*) cline\n integer last,pun(9)\n!\\end{verbatim}\n! enter many_equilibria\n! by default all phases suspended\n! 1 entered phases \n! 2 fixed phases \n! 3 dormant phases \n! 4 conditions ....\n! 5 experiments ....\n! 6 calculate symbols \n! 7 list state_variables \n! 8 table_start\n! values in columns ...\n! 9 table_end\n!10 referece state\n!11 plot_data\n!12 not used\n!\n! values required by @ will appear in table in column order\n! EXAMPLE:\n! enter many_equilibria\n! fixed 1 liquid @1\n! condition T=1000 p=1e5\n! experiment x(liq,cr)=@2:@3 x(@1,cr)=@4:10%\n! table_start\n! bcc 0.15 0.02 0.20\n! ...\n! table_end\n! expanded experiment line:\n! experiment x(liq,cr)=0.15:0.02 x(bcc,cr)=0.20:10%\n!\n! ncom is numbor of command, ncol is max number of columns in tables\n integer, parameter :: ncom=12,ncol=9\n character (len=12), dimension(ncom), parameter :: commands=&\n! 123456789.12...123456789.12...123456789.12...123456789.12\n ['FIXED ','ENTERED ','DORMANT ','CONDITIONS ',&\n 'EXPERIMENTS ','CALCULATE ','LIST ','TABLE_START ',&\n 'COMMENT ','REFERENCE_S ','PLOT_DATA ',' ']\n character*128 rowtext(ncom),text*128,dummy*128,tval*24,savetitle*24\n character*128 eqlin(ncom),eqname*24,plotdatafile*8,encoded*24\n character*512 curdir\n integer dcom,kom,done(ncom),ip,jp,kp,ival,jval,neq,slen,shift,ieq,nystat\n integer iel,iph,ics,maxcol,jj\n type(gtp_equilibrium_data), pointer ::ceq\n double precision xxx,xxy,pxx,pyy,tpa(2),xarr(6)\n! This is to know where to store column values from a row\n TYPE gtp_row\n integer column,position\n end type gtp_row\n type(gtp_row), dimension(ncom,ncol) :: colvar,coleq \n logical plotfile\n!\n done=0\n plotfile=.FALSE.\n do ip=1,ncom-1\n colvar(ip,1)%column=0\n rowtext(ip)=' '\n enddo\n maxcol=0\n dcom=0\n100 continue\n call gparcdx('Table head line: ',cline,last,5,text,' ','?Enter many equil')\n kom=ncomp(text,commands,ncom,last)\n if(kom.le.0) then\n write(kou,110)text(1:len_trim(text))\n110 format('Error in subcommand to enter many: ',a)\n gx%bmperr=4278; goto 1000\n endif\n! the table_start command means end of head, generate one equilibria per row\n if(kom.eq.8) goto 299\n! =================================================================\n! the heading is stored in character array rowtext(1..12)\n! Keep the whole line, the only thing we handle now are column references\n dcom=dcom+1\n rowtext(dcom)=cline\n!=====================================================================\n! seach for column indicators @digit (0< digit <=9)\n ip=1\n200 continue\n! write(*,*)'3B at 200: ',rowtext(kom)(ip:len_trim(rowtext(kom))),ip\n jp=index(rowtext(dcom)(ip:),'@')\n if(jp.gt.0) then\n! only a single digit allowed!!\n ival=ichar(rowtext(dcom)(ip+jp:ip+jp))-ichar('0')\n if(ival.le.0 .or. ival.gt.9) then\n write(*,*)'3B Error in line: \"',trim(rowtext(dcom)),'\"'\n gx%bmperr=4399; goto 1000\n endif\n! maxcol is the maximal column referred to in the head\n if(ival.gt.maxcol) maxcol=ival\n if(ival.le.0 .or. ival.gt.9) then\n! column 0 is name of equilibrium, not a value\n write(kou,*)ival,rowtext(dcom)(1:jp+1)\n210 format('Illegal column for variable: ',i3,': ',a)\n gx%bmperr=4399; goto 1000\n else\n do kp=1,ncol\n if(colvar(dcom,kp)%column.eq.0) then\n if(kp.lt.ncol) colvar(dcom,kp+1)%column=0\n colvar(dcom,kp)%column=ival\n colvar(dcom,kp)%position=ip+jp-1\n goto 250\n endif\n enddo\n! write(kou,240)ncol,dcom,rowtext(dcom)(1:len_trim(rowtext(dcom)))\n240 format('More than ',i2,' column variables used in row ',i3/a)\n gx%bmperr=4279; goto 1000\n! no problem, continue\n250 continue\n endif\n ip=ip+jp\n if(ip.lt.len_trim(rowtext(dcom))) then\n goto 200\n endif\n endif\n! force reading next command line from file or keyboard\n last=len(cline)\n goto 100\n!\n!------------------------------------------------------------\n! Now start generating one equilibrium per line in table\n299 continue\n neq=0\n300 continue\n! we must not destroy the values in colvar and rowtext!!\n coleq=colvar\n eqlin=rowtext\n! This is input of lines of the many-equilibria\n call gparcx('Table row: ',cline,last,5,text,' ','?Enter table row')\n! allow empty lines\n if(len_trim(text).le.1) goto 300\n! remove TAB characters\n call untab(text)\n! make all upper case\n call capson(text)\n! write(*,*)'3B 300: ',cline(1:len_trim(cline))\n if(text(1:5).eq.'TABLE') then\n! finish if first word on line is \"TABLE\" meaning TABLE_END\n! the beginning has already passed\n write(kou,310)neq\n310 format('Created ',i5,' equilibria')\n goto 1000\n endif\n! values are in column order,the digit after @\n ip=0\n values: do ival=0,maxcol\n! value in column ival should replace all @digit in all lines, allow \",\" in tval\n call getext(text,ip,2,tval,' ',slen)\n! write(*,*)'3B tval: ',tval,slen,ival\n if(slen.le.0) then\n write(kou,*)'Table row missing value in column: ',ival\n gx%bmperr=4280; goto 1000\n endif\n! first value, in column 0, is equilibrium name\n if(ival.eq.0) then\n eqname=tval; cycle values\n endif\n! the column value can be used in several places, also in the same row\n com2: do jp=1,ncom-1\n shift=0\n com3: do kp=1,ncol\n if(coleq(jp,kp)%column.gt.0) then\n! write(*,330)'3B replace: ',jp,kp,coleq(jp,kp)%column,ival,&\n! shift,tval\n330 format(a,2i3,i14,2i4,': ',a)\n if(coleq(jp,kp)%column.eq.ival) then\n! insert column value at coleq(jp,kp)%position\n dummy=eqlin(jp)(coleq(jp,kp)%position+2:)\n eqlin(jp)(coleq(jp,kp)%position:)=tval\n eqlin(jp)(coleq(jp,kp)%position+slen:)=dummy\n! write(*,*)'3B eqlin: ',eqlin(jp)(1:len_trim(eqlin(jp)))\n shift=shift+slen-2\n else\n! we must update all following positions in coleq(jp,...)\n! write(*,332)'3B shifting: ',jp,kp,coleq(jp,kp)%position,shift\n332 format(a,2i3,2x,2i4)\n coleq(jp,kp)%position=coleq(jp,kp)%position+shift\n endif\n else\n cycle com2\n endif\n enddo com3\n enddo com2\n enddo values\n! check the final equilibrium description\n neq=neq+1\n! write(*,*)'3B New equilibrium: ',eqname,dcom\n! do kom=1,dcom\n! write(kou,340)neq,kom,eqlin(kom)(1:len_trim(eqlin(kom)))\n!340 format('3B cc',2i3,' :',a)\n! enddo\n!========================================================================\n! create the equilibrium using the row values\n! write(*,*)'3B enter equilibrium: ',eqname,ieq\n call enter_equilibrium(eqname,ieq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3B entered equilibrium: ',eqname\n call selecteq(ieq,ceq)\n! write(kou,515)eqname,ieq\n!515 format('3B Entered equilibrium: ',a,' with number ',i4)\n! by default set all phases suspended\n ip=-1; jp=1; nystat=PHSUS; xxx=zero\n! write(*,*)'3B suspending all phases'\n call change_phase_status(ip,jp,nystat,xxx,ceq)\n! call change_many_phase_status(tval,nystat,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!========================================================================\n! now set values for the equilibrium description with dcom lines\n! THESE COMMANDS IS NOT INTERACTIVE, they should be read from a file\n do jval=1,dcom\n kom=ncomp(eqlin(jval),commands,ncom,last)\n! write(*,12)'3B eqlin: ',jval,trim(eqlin(jval)),last,kom\n12 format(a,i3,' \"',a,'\" ',2i3)\n SELECT CASE(kom)\n!---------------------------\n CASE DEFAULT\n write(*,*)'Error generating equilibrium: ',trim(eqlin(jval))\n!---------------------------\n CASE(1,2)! fixed and entered phases\n! pick up the number of moles of the phases as first argument after command\n call getext(eqlin(jval),last,1,tval,'1.0',slen)\n ip=1\n call getrel(tval,ip,xxx)\n if(buperr.ne.0) then\n write(*,11)'3B Line causing error: ',trim(eqlin(jval))\n11 format(/a,' \"',a,'\"'/)\n gx%bmperr=4281; goto 1000\n endif\n nystat=PHFIXED\n if(kom.eq.2) nystat=PHENTERED\n if(eolch(eqlin(jval),last)) then\n write(*,*)'3B no phase name after status command'\n gx%bmperr=4282; goto 1000\n endif\n call change_many_phase_status(eqlin(jval)(last:),nystat,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------\n CASE(3)! domant phases\n nystat=PHSUS\n xxx=zero\n call change_many_phase_status(eqlin(jval)(last:),nystat,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------\n CASE(4)! conditions\n ip=0\n call set_condition(eqlin(jval)(last:),ip,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------\n CASE(5)! experiments\n ip=0\n! write(*,*)'3B exp: \"',trim(eqlin(jval)(last:)),'\"',jp\n call enter_experiment(eqlin(jval)(last:),ip,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!---------------------------\n CASE(6)! calculate symbol\n if(.not.allocated(ceq%eqextra)) then\n allocate(ceq%eqextra(3))\n ceq%eqextra(2)=' '\n ceq%eqextra(3)=' '\n endif\n ceq%eqextra(1)=eqlin(jval)(last:)\n!---------------------------\n CASE(7)! list state variables and modelled properties\n if(.not.allocated(ceq%eqextra)) then\n allocate(ceq%eqextra(3))\n ceq%eqextra(1)=' '\n ceq%eqextra(3)=' '\n endif\n ceq%eqextra(2)=eqlin(jval)(last:)\n!---------------------------\n! CASE(8)! table start should never occur\n!---------------------------\n CASE(9)! comment\n ceq%comment=eqlin(jval)(last:)\n!---------------------------\n CASE(10)! reference state\n call gparcx('Component name: ',eqlin(jval),last,1,tval,' ',&\n '?Enter many equil')\n call find_component_by_name(tval,iel,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call gparcx('Reference phase: ',eqlin(jval),last,1,tval,'SER ',&\n '?Enter many equil')\n if(tval(1:4).eq.'SER ') then\n! write(kou,*)'Reference state is stable phase at 298.15 K and 1 bar'\n! this means no reference phase, SER is at 298.15K and 1 bar\n iph=-1\n else\n call find_phase_by_name(tval,iph,ics)\n if(gx%bmperr.ne.0) goto 1000\n! temperature * means always to use current temperature\n xxy=-one\n call gparrx('Temperature: /*/: ',eqlin(jval),last,xxx,xxy,&\n '?Enter many equil')\n if(buperr.ne.0) then\n! write(*,*)'3B buperr: ',buperr\n buperr=0\n tpa(1)=-one\n elseif(xxx.le.zero) then\n tpa(1)=-one\n else\n tpa(1)=xxx\n endif\n xxy=1.0D5\n call gparrdx('Pressure: ',eqlin(jval),last,xxx,xxy,&\n '?Enter many equil')\n if(xxx.le.zero) then\n tpa(2)=xxy\n else\n tpa(2)=xxx\n endif\n endif\n! write(*,*)'3B Reference T and P: ',tpa\n call set_reference_state(iel,iph,tpa,ceq)\n!---------------------------\n CASE(11)! PLOT_DATA\n call getint(eqlin(jval),last,ip)\n if(buperr.ne.0) then\n write(kou,*)'Dataset number must be 1 to 9',buperr\n elseif(ip.eq.0) then\n! this is a special plotdata file for calculated values, store in eqextra(3)\n if(.not.allocated(ceq%eqextra)) then\n allocate(ceq%eqextra(3))\n ceq%eqextra(1)=' '\n ceq%eqextra(2)=' '\n endif\n ceq%eqextra(3)=' 0 '//eqlin(jval)(last:)\n! write(*,*)'3B eqextra(3): ',trim(ceq%eqextra(3))\n else\n if(ip.le.0 .or. ip.gt.9) then\n write(*,*)'3B plot_data dataset must be from 1 to 9'\n goto 1000\n endif\n! this is for plot datafile 1 to 9\n if(pun(ip).eq.0) then\n! open file\n pun(ip)=30+ip\n plotdatafile='oc_many0'\n plotdatafile(8:8)=char(ichar('0')+ip)\n! call getcwd(curdir) \n! write(*,*)'3B current dir: ',trim(curdir)\n! write(*,*)'3B working dir: ',trim(workingdir)\n write(*,77)plotdatafile//'.plt',trim(workingdir)\n77 format('3B Plot data written on ',a/3x,'in directory: ',a)\n open(pun(ip),file=trim(workingdir)//'/'//plotdatafile//'.plt',&\n access='sequential',status='unknown')\n call getrel(eqlin(jval),last,pxx)\n call getrel(eqlin(jval),last,pyy)\n call getint(eqlin(jval),last,iel)\n if(buperr.ne.0) then\n write(*,*)'3B Incorrect values in plot_data: ',&\n trim(eqlin(jval))\n buperr=0\n endif\n if(eolch(eqlin(jval),last)) then\n savetitle='Unknown'\n else\n savetitle=trim(eqlin(jval)(last:))\n endif\n! write(pun(ip),600)iel,trim(eqlin(jval)(last:))\n write(pun(ip),600)\n600 format('# GUNPLOT file generated by enter many_equilibria '/&\n 'set title \"Open Calphad 5 : with GNUPLOT\"'/&\n 'set xlabel \"whatever\"'/&\n 'set ylabel \"whatever\"'/&\n 'set key bottom right'/&\n '#'/'# You can use expressions to convert values:'/&\n '# using (1-$3):2 means x-value is \"1-value in column 3\",',&\n ' y-value is column 2'/'#'/&\n '# pt pointtype 1 +, 2 x, 3 star, 4 square, 5 filled square, 6 circle',/&\n '#',14x,'7 filled circle, 8 triangle up, 9 filled triangle up'/&\n '#',14x,'10 triangle down, 11 filled triangle down, 12 romb'/&\n '#',14x,'13 filled romb, 14 pentad, 15 filled pentad, 16 same as 1 etc'/&\n '# ps pointsize'/'#'/&\n '# To make a nice plot with different symbols for each experimentalist'/&\n '# add a plot command for each pointtype with a separate title like:'/&\n '# plot \"-\" using 2:3 with points pt 3 ps 1 title \"Author A\",\\ '/&\n '# \"\" using 2:3 with points pt 4 ps 1 title \"Author B\",\\ '/&\n '# etc (see GNUPLOT documentation)',/&\n '# and add a single \"e\" after the last line for each pointtype '/'#'/&\n 'plot \"-\" using 2:3:4 with points pt variable ps 1 title \"please add id\"')\n! finished opening file\n else\n! This is for reading plot_data values when the file is open\n call getrel(eqlin(jval),last,pxx)\n call getrel(eqlin(jval),last,pyy)\n call getint(eqlin(jval),last,iel)\n if(buperr.ne.0) then\n write(*,*)'3B Incorrect values in plot_data',&\n trim(eqlin(jval))\n buperr=0\n endif\n if(eolch(eqlin(jval),last)) then\n savetitle='Unknown'\n endif\n endif\n! write the plot_data values on the file\n write(pun(ip),610)' ',ip,pxx,pyy,iel\n610 format(a,i2,2x,2(1pe14.6),i3,5x,a)\n! endif data_plot type\n endif\n! endif buperr\n!---------------------------\n! CASE(12)! unused\n! continue\n end SELECT\n enddo\n!\n! force reading next row with values for another equilibrium\n last=len(cline)\n goto 300\n!\n1000 continue\n if(gx%bmperr.ne.0) write(*,*)'Error return from enter_many_equil',gx%bmperr\n! we can have many enter many with plot data, do not close here!\n! The file(s) will be closed when the command enter range\n! if(plotfile) then\n! write(pun,1010)\n!1010 format('e'/'pause mouse'/)\n! close(pun)\n! endif\n return\n end subroutine enter_many_equil\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine mqmqa_species\n!\\begin{verbatim}\n subroutine mqmqa_species(name1,inline,nend)\n! almost identical to subroutine mqmqa_species(inline,const,nend,...\n! called from readtdb in gtp3E.F90. If nend<0 initiate to 1\n! called also from gtp3EY, OCenterspecies\n! the species is created at the end if all is OK\n! can take input from database file or terminal\n! name1 is OC species name. Must contain / followd by letter\n! inline is A/B or A,C/B or A/B,D or A,C/B,D with , and /\n! where A, B, C etc must be entered species\n! possible inline: \"Fe,Al/Si1/4O,Al2/3O\" ???\n! it has to decode the list of species A, B, C or D\n implicit none\n integer nend\n! nend inncremented for each endmember constituent, set -1 at first call\n! name2 is the stoichiometry,dimension maxconst! check for overflow\n character*(*) name1, inline\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! to enter a whole database, max set by seqnum='01' to '99'\n! integer, parameter :: f1=maxconst\n! integer, parameter :: f1=200\n! const is array of all quadruplet names, \n! mqxquads is maxium number of quads, mqq is max number of species in quads\n integer, parameter :: maxquads=99,mqq=30\n! it will be all quads\n character const(maxquads)*24\n integer ip,lenc,jp,kp,ncat,ntot,isp(4),loksp,loksparr(4),nspel,thiscon,s1\n integer jelno(9),ielno(9),nextra,ee,nel,order1,order2,lat,nquad,ij,ik\n logical endmember,sametwice1,sametwice2,nomqmqava\n character*24 cation1,species(4),quaderr\n character quadname*64,ch1*1,elnames(9)*2\n character*2 :: seqnum='00'\n! beginning of text to save in species record\n integer sinsp\n double precision val,qstoi(mqq),smass,qsp,extra(5),stoi(20),double(4)\n double precision vazero,totstoi\n! Example of input line with \"constituents\":\n! 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\n! 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 \n! The 2.4 for the pairs is the default FNN/SNN ratio\n! Added to have correct reference state for SNN quadruplets when elements with\n! multiple valencies are used such as U+3 and U+4\n! Species representing different valencies of an element have names as UQ4 \n! fnnquads store names of FNN quadruplets\n integer nfnnq,nsnnq,pair,qorder(maxconst),haha\n integer, parameter :: mfnnq=40\n character (len=24) :: fnnquads(mfnnq),snnrefs(4,maxconst-mfnnq)\n! this save is probably redundant\n save seqnum,nfnnq,nsnnq,fnnquads,snnrefs\n!\n if(nend.lt.0) then \n! nend should be a global variable which can be reinitiated with NEW\n nend=0\n mqmqanend=0\n endif\n! write(*,575)trim(name1),trim(inline),nend\n575 format('3B In mqmqa_species: \"',a,'\" \"',a,'\" ',i5)\n! write(*,2)trim(inline),name1,nend\n2 format('3B in mqmqa_species: \"',a,'\" \"',a,'\" ',i3)\n! This toutine will be called for each mqmqa species entered\n! increased %contyp with 4 integers to indices of sublattice species\n if(.not.allocated(mqmqa_data%contyp)) then\n! these should not be already allocated but ... who knows \n! sometimes there can be two liquids in the TDB file ....\n! write(*,*)'3B Allocating mqmqa_data, max constituents: ',maxquads\n allocate(mqmqa_data%contyp(14,maxquads))\n allocate(mqmqa_data%constoi(4,maxquads))\n allocate(mqmqa_data%totstoi(maxquads))\n! how much each pair is part of a quadruplet, needed for pair fractions\n if(allocated(mqmqa_data%pp)) deallocate(mqmqa_data%pp)\n allocate(mqmqa_data%pp(4,maxquads))\n allocate(mqmqa_data%pinq(12))\n mqmqa_data%contyp=0\n mqmqa_data%nconst=0\n mqmqa_data%constoi=zero\n mqmqa_data%pp=zero\n! these values should maybe be saved between calls ....\n seqnum='00'\n nfnnq=0\n nsnnq=0\n endif\n ip=0\n call capson(inline)\n! number of quads\n nquad=0\n mqmqa_data%totstoi=zero\n! this set TRUE means VA not allowed in MQMQA phase\n nomqmqava=.TRUE.\n100 continue\n if(eolch(inline,ip)) goto 900\n haha=0\n! set TRUE below if two species represent the same element, such as Fe2Q, Fe3Q\n sametwice1=.FALSE.; sametwice2=.FALSE.\n! here a new quadrupole. Third argumment 2 means terminated by space\n! getext increment ip by 1 before extracting so decrement first\n ip=ip-1\n sinsp=ip\n! trying to extract quad information\n! write(*,*)'3B inline: \"',trim(inline),'\"',ip\n call getext(inline,ip,2,quadname,' ',lenc)\n if(buperr.ne.0) then\n write(*,*)'3B error reading name of quadrupole'\n buperr=0; goto 1000\n endif\n! write(*,*)'3B quadname 3: ',trim(quadname),ip\n! a \":\" terminates list of quadrupoles\n if(quadname(1:1).eq.':') goto 900\n! a slash / separate species in different sublattices \n! if a species does not exist skip this quadrupole (not an error)\n jp=index(quadname,'/')\n if(jp.le.0) then\n write(*,*)'3B missing / in quadrupole \"',trim(quadname),'\"'\n gx%bmperr=4399; goto 1000\n endif\n isp=0\n double=one\n kp=index(quadname,',')\n! write(*,*)'3B quadrupole: ',trim(quadname),kp,jp\n order1=0\n if(kp.gt.0 .and. kp.lt.jp) then\n! there are two cation species in an SNN\n species(1)=quadname(1:kp-1)\n species(2)=quadname(kp+1:jp-1)\n call find_species_by_name_exact(species(1),isp(1))\n call find_species_by_name_exact(species(2),isp(2))\n if(gx%bmperr.ne.0) then\n! This normal if species not selected\n! write(*,*)'3B cannot find cations in: ',trim(quadname(1:jp-1)),&\n! ' maybe not selected'\n goto 810\n endif\n ncat=2\n else\n! There is a single cation, maybe FNN or quad with two anions\n species(1)=quadname(1:jp-1)\n call find_species_by_name_exact(species(1),isp(1))\n if(gx%bmperr.ne.0) then\n! This normal if species not selected\n! write(*,*)'3B cannot find cation: ',trim(species(1)),&\n! ' maybe not selected'\n goto 810\n endif\n isp(2)=0\n ncat=1\n! this is because a single cation should have stoichimetry 2.0/bonds\n double(1)=2.0D0\n endif\n!-------------------\n! the cation(s) exist, now check anions, jp is position of /\n kp=index(quadname(jp:),',')\n order2=0\n if(kp.gt.0) then\n! there are two anions\n ntot=ncat+1\n species(ntot)=quadname(jp+1:jp+kp-2)\n! write(*,*)'3B anion1: ',species(ntot)\n call find_species_by_name_exact(species(ntot),isp(ntot))\n! call find_species_record(species(ntot),isp(ntot))\n if(gx%bmperr.ne.0) then\n! This normal if species not selected\n! write(*,*)'3B cannot find anion: ',trim(species(ntot)),&\n! ' maybe not selected'\n goto 810\n endif\n ntot=ntot+1\n species(ntot)=quadname(jp+kp:)\n! this is second anion\n! write(*,*)'3B anion2: ',species(ntot)\n call find_species_by_name_exact(species(ntot),isp(ntot))\n! call find_species_record(species(ntot),isp(ntot))\n if(gx%bmperr.ne.0) then\n! This normal if species not selected\n! write(*,*)'3B cannot find anion: ',trim(species(ntot)),&\n! ' maybe not selected'\n goto 810\n if(isp(ntot-1).eq.isp(ntot)) then\n write(*,*)'3B two anions represent the same species'\n sametwice2=.TRUE.\n endif\n endif\n else\n! a single anion\n ntot=ncat+1\n species(ntot)=quadname(jp+1:)\n! write(*,*)'3B anion: ',species(ntot)\n call find_species_by_name_exact(species(ntot),isp(ntot))\n! call find_species_record(species(ntot),isp(ntot))\n if(gx%bmperr.ne.0) then\n! This normal if species not selected\n! write(*,*)'3B cannot find anion: ',trim(species(ntot)),&\n! ' maybe not selected: ',trim(quadname)\n goto 810\n endif\n! this is because a single cation should have stoichimetry 2.0/bonds\n double(ntot)=2.0D0\n endif\n! New code 22.12.14/BoS to handle element with multiple valences\n! we have to save the SNNs reference to its FNN quads \n! FNN are First NearestNeighbours with 2 constituents\n! Note the SNN may be entered before the FNN\n if(ntot.eq.2) then\n nfnnq=nfnnq+1\n! qorder is used when rearranging the quads in alphabetical order\n qorder(mqmqa_data%nconst+1)=nfnnq\n if(nfnnq.gt.size(fnnquads)) then\n write(*,61)nfnnq,size(fnnquads)\n61 format('3B Too many quads in MQMQA liquid ',2i3)\n gx%bmperr=4399\n goto 1000\n endif\n fnnquads(nfnnq)=quadname\n else\n nsnnq=nsnnq+1\n qorder(mqmqa_data%nconst+1)=-nsnnq\n do ij=1,4\n snnrefs(ij,nsnnq)=' '\n enddo\n! we have to generate the FNN constituents of this SNN, very clumsy\n ik=0\n do ij=1,ncat\n do kp=ncat+1,ntot\n ik=ik+1\n snnrefs(ik,nsnnq)=trim(species(ij))//'/'//species(kp)\n enddo\n enddo\n! write(*,62)'3B found SNN constituent ',nsnnq,trim(quadname),ntot,&\n! (trim(snnrefs(ij,nsnnq)),ij=1,ik)\n62 format(a,i3,1x,a,1x,i3,': ',(a,1x,a,1x,a,1x,a))\n endif\n \n! end new code...............\n! double(1..4) should be 2.0 for species 1..4 single in the sublattice\n! if the species has been rearranged we must rearrange the stoichiometry also \n! write(*,77)'3B species: ',(trim(species(kp)),isp(kp),kp=1,ntot)\n77 format(a,4(a,i5,2x))\n!----------------------------------------------------------\n! we have found all species, we have a new quadrupol\n mqmqa_data%nconst=mqmqa_data%nconst+1\n if(mqmqa_data%nconst.gt.maxquads) then\n write(*,777)maxquads\n777 format('3XQ Too many quadrupoles, max ',i3)\n gx%bmperr=4399; goto 1000\n endif\n thiscon=mqmqa_data%nconst\n! write(*,*)'3B thiscon: ',thiscon\n if(thiscon.ge.maxconst) then\n write(*,*)'3B Too many constituents in MQMQA phase: ',maxconst\n gx%bmperr=4399; goto 1000\n endif\n! save sublattice species record for the bonds\n! mqmqa_data%contyp(11,thiscon)=isp(1)\n! mqmqa_data%contyp(12,thiscon)=isp(2)\n! mqmqa_data%contyp(13,thiscon)=isp(3)\n! mqmqa_data%contyp(14,thiscon)=isp(4)\n! now read the coordination values, 2, 3 or 4, Z^A_{AB:XY)\n kp=ip\n if(.not.allocated(mqmqa_data%constoi)) then\n! I had a segmentation fault here when calling this routine twice\n write(*,*)'3B error mqmqa_data%constoi not allocated'\n gx%bmperr=4399; goto 1000\n endif\n! There are always 2 stoichiometries ....\n call getrel(inline,ip,mqmqa_data%constoi(1,thiscon))\n call getrel(inline,ip,mqmqa_data%constoi(2,thiscon))\n if(buperr.ne.0) then\n write(*,*)'3B error reading stoichiometry 2',inline(kp:ip)\n goto 1000\n endif\n!\n if(ntot.eq.2) then\n! this is the \\zeta value needed to calculate the entropy of pairs\n call getrel(inline,ip,mqmqa_data%constoi(3,thiscon))\n elseif(ntot.gt.2) then\n call getrel(inline,ip,mqmqa_data%constoi(3,thiscon))\n endif\n if(ntot.gt.3) call getrel(inline,ip,mqmqa_data%constoi(4,thiscon))\n if(buperr.ne.0) then\n write(*,*)'3B error in stoichiometry: \"',inline(kp:ip),'\"'\n goto 1000\n endif\n! this is needed if a quadrupole species is not an element ...\n! ncat is number in species in first sublattice, ntot is total number (max 4)\n! %spstoi not used ??\n! if(ntot.eq.2) then\n! mqmqa_data%spstoi(1,1,thiscon)=2.0d0/mqmqa_data%constoi(1,thiscon)\n! mqmqa_data%spstoi(2,1,thiscon)=2.0d0/mqmqa_data%constoi(2,thiscon)\n! elseif(ncat.eq.1) then\n! mqmqa_data%spstoi(1,1,thiscon)=2.0d0/mqmqa_data%constoi(1,thiscon)\n! mqmqa_data%spstoi(2,1,thiscon)=one/mqmqa_data%constoi(2,thiscon)\n! mqmqa_data%spstoi(2,2,thiscon)=one/mqmqa_data%constoi(3,thiscon)\n! else\n! mqmqa_data%spstoi(1,1,thiscon)=one/mqmqa_data%constoi(1,thiscon)\n! mqmqa_data%spstoi(1,2,thiscon)=one/mqmqa_data%constoi(2,thiscon)\n! if(ntot.eq.3) then\n! mqmqa_data%spstoi(1,2,thiscon)=2.0d0/mqmqa_data%constoi(3,thiscon)\n! else\n! mqmqa_data%spstoi(1,2,thiscon)=one/mqmqa_data%constoi(3,thiscon)\n! mqmqa_data%spstoi(2,2,thiscon)=one/mqmqa_data%constoi(4,thiscon)\n! endif\n! endif\n!********************************************************************\n! IF ALL INPUT IS IN ALPHABETICAL ORDER (incl elements!) IT WORKS\n! For non-alphabetical input a very strong link between the\n! order of species order and stoichiometry also connected to endmember\n! order when species replaced by species .... SUCK \n!********************************************************************\n! if(order2.gt.0) then \n! val=mqmqa_data%constoi(ntot-1,thiscon)\n! mqmqa_data%constoi(ntot-1,thiscon)=mqmqa_data%constoi(ntot,thiscon)\n! mqmqa_data%constoi(ntot,thiscon)=val\n! endif\n! write(*,33)(mqmqa_data%constoi(jp,thiscon),jp=1,4)\n33 format('3B mqmqstoi: ',4F10.4)\n! Now we have a quadrupole, create the species and enter contyp and constoi\n! sum up the elements in the quadrupole\n! VA must have stoichiometry zero otherwise minimizer is confused\n qstoi=zero\n nel=0\n jelno=0\n loksparr=0\n ielno=0\n vazero=zero\n totstoi=zero\n! add stoichiometry from all species in the quadrupole\n! NOTE multiply stoichiometry with double for either or both sublattices\n! NOTE ALSO some elements may appear twice representing different charge!!\n sumstoi: do kp=1,ntot\n call get_species_location(isp(kp),loksp,cation1)\n! how is the Va stored in a species?? it has loksp=1\n! write(*,34)trim(cation1),kp,ntot,isp(kp),loksp\n34 format('3B stoik: ',a,4i5)\n! extract data directly from the local arrays\n nspel=splista(loksp)%noofel\n do ee=1,nspel\n ielno(ee)=splista(loksp)%ellinks(ee)\n if(ielno(ee).eq.0) then\n! TEMPORARY SKIP MQMQA species with vacancies\n write(*,*)'3B Warning quad with vacancies ingnored: ',trim(quadname)\n mqmqa_data%nconst=mqmqa_data%nconst-1\n goto 100\n! TEMPORARY TREATMENT OF VA ALONE IN A SUBLATTICE\n! ielno(ee)=0 indicate Va, try setting its stoichiometry to zero !!!\n! write(*,'(a,4i3)')'3B Vacancy removed from totstoi:',kp,ee,ielno(ee)\n vazero=vazero-splista(loksp)%stoichiometry(ee)\n stoi(ee)=zero\n! must be tested\n write(*,*)'3B Warning quad with vacancies ',&\n 'in a sublattice may not work: ',trim(splista(loksp)%symbol)\n! maybe here use mqmqa_data%quadsp to indicate vacancy??\n! NOTE species indices changes as we add new species\n! This does not work if there are real species on same sublattice as Va\n! maybe just ignore Va in sum of stoichiometries?\n else\n stoi(ee)=splista(loksp)%stoichiometry(ee)\n endif\n enddo\n! write(*,*)'3B ielno: ',(ielno(jp),jp=1,nspel)\n if(gx%bmperr.ne.0) goto 1000\n loksparr(kp)=loksp\n! loop for all elements in species\n if(nspel.gt.1) then\n write(*,'(a,a,a)')'3B *** Warning, quad species \"',&\n trim(cation1),'\" has two elements, calculations may fail'\n endif\n elstoi: do jp=1,nspel\n notnew: do ee=1,nel\n if(ielno(jp).eq.jelno(ee)) then\n! debug info\n! Problems here if species has more than 2 cations ............\n write(kou,3001)trim(quadname),jp,nspel,ee,nel\n3001 format('3B same element twice as cation or anion in: ',&\n a,2x,2i3,2x,2i3)\n write(*,3005)thiscon\n3005 format('3B constituent index: ',i3)\n! write(kou,3002)(mqmqa_data%constoi(pair,s1),pair=1,4)\n! same cation twice in a quad should not be a problem, it will should a \n! different stoichiometry relative to the element by itself and should\n! be treated as a quadruplet by itself and form separate mixed quadruplets\n! so it must have some kind of unique identifier.\n! Example Fe+2 and Fe+3: FeCl2 and FeCl3\n write(kou,3010)(mqmqa_data%constoi(pair,thiscon),pair=1,4)\n3010 format('3B factors: ',4(1pe15.6))\n! Or if the same element occur in two anion/cation species, such as Fe+2/Fe+3\n! we must treat all elements as new??\n! exit notnew\n endif\n enddo notnew\n if(ee.gt.nel) then\n! a new element in this quad\n nel=nel+1\n jelno(nel)=ielno(jp)\n ee=nel\n else\n ee=ielno(jp)\n endif\n! ee is element index in species\n elnames(ee)=ellista(ielno(jp))%symbol\n! qstoi is the sum of species/element mm in all species of the quadrupole\n! element alone in a sublattice should have the stoichiometry doubled\n! The stoichiometry should be divided by the coordination number\n qstoi(ee)=qstoi(ee)+&\n double(kp)*stoi(jp)/mqmqa_data%constoi(kp,thiscon)\n! write(*,35)thiscon,kp,ee,nel,jp,&\n! double(kp),qstoi(ee),stoi(jp),mqmqa_data%constoi(kp,thiscon)\n35 format('3B qstoi: ',5i5,6F7.4)\n totstoi=totstoi+qstoi(ee)\n enddo elstoi\n enddo sumstoi\n mqmqa_data%totstoi(thiscon)=totstoi\n! %totstoi is probably useless, the important part above is removing Va\n! write(*,'(a,i3,F10.4)')'3B totstoi: ',thiscon,mqmqa_data%totstoi(thiscon)\n! enter some data in mqmqa_data%contyp; we cannot enter endmember links\n! because we need to sort the mqmqa_data%contyp\n endmember=.FALSE.\n! do kp=1,9\n do kp=1,14\n mqmqa_data%contyp(kp,thiscon)=0\n enddo\n! DEBUG contyp\n! write(*,3434)'A',thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14)\n! I am not sure if %contyp(10,thiscon) is already set to species index?\n! do kp=11,14\n! mqmqa_data%contyp(kp,thiscon)=0\n! enddo\n if(ncat.eq.1) then\n mqmqa_data%contyp(1,thiscon)=2\n if(ntot.eq.ncat+1) then\n! this is an endmember\n mqmqa_data%contyp(2,thiscon)=-2\n nend=nend+1\n mqmqa_data%contyp(5,thiscon)=nend\n endmember=.TRUE.\n else\n mqmqa_data%contyp(2,thiscon)=-1\n mqmqa_data%contyp(3,thiscon)=-1\n endif\n else\n mqmqa_data%contyp(1,thiscon)=1\n mqmqa_data%contyp(2,thiscon)=1\n if(ntot.eq.ncat+1) then\n mqmqa_data%contyp(3,thiscon)=-2\n else\n mqmqa_data%contyp(3,thiscon)=-1\n mqmqa_data%contyp(4,thiscon)=-1\n endif\n endif\n! temporarily add species location in position 6..9 for all quadrupoles\n! For non-endmembers they will be replaced by the endmembers indices\n mqmqa_data%contyp(6,thiscon)=loksparr(1)\n mqmqa_data%contyp(7,thiscon)=loksparr(2)\n mqmqa_data%contyp(8,thiscon)=loksparr(3)\n mqmqa_data%contyp(9,thiscon)=loksparr(4)\n! make a copy of this in 11..14\n mqmqa_data%contyp(11,thiscon)=loksparr(1)\n mqmqa_data%contyp(12,thiscon)=loksparr(2)\n mqmqa_data%contyp(13,thiscon)=loksparr(3)\n mqmqa_data%contyp(14,thiscon)=loksparr(4)\n haha=thiscon\n nspel=0\n! loop from 0 to include the vacancy, it will be the first element?\n! why loop to 20? Well, I assume there is less than 20 different species\n do kp=1,mqq\n if(qstoi(kp).gt.zero) then\n nspel=nspel+1\n ielno(nspel)=kp\n! stoichiometry should be divided by coordination number\n stoi(nspel)=qstoi(kp)\n endif\n enddo\n! DEBUG contyp\n! write(*,3434)'B',thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14)\n3434 format('3B contyp',a,': ',i3,': ',4i3,1x,i4,1x,4i3,1x,i3,1x,4i3)\n! create the quadname from the species names\n if(mqmqa_data%contyp(1,thiscon).eq.2) then\n quadname=trim(species(1))//'/'\n ntot=2\n else\n quadname=trim(species(1))//trim(species(2))//'/'\n ntot=3\n endif\n kp=len_trim(quadname)\n if(mqmqa_data%contyp(3,thiscon).eq.-1) then\n! possibilies: 2 -2 0 0 ; 2 -1 -1 0; 1 1 -2 0; 1 1 -1 -1\n quadname(kp+1:)=trim(species(ntot))//species(ntot+1)\n else\n quadname(kp+1:)=species(ntot)\n endif\n if(sametwice1 .or. sametwice2) then\n write(*,*)'3B same twice: ',sametwice1,sametwice2\n write(*,'(a,a,2i3,5i5)')'3B ielno1: ',trim(quadname),thiscon,nspel,&\n (mqmqa_data%contyp(kp,thiscon),kp=6,9)\n write(*,'(a,i3,10(F10.7))')'3B stoi: ',nspel,(stoi(kp),kp=1,nspel)\n endif\n! write(*,*)'3B quadname 4: ',quadname\n! remove , from quadname, keep /\n! kp=index(quadname,',')\n! do while(kp.gt.0)\n! quadname(kp:)=quadname(kp+1:)\n! kp=index(quadname,',')\n! enddo\n! the quadname can be ambiguous, for example NASI/FO if there is a NASI/F\n kp=len_trim(quadname)\n! check if quad already entered (ignoring the -Qij)\n! all constituent names are in const(1..kend)\n do s1=1,thiscon\n if(quadname(1:kp).eq.const(s1)(1:kp)) then\n write(*,567)'3B Same quadruplet twice: \"',trim(quadname)//'\"',&\n kp,s1,thiscon,'\"'//trim(const(s1))//'\"'\n567 format(a,a,3i3,a)\n write(*,'(a,2i3,a)')'3B ip,inline:',ip,s1,': \"'//trim(inline)//'\"'\n gx%bmperr=4399; goto 1000\n endif\n enddo\n! check we have not too many quads\n nquad=nquad+1\n if(nquad.gt.maxquads) then\n write(*,*)'3B Error, too many quadruplets, max: ',maxquads,nquad\n gx%bmperr=4399\n goto 1000\n endif\n! add a suffix _Q !!\n! write(*,*)'3B test seqnum 2: ',seqnum\n call incnum(seqnum)\n! write(*,*)'3B test seqnum 2: ',seqnum\n quadname(kp+1:)='-Q'//seqnum\n! we must return this to enter it also in selsp!!! BUT WITH THE DIGITS!\n! kp=len_trim(quadname)\n name1=quadname(1:kp+2)\n! write(*,600)trim(quadname),nspel,(trim(elnames(kp)),qstoi(kp),kp=1,nspel)\n600 format('3B enter quad: ',a,i3,4(1x,a,F6.3))\n call enter_species(quadname,nspel,elnames,qstoi)\n if(gx%bmperr.ne.0) then\n write(*,'(a,a,2l2,i5,10i5)')'3B failed to enter quad: ',trim(quadname),&\n sametwice1,sametwice2,&\n gx%bmperr,(mqmqa_data%contyp(kp,thiscon),kp=6,9)\n write(*,'(a,i3,4(F10.6))')trim(quadname),nspel,(qstoi(kp),kp=1,4)\n goto 1000\n! else\n! write(*,*)'3B found MQMQA quad: ',trim(quadname)\n endif\n! write(*,*)'3B returning the quadrupole name'\n const(thiscon)=quadname\n! we must use the location of the endmember species?? YES\n call find_species_by_name_exact(quadname,kp)\n if(gx%bmperr.ne.0) then\n write(*,*)'3B quad link from species failed',trim(quadname)\n goto 1000\n endif\n call get_species_location(kp,loksp,cation1)\n! save quad index in species record\n! write(*,611)nspel,loksp,kp,thiscon\n611 format('3B set link from species to quad',4i5)\n! splista(loksp)%quadindex=thiscon\n splista(loksp)%quadindex=haha\n! finally store the input information\n splista(loksp)%mqmqa1=trim(inline)\n! write(*,*)'3B saved quad info: \"',splista(loksp)%mqmqa1,'\"'\n!\n! write(*,612)trim(quadname),kp,loksp,thiscon,haha,splista(loksp)%quadindex\n612 format('3B found quad: ',a,6i5)\n if(gx%bmperr.ne.0) goto 1000\n! in this place we must store the final constituent index of this species\n! the constituents are arranged alphabetical in the call to enter_phase\n mqmqa_data%contyp(10,thiscon)=-loksp\n! write(*,602)thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14),&\n! qorder(thiscon),(mqmqa_data%constoi(kp,thiscon),kp=1,4)\n! if(qorder(thiscon).gt.0) then\n! write(*,603)'3B FNN: ',trim(fnnquads(thiscon))\n! else\n! write(*,603)'3B SNN: ',(trim(snnrefs(ij,thiscon)),ij=1,4)\n! endif\n! loop back to read next quadrupole\n goto 100\n!-----------------------------------------------------------------------\n! illegal quadrupole, skip this quadruple there can be 2-4 reals trailing\n800 continue\n write(*,*)'3B quadrupole not selected: ',trim(quadname)\n! species not entered, maybe not selected\n810 continue\n gx%bmperr=0\n call getrel(inline,ip,val)\n call getrel(inline,ip,val)\n if(buperr.ne.0) goto 1000\n! there can be up to 4 reals, this is the third or a new quad or :\n call getrel(inline,ip,val)\n if(buperr.ne.0) then\n ch1=inline(ip:ip)\n call capson(ch1)\n if((ch1.ge.'A' .and. ch1.le.'Z') .or. ch1.eq.':') then\n! this is the name of another quadrupole\n! write(*,*)'3B Error reset, continuing'\n buperr=0; goto 100\n endif\n endif\n! this is the last real or a new quadrupole\n call getrel(inline,ip,val)\n if(buperr.ne.0) then\n ch1=inline(ip:ip)\n call capson(ch1)\n if((ch1.ge.'A' .and. ch1.le.'Z') .or. ch1.eq.':') then\n! this is the name of another quadrupole\n! write(*,*)'3B Error reset, continuing'\n buperr=0; goto 100\n endif\n endif\n! write(*,*)'3B trying next one'\n goto 100\n!------------------------------------------\n! jump here when EOL or : detected\n! routine may be called again with more quadrupoles if interactive input\n! and with loop different from 0\n900 continue\n! we come here when all constituents read, maybe there are none??\n! if(nend.eq.0) then\n! write(*,*)'3B MQMQA phase has no constituents!'\n! gx%bmperr=4399\n! endif\n! With the MQMQA ohase one cannot have composition sets (only one mqmqa_data%)\n! indicate that one cannot make gridtests after an equilibrium calculation\n! globaldata%status=ibset(globaldata%status,GSNOAFTEREQ)\n goto 1000\n! this is just debug output\n ik=1; ij=1\n do thiscon=1,mqmqa_data%nconst\n if(qorder(thiscon).gt.0) then\n write(*,603)'3B FNN: ',trim(fnnquads(ik))\n ik=ik+1\n else\n write(*,603)'3B SNN: ',(trim(snnrefs(s1,ij)),s1=1,4)\n ij=ij+1\n endif\n603 format(a,4(1x,a))\n write(*,602)thiscon,(mqmqa_data%contyp(kp,thiscon),kp=1,14),&\n qorder(thiscon),(mqmqa_data%constoi(kp,thiscon),kp=1,4)\n602 format('3B contyp: ',i2,1x,4i3,1x,i3,1x,4i2,1x,i3,1x,4i2,1x,i4/30x,4F10.6)\n enddo\n!\n1000 continue\n! write(*,*)'3B leaving mqmqa_species',thiscon\n! write(*,910)nend\n910 format('3B found ',i3,' FNN constituents in MQMQA')\n return\n end subroutine mqmqa_species !loop\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine mqmqa_rearrange\n!\\begin{verbatim}\n subroutine mqmqa_rearrange(const)\n! This routine will scan the mqmqa_data datastructure\n! The phase record does not yet exist ...\n! and for all non-endmembers replace links to species by links to endmembers\n! and calculate and store several useful things\n! NOTE the phase is not yet entered!! we only have arrays with data\n implicit none\n! array with names of quadrupole constituents, needed by enter phase!!\n character const(*)*24\n!\\end{verbatim}\n! mqmqa_data contain information needed for the liquid modeled with MQMQA\n integer, parameter :: f1=maxconst\n! integer endmem(2,f1),s1,s2,s3,s4,s5,s6,nend,new(4),need,found,pair\n integer s1,s2,s3,s4,s5,s6,nend,new(4),need,found,pair\n integer subcon1(f1),subcon2(f1),ncon1,ncon2,ix1,ix2,lattice,indx(f1)\n integer top,stack(0:f1),last,mqm1(f1),mqm2(f1),jk,kkk,ll,loksp,nyfas\n integer ee,gg,pix,plink(4),pinq(f1),krux,ccontyp(14,f1)\n character spname1*24,spname2*24\n double precision cconstoi(4,f1),ctotstoi(f1)\n!\n! write(*,2)\n2 format('3B in mqmqa_rearrange fixing mqmqa_data%contyp and more')\n! attempt to fix problem with stoichiometries and order, sort const\n need=mqmqa_data%nconst\n! save element index of quad\n if(need.gt.f1) then\n write(*,*)'3B too many constituents, ',need,', max: ',f1\n gx%bmperr=4399; goto 1000\n endif\n! do s1=1,mqmqa_data%nconst\n! write(*,820)'3B Phase constituent: ',s1,trim(const(s1))\n! enddo\n! write(*,8)(trim(const(s1)),s1=1,need)\n8 format(/'3B orig: ',20(a,1x))\n! write(*,*)'3B calling MQSORT'\n if(need.gt.1) then\n call mqsort(const,need,indx)\n if(buperr.ne.0) then\n gx%bmperr=4399; goto 1000\n endif\n! write(*,'(a,20i3)')'3B order: ',(indx(s1),s1=1,need)\n else\n indx(1)=1\n endif\n! indx(i) gives the alphabetical order of const(1)\n! write(*,9)(trim(const(indx(s1))),s1=1,need)\n9 format('3B sort: ',20(a,2x))\n! set inorder in alphabetical order\n! do s1=1,need\n! inorder(s1)=const(indx(s1))\n! enddo\n! write(*,'(a,10(1x,a))')'3B quads: ',(trim(inorder(s1)),s1=1,need)\n! write(*,*)'3B original order:'\n! do s1=1,need\n! NOTE here -%contyp(10,s1) is the order the species were created\n! write(*,7)'3B orig: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4),&\n! trim(splista(-mqmqa_data%contyp(10,s1))%symbol)\n! enddo\n!7 format(a,i2,14i3,i4,4F6.2,1x,a)\n! rearrange contyp and constoi according to indx... example:\n! original order: 1 2 3 4 5 6 7 8 9\n! alphabet order: 7 3 2 5 1 6 8 9 4\n! stack: push 1; push 7; push 8; push 9; 9 push 4; push 5: find 5=1\n! stack from top: 5, 4, 9, 8, 7, 1\n! save(5); copy 4 to (5); copy 9 to (4); copy 8 to (9); copy 7 to (8);\n! this is the position to store inintial record index\n stack(0)=f1\n! write(*,'(a,20i3)')'3B index: ',(s3,s3=1,need)\n! write(*,'(a,20i3)')'3B sort1: ',(indx(s3),s3=1,need)\n! stop 2\n!\n! Now the constituents are in alphabetical order, rearrange mqmqa_data%contyp\n! %constoi and totat, don't be smart or fast, just copy\n do s1=1,need\n do s2=1,14\n ccontyp(s2,s1)=mqmqa_data%contyp(s2,s1)\n enddo\n do s2=1,4\n cconstoi(s2,s1)=mqmqa_data%constoi(s2,s1)\n enddo\n ctotstoi(s1)=mqmqa_data%totstoi(s1)\n enddo\n! now write them back in their correct order\n do s1=1,need\n s3=indx(s1)\n do s2=1,14\n mqmqa_data%contyp(s2,s1)=ccontyp(s2,s3)\n enddo\n do s2=1,4\n mqmqa_data%constoi(s2,s1)=cconstoi(s2,s3)\n enddo\n mqmqa_data%totstoi(s1)=ctotstoi(s3)\n! also set correct name in const\n if(-mqmqa_data%contyp(10,s1).le.0) then\n write(*,*)'3B negative index to mqmqa symbol:',s1,&\n -mqmqa_data%contyp(10,s1)\n stop\n else\n const(s1)=splista(-mqmqa_data%contyp(10,s1))%symbol\n endif\n enddo\n! We must correct the order of pairs, they must be from 1 and up !!!\n! Later we will change 6..9 in SNN quads to pair indices\n s2=1\n do s1=1,need\n if(mqmqa_data%contyp(5,s1).gt.0) then\n mqmqa_data%contyp(5,s1)=s2\n s2=s2+1\n endif\n enddo\n! write(*,*)'3B in alphabetical order?'\n! do s1=1,need\n! NOTE here -%contyp(10,s1) is the order the species were created\n! write(*,7)'3B orig: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4),trim(const(s1))\n! enddo\n! goto 300\n300 continue\n pair=0\n! endmem never used !!! skip it\n! endmem=0\n! write(*,*)'3B Loop to set SNN endmembers links to FNN and factor'\n try1: do s1=1,mqmqa_data%nconst\n if(mqmqa_data%contyp(5,s1).gt.0) then\n! this is a mixed SNN endmember, only one anion allowed!\n if(mqmqa_data%contyp(8,s1).gt.0) then\n write(*,*)'3B reciprocal quads not implemented'\n gx%bmperr=4399; goto 1000\n endif\n pair=pair+1\n pinq(pair)=s1\n! endmem(1,pair)=mqmqa_data%contyp(6,s1)\n! endmem(2,pair)=mqmqa_data%contyp(7,s1)\n! save stoichiometry of each constituent in pp(1..2,s1)\n mqmqa_data%pp(1,s1)=2.0D0/mqmqa_data%constoi(1,s1)\n! mqmqa_data%pp(2,s1)=2.0D0/mqmqa_data%constoi(1,s1)\n mqmqa_data%pp(2,s1)=2.0D0/mqmqa_data%constoi(2,s1)\n! write(*,'(a,2i3,1x,4i3,4(1pe12.4)/27x,4(1pe12.4))')'3B SNN: ',pair,s1,&\n! (mqmqa_data%contyp(s2,s1),s2=6,9),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4),(mqmqa_data%pp(s2,s1),s2=1,4)\n! else\n! write(*,'(a,2i3,1x,4i3,4(1pe12.4))')'3B FNN: ',0,s1,&\n! (mqmqa_data%contyp(s2,s1),s2=6,9),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4)\n endif\n! note code above is skipped due to cycle try1\n enddo try1\n!\n! write(*,*)'3B allocating pairs: ',pair\n mqmqa_data%npair=pair\n! if(.not.allocated(mqmqa_data%pinq)) then\n! the problem with an already allocated mqmqa_data\n! was that a TDB file had 2 MQMQA phases .... SUCK\n! mqmqa1 data character ... problem reading MQMQA as TDB or XTDB \n! where is pinq set??\n! write(*,*)'3B pinq:',pair,pinq(1),pinq(2),pinq(3)\n do s1=1,pair\n! mqmqa_data%pinq destroyed here, where is it set?\n mqmqa_data%pinq(s1)=pinq(s1)\n enddo\n! write(*,*)'3B pinq1: ',(mqmqa_data%pinq(s2),s2=1,mqmqa_data%npair)\n if(pair.le.0) then\n write(*,*)'3B No pairs among mqmqa constituents!',mqmqa_data%nconst\n gx%bmperr=4399; goto 1000\n endif \n!\n! write(*,*)'3B replace SNN species by pairs: ',mqmqa_data%nconst,pair\n! do s1=1,mqmqa_data%nconst\n! write(*,12)'3B quad1: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4)\n! enddo\n12 format(a,i3,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,4F5.2,1x,a)\n!\n subcon1=0; subcon2=0; ncon1=0; ncon2=0\n! write(*,*)'3B replace species with pairs'\n!\n new=0\n loop: do s1=1,mqmqa_data%nconst\n if(mqmqa_data%contyp(5,s1).gt.0) then\n! calculate the number of constituents on each sublattice\n lat1: do s2=1,ncon1\n if(mqmqa_data%contyp(6,s1).eq.subcon1(s2)) exit lat1\n enddo lat1\n if(s2.gt.ncon1) then\n ncon1=ncon1+1\n subcon1(ncon1)=mqmqa_data%contyp(6,s1)\n endif\n lat2: do s2=1,ncon2\n if(mqmqa_data%contyp(7,s1).eq.subcon2(s2)) exit lat2\n enddo lat2\n if(s2.gt.ncon2) then\n ncon2=ncon2+1\n subcon2(ncon2)=mqmqa_data%contyp(7,s1)\n endif\n! write(*,'(a,2i3,2x,2i3,2x,a)')'3B FNN: ',ncon1,ncon2,&\n! subcon1(ncon1),subcon2(ncon2),trim(const(s1))\n cycle loop\n endif\n! write(*,'(a,20i3)')'3B pinq2:',(mqmqa_data%pinq(s2),s2=1,mqmqa_data%npair)\n! write(*,'(a,20i3)')'3B pinq3:',(pinq(s2),s2=1,mqmqa_data%npair)\n found=0; need=2\n! THIS IS A QUAD WITH 3 OR MORE SPECIES\n! Replace CAREFULLY the species with pair pointers\n! The order of the pairs MUST reflect the order of %constoi factors\n! because when normalizing the pair fractions we need these factors\n! AB/XX should have first pair A/X then B/X b_A b_B b_X\n! AA/XY should have first A/X, then A/Y b_A b_X b_Y\n! AB/XY should have pairs in order A/X, A/Y, B/X, BY b_A b_B b_X b_Y\n! BUG: when 2 constituents in 2nd sublattice\n if(mqmqa_data%contyp(9,s1).gt.0) need=4\n! write(*,87)'3B set pair links in quad ',s1,&\n! (mqmqa_data%contyp(s2,s1),s2=6,9)\n87 format(a,i3,5x,4i4)\n pix=0\n plink=0\n! mqmqa_data%contyp(1,s1) is 1 if two species in first subl., otherwise 2\n krux=3-mqmqa_data%contyp(1,s1)\n do s2=1,krux\n ee=mqmqa_data%contyp(5+s2,s1)\n! %contyp(krux+1,s1) indicates (as negative) if one or 2 in second sublattice\n do s3=1,3+mqmqa_data%contyp(krux+1,s1)\n! specis is in 5+krux+s3\n gg=mqmqa_data%contyp(5+krux+s3,s1)\n! write(*,'(a,6i3,2x,4i3,2x,2i3)')'3B SNN and pair: ',s1,s2,s3,krux,&\n! 3-mqmqa_data%contyp(krux+1,s1),&\n! 5+krux+s3,(mqmqa_data%contyp(s4,s1),s4=6,9),ee,gg\n fpair: do s4=1,mqmqa_data%npair\n s5=mqmqa_data%pinq(s4)\n! s5 is %contyp index of pair s2\n! write(*,*)'3B pair: ',ee,gg,mqmqa_data%contyp(11,s4),&\n! mqmqa_data%contyp(12,s4)\n if(mqmqa_data%contyp(11,s5).eq.ee .and. &\n mqmqa_data%contyp(12,s5).eq.gg) then\n! pix=pix+1; plink(pix)=s5\n! not by s5 which is index in %contyp but pair index\n pix=pix+1; plink(pix)=mqmqa_data%contyp(5,s5)\n! write(*,*)'3B found pair in %contyp ',s5,pix\n exit fpair\n endif\n enddo fpair\n! if s4 is greater than mqmqa_data%npair we have not found any pair\n if(s4.gt.mqmqa_data%npair) then\n write(*,'(a,2i3,a,i3)')'3B failed search for pair: ',ee,gg,&\n ' in quadruplet ',s1\n! species name should be in splista, or is ee, gg not loksp?\n write(*,838)trim(splista(ee)%symbol),trim(splista(gg)%symbol)\n838 format('3B specie in first sublattice \"',a,'\" or second \"',&\n a,'\" not found.')\n write(*,*)'All quad names: '\n do s5=1,mqmqa_data%nconst\n write(*,839)s5,mqmqa_data%contyp(5,s5),&\n (mqmqa_data%contyp(s6,s5),s6=10,14)\n839 format('3B Quads: ',i3,2x,i3,2x,i3,2x,4i3)\n enddo\n gx%bmperr=4399; goto 1000\n endif\n enddo\n enddo\n!----------------------------------------------------\n! replace species in 6..9 by plink\n! write(*,887)(mqmqa_data%contyp(s3,s1),s3=6,9),plink\n887 format('3B replacing: ',4i4,' by ',4i4)\n do s3=1,4\n mqmqa_data%contyp(5+s3,s1)=plink(s3)\n enddo\n enddo loop\n!----------------------\n! write(*,*)'3B replaced all species by pairs'\n! do s1=1,mqmqa_data%nconst\n! write(*,12)'3B quad2: ',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4)\n! enddo\n! cations and anions\n write(*,*)'3B Number of cations and anions ',ncon1,ncon2\n mqmqa_data%ncon1=ncon1\n mqmqa_data%ncon2=ncon2\n! copy the value in constoi(3,s1) for all pairs to qfnnsnn\n if(.not.allocated(mqmqa_data%qfnnsnn)) then\n allocate(mqmqa_data%qfnnsnn(50))\n endif\n mqmqa_data%qfnnsnn=zero\n do s1=1,mqmqa_data%nconst\n s2=mqmqa_data%contyp(5,s1)\n if(s2.gt.0) then\n mqmqa_data%qfnnsnn(s2)=mqmqa_data%constoi(3,s1)\n mqmqa_data%constoi(3,s1)=zero\n endif\n enddo\n! do s1=1,mqmqa_data%nconst\n! write(*,34)'3B fixed: ',(mqmqa_data%contyp(s2,s1),s2=1,14)\n! enddo\n!-----------------------------------------\n! check we have all necessary quadrupoles, the DAT file may not provide all!!\n! pairs:\n s1=ncon1*ncon2\n! write(*,*)'3B ncon1,ncon2: ',ncon1,ncon2,s1\n if(s1-pair.ne.0) write(*,*)'3B wrong number of endmembers: ',s1,pair\n! binara SNN: ncon1*(ncon1-1)/2*ncon2 (in both sublattices): \n! (3)(2) means (3*2/2)*(2) + (3)*(2*1/2) = 6+3 = 9\n! (4)(2) means (4*3/2)*(2) + (4)*(2*1/2) = 12+4 = 16\n! (4)(3) means (4*3/2)*(3) + (4)*(3*2/2) = 18+12 = 30\n s2=ncon1*(ncon1-1)/2*ncon2 + ncon1*ncon2*(ncon2-1)/2\n! reciprocal SNN: ncon1*(ncon1-1)/2*ncon2*(ncon2-1)/2\n! (3)(2) means 3*2*1/2 = 3\n s3=ncon1*(ncon1-1)*ncon2*(ncon2-1)/4\n!\n! write(*,'(a,5i4)')'3B MQMQA: quads, FNN pairs, binary and reciprocal SNNs:',&\n! mqmqa_data%nconst,s1,s2,s3\n! write(*,760)mqmqa_data%nconst,s1,s2,s3\n760 format('3B MQMQA quads: ',i3,', with ',i3,' FNN pairs, ',i3,&\n ' binary SNNs and ',i3,' reciprocal SNNs')\n if(s1+s2+s3-mqmqa_data%nconst.ne.0) then\n write(*,'(a,i5,a,i5)')'3B total number of quadrupoles is wrong, is ',&\n s1+s2+s3,' should be: ',mqmqa_data%nconst\n! IN THE FURURE ... we should automatically create the additional quadrupoles\n! call mqmqa_addquads\n! if(gx%bmperr.ne.0) goto 1000\n gx%bmperr=4399; goto 1000\n endif\n! They all have zero Gibbs energy of formation.\n! write(*,'(a,i3,2x,2i3,3i5)')'3B some numbers:',mqmqa_data%nconst,&\n! ncon1,ncon2,pair,s1,s2\n! according to original MQMQA model we MUST have all quadrupoles\n! debug output\n! do s1=1,mqmqa_data%nconst\n! write(*,763)'3B quad3:',s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\n! (mqmqa_data%constoi(s2,s1),s2=1,4)\n! enddo\n763 format(a,i2,i3,3i2,2i4,3i3,2i4,3i3,4F6.2)\n! we have to set values in nonpairs for pairpart, pp, it should be stoich of\n! the sublattice element \n! write(*,*)'3B attempt to associate the pair with pairpart'\n pp: do s1=1,mqmqa_data%nconst\n if(mqmqa_data%contyp(5,s1).gt.0) cycle pp\n! an SNN quadruplet\n! write(*,'(a,i3,4i2,i3,1x,4i3,1x,i3,1x,4i3)')'3B %contyp: ',s1,&\n! (mqmqa_data%contyp(s3,s1),s3=1,14)\n do s2=1,4\n! s3 is index of a pair in the SNN\n s3=mqmqa_data%contyp(5+s2,s1)\n if(s3.gt.0) then\n! if there is a pair link, use s3 to associate %constoi with pair ????\n mqmqa_data%pp(s2,s1)=one/mqmqa_data%constoi(s2,s1)\n! write(*,'(a,3i3,2F12.8,1x,a)')'3B SNN%pp: ',s1,s2,s3,&\n! mqmqa_data%constoi(s2,s1),mqmqa_data%pp(s2,s1),const(s1)\n endif\n enddo\n enddo pp\n!\n! DO NOT CHANGE ABOVE, probably necessay for the configurational entropy\n! just add what is needed for the asymmetrical excess below\n! check what is available in mqmqa_data record\n! write(*,800)mqmqa_data%nconst\n!800 format('3B line 8010 we have finished subroutine mqmqa_rearrange: ',i3)\n! do s1=1,mqmqa_data%nconst\n! I do not understand many of the indices in this array and I miss some\n! for example the element indices of the cations and anions\n! I have added 4 arrays: quadel_i, quadel_j, _k _l for element indices in xquad\n! write(*,810)s1,(mqmqa_data%contyp(s2,s1),s2=1,14)\n!810 format('3B contyp ',i3,2x,2i3,2x,2i3,i4,2i3,2x,2i3,i5,4i3)\n! enddo\n! do s1=1,mqmqa_data%nconst\n! write(*,820)'Phase constituent: ',s1,trim(const(s1))\n!820 format(a,i3,' name: ',a)\n! enddo\n! do s1=1,noofsp\n! write(*,820)'Species: ',s1,trim(splista(species(s1))%symbol)\n! enddo\n!\n! write(*,*)'3B We need to add cross references between xquad and fractions'\n!\n \n!\n! do s1=1,mqmqa_data%nconst\n! an AB/XY has 4 FNN paris\n! write(*,'(a,i2,4F10.7,1x,a)')'3B all pairparts: ',s1,&\n! (mqmqa_data%pp(s2,s1),s2=1,4),trim(const(s1))\n! enddo\n1000 continue\n write(*,1010)\n1010 format('3B mqmqa_rearrange has verified the data structure')\n! maybe also call create_asymmetry in gtp3XQ.F90 ?\n return\n end subroutine mqmqa_rearrange\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine mqmqa_quadbonds\n!\\begin{verbatim}\n subroutine mqmqa_quadbonds(index,values)\n! This routine will return quad specifics\n implicit none\n integer index\n double precision values(*)\n!\\end{verbatim}\n integer i\n! (mqmqa_data%constoi(s2,s1),s2=1,4),trim(const(s1))\n do i=1,4\n values(i)=mqmqa_data%constoi(i,index)\n enddo\n if(values(3).eq.zero) then\n! this is an A/X quadruplet, return FNNSNN factor\n i=mqmqa_data%contyp(5,index)\n if(i.le.0) then\n write(*,*)'3B error, no FNNSNN factor for quadruplet: ',index,i\n else\n values(3)=mqmqa_data%qfnnsnn(i)\n endif\n endif\n return\n end subroutine mqmqa_quadbonds\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine mqmqa_addquads\n!\\begin{verbatim}\n subroutine mqmqa_addquads\n! This routine will add missing quads using the pairs \n implicit none\n!\\end{verbatim}\n! mqmqa_data contain information needed for the liquid modeled with MQMQA\n write(*,*)'3B not implemented yet: mqmqa_addquads'\n gx%bmperr=4399\n1000 continue\n return\n end subroutine mqmqa_addquads\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine enter_species_property\n!\\begin{verbatim}\n subroutine enter_species_property(loksp,nspx,value)\n! enter an extra species property for species loksp\n implicit none\n integer loksp,nspx\n double precision value\n!\\end{verbatim} %+\n! this is illegal for species that are elements ...\n if(btest(splista(loksp)%status,SPEL) .or. &\n btest(splista(loksp)%status,SPVA)) then\n! write(*,*)'Illegal to set this for element species'\n gx%bmperr=4298\n elseif(.not.allocated(splista(loksp)%spextra)) then\n write(*,*)'3B this species has no allocated extra data'\n gx%bmperr=4399; goto 1000\n elseif(nspx.gt.size(splista(loksp)%spextra)) then\n write(*,*)'3B species has not sufficient extra data allocated ',nspx\n gx%bmperr=4399; goto 1000\n else\n splista(loksp)%spextra(nspx)=value\n endif\n1000 continue\n return\n end subroutine enter_species_property\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_uniquac_species\n!\\begin{verbatim}\n subroutine set_uniquac_species(loksp)\n! set the status bit and allocates spexttra array\n implicit none\n integer loksp\n!\\end{verbatim}\n! this is illegal for species that are elements ...\n if(btest(splista(loksp)%status,SPEL) .or. &\n btest(splista(loksp)%status,SPVA)) then\n gx%bmperr=4298\n else\n splista(loksp)%status=ibset(splista(loksp)%status,SPUQC)\n if(.not.allocated(splista(loksp)%spextra)) then\n allocate(splista(loksp)%spextra(2))\n splista(loksp)%spextra=one\n endif\n endif\n1000 continue\n return\n end subroutine set_uniquac_species\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine enter_material\n!\\begin{verbatim}\n subroutine enter_material(cline,last,nv,xknown,ceq)\n! enter a material from a database\n! called from user i/f\n implicit none\n integer last,nv\n character cline*(*)\n double precision xknown(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer nel,j1,j2,j3\n character material*72,database*72,selel(20)*2,ext*4,alloy(20)*2\n character majorel*2,ftype*1,bline*128,elnam*2\n double precision xalloy(20),rest,xxx,xxy\n logical byte\n! these are saved for use in a subsequent call\n save selel,majorel,ftype,xalloy\n!\n if(.not.btest(globaldata%status,GSNOPHASE)) then\n! Ask for new alloy composition:\n if(ftype.eq.'Y') then\n rest=1.0D2\n bline='Mass % of '\n else\n rest=one\n bline='Mole fraction of '\n endif\n j2=len_trim(bline)+2\n do j1=1,noofel\n if(ellista(j1)%symbol.eq.majorel) cycle\n bline(j2:)=ellista(j1)%symbol\n xxy=xalloy(j1)\n60 continue\n call gparrdx(bline,cline,last,xxx,xxy,'?Enter Material')\n if(buperr.ne.0 .or. xxx.le.zero) then\n write(*,*)'3B Illegal value for composition'\n goto 60\n endif\n xalloy(j1)=xxx\n rest=rest-xxx\n enddo\n else\n ext='.TDB'\n call gparcx('Database: ',cline,last,1,database,' ','?Enter matrial')\n! this extracts all element symbols from database\n call checkdb2(database,ext,nel,selel)\n if(gx%bmperr.ne.0) goto 1000\n write(kou,70)(selel(nv),nv=1,nel)\n70 format('Elements: ',15(a2,', '))\n! ask for major component\n call gparcx('Major element or material: ',cline,last,1,majorel,' ',&\n '?Enter material')\n call capson(majorel)\n do nv=1,nel\n if(majorel.eq.selel(nv)) goto 100\n enddo\n write(*,*)'3B No such element in the database'\n gx%bmperr=4399\n goto 1000\n100 continue\n call gparcdx('Input in mass percent? ',cline,last,1,ftype,'Y',&\n '?Enter material')\n if(ftype.eq.'Y') then\n rest=1.0D2\n write(*,102)'mass percent'\n else\n rest=one\n write(*,102)'mole fractions'\n endif\n102 format('Input expected in ',a/)\n110 continue\n call gparcx('First alloying element:',cline,last,1,alloy(1),' ',&\n '?Enter matrial')\n nv=0\n call capson(alloy(1))\n do j1=1,nel\n if(alloy(1).eq.selel(j1)) goto 200\n enddo\n write(*,*)'3B No such element in database'\n goto 110\n!-----\n200 continue\n do j1=1,nv\n if(alloy(nv+1).eq.alloy(j1)) then\n write(*,*)'3B Alloying element already entered'\n goto 250\n endif\n enddo\n nv=nv+1\n220 continue\n if(ftype.eq.'Y') then\n call gparrdx('Mass percent: ',cline,last,xalloy(nv),one,&\n '?Enter material')\n if(buperr.ne.0) then\n write(*,*)'Give a numeric value'; buperr=0\n goto 220\n endif\n else\n call gparrdx('Mole fraction: ',cline,last,xalloy(nv),1.0D-2,&\n '?Enter material')\n if(buperr.ne.0) then\n write(*,*)'Give a numeric value'; buperr=0\n goto 220\n endif\n endif\n if(xalloy(nv).le.zero) then\n write(*,*)'Composition must be positive!'\n goto 220\n endif\n rest=rest-xalloy(nv)\n if(rest.le.zero) then\n write(*,240)'zero!!'\n240 format('Your major component composition is less than ')\n gx%bmperr=4399; goto 1000\n elseif(rest.le.5.0D-1) then\n write(*,240)'half the system!!'\n endif\n250 continue\n if(nv.eq.1) then\n call gparcx('Second alloying element:',cline,last,1,alloy(2),' ',&\n '?Enter material')\n if(alloy(2).eq.' ') goto 500\n elseif(nv.eq.2) then\n call gparcx('Third alloying element:',cline,last,1,alloy(3),' ',&\n '?Enter material')\n if(alloy(3).eq.' ') goto 500\n else\n call gparcx('Next alloying element:',cline,last,1,&\n alloy(nv+1),' ','?Enter material')\n if(alloy(nv+1).eq.' ') goto 500\n endif\n call capson(alloy(nv+1))\n do j1=1,nel\n if(alloy(nv+1).eq.selel(j1)) goto 200\n enddo\n write(*,*)'3B No such element in database'\n goto 250\n!----------------------\n! read the database including the major element\n500 continue\n! write(*,505)'Comp: ',nv,(alloy(j1),xalloy(j1),j1=1,nv)\n505 format(a,i2,2x,8(a2,F8.4,', '))\n nv=nv+1\n alloy(nv)=majorel\n xalloy(nv)=rest\n! write(*,505)'3B m1: ',nv,(alloy(j1),xalloy(j1),j1=1,nv)\n call readtdb(database,nv,alloy)\n if(gx%bmperr.ne.0) goto 1000\n! order the amounts in xalloy in alphabetical order\n byte=.true.\n order: do while(byte)\n byte=.false.\n do j1=1,nv\n do j2=j1+1,nv\n if(alloy(j1).gt.alloy(j2)) then\n byte=.true.\n elnam=alloy(j1)\n alloy(j1)=alloy(j2)\n alloy(j2)=elnam\n xxx=xalloy(j1)\n xalloy(j1)=xalloy(j2)\n xalloy(j2)=xxx\n! write(*,505)'3B m1: ',nv,(alloy(j3),xalloy(j3),j3=1,nv)\n cycle order\n endif\n enddo\n enddo\n enddo order\n! these are saved until another enter material command\n do j1=1,nv\n xknown(j1)=xalloy(j1)\n enddo\n! write(*,505)'3B m2: ',nv,(alloy(j1),xknown(j1),j1=1,nv)\n510 format('3B em: ',10(a2,F6.3,1x))\n endif\n!----------------------------------\n! set conditions for composition (replace major by N=1)\n bline=' '\n j2=len_trim(bline)+2\n do j1=1,nv\n if(alloy(j1).eq.majorel) cycle\n if(ftype.eq.'Y') then\n bline(j2:)='W%('//trim(alloy(j1))//')='\n else\n bline(j2:)='X('//trim(alloy(j1))//')='\n endif\n j2=len_trim(bline)+1\n call wrinum(bline,j2,10,0,xalloy(j1))\n j2=j2+2\n enddo\n bline(j2:)=' N=1 '\n j2=len_trim(bline)+2\n write(*,*)'3B em: ',trim(bline)\n! set_condition will increment j1\n j1=1\n call set_condition(bline,j1,ceq)\n1000 continue\n return\n end subroutine enter_material\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine delete_all_conditions\n!\\begin{verbatim}\n subroutine delete_all_conditions(mode,ceq)\n! deletes the (circular) list of conditions in an equilibrium\n! it also deletes any experiments\n! if mode=1 the whole equilibrium is removed, do not change phase status\n! because the phase_varres records have been deallocated !!!\n! I am not sure it releases any memory though ...\n implicit none\n integer mode\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_condition), pointer :: last,current,next\n integer iph,ics,lokcs\n!\n! write(*,*)'3B deleting conditions and experiments',trim(ceq%eqname)\n last=>ceq%lastcondition\n do while(associated(last))\n next=>last%next\n do while(.not.associated(next,last))\n current=>next\n next=>current%next\n! if mode=0 then the equilibrium is not deleted, just the conditions\n if(mode.eq.0 .and. current%active.eq.0) then\n! if condition is active and that a phase is fix change the phase status!!\n! A fix phase has a negative statevariable-id\n iph=-current%statvar(1)%statevarid\n! write(*,*)'3B Active condition: ',iph\n if(iph.gt.0) then\n! write(*,*)'3B rest status for phase: ',iph\n ics=current%statvar(1)%compset\n110 continue\n if(phasetuple(iph)%compset.ne.ics) then\n iph=phasetuple(iph)%nextcs\n if(iph.gt.0) goto 110\n! this composition set does not exist\n gx%bmperr=4399; goto 1000\n else\n lokcs=phasetuple(iph)%lokvares\n! set the phase status to entered and unknown\n! write(*,*)'3B remove phase condition: ',iph,ics,lokcs\n ceq%phase_varres(lokcs)%phstate=0\n endif\n endif\n! else\n! write(*,*)'3B inactive condition: ',current%statvar(1)%statevarid\n endif\n deallocate(current)\n enddo\n! write(*,*)'3B last condition'\n if(mode.eq.0 .and. last%active.eq.0) then\n! if condition is active and that a phase is fix change the phase status!!\n! A fix phase has a negative statevariable-id\n iph=-last%statvar(1)%statevarid\n! write(*,*)'3B Active condition: ',iph\n if(iph.gt.0) then\n! write(*,*)'3B restore status for phase: ',iph\n ics=last%statvar(1)%compset\n120 continue\n if(phasetuple(iph)%compset.ne.ics) then\n iph=phasetuple(iph)%nextcs\n if(iph.gt.0) goto 120\n! this composition set does not exist\n gx%bmperr=4399; goto 1000\n else\n lokcs=phasetuple(iph)%lokvares\n! set the phase status to entered and stable (not fix)\n! write(*,*)'3B change phase status: ',iph,ics,lokcs\n ceq%phase_varres(lokcs)%phstate=phentstab\n! write(*,*)'3B new phase status: ',&\n! ceq%phase_varres(lokcs)%phstate\n endif\n endif\n endif\n! write(*,*)'3B deallocate last condition'\n deallocate(last)\n! write(*,*)'3B last condition deallocated'\n enddo\n nullify(ceq%lastcondition)\n!------------------------------\n! same for experiments (no fix phases)\n last=>ceq%lastexperiment\n do while(associated(last))\n next=>last%next\n do while(.not.associated(next,last))\n current=>next\n next=>current%next\n deallocate(current)\n enddo\n deallocate(last)\n enddo\n nullify(ceq%lastexperiment)\n! same for experiments ...\n1000 continue\n! mark conditions and current result may not be compatible\n ceq%status=ibset(ceq%status,EQINCON)\n return\n end subroutine delete_all_conditions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine delete_equilibria\n!\\begin{verbatim}\n subroutine delete_equilibria(name,ceq)\n! deletes equilibria (needed when repeated step/map)\n! name can be an abbreviation line \"_MAP*\"\n! deallocates all data. Minimal checks ... one cannot delete \"ceq\"\n implicit none\n character name*(*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: curceq\n type(gtp_condition), pointer :: lastcond,pcond,qcond\n integer cureq,ieq,ik,novarres,ipv,ndel\n!\n cureq=ceq%eqno\n! write(*,*)'In delete_equilibria ',cureq,trim(name)\n ik=index(name,'*')-1\n if(ik.lt.0) ik=min(24,len(name))\n novarres=highcs\n ndel=0\n! write(*,*)'3B delete equilibria: ',eqfree-1,highcs,csfree\n eqloop: do ieq=eqfree-1,2,-1\n! we cannot have \"holes\" in the free list?? NO! Delete from the end...\n if(ieq.eq.cureq) exit eqloop\n if(eqlista(ieq)%eqname(1:ik).ne.name(1:ik)) exit eqloop\n! write(*,*)'3B Deleting equil: ',trim(eqlista(ieq)%eqname),ieq\n eqlista(ieq)%eqname=' '\n deallocate(eqlista(ieq)%complist)\n deallocate(eqlista(ieq)%compstoi)\n deallocate(eqlista(ieq)%invcompstoi)\n deallocate(eqlista(ieq)%cmuval)\n!\n! the next line should be removed when highcs implemented\n! novarres=csfree-1\n! write(*,*)'3B deallocationg phase_varres'\n do ipv=1,novarres\n! it can happen a phase_varres record is not allocated when previous errors\n! \n if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%yfr)) cycle\n deallocate(eqlista(ieq)%phase_varres(ipv)%yfr)\n! with map 17 error here because not allocated, skip if not allocated\n if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%constat)) cycle\n deallocate(eqlista(ieq)%phase_varres(ipv)%constat)\n! skip also if this is not allocated\n if(.not.allocated(eqlista(ieq)%phase_varres(ipv)%mmyfr)) cycle\n! If all prevous allocated I hope these will not cause errors ....\n deallocate(eqlista(ieq)%phase_varres(ipv)%mmyfr)\n eqlista(ieq)%phase_varres(ipv)%status2=&\n ibclr(eqlista(ieq)%phase_varres(ipv)%status2,CSDEFCON)\n deallocate(eqlista(ieq)%phase_varres(ipv)%sites)\n deallocate(eqlista(ieq)%phase_varres(ipv)%listprop)\n deallocate(eqlista(ieq)%phase_varres(ipv)%gval)\n deallocate(eqlista(ieq)%phase_varres(ipv)%dgval)\n deallocate(eqlista(ieq)%phase_varres(ipv)%d2gval)\n! do not deallocate explicitly disfra as it is another phase_varres record ...\n enddo\n deallocate(eqlista(ieq)%phase_varres)\n deallocate(eqlista(ieq)%eq_tpres)\n! write(*,*)'3B Deallocating svfunres for equilibrium:',trim(name)\n deallocate(eqlista(ieq)%svfunres)\n! this deletes the conditions and experiments (if any)\n curceq=>eqlista(ieq)\n call delete_all_conditions(1,curceq)\n if(gx%bmperr.ne.0) then\n write(kou,800)gx%bmperr,ieq\n800 format(' *** Error ',i6,' deleting equilibrium ',i5)\n gx%bmperr=0\n endif\n ndel=ndel+1\n eqfree=eqfree-1\n enddo eqloop\n! we have deleted all equilibria until ieq+1\n if(ocv()) write(*,900)ieq+1,eqfree\n if(ndel.gt.0) write(*,900)ndel,eqfree-1\n900 format('3B Deleted ',i3,' equilibria. First free ',i3)\n eqfree=ieq+1\n1000 continue\n return\n end subroutine delete_equilibria\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine copy_equilibrium\n!\\begin{verbatim}\n subroutine copy_equilibrium(neweq,name,ceq)\n! creates a new equilibrium which is a copy of ceq. \n implicit none\n character name*(*)\n type(gtp_equilibrium_data), pointer ::neweq,ceq\n!\\end{verbatim} %+\n integer number\n call copy_equilibrium2(neweq,number,name,ceq)\n1000 continue\n return\n end subroutine copy_equilibrium\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine copy_equilibrium2\n!\\begin{verbatim} %-\n subroutine copy_equilibrium2(neweq,number,name,ceq)\n! creates a new equilibrium which is a copy of ceq. THIS IS STILL USED !! ??\n! Allocates arrayes for conditions,\n! components, phase data and results etc. from equilibrium ceq\n! returns a pointer to the new equilibrium record\n! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be\n! copied as a whole, not each record structure separately ... ???\n implicit none\n character name*(*)\n integer number\n type(gtp_equilibrium_data), pointer ::neweq,ceq\n!\\end{verbatim}\n type(gtp_condition), pointer :: oldcond,lastcond\n type(gtp_condition), pointer :: newcond1,newcond2\n type(gtp_condition), pointer :: bugcond\n character name2*64\n integer ieq,ipv,jz,iz,jl,jk,novarres,oldeq\n logical okname\n!\n! write(*,*)'In copy_equilibrium2',trim(name),eqfree\n nullify(neweq)\n if(.not.allowenter(3)) then\n! write(*,*)'3B Not allowed to copy or enter equilibria'\n gx%bmperr=4153; goto 1000\n endif\n! write(*,*)'3B allow enter OK'\n! not allowed to enter equilibria if there are no phases\n! if(btest(globaldata%status,GSNOPHASE)) then\n! write(*,*)'3B Meaningless to copy equilibria with no phase data'\n! gx%bmperr=7777; goto 1000\n! endif\n! equilibrium names starting with _ are automatically created by mapping\n! and in some other cases.\n if(name(1:1).eq.'_') then\n name2=name(2:)\n jk=1\n elseif(name(1:1).eq.' ') then\n write(*,*)'A name must start with a letter'\n gx%bmperr=4284; goto 1000\n else\n name2=name\n jk=0\n endif\n call capson(name2)\n! write(*,*)'3B Entering copy equilibria: ',name2,jk\n! program crashed with this construction\n! if(.not.proper_symbol_name(name2,0)) then\n okname=proper_symbol_name(name2,0)\n if(.not.okname) then\n! the name must start with a letter A-Z and contain letters, numbers and _\n gx%bmperr=4122\n goto 1000\n endif\n! write(*,*)'3B name check ok: ',jk\n! remove initial \"_\" used for automatically created equilibria\n if(jk.eq.1) then\n! changing this cause a lot of trouble ... but I do not understand\n name2='_'//name2\n! name2=name2(2:)\n endif\n! check if name already used\n! write(*,*)'3B check if name unique: ',name2\n call findeq(name2,ieq)\n if(gx%bmperr.eq.0) then\n gx%bmperr=4123\n goto 1000\n else\n! reset error code\n gx%bmperr=0\n endif\n! write(*,*)'3B check if name unique: ',eqfree\n if(eqfree.le.maxeq) then\n ieq=eqfree\n eqfree=eqfree+1\n else\n! write(*,*)'Too many equilibrium required, increase dimension',eqfree\n gx%bmperr=4283; goto 1000\n endif\n number=ieq\n if(ieq.eq.1) then\n! write(*,*)'Cannot copy to default equilibria'\n gx%bmperr=4285; goto 1000\n endif\n! write(*,*)'3B copy eq',eqfree,maxeq,ieq\n! allocate data arrayes in equilibrium record\n eqlista(ieq)%nexteq=0\n eqlista(ieq)%eqname=name2\n eqlista(ieq)%eqno=ieq\n! do not copy comment but set it to blanks\n eqlista(ieq)%comment=' '\n! component list and matrix, if second or higher equilibrium copy content\n! write(*,*)'3B: copyeq 1A: ',maxel,noofel\n allocate(eqlista(ieq)%complist(noofel))\n allocate(eqlista(ieq)%compstoi(noofel,noofel))\n allocate(eqlista(ieq)%invcompstoi(noofel,noofel))\n allocate(eqlista(ieq)%cmuval(noofel))\n! write(*,*)'3B: copyeq 1B: ',noofel\n! careful here because FIRSTEQ has other dimensions than the other\n do jl=1,noofel\n eqlista(ieq)%complist(jl)=ceq%complist(jl)\n eqlista(ieq)%cmuval(jl)=ceq%cmuval(jl)\n do jk=1,noofel\n eqlista(ieq)%compstoi(jk,jl)=ceq%compstoi(jk,jl)\n eqlista(ieq)%invcompstoi(jk,jl)=ceq%invcompstoi(jk,jl)\n enddo\n enddo\n oldeq=ceq%eqno\n! what about the weight?\n eqlista(ieq)%weight=ceq%weight\n! write(*,*)'3B copyeq 1: ',ceq%weight,eqlista(ieq)%weight\n do jl=1,noofel\n eqlista(ieq)%complist(jl)%splink=eqlista(oldeq)%complist(jl)%splink\n eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink\n eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status\n if(firsteq%complist(jl)%phlink.gt.0) then\n! only if there is a defined reference state\n eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate\n eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref\n eqlista(ieq)%complist(jl)%chempot=zero\n do jk=1,noofel\n eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk)\n eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk)\n enddo\n if(.not.allocated(eqlista(ieq)%complist(jl)%endmember)) then\n iz=size(firsteq%complist(jl)%endmember)\n allocate(eqlista(ieq)%complist(jl)%endmember(iz))\n eqlista(ieq)%complist(jl)%endmember=firsteq%complist(jl)%endmember\n endif\n else\n eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate\n endif\n enddo\n! these records keep calculated values of G and derivatives for each phase\n! For phase lokph the index to phase_varres is in phlista(lokph)%cslink\n! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics)\n! for ieq>1 allocate the current number of phase_varres records plus 10\n! for extra composition sets added later\n! 170524: It seems that phase_varres for disordered fraction sets are not\n! included in novarres in novarres or highcs!!\n! BEWARE: allocation: calculating with one phase with 8 composition sets\n! and disordered fractions sets !!!\n if(oldeq.eq.1) then\n! the first equilibria has many phase_varres record as we do not what system\n! we will have. If we copy that we create as many varres as in the enter_equil\n iz=2*noofph+2*noofel+10\n else\n! When we copy other equilibria we copy the same number as in the origin\n iz=size(ceq%phase_varres)\n endif\n allocate(eqlista(ieq)%phase_varres(iz))\n! write(*,*)'3B copy_equil allocates: ',oldeq,ieq,iz,highcs,csfree\n! now copy the current content of ceq%phase_varres to this equilibrium\n! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0\n! and phase_varres index 1, the number of phase_varres records is not the\n! same as number of phases ....\n!\n! strange error here running STEP on bigfcc4: crash with message:\n! Index \"3\" of dimension 1 of array \"eqlista\" above upper bound of 2\n! write(*,*)'3B 3737:',novarres,ieq,oldeq,size(eqlista(oldeq)%phase_varres)\n! Ahhhh, there are 2 phase_varres records for each phase because of \n! disordered fraction set, one for the ordered with 33 y-fractions, one for\n! the disordered with 8 y-fractions. \n! A simple dimensioning problem: 1 phase, 8 compsets, disordered fracset\n! requires 17 phase_varres. Before the \"max\" above I had dimensioned for 2\n! BEWARE: I am not sure novarres is correct ...\n! copypv: do ipv=1,min(novarres+3,size(ceq%phase_varres))\n! copypv: do ipv=1,novarres\n! THIS CREATED ALL TROUBLE ... I did not copy all varres records used!!\n copypv: do ipv=1,iz\n eqlista(ieq)%phase_varres(ipv)=eqlista(oldeq)%phase_varres(ipv)\n! in matsmin nprop seemed suddenly to be zero in copied equilibria ....\n! write(*,*)'3B copyeq 2: ',ieq,ipv,eqlista(ieq)%phase_varres(ipv)%nprop\n! Bug 170524 ... disordered phase_varres had no \n! write(*,833)'3B copyeq: ',oldeq,ipv,novarres,&\n! eqlista(oldeq)%phase_varres(ipv)%disfra%varreslink,&\n! eqlista(ieq)%phase_varres(ipv)%disfra%varreslink\n833 format(a,2i3,i5,2i3,10i5)\n enddo copypv\n900 continue\n! write(*,*)'3B To copy conditions:'\n! copy conditions (and experiments) !!!\n lastcond=>eqlista(oldeq)%lastcondition\n if(associated(lastcond)) then\n jz=1\n call copy_condition(eqlista(ieq)%lastcondition,lastcond)\n! write(*,770)'3B cc1: ',jz,lastcond%prescribed,&\n! eqlista(ieq)%lastcondition%prescribed\n newcond1=>eqlista(ieq)%lastcondition\n bugcond=>newcond1\n oldcond=>lastcond%next\n do while(.not.associated(oldcond,lastcond))\n jz=jz+1\n newcond2=>newcond1\n call copy_condition(newcond1%next,oldcond)\n newcond1=>newcond1%next\n! write(*,770)'3B cc2: ',jz,oldcond%prescribed,newcond1%prescribed\n770 format(a,i2,6(1pe12.4))\n newcond1%previous=>newcond2\n oldcond=>oldcond%next\n enddo\n newcond1%next=>bugcond\n! write(*,*)'3B Copied all condition',jz\n else\n nullify(eqlista(ieq)%lastcondition)\n endif\n! copy experiments) ... later\n!\n nullify(eqlista(ieq)%lastexperiment)\n!\n! copy TPfuns and symbols and current values\n! write(*,*)'3B Copy tpval arrays'\n eqlista(ieq)%tpval=ceq%tpval\n allocate(eqlista(ieq)%eq_tpres(maxtpf))\n! write(*,*)'3B allocated tpres arrays'\n eqlista(ieq)%eq_tpres=ceq%eq_tpres\n allocate(eqlista(ieq)%svfunres(maxsvfun))\n! write(*,*)'3B allocated svfunres arrays'\n eqlista(ieq)%svfunres=ceq%svfunres\n! copy convergence criteria\n eqlista(ieq)%xconv=ceq%xconv\n eqlista(ieq)%gdconv(1)=ceq%gdconv(1)\n eqlista(ieq)%gdconv(2)=ceq%gdconv(2)\n! woops ... this is still used\n! stop 'old copy_equilibrium ... we should never be here'\n eqlista(ieq)%maxiter=ceq%maxiter\n! write(*,*)'3B finished copy equilibrium',ieq\n eqlista(ieq)%eqno=ieq\n neweq=>eqlista(ieq)\n! status word is initiated to zero, no need to copy?? Maybe EQMIXED?\n! write(*,*)'3B copy_eq: ',neweq%status,ceq%status\n! write(*,*)'3B Assigned pointer to new equilibrium',neweq%eqno\n1000 continue\n! write(*,*)'3B exit copy_equilibrium'\n return\n end subroutine copy_equilibrium2 !csfree\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine copy_condition\n!\\begin{verbatim}\n subroutine copy_condition(newrec,oldrec)\n! Creates a copy of the condition record \"oldrec\" and returns a link\n! to the copy in newrec. The links to \"next/previous\" are nullified\n implicit none\n type(gtp_condition), pointer :: oldrec\n type(gtp_condition), pointer :: newrec\n!\\end{verbatim}\n! write(*,*)' *** In copy_condition: ',oldrec%prescribed\n allocate(newrec)\n! write(*,*)' *** Allocated'\n newrec=oldrec\n! write(*,*)' *** Copied old condition to new',newrec%prescribed\n1000 continue\n return\n end subroutine copy_condition\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable integer function newhighcs\n!\\begin{verbatim}\n integer function newhighcs(reserved)\n! updates highcs and arranges csfree to be in sequential order\n! highcs is the higest used varres record before the last reservation\n! or release of a record. release is TRUE if a record has been released \n! csfree is the beginning of the free list of varres records.\n implicit none\n logical reserved\n!\\end{verbatim}\n integer high,lok,free,prev\n! Do not be smart, go through the whole array\n! in all used varres record the %nextfree is zero\n high=0\n free=0\n do lok=1,size(firsteq%phase_varres)\n if(firsteq%phase_varres(lok)%nextfree.eq.0) then\n high=lok\n elseif(free.eq.0) then\n! we have the first record belonging to the free list\n free=lok\n prev=lok\n else\n firsteq%phase_varres(prev)%nextfree=lok\n prev=lok\n endif\n enddo\n! verification ??\n prev=2*noofph+2\n! write(*,*)'3B high and free: ',high,free,reserved,highcs,csfree\n! write(*,110)(firsteq%phase_varres(lok)%nextfree,lok=free,prev)\n110 format(12(i6)) \n! write(*,120)free,csfree,high,&\n! (firsteq%phase_varres(lok)%nextfree,lok=free,high)\n120 format('3B cs: ',3i5,(14i4))\n newhighcs=high\n csfree=free\n! write(*,*)'3B in newhighcs: ',csfree,highcs\n1000 continue\n end function newhighcs\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable init_phlista\n!\\begin{verbatim}\n subroutine init_phlista(nyfas)\n! inititates all data in a new phase, attempt to make make NEW work better\n! It has not helped with the convergence problems repeating calculating step1 \n integer nyfas\n!\\end{verbatim}\n! write(*,*)'Initate phase data ',nyfas\n phlista(nyfas)%models=' '\n phlista(nyfas)%phletter=' '\n phlista(nyfas)%status1=0\n phlista(nyfas)%alphaindex=0\n phlista(nyfas)%noofcs=0\n phlista(nyfas)%nooffs=0\n nullify(phlista(nyfas)%additions)\n nullify(phlista(nyfas)%ordered)\n nullify(phlista(nyfas)%disordered)\n phlista(nyfas)%noemr=0\n phlista(nyfas)%ndemr=0\n! these are allocatable arrays\n! nullify(phlista(nyfas)%oendmemarr)\n! nullify(phlista(nyfas)%dendmemarr)\n phlista(nyfas)%noofsubl=0\n phlista(nyfas)%tnooffr=0\n! this is an array with 9 elements\n phlista(nyfas)%linktocs=0\n! ignore nooffr and constitlist as allocateble arrays \n phlista(nyfas)%i2slx=0\n nullify(phlista(nyfas)%tooplast)\n nullify(phlista(nyfas)%toopfirst)\n phlista(nyfas)%lasttoopid=0\n! That are all data in a phlista record\n1000 continue\n return\n end subroutine init_phlista\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n" }, { "path": "src/models/gtp3C.F90", "content": "!\n! gtp3C included in gtp3.F90\n!\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 7. Section: list data\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_elements\n!\\begin{verbatim}\n subroutine list_all_elements(unit)\n! lists elements\n implicit none\n integer unit\n!\\end{verbatim} %+\n integer jl,ipos\n character line*80\n line=' '\n write(unit,10)noofel\n10 format(/'List of ',i2,' elements'/ &\n ' No Sym Name',10X,'Reference state',12X,&\n 'Mass H298-H0 S298 Status')\n loop1: do jl=-1,noofel\n ipos=1\n call list_element_data(line,ipos,elements(jl))\n if(gx%bmperr.ne.0) goto 1000\n write(unit,100)jl,line(1:ipos)\n enddo loop1\n100 format(i3,2x,A)\n1000 continue\n return\n end subroutine list_all_elements\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_elements2(unit)\n!\\begin{verbatim} %-\n subroutine list_all_elements2(unit)\n! lists elements\n implicit none\n integer unit\n!\\end{verbatim}\n integer jl\n character line*80\n line=' '\n loop1: do jl=-1,noofel\n write(unit,100) ellista(jl)%symbol,ellista(jl)%ref_state,&\n ellista(jl)%mass,ellista(jl)%h298_h0,ellista(jl)%s298\n enddo loop1\n100 format('ELEMENT ',A,' ',A,3(1pe12.4),' !')\n1000 continue\n return\n END subroutine list_all_elements2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_components\n!\\begin{verbatim}\n subroutine list_all_components(unit,ceq)\n! lists the components for an equilibrium\n implicit none\n integer unit\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jl,loksp\n character symbol*24\n double precision moles,masspercent,chempot\n moles=zero\n masspercent=zero\n chempot=zero\n write(unit,10)\n10 format('List of components'/ &\n 'No Symbol',19X,'Moles',6x,'Mass %',5x,'Chem pot',3x,'Ref. state')\n loop1: do jl=1,noofel\n loksp=ceq%complist(jl)%splink\n symbol=splista(loksp)%symbol\n write(unit,100)jl,symbol,moles,masspercent,chempot,&\n ceq%complist(jl)%refstate\n enddo loop1\n100 format(i2,1x,A,3(1PE11.3),1X,A)\n1000 continue\n return\n end subroutine list_all_components\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_element_data\n!\\begin{verbatim}\n subroutine list_element_data(text,ipos,elno)\n implicit none\n character text*(*)\n integer ipos,elno\n!\\end{verbatim}\n if(elno.lt.-1 .or. elno.gt.noofel) then\n gx%bmperr=4042\n goto 1000\n endif\n if(ipos.lt.1 .or. ipos.ge.len(text)) then\n gx%bmperr=4043\n goto 1000\n endif\n text(ipos:ipos+2)=ellista(elno)%symbol\n text(ipos+3:ipos+16)=ellista(elno)%name\n text(ipos+17:ipos+40)=ellista(elno)%ref_state\n write(text(ipos+41:ipos+73),100)ellista(elno)%mass,&\n ellista(elno)%h298_h0,ellista(elno)%s298,ellista(elno)%status\n100 format(1x,f7.3,1x,f7.2,1x,f7.3,1x,z8)\n ipos=len_trim(text)\n! write(*,*)'3C x:',text(1:79)\n1000 continue\n return\n END subroutine list_element_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_species_data\n!\\begin{verbatim}\n subroutine list_species_data(text,ipos,spno)\n implicit none\n character text*(*)\n integer ipos,spno\n!\\end{verbatim} %+\n character dummy*48\n integer jpos\n if(spno.lt.1 .or. spno.gt.noofsp) then\n! write(*,*)'3C in list_species_data'\n gx%bmperr=4051\n goto 1000\n endif\n if(ipos.lt.1 .or. ipos.ge.len(text)) then\n gx%bmperr=4043\n goto 1000\n endif\n text(ipos:ipos+24)=splista(spno)%symbol\n text(ipos+25:ipos+25)=' '\n dummy=' '\n call encode_stoik(dummy,jpos,5,spno)\n text(ipos+26:ipos+48)=dummy(1:min(23,jpos))\n if(jpos.gt.23) text(ipos+46:ipos+48)='<.>'\n text(ipos+49:ipos+49)=' '\n write(text(ipos+50:ipos+56),100)splista(spno)%mass\n write(text(ipos+57:ipos+62),105)splista(spno)%charge\n!100 format(F7.3)\n! some MQMQA species are more than 1000 g\n100 format(F7.2)\n105 format(F6.2)\n text(ipos+66:)=' '\n! write(*,120)splista(spno)%status\n write(text(ipos+63:ipos+70),120)splista(spno)%status\n write(text(ipos+71:ipos+73),125)splista(spno)%quadindex\n120 format(Z8)\n125 format(i3)\n ipos=ipos+73\n1000 continue\n return\n END subroutine list_species_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_species_data2\n!\\begin{verbatim} %-\n subroutine list_species_data2(text,ipos,loksp)\n! loksp is species record ...\n implicit none\n character text*(*)\n integer ipos,loksp,tdb\n!\\end{verbatim}\n character dummy*24\n integer jpos\n if(loksp.lt.1 .or. loksp.gt.noofsp) then\n! write(*,*)'3C in list_species_data2'\n gx%bmperr=4051\n goto 1000\n endif\n if(ipos.lt.1 .or. ipos.ge.len(text)) then\n gx%bmperr=4043\n goto 1000\n endif\n text(ipos:ipos+24)=splista(loksp)%symbol\n text(ipos+25:ipos+25)=' '\n dummy=' '\n if(splista(loksp)%quadindex.gt.0) then\n write(*,*)'3C quads listed in another way'\n goto 1000\n endif\n! if(tdb.ne.1) then\n! text(ipos:)=splista(loksp)%mqmqa1\n! write(*,*)'3C list_species_data2: ',trim(text)\n! else\n! quads never arrive here\n call encode_stoik(dummy,jpos,5,loksp)\n text(ipos+26:ipos+48)=dummy(1:jpos)\n! endif\n! mqmqa SPECIES KLA/CL-Q K,LA/CL 3.5 6 2.5454546 !\n! mqmqa SPECIES MG/CL-Q MG/CL 6 3 4 !\n! write(text(ipos+50:ipos+59),100)splista(loksp)%mass\n! write(text(ipos+60:ipos+65),105)splista(loksp)%charge\n!100 format(F10.3)\n! Some MQMQA species are more than 1000 g\n100 format(F10.2)\n105 format(F6.1)\n! text(ipos+66:)=' '\n! write(*,120)splista(loksp)%status\n! write(text(ipos+66:ipos+73),120)splista(loksp)%status\n120 format(Z8)\n! ipos=ipos+73\n1000 continue\n return\n END subroutine list_species_data2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_species\n!\\begin{verbatim}\n subroutine list_all_species(unit)\n implicit none\n integer unit\n!\\end{verbatim}\n integer jl,ipos,loksp\n character line*100\n write(unit,10)noofsp\n10 format(/'List of ',i3,' species'/ &\n ' No Symbol',20X,'Stoichiometry',9X,'Mass',5x,'Charge Status Qua')\n loop1: do jl=1,noofsp\n ipos=1\n call list_species_data(line,ipos,species(jl))\n if(gx%bmperr.ne.0) goto 1000\n write(unit,100)jl,line(1:ipos)\n! uniquac values\n loksp=species(jl)\n if(btest(splista(loksp)%status,SPUQC)) then\n write(unit,110)splista(loksp)%spextra\n endif\n enddo loop1\n100 format(i4,1x,A)\n110 format(5x,'UNIQUAC area (q): ',F10.4,', segments (r): ',F10.4)\n1000 continue\n return\n END subroutine list_all_species\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_sorted_phases\n!\\begin{verbatim}\n subroutine list_sorted_phases(unit,mode,ceq)\n! short list with one line for each phase\n! suspended phases merged into one line\n! stable first, then entered ordered in driving force order, then dormant\n! also in driving force order. Only 10 of each, the others lumped together\n! if mode not zero include status bits\n implicit none\n integer unit, mode\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp,nent,nstab,iph,jph,shbest\n character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1\n integer, dimension(:), allocatable :: entph,dorph\n TYPE(gtp_phase_varres), pointer :: csrec\n double precision am1,am2\n!\n! write(*,*)'3C list_sorted_phases'\n allocate(entph(nooftuples))\n allocate(dorph(nooftuples))\n nstab=0; nent=0; ndorm=0; nsusp=1\n susph=' '\n ch1=' '\n shbest=0\n phloop: do jk=1,noofph\n lokph=phases(jk)\n csloop: do ics=1,phlista(lokph)%noofcs\n! write(*,17)'3C sort1: ',nent,(entph(iph),iph=1,nent)\n17 format(a,i3,2x,16(i4))\n lokcs=phlista(lokph)%linktocs(ics)\n csrec=>ceq%phase_varres(lokcs)\n! write(*,*)'3C sorting: ',trim(phlista(lokph)%name),' ',csrec%phstate\n if(csrec%phstate.ge.PHENTSTAB) then\n if(nent.eq.0) then\n nent=1;\n entph(nent)=lokcs\n! write(*,*)'3C first phase stable: ',nent,nent,lokcs\n else\n! FIX and STABLE phases first in order of amount\n do iph=1,nent\n am1=csrec%amfu*csrec%abnorm(1)\n am2=ceq%phase_varres(entph(iph))%amfu*&\n ceq%phase_varres(entph(iph))%abnorm(1)\n if(am1.lt.am2) cycle\n! if(csrec%amfu.lt.ceq%phase_varres(entph(iph))%amfu) cycle\n! this is the place for this phase, shift later down\n do jph=nent,iph,-1\n entph(jph+1)=entph(jph)\n enddo\n exit\n enddo\n! according to new fortran standard loop variable at exit is high limit+1\n! write(*,18)'3C inserted stable phase ',iph,lokcs,csrec%amfu\n18 format(a,2i4,1pe12.4)\n entph(iph)=lokcs\n nent=nent+1\n! write(*,*)'3C stable phase: ',nent,iph,lokcs\n endif\n elseif(csrec%phstate.eq.PHENTERED .or. &\n csrec%phstate.eq.PHENTUNST) then\n! if dgm>0 this phase should be stable !!! add warning at the end\n if(csrec%dgm.gt.zero) shbest=csrec%phtupx\n if(nent.eq.0) then\n nent=1\n entph(nent)=lokcs\n! write(*,69)'3C first phase unstable: ',nent,nent,lokcs,csrec%dgm\n else\n! ENTERED, not stable, sort after all stable phase and with smallest DGM first\n do iph=1,nent\n! bypass all stable phases\n if(ceq%phase_varres(entph(iph))%amfu.gt.zero) cycle\n if(csrec%dgm/csrec%abnorm(1).lt.&\n ceq%phase_varres(entph(iph))%dgm/ceq%phase_varres(entph(iph))%abnorm(1)) cycle\n! this is the place for this phase, shift later phases down\n do jph=nent,iph,-1\n entph(jph+1)=entph(jph)\n enddo\n exit\n enddo\n! according to new fortran standard loop variable at exit is high limit+1\n! write(*,18)'3C inserted ustable phase ',iph,lokcs,csrec%dgm\n entph(iph)=lokcs\n nent=nent+1\n! write(*,69)'3C unstable phase: ',iph,nent,lokcs,csrec%dgm\n69 format(a,3i4,1pe12.4)\n endif\n elseif(csrec%phstate.eq.PHDORM) then\n if(ndorm.eq.0) then\n ndorm=ndorm+1\n dorph(ndorm)=lokcs\n! write(*,*)'3C first dormant phase: ',ndorm,ndorm,lokcs\n else\n! DORMANT sort after with smallest (least nagative) DGM first\n do iph=1,ndorm\n if(csrec%dgm.lt.&\n ceq%phase_varres(dorph(iph))%dgm/ceq%phase_varres(dorph(iph))%abnorm(1)) cycle\n! this is the place for this phase, shift later down\n do jph=ndorm,iph,-1\n dorph(jph+1)=dorph(jph)\n enddo\n exit\n enddo\n! according to new fortran standard loop variable at exit is high limit+1\n dorph(iph)=lokcs\n ndorm=ndorm+1\n! write(*,*)'3C dormant phase: ',iph,ndorm,lokcs\n endif\n elseif(csrec%phstate.eq.PHSUS) then\n! skip composition set number and pre/suffixes at present ....\n susph(nsusp:)=trim(phlista(lokph)%name)//', '\n nsusp=len_trim(susph)+2\n if(ics.gt.1) then\n susph(nsusp-2:)='#'//char(ichar('0')+ics)//','\n nsusp=nsusp+2\n endif\n endif\n enddo csloop\n enddo phloop\n! we have now sorted stable, entered and dormant phases\n selmode: if(mode.eq.0) then\n! This listing does not include the status bits, maybe add some information?\n write(unit,10)\n10 format(/'List of stable and entered phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT')\n! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2')\n! come back here for dormant phases ??\n jph=0\n entlist: do iph=1,nent\n trailer=' '\n lokcs=entph(iph)\n csrec=>ceq%phase_varres(lokcs)\n lokph=csrec%phlink\n phname=phlista(lokph)%name\n! how do I to know composition set number??? \n! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset\n if(phlista(lokph)%noofcs.gt.1) then\n ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset\n chs=char(ichar('0')+ics)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//phname\n else\n csname=phname\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=&\n csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp)\n csname=csname(1:len_trim(csname))//'#'//chs//trailer\n else\n csname=phname\n endif\n! phase names for composition sets can be larger than 24, remove middle part\n jl=len_trim(csname)\n if(jl.gt.24) then\n csname=csname(1:12)//'..'//csname(jl-9:jl)\n endif\n ch1='X'\n write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),&\n csrec%abnorm(1),csrec%dgm/csrec%abnorm(1)\n112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2)\n if(csrec%dgm.lt.zero) then\n jph=jph+1\n if(jph.gt.10) then\n write(unit,*)' ... remaining phases further from stability'\n exit entlist\n endif\n endif\n enddo entlist\n if(shbest.gt.0) then\n call get_phasetup_name(shbest,phname)\n write(*,117)trim(phname)\n117 format(' *** WARNING: unstable phase with positive driving force: ',a)\n endif\n if(ndorm.eq.0) goto 400\n write(unit,210)\n210 format(/'List of dormant phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT')\n jph=0\n dorlist1: do iph=1,ndorm\n trailer=' '\n lokcs=dorph(iph)\n csrec=>ceq%phase_varres(lokcs)\n lokph=csrec%phlink\n phname=phlista(lokph)%name\n! how do I to know composition set number??? \n! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset\n if(phlista(lokph)%noofcs.gt.1) then\n ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset\n chs=char(ichar('0')+ics)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//phname\n else\n csname=phname\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=&\n csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp)\n csname=csname(1:len_trim(csname))//'#'//chs//trailer\n else\n csname=phname\n endif\n! phase names for composition sets can be larger than 24, remove middle part\n jl=len_trim(csname)\n if(jl.gt.24) then\n csname=csname(1:12)//'..'//csname(jl-9:jl)\n endif\n ch1='D'\n write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),&\n csrec%abnorm(1),csrec%dgm/csrec%abnorm(1)\n jph=jph+1\n if(jph.gt.10) then\n write(unit,*)' ... other phases further from stability'\n exit dorlist1\n endif\n enddo dorlist1\n else\n! This is the old listing including status bits \n write(unit,30)\n30 format(/'List of stable and entered phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2')\n! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2')\n! come back here for dormant phases\n jph=0\n entlist2: do iph=1,nent\n trailer=' '\n lokcs=entph(iph)\n csrec=>ceq%phase_varres(lokcs)\n lokph=csrec%phlink\n phname=phlista(lokph)%name\n! how do I to know composition set number??? \n! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset\n if(phlista(lokph)%noofcs.gt.1) then\n ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset\n chs=char(ichar('0')+ics)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//phname\n else\n csname=phname\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=&\n csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp)\n csname=csname(1:len_trim(csname))//'#'//chs//trailer\n else\n csname=phname\n endif\n! phase names for composition sets can be larger than 24, remove middle part\n jl=len_trim(csname)\n if(jl.gt.24) then\n csname=csname(1:12)//'..'//csname(jl-9:jl)\n endif\n ch1='X'\n write(unit,412)phlista(lokph)%alphaindex,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),csrec%abnorm(1),&\n csrec%dgm/csrec%abnorm(1),phlista(lokph)%status1,&\n ceq%phase_varres(lokcs)%status2,ch1\n412 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1)\n if(csrec%dgm.lt.zero) then\n jph=jph+1\n if(jph.gt.10) then\n write(unit,*)' ... remaining phases further from stability'\n exit entlist2\n endif\n endif\n enddo entlist2\n if(shbest.gt.0) then\n call get_phasetup_name(shbest,phname)\n write(*,117)trim(phname)\n endif\n!\n if(ndorm.eq.0) goto 400\n write(unit,211)\n211 format(/'List of dormant phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2')\n jph=0\n dorlist: do iph=1,ndorm\n trailer=' '\n lokcs=dorph(iph)\n csrec=>ceq%phase_varres(lokcs)\n lokph=csrec%phlink\n phname=phlista(lokph)%name\n! how do I to know composition set number??? \n! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset\n if(phlista(lokph)%noofcs.gt.1) then\n ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset\n chs=char(ichar('0')+ics)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//phname\n else\n csname=phname\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) csname=&\n csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp)\n csname=csname(1:len_trim(csname))//'#'//chs//trailer\n else\n csname=phname\n endif\n! phase names for composition sets can be larger than 24, remove middle part\n jl=len_trim(csname)\n if(jl.gt.24) then\n csname=csname(1:12)//'..'//csname(jl-9:jl)\n endif\n ch1='D'\n write(unit,113)phlista(lokph)%alphaindex,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),&\n csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),phlista(lokph)%status1,&\n ceq%phase_varres(lokcs)%status2,ch1\n113 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1)\n jph=jph+1\n if(jph.gt.10) then\n write(unit,*)' ... other phases further from stability'\n exit dorlist\n endif\n enddo dorlist\n endif selmode\n! list suspended phases without composition set numbers\n400 continue\n if(nsusp.gt.1) then\n write(unit,300)\n300 format(/'List of suspended phases:')\n! First indentation 4, for 2nd and later lines 4 also\n call wrice2(unit,2,4,78,1,susph(1:nsusp-3))\n endif\n1000 continue\n return\n end subroutine list_sorted_phases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_phases\n!\\begin{verbatim}\n subroutine list_all_phases(unit,ceq)\n! short list with one line for each phase\n! suspended phases merged into one line\n implicit none\n integer unit\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! separate entered/fixed form suspended/dormant\n integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp\n character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1\n! type(gtp_phasetuple), allocatable :: dormant\n TYPE(gtp_phase_varres), pointer :: csrec\n susph=' '\n nsusp=1\n write(unit,10)nooftuples\n10 format(/'List of ',i3,' phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2')\n! 230709 ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2')\n! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2')\n jl=0\n trailer=' '\n! write(*,*)'3C In list_all_phases',noofph\n! allocate(dormant(noofph))\n! dormant=0\n ndorm=0\n! come back here for listing dormant phases\n20 continue\n!\n phloop: do jk=1,noofph\n line=' '\n! list in alphabetical order except gas and liquid(s) first\n lokph=phases(jk)\n csloop: do ics=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ics)\n csrec=>ceq%phase_varres(lokcs)\n! write(*,*)'3C lpd: 69: ',jk,ics,lokph,lokcs\n if(ndorm.ge.0) then\n if(csrec%phstate.eq.PHDORM) then\n ndorm=ndorm+1\n cycle\n elseif(csrec%phstate.eq.PHSUS) then\n! skip composition set number and pre/suffixes at present ....\n susph(nsusp:)=phlista(lokph)%name(1:&\n len_trim(phlista(lokph)%name))//', '\n nsusp=len_trim(susph)+2\n if(ics.gt.1) then\n susph(nsusp-2:)='#'//char(ichar('0')+ics)//','\n nsusp=nsusp+2\n endif\n cycle\n endif\n elseif(csrec%phstate.ne.PHDORM) then\n! when ndorm<0 skip all ohases that are suspended, entered or fix\n cycle\n endif\n phname=phlista(lokph)%name\n jl=jl+1\n! write(*,70)'3C lpd: 70:',phname,phlista(lokph)%noofcs\n!70 format(a,a24,5i6)\n if(phlista(lokph)%noofcs.gt.1) then\n chs=char(ichar('0')+ics)\n kp=len_trim(csrec%prefix)\n if(kp.gt.0) then\n csname=csrec%prefix(1:kp)//'_'//phname\n else\n csname=phname\n endif\n kp=len_trim(csrec%suffix)\n if(kp.gt.0) &\n csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp)\n csname=csname(1:len_trim(csname))//'#'//chs//trailer\n else\n csname=phname\n endif\n! phase names for composition sets can be larger than 24, remove middle part\n jl=len_trim(csname)\n if(jl.gt.24) then\n csname=csname(1:12)//'..'//csname(jl-9:jl)\n endif\n if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then\n ch1='F'\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then\n ch1='S'\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phentered) then\n ch1='E'\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phentunst) then\n ch1='U'\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phdorm) then\n ch1='D'\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phsus) then\n ch1='X'\n else\n write(*,*)'3C unknown state: ',ceq%phase_varres(lokcs)%phstate\n endif\n!\n if(csrec%amfu.ne.zero) then\n if(csrec%dgm.eq.zero) then\n! write(unit,110)jk,ics,csname, &\n write(unit,110)jk,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),&\n csrec%abnorm(1),phlista(lokph)%status1,&\n ceq%phase_varres(lokcs)%status2,ch1\n! 230709 shorter\n110 format(i3,i4,1x,a24,1PE10.2,1x,0PF8.2,' 0.0 ',2(0p,z8),a1)\n!110 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,' 0.0',2(0p,z8),a1)\n!110 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,' 0.0',2(0p,z8))\n else\n! write(unit,112)jk,ics,csname, &\n write(unit,112)jk,csrec%phtupx,csname, &\n csrec%amfu*csrec%abnorm(1),&\n csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),&\n phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1\n! 230709 shorter\n112 format(i3,i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,1x,2(0p,z8),a1)\n!112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1)\n!112 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,1PE10.2,2(0p,z8))\n endif\n else\n! write(unit,111)jk,ics,csname, &\n write(unit,111)jk,csrec%phtupx,csname, &\n csrec%abnorm(1),csrec%dgm/csrec%abnorm(1),&\n phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1\n! 230709 shorter\n111 format(i3,i4,1x,a24,' 0.0',1x,0PF8.2,1PE10.2,1x,2(0p,z8),a1)\n!111 format(2i4,1x,a24,' 0.0',1x0PF8.2,1PE10.2,2(0p,z8),a1)\n!111 format(2i4,1x,a24,' 0.0',1x0PF9.2,1PE10.2,2(0p,z8))\n endif\n enddo csloop\n enddo phloop\n if(ndorm.gt.0) then\n write(unit,200)\n! 230709 shorter\n200 format(/'List of dormant phases'/ &\n ' No tup Name',22x,'Mol.comp. Comp/FU dGm/RT Status1 Status2')\n! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2')\n ndorm=-1\n goto 20\n endif\n! list suspended phases without composition set numbers\n if(nsusp.gt.1) then\n write(unit,300)\n300 format(/'List of phases that are suspended:')\n! First indentation 4, for 2nd and later lines 4 also\n call wrice2(unit,2,4,78,1,susph(1:nsusp-3))\n endif\n1000 continue\n! temporary list all phase tuples\n! do jl=1,nooftuples\n! lokph=phases(phasetuple(jl)%phase)\n! lokcs=phlista(lokph)%linktocs(phasetuple(jl)%compset)\n! write(*,600)jl,phasetuple(jl)%phase,phasetuple(jl)%compset,lokcs,&\n! firsteq%phase_varres(lokcs)%phtupx\n!600 format('Phase tuple: ',3i4,' backlink: ',5i4)\n! enddo\n return\n END subroutine list_all_phases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_global_results\n!\\begin{verbatim}\n subroutine list_global_results(lut,ceq)\n! list G, T, P, V and some other things\n implicit none\n integer lut\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character encoded*64\n double precision x1,x2,x3,xn,rtn\n!\n! write(kou,*)'gtp3C: output unit: ',lut\n encoded=' '\n call get_state_var_value('T ',x1,encoded,ceq)\n call get_state_var_value('P ',x2,encoded,ceq)\n! We must use VS to get SER reference \n call get_state_var_value('VS ',x3,encoded,ceq)\n! this will write error message if any and reset the code\n if(.not.gtp_error_message(0)) then\n! no error, list the data\n write(lut,10)x1,x1-273.15,x2,x3\n10 format('T= ',F9.2,' K (',F9.2,' C), P= ',1pe11.4,&\n ' Pa, V= ',1pe11.4,' m3')\n rtn=globaldata%rgas*x1\n else\n rtn=one\n endif\n! problem with N, should not take into account the atoms/formula units?\n call get_state_var_value('N ',xn,encoded,ceq)\n call get_state_var_value('B ',x2,encoded,ceq)\n if(.not.gtp_error_message(0)) then\n write(lut,11)xn,x2,rtn\n11 format('N= ',1pe12.4,' moles, B= ',1pe12.4,' g, RT= ',1pe12.4,' J/mol')\n endif\n! we must use suffix S to have values referred to SER\n call get_state_var_value('GS ',x1,encoded,ceq)\n call get_state_var_value('HS ',x2,encoded,ceq)\n! CCI changed format of S\n! call get_state_var_value('S ',x3,encoded,ceq)\n call get_state_var_value('SS ',x3,encoded,ceq)\n if(.not.gtp_error_message(0)) then\n! just use G, H and S here as the heading state the SER refernce state is used\n write(lut,12)x1,x1/xn,x2,x3\n12 format('G= ',1pe12.5,' J, G/N=',1pe11.4,' J/mol, H=',1pe11.4,&\n ' J, S=',1pe10.3,' J/K')\n!CCI end\n endif\n1000 continue\n return\n end subroutine list_global_results\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_components_result\n!\\begin{verbatim}\n subroutine list_components_result(lut,mode,ceq)\n! list one line per component (name, moles, x/w-frac, chem.pot. reference state\n! mode 1=mole fractions, 2=mass fractions\n implicit none\n integer lut,mode\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character svtext*64,encoded*64,name*24\n integer ie,kl\n double precision x1,x2,x3,x4,rtn\n encoded=' '\n if(mode.eq.1) then\n write(lut,7)\n!7 format('Component name',11x,'Moles',7x,'Mole-fracs Chem.potent. ',&\n7 format('Component name',4x,'Moles',6x,'Mole-fr Chem.pot/RT ',&\n 'Activities Ref.state')\n elseif(mode.eq.2) then\n write(lut,9)\n9 format('Component name',4x,'Moles',6x,'Mass-fr Chem.pot/RT ',&\n 'Activities Ref.state')\n endif\n call get_state_var_value('T ',x1,encoded,ceq)\n rtn=globaldata%rgas*x1\n do ie=1,noofel\n call get_component_name(ie,name,ceq)\n kl=len_trim(name)\n svtext='N('//name(1:kl)//') '\n! write(*,*)'3C state variable :',svtext\n call get_state_var_value(svtext,x1,encoded,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n if(mode.eq.1) then\n svtext='X('//name(1:kl)//') '\n elseif(mode.eq.2) then\n svtext='W('//name(1:kl)//') '\n endif\n call get_state_var_value(svtext,x2,encoded,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! This should be read from component record .... ???? YES\n svtext='MU('//name(1:kl)//') '\n! write(*,*)'3C state variable :',svtext\n call get_state_var_value(svtext,x3,encoded,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3C Error line 659: ',trim(svtext),gx%bmperr\n gx%bmperr=0; x3=1.0D2*rtn\n endif\n! divide mu with RT, lnac\n if(abs(x3).gt.1.0D-30) then\n x3=x3/rtn\n else\n x3=zero\n endif\n x4=exp(x3)\n! reference state, by default \"SER (default)\" take from component record\n! if(ceq%complist(ie)%phlink.gt.0) then\n encoded=ceq%complist(ie)%refstate\n! else\n! default name of reference state\n! encoded='SER (default)'\n! endif\n write(lut,10)name(1:16),x1,x2,x3,x4,encoded(1:16)\n!10 format(a,3(1pe12.4),2x,a)\n10 format(a,1pe12.4,0pf9.5,2(1pe12.4),2x,a)\n enddo\n1000 continue\n return\n end subroutine list_components_result\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_phases_with_positive_dgm\n!\\begin{verbatim}\n subroutine list_phases_with_positive_dgm(mode,lut,ceq)\n! list one line for each phase+comp.set with positive dgm on device lut\n! The phases must be dormant or the result is in error. mode is not used\n implicit none\n integer mode,lut\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character name*24\n! character*10, dimension(-3:2) :: status=&\n! ['SuspendedEntered ','Fix ','Dormant ','Suspended ']\n integer once,iph,lokph,ics,lokcs,kkz,jd\n integer, dimension(:), allocatable :: phtupx\n integer, dimension(:), allocatable :: isort\n double precision xxx\n! write(*,*)'3C In list_phases_with_positive_dgm'\n once=0\n do iph=1,noofph\n lokph=phases(iph)\n csloop: do ics=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ics)\n if(ceq%phase_varres(lokcs)%phstate.lt.PHDORM) cycle csloop\n! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then\n! write(*,*)'3C ignoring phase with net charge: ',iph,ics\n! cycle csloop\n! endif\n if(ceq%phase_varres(lokcs)%dgm/&\n ceq%phase_varres(lokcs)%abnorm(1).gt.1.0D-4) then\n if(once.eq.0) then\n allocate(phtupx(nooftuples))\n endif\n once=once+1\n if(once.eq.1) write(lut,109)\n109 format(/' *** There are phase(s) which would like to be stable:')\n phtupx(once)=ceq%phase_varres(lokcs)%phtupx\n write(lut,78, advance='no')trim(phlista(lokph)%name),&\n ceq%phase_varres(lokcs)%dgm/ceq%phase_varres(lokcs)%abnorm(1)\n78 format(3x,a,1pe12.4)\n! write(*,98)once,phtupx(once),phasetuple(phtupx(once))%phase,iph,&\n! lokcs,ceq%phase_varres(lokcs)%dgm,&\n! ceq%phase_varres(lokcs)%netcharge\n98 format('3C dgm: ',5i4,2(1pe12.4),'; ')\n endif\n enddo csloop\n enddo\n if(once.gt.0) write(*,*)\n! skip the listing below\n goto 1000\n if(once.gt.0) then\n write(lut,110)once\n110 format(/' *** ',i3,' Phases which would like to be stable in order')\n allocate(isort(once))\n! call sortrdd(pdgm,once,isort)\n! if(buperr.ne.0) then\n! write(*,*)'Error sorting fractions',buperr\n! goto 1000\n! endif\n do jd=1,once\n! add next line when we have sorted\n! isort(jd)=jd\n isort(jd)=phtupx(jd)\n! This is getting messy again, the phase tuple index is at present\n! the index to phase_varres +1 (as index 1 is the stable reference phase)\n! iph=phasetuple(phtupx(isort(jd)))%phaseix\n! removing redundant call to get_phase_compset\n! iph=phasetuple(phtupx(isort(jd)))%ixphase\n! ics=phasetuple(phtupx(isort(jd)))%compset\n! call get_phase_compset(iph,ics,lokph,lokcs)\n! if(gx%bmperr.ne.0) goto 1000\n lokph=phasetuple(phtupx(isort(jd)))%lokph\n lokcs=phasetuple(phtupx(isort(jd)))%lokvares\n! write(*,117)jd,isort(jd),iph,ics,lokcs,phtupx(isort(jd)),&\n! ceq%phase_varres(lokcs)%dgm\n117 format('3C Phase: ',2i3,2i5,2i7,1pe10.2)\n! call get_phasetup_name(phasetuple(isort(jd)),name)\n! kkz=test_phase_status(iph,ics,xxx,ceq)\n! write(*,*)'3C: error: ',name,lokcs,kkz\n! old kkz.le.2 means entered or fixed\n! if(kkz.le.3) then\n! now: kkz= -3, -2, -1, 0, 1, 2 \n! means SUSPEND, DORMANT, ENTENTED/UNST, ENTERED, ENTERD/STABLE, FIXED\n kkz=ceq%phase_varres(lokcs+1)%phstate\n if(kkz.ge.PHDORM) then\n write(lut,120)name,phstate(kkz),&\n ceq%phase_varres(lokcs+1)%dgm/ceq%phase_varres(lokcs+1)%abnorm(1)\n120 format('Phase: ',a,' Status: ',a,' Driving force:',1pe12.4)\n endif\n enddo\n endif\n1000 continue\n return\n end subroutine list_phases_with_positive_dgm\n\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_phase_results\n!\\begin{verbatim}\n subroutine list_phase_results(iph,jcs,mode,lut,once,ceq)\n! list results for a phase+comp.set on lut\n! mode specifies the type and amount of results,\n! unit digit: 0=mole fraction, othewise mass fractions\n! 10th digit: 0=only composition, 10=also constitution\n! 100th digit: 0=value order, 100=alphabetical order\n! 1000th digit: 0=all phases, 1000=only stable phases\n! 10000th digit: 1= constituent fractions times formula unit of phase (Solgas)\n! ? digit, just one line per phase\n implicit none\n integer iph,jcs,mode,lut\n logical once\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n character text*256,phname*24,status*10\n character (len=24), dimension(:), allocatable :: consts\n! character*24, allocatable (:) :: consts\n double precision xmol(maxel),wmass(maxel),totmol,totmass,amount,abv,mindgm\n!CCI moles per Formula Unit\n double precision totmolperFU\n!CCI\n double precision, dimension(:), allocatable :: ymol\n integer lokph,lokcs,kode,nz,jl,nk,ll,ip,kstat\n mindgm=1.0D-10\n if(ocv()) write(*,*)'3C mode: ',mode\n if(iph.lt.1 .or. iph.gt.noofph) then\n! write(*,*)'3C lpr ',iph,jcs,mode\n gx%bmperr=4050; goto 1000\n endif\n lokph=phases(iph)\n if(btest(phlista(lokph)%status1,phhid)) then\n! phase is hidden\n gx%bmperr=4119; goto 1000\n endif\n!\n! .gt.9\n!\n if(jcs.lt.0 .or. jcs.gt.phlista(lokph)%noofcs) then\n gx%bmperr=4072; goto 1000\n elseif(jcs.eq.0) then\n jcs=1\n endif\n lokcs=phlista(lokph)%linktocs(jcs)\n! write(*,*)'3C lpr 2: ',jcs,phlista(lokph)%noofcs,lokcs\n! get name with pre- and suffix\n call get_phase_name(iph,jcs,phname)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,11)'3C Phase name: ',iph,jcs,phname\n!11 format(a,2i3,'\"',a,'\"')\n if(mode.ge.1000) then\n! if mode>=1000 list stable phases only (dgm<0 )\n! if(ceq%phase_varres(lokcs)%amount(1).eq.zero) then\n if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then\n if(ceq%phase_varres(lokcs)%phstate.gt.phentered) then\n write(lut,18)phname(1:len_trim(phname)),&\n ceq%phase_varres(lokcs)%netcharge\n18 format('Phase: ',a,' has stable status with net charge: ',F6.3)\n goto 1000\n endif\n endif\n if(ceq%phase_varres(lokcs)%amfu.eq.zero) then\n! skip phases with zero amount unless expcitly stable or positive dgm\n if(ceq%phase_varres(lokcs)%dgm.eq.zero) then\n! if(ceq%phase_varres(lokcs)%phstate.ne.PHFIXED) goto 1000\n if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) goto 1000\n elseif(ceq%phase_varres(lokcs)%dgm.lt.mindgm) then\n goto 1000\n endif\n endif\n endif\n! phase status (except hidden) .... use get_phase_status instead ???\n! if(btest(ceq%phase_varres(lokcs)%status2,cssus)) then\n! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then\n if(ceq%phase_varres(lokcs)%phstate.eq.PHDORM) then\n status='Dormant'\n kstat=4\n! skip dormant phases unless once TRUE (positive driving force)\n! if(ceq%phase_varres(lokcs)%dgm.le.mindgm) goto 1000\n if(.not.once) goto 1000\n elseif(ceq%phase_varres(lokcs)%phstate.eq.PHSUS) then\n! skip suspended phases\n status='Suspended'\n goto 1000\n! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then\n elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then\n status='Fixed'\n kstat=2\n else\n status='Entered'\n kstat=1\n! skip phase with net charge\n! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) goto 1000\n! skip entered phases that have positive driving force, why??\n! if(ceq%phase_varres(lokcs)%dgm.gt.zero) goto 1000\n endif\n if(phname(1:1).lt.'A' .or. phname(1:1).gt.'Z') then\n! in some cases unprintable phase names appears!!\n write(lut,19)iph,jcs,lokph,lokcs\n19 format(' *** Warning: illegal phase name: ',10i5)\n endif\n!X write(lut,20)phname,status,ceq%phase_varres(lokcs)%dgm\n20 format(/'Phase: ',A,' Status: ',A,' Driving force: ',1PE12.4)\n!------------------------\n! xmol=zero\n! wmass=zero\n call calc_phase_molmass(iph,jcs,xmol,wmass,totmol,totmass,amount,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3C Error: ',gx%bmperr; goto 1000\n endif\n!CCI\n totmolperFU=ceq%phase_varres(lokcs)%amfu\n!CCI \n! write(*,99)'3C xmol: ',xmol\n!99 format(a,6(1pe12.4))\n kode=mod(mode,10)\n! write(*,*)'3C lpr 3: ',mode,kode\n abv=ceq%phase_varres(lokcs)%abnorm(1)\n! a shorter output\n! write(lut,700)phname,status(1:1),totmol,totmass*0.001, &\n! amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),&\n! ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm\n! try to fill upp the phase name with '.'\n nz=len_trim(phname)\n phname(nz+1:)='.........................'\n if(kode.eq.0) then\n! The volume value here is WRONG: ceq%phase_varres(lokcs)%gval(3,1) !!! ???\n if(once) write(lut,699)'Moles '\n once=.FALSE.\n699 format(/'Name Status ',a,' Volume',&\n ' Form.Units Cmp/FU dGm/RT Comp:')\n! ' Form.U At/FU DGM Fracs:')\n write(lut,700)phname,status(1:1),totmol,&\n amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),&\n ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm/abv,'X:'\n! phase status moles/mass (volume FU) Atomes/FU DGM Content\n700 format(a,1x,a, 1pe11.3, 2(1pe10.2),1x,0pF7.2,1pe10.2,2x,a)\n!X if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) then\n!X write(lut,28)totmol,totmass*0.001, &\n!X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),&\n!X ceq%phase_varres(lokcs)%netcharge\n!X else\n!X write(lut,25)totmol,totmass*0.001, &\n!X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1)\n!X endif\n!X write(lut,21)ceq%phase_varres(lokcs)%amfu,abv\n21 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,&\n ', Molar content:')\n else\n if(once) write(lut,699)'Mass '\n once=.FALSE.\n write(lut,700)phname,status(1:1),totmass*0.001, &\n amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),&\n ceq%phase_varres(lokcs)%amfu,abv,ceq%phase_varres(lokcs)%dgm/abv,'W:'\n!X write(lut,25)totmol,totmass*0.001,&\n!X amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1)\n!X write(lut,22)ceq%phase_varres(lokcs)%amfu,abv\n22 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,&\n ', Mass fractions:')\n endif\n25 format('Moles',1PE12.4,', Mass',1PE12.4,' kg, Volume',1PE12.4,' m3')\n28 format('Moles',1PE11.3,' Mass',1PE11.3,' kg, Volume',1PE11.3,' m3,',&\n ' Charge: ',1pe11.3)\n! skip composition\n if(mode.eq.10020) goto 1000\n! composition\n nz=noofel\n allocate(consts(nz))\n consts=' '\n do jl=1,nz\n consts(jl)=splista(ceq%complist(jl)%splink)%symbol\n enddo\n! write(*,187)'3C lpr: ',consts\n!187 format(a,20(1x,a2))\n if(kode.eq.0) then\n call format_phase_composition(mode,nz,consts,xmol,lut)\n else\n call format_phase_composition(mode,nz,consts,wmass,lut)\n endif\n deallocate(consts)\n if(gx%bmperr.ne.0) goto 1000\n!-------------------------------------\n! constitution only if nonzero tenth-digit of mode or if GAS\n300 continue\n if(.not.btest(phlista(lokph)%status1,PHGAS)) then\n if(mod(mode/10,10).le.0) goto 900\n endif\n if(mode.ge.10000) then\n! CCI modification warning!\n write(lut,309)\n309 format(' *** NOTE: values below are constituent fractions',&\n ' times formula unit of phase!')\n endif\n write(lut,310,advance='no')\n310 format('Constitution: ')\n!---------------\n nk=0\n sublatloop: do ll=1,phlista(lokph)%noofsubl\n nz=phlista(lokph)%nooffr(ll)\n! if(phlista(lokph)%noofsubl.gt.1) then\n if(size(ceq%phase_varres(lokcs)%sites).gt.1) then\n! write(lut,320)ll,nz,phlista(lokph)%sites(ll)\n if(ll.gt.1) then\n write(lut,319)ll,nz,ceq%phase_varres(lokcs)%sites(ll)\n else\n write(lut,320)ll,nz,ceq%phase_varres(lokcs)%sites(ll)\n endif\n319 format(14x,'Sublattice ',i2,' with ',i5,' constituents and ',&\n F12.6,' sites')\n320 format('Sublattice ',i2,' with ',i5,' constituents and ',&\n F12.6,' sites')\n! elseif(phlista(lokph)%sites(ll).eq.one) then\n elseif(ceq%phase_varres(lokcs)%sites(ll).eq.one) then\n write(lut,321)nz\n321 format('There are ',i5,' constituents:')\n else\n! write(lut,322)nz,phlista(lokph)%sites(ll)\n write(lut,322)nz,ceq%phase_varres(lokcs)%sites(ll)\n322 format('Single lattice with ',i5,' constituents and ',&\n F12.6,' sites')\n endif\n text=' '; ip=1\n allocate(consts(nz))\n allocate(ymol(nz))\n consts=' '\n do jl=1,nz\n! jcons=splista(phlista(lokph)%constitlist(nk+jl))%alphaindex\n consts(jl)=' '\n if(phlista(lokph)%constitlist(nk+jl).gt.0) then\n consts(jl)=splista(phlista(lokph)%constitlist(nk+jl))%symbol\n else\n consts(jl)='*'\n endif\n ymol(jl)=ceq%phase_varres(lokcs)%yfr(nk+jl)\n enddo\n!CCI for mode >= 10000\n if(mode.ge.10000) then\n ymol=ymol*totmolperFU\n endif\n!CCI end\n call format_phase_composition(mode,nz,consts,ymol,lut)\n deallocate(consts)\n deallocate(ymol)\n if(gx%bmperr.ne.0) goto 1000\n nk=nk+nz\n enddo sublatloop\n900 continue\n! write an empty line after each phase ...\n write(lut,*)\n1000 continue\n return\n end subroutine list_phase_results\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_short_results\n!\\begin{verbatim}\n subroutine list_short_results(lut,ceq)\n! list short results for all stable phases (for debugging) lut\n implicit none\n integer lut\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer iph,ics,lokph,lokcs,i1,i2\n phaseloop: do iph=1,noofph\n lokph=phases(ics)\n compsets: do ics=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ics)\n if(ceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then\n write(lut,110)phlista(lokph)%name,ics,ceq%phase_varres(lokcs)%amfu\n110 format(a,i2,4(1pe12.4))\n endif\n enddo compsets\n enddo phaseloop\n1000 continue\n return\n end subroutine list_short_results\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine format_phase_composition\n!\\begin{verbatim}\n subroutine format_phase_composition(mode,nv,consts,vals,lut)\n! list composition/constitution in alphabetical or value order\n! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent\n! tiotalsiffra alphabetical order ... ??\n! mode >100 else alphabetical order\n! nv is number of components/constitunents (in alphabetical order in consts)\n! components/constituents in consts, fractions in vals\n implicit none\n integer nv,mode,lut\n character consts(nv)*(*)\n double precision vals(nv)\n!\\end{verbatim}\n integer maxl,jl,kp,ncol,nrow2,nvrest,n1,nempty,n3r,n4r\n character names(4)*12\n integer, dimension(:), allocatable :: isort\n! 3-13 position name, 12 positions value (1pe12.5), 2 positions separator\n! NOTE components can have negative fractions but not constituents\n! so leave one blank after component names\n! Constituents with names longer than 13 will be written A23456..12345\n! with 6 initial characters, two dots and then the 5 last characters\n! Max 4 columns with 18 positions(=72) plus 3*2=6 position separator,\n! min 3 columns with 24 positions(=72) plus 2*2=4 position separator\n!\n! max length of names and number of columns\n maxl=0\n do jl=1,nv\n kp=len_trim(consts(jl))\n if(kp.gt.maxl) then\n maxl=kp\n endif\n enddo\n if(maxl.le.4) then\n! use 4 columns if names are short\n ncol=4\n else\n ncol=3\n endif\n! number of rows is needed to have valuses in columns decending like:\n! FE 0.75 SI 0.05 Ti 0.02 C 0.01\n! CR 0.20 Mn 0.04 V 0.01\n!-----------------------------------\n nrow2=(nv+ncol-1)/ncol\n! always use isort for the order, if alphabetical isort(i)=i\n allocate(isort(nv+4))\n isort=0\n! if(mode.ge.100) then\n! write(*,*)'3C mode: ',mode,mod(mode,100),mode-100*mod(mode,100)\n! if(mod(mode,10).eq.0) then\n if(mod(mode/100,10).eq.0) then\n! value order\n call sortrdd(vals,nv,isort)\n if(buperr.ne.0) then\n write(*,*)'Error sorting fractions',buperr\n gx%bmperr=buperr; goto 1000\n endif\n! write(*,'(a,10i3)')'3C value order',nv,ncol,nrow2\n else\n! if alphabetical order just set isort(i)=i, same index as for vals\n! write(*,'(a,10i3)')'3C alphabetical order',nv,ncol,nrow2\n do jl=1,nv\n isort(jl)=jl\n enddo\n endif\n! write(*,'(a,i3,2x,15i3)')'3C isort: ',nv,isort\n! list constituents in the order of isort\n if(ncol.eq.4) then\n! All names max 4 characters, 4 columns: 1 + 4+1+13+2 +20 +20 +18 = 79\n nvrest=nv\n n1=1\n! number of empty colums in last row is 4*nrow2-nv\n nempty=4*nrow2-nv\n! 3rd and 4th column may start from one or two indices less\n n3r=2*nrow2\n n4r=3*nrow2\n if(nempty.eq.3) then\n n3r=n3r-1\n n4r=n4r-2\n elseif(nempty.eq.2) then\n n4r=n4r-1\n endif\n100 continue\n! this can be quite complicated as last row may be partially empty as \n if(nvrest.ge.4) then\n names(1)=consts(isort(n1))\n names(2)=consts(isort(n1+nrow2))\n names(3)=consts(isort(n1+n3r))\n! 4th column may be empty after first row\n if(n1+n4r.le.nv) then\n names(4)=consts(isort(n1+n4r))\n write(lut,110)names(1)(1:4),vals(n1),&\n names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r),&\n names(4)(1:4),vals(n1+n4r)\n110 format(1x,a,1x,1pe13.5,3(2x,a,1x,1pe13.5))\n nvrest=nvrest-4\n else\n write(lut,110)names(1)(1:4),vals(n1),&\n names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r)\n nvrest=nvrest-3\n endif\n n1=n1+1\n else\n! List in 4 columns, last row less than 4 columns\n names(1)=consts(isort(n1))\n if(nvrest.gt.1) then\n names(2)=consts(isort(n1+nrow2))\n if(nvrest.gt.2) then\n names(3)=consts(isort(n1+n3r))\n write(lut,110)names(1)(1:4),vals(n1),&\n names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r)\n else\n write(lut,110)names(1)(1:4),vals(n1),&\n names(2)(1:4),vals(n1+nrow2)\n endif\n else\n write(lut,110)names(1)(1:4),vals(n1)\n endif\n nvrest=0\n endif\n if(nvrest.gt.0) goto 100\n else\n! List in 3 columns as constituent names are long\n! All listed names have max 13 characters, longer names are truncated\n nvrest=nv\n n1=1\n! number of empty columns in last row\n nempty=3*nrow2-nv\n! 3rd column may start from an indices less\n n3r=2*nrow2\n! if(nempty.eq.2) then\n! BoS modified 19.11.19 at CEA ... wrong??\n! if(nempty.eq.1) then\n! n3r=n3r-1\n! endif\n200 continue\n! write(*,'(a,4i4,2x,3i4)')'3C last species wrong: ',n1,nrow2,nempty,n3r,&\n! isort(n1),isort(n1+nrow2),isort(n1+n3r)\n if(nvrest.ge.3) then\n names(1)=consts(isort(n1))\n names(2)=consts(isort(n1+nrow2))\n203 format(a,i3,2x,10i3)\n if(n1+2*nrow2.le.nv) then\n! write(*,203)'3C Row1 ',n1,nrow2,n3r,nempty,isort(n1),&\n! isort(n1+nrow2),isort(n1+n3r)\n names(3)=consts(isort(n1+n3r))\n write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2),&\n names(3),vals(n1+n3r)\n210 format(1x,a,1pe12.5,2(2x,a,1pe12.5))\n nvrest=nvrest-3\n else\n! write(*,203)'Row2 ',n1,nrow2,n3r,nempty,isort(n1),isort(n1+nrow2)\n write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2)\n nvrest=nvrest-2\n endif\n n1=n1+1\n else\n! last row can be 1 or 2 columns\n names(1)=consts(isort(n1))\n if(nvrest.gt.1) then\n! write(*,203)'Row3 ',n1,nrow2,n3r,nempty,isort(n1),isort(n1+nrow2)\n names(2)=consts(isort(n1+nrow2))\n write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2)\n else\n! write(*,203)'3C Row4 ',n1\n write(lut,210)names(1),vals(n1)\n endif\n nvrest=0\n endif\n if(nvrest.gt.0) goto 200\n endif\n!\n1000 continue\n return\n end subroutine format_phase_composition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_many_formats\n!\\begin{verbatim}\n subroutine list_many_formats(cline,last,ftyp,unit1)\n! lists all data in different formats: SCREEN/TDB/MACRO/LaTeX/ODB\n! ftyp: 1 2 3 ???\n! unfinished\n implicit none\n character cline*(*)\n integer last,unit1,ftyp\n!\\end{verbatim}\n integer iph,ipos,kousave,unit,isp\n! the retured file name can be very long\n character text*512, text2*2000,fil*128,zext*5\n character date*8,CHTD*1\n! if not screen then ask for file name\n! for screen output of file use /option= ...\n! write(*,*)'3C In list_many_formats',ftyp \n! problem with program jus dies after gparfilex trying to write a TDB file\n! gparfilex called in PMON6\n if(ftyp.ne.1) then\n! call gparcdx('Output file: ',cline,last,1,fil,'database','?Output format')\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, -8=LOG\n! NEGATIVE is for write, 0 read without filter, -100 write without filter\n! gparfilex may call TINYFILESDIALOG\n text=' '\n call gparfilex('Output file: ',cline,last,1,fil,text,&\n -ftyp,'?Output format')\n! Sometimes segmentation fault between the exit of GPARFILEX and this write\n write(*,*)'3C back from gparfilex',ftyp,' \"',trim(fil),'\"'\n ipos=len_trim(fil)\n if(ipos.le.0) then\n write(*,*)'No file name, quit'\n gx%bmperr=4399\n goto 1000\n endif\n! if there is a segmentation fault it is inside gparfilex SUCK\n write(*,*)'3C file name: ',trim(fil)\n! it is impossible to have a blank name here, check if there is an extension\n iph=index(fil,'.')\n if(iph.gt.0) then\n! There must be a letter after the period\n if(iph.eq.ipos) iph=0\n endif\n if(iph.eq.0) then\n if(ftyp.eq.2) then\n! TDB file a la TC\n fil(ipos+1:)='.TDB'\n elseif(ftyp.eq.3) then\n fil(ipos:)='.OCM'\n elseif(ftyp.eq.4) then\n fil(ipos:)='.tex'\n elseif(ftyp.eq.6) then\n! XTDB\n fil(ipos:)='.XTDB'\n else\n! filetype not used\n gx%bmperr=4399; goto 1000\n endif\n endif\n write(*,*)'3C opening a new file',ftyp\n! check if file exists ... overwriting not allowed ...\n open(unit=31,file=fil,access='sequential',status='new',err=900)\n kousave=unit\n unit=31\n endif\n99 continue\n call date_and_time(date)\n! write(*,*)'3C select case: ',ftyp\n select case(ftyp) \n case default\n write(kou,*)'No such format'\n!----------------------------------------------------------\n! This can be written to file using the /output option\n case(1) ! ftyp=1 SCREEN format\n! add a line if EET (Hickel T, equi-entropy check)\n if(globaldata%sysreal(1).gt.zero) &\n write(kou,'(/\"Equi-entropy check (EEC) enabled above T= \",f8.2)')&\n globaldata%sysreal(1)\n call list_all_elements(kou)\n if(gx%bmperr.ne.0) goto 1000\n call list_all_species(kou)\n if(gx%bmperr.ne.0) goto 1000\n call list_all_funs(kou)\n if(gx%bmperr.ne.0) goto 1000\n do iph=1,noph()\n call list_phase_data(iph,' ',kou)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! list reference phase last\n iph=0\n call list_phase_data(0,' ',kou)\n! finally list the data bibliography\n write(kou,*)\n call list_bibliography(' ',kou)\n!--------------------------------------------------------------\n! write on unit\n case(2) ! ftyp=2 TDB format \n write(*,*)'Please use the SAVE command'\n goto 1000\n! CHTD1 keeps track of type definitions, note: incremented before use\n CHTD='0'\n! NOTE this is not the normal subroutine to save TDB formats, see list_tdb_\n write(*,*)'3C saving TDB format'\n if(notallowlisting(privilege)) goto 1000\n write(*,*)'Use SAVE TDB to write a TDB database file'\n goto 1000\n!\n write(*,106)date(1:4),date(5:6),date(7:8)\n write(unit,106)date(1:4),date(5:6),date(7:8)\n106 format('$ Database file written by Open Calphad ',a,'-',a,'-',a/)\n call list_all_elements2(unit)\n write(unit,107)\n107 format(/'$ =================',/)\n text=' '\n sploop: do isp=1, nosp()\n! skip vacancy species and species that are elements\n iph=species(isp)\n ipos=1\n write(*,*)'3C listing using list_species_data2'\n call list_species_data2(text,ipos,iph)\n! not very logical, using species index below and location above ... suck\n if(testspstat(isp,SPEL) .or. testspstat(isp,SPVA)) then\n cycle sploop\n endif\n write(unit,110)text(1:len_trim(text))\n110 format('SPECIES ',A,' !') \n end do sploop\n write(unit,107)\n text2=' '\n! skip the first two functions which are R and RTLNP (using R)\n! write RTLNP in correct TDB form here\n text2='FUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N !'\n write(unit,112)text2(1:len_trim(text2))\n112 format(a)\n!\n tpfuns: do iph=3, notpf()! freetpfun-1\n text2='FUNCTION '\n call list_tpfun(iph,0,text2(10:))\n! skip functions with names staring with _ as they are parameters\n if(text2(10:10).eq.'_') cycle tpfuns\n! for the remaining functions OC writes them with = T_low ...\n! and for TC one must remove the = sign\n ipos=index(text2,'=')\n text2(ipos:ipos)=' '\n! then add a ! at the end\n ipos=len_trim(text2)\n text2(ipos+1:)=' !'\n call wrice2(unit,0,8,78,1,text2)\n end do tpfuns\n write(unit,107)\n write(unit,130)\n130 format(/'TYPE_DEFINITION % SEQ * !'/ &\n 'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ &\n 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/)\n write(unit,107)\n do iph=1, noph()\n call list_phase_data2(iph,ftyp,CHTD,unit)\n enddo\n write(unit,107)\n write(unit,140)\n140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE')\n call list_bibliography(' ',unit)\n write(unit,141)\n141 format('!')\n close(unit)\n!--------------------------------------------------------------\n case(3) ! ftyp=3 MACRO format\n write(kou,*)'MACRO not implemented yet'\n!--------------------------------------------------------------\n case(4) ! ftyp=4 LATEX format\n write(kou,*)'LaTeX not implemented yet'\n!--------------------------------------------------------------\n case(5) ! ftyp=5 Graphics PLT format\n write(*,*)'PLT format is for plotting'\n!--------------------------------------------------------------\n case(6) ! ftyp=6 XTDB format\n! write(kou,*)'XTDB not implemented yet'\n write(*,*)'Please use the SAVE command'\n end select\n!--------------------------------------------------------------\n goto 1000\n! error\n900 continue\n! write(kou,*)'File already exist, overwriting not allowed'\n close(31)\n gx%bmperr=4190\n1000 continue\n if(ftyp.ne.1 .and. gx%bmperr.eq.0) write(*,*)'Output saved on ',trim(fil)\n! unit=kousave\n return\n end subroutine list_many_formats\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_TDB_format\n!\\begin{verbatim}\n subroutine list_TDB_format(filename)\n! lists all data TDB format\n implicit none\n character filename*(*)\n!\\end{verbatim}\n integer iph,ipos,unit,isp,noq\n! the retured file name can be very long\n character text*512, text2*2000\n character date*8,CHTD*1\n! if not screen then ask for file name\n! for screen output of file use /option= ...\n! write(*,*)'3C In list_TDB_formats'\n! problem with program jus dies after gparfilex trying to write a TDB file\n! gparfilex called in PMON6\n call date_and_time(date)\n! write on unit\n! write(*,*)'3C opening a TDB file: ',trim(filename)\n! check if file exists ... overwriting not allowed ...\n open(unit=31,file=filename,access='sequential',status='new',err=900)\n unit=31\n! CHTD1 keeps track of type definitions, note: incremented before use\n CHTD='0'\n! write(*,*)'3C saving TDB format on: ',trim(filename)\n if(notallowlisting(privilege)) goto 1000\n! write(*,106)date(1:4),date(5:6),date(7:8)\n write(unit,106)date(1:4),date(5:6),date(7:8)\n106 format('$ Database file written by Open Calphad ',a,'-',a,'-',a/)\n call list_all_elements2(unit)\n write(unit,107)\n107 format(/'$ =================',/)\n text=' '\n sploop: do isp=1, nosp()\n! skip vacancy species and species that are elements\n iph=species(isp)\n ipos=1\n! special format of text for MQMQA species\n if(splista(iph)%quadindex.gt.0) then\n! remove the 2 number after -Q\n noq=index(splista(iph)%symbol,'-Q')\n text=splista(iph)%symbol(1:noq+1)//' '//splista(iph)%mqmqa1\n! write(*,*)'3C quad: ',trim(text)\n else\n call list_species_data2(text,ipos,iph)\n! not very logical, using species index below and location above ... suck\n endif\n if(testspstat(isp,SPEL) .or. testspstat(isp,SPVA)) then\n cycle sploop\n endif\n write(unit,110)trim(text)\n110 format('SPECIES ',A,' !') \n end do sploop\n write(unit,107)\n text2=' '\n! skip the first two functions which are R and RTLNP (using R)\n! write RTLNP in correct TDB form here\n text2='FUNCTION RTLNP 10 R*T*LN(1.0D-5*P); 20000 N !'\n write(unit,112)trim(text2)\n write(*,112)trim(text2)\n112 format(a)\n!\n tpfuns: do iph=3, notpf()! freetpfun-1\n text2='FUNCTION '\n call list_tpfun(iph,0,text2(10:))\n! skip functions with names staring with _ as they are parameters\n if(text2(10:10).eq.'_') cycle tpfuns\n! for the remaining functions OC writes them with = T_low ...\n! and for TC one must remove the = sign\n ipos=index(text2,'=')\n text2(ipos:ipos)=' '\n! then add a ! at the end\n ipos=len_trim(text2)\n text2(ipos+1:)=' !'\n call wrice2(unit,0,8,78,1,text2)\n end do tpfuns\n write(unit,107)\n write(unit,130)\n130 format(/'TYPE_DEFINITION % SEQ * !'/ &\n 'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ &\n 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/)\n write(unit,107)\n do iph=1, noph()\n call list_phase_data2(iph,2,CHTD,unit)\n enddo\n write(unit,107)\n write(unit,140)\n140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE')\n call list_bibliography(' ',unit)\n write(unit,141)\n141 format('!')\n close(unit)\n write(*,*)'Output saved on ',trim(filename)\n goto 1000\n! error openingfile\n900 continue\n write(*,*)'Error opening or writing on the TDB file: ',trim(filename)\n1000 continue\n return\n end subroutine list_TDB_format\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_phase_model\n!\\begin{verbatim}\n subroutine list_phase_model(iph,ics,lut,CHTD,ceq)\n! list model (no parameters) for a phase on lut\n implicit none\n integer iph,ics,lut\n TYPE(gtp_equilibrium_data), pointer :: ceq\n character CHTD*1\n!\\end{verbatim}\n character phname*24,l78*78\n! integer, dimension(maxsubl) :: endm,ilist\n integer lokcs,knr,kmr,ll,ip,lokph,ftyp\n TYPE(gtp_fraction_set) :: disfra\n type(gtp_phase_add), pointer :: addrec\n double precision rl\n! screen\n ftyp=1\n! if ics=0 list fractions for all composition sets\n lokph=phases(iph)\n! name, model name\n! sublattices, status,\n! additions\n! sites, constituents and fractions in each disordered constituents\n! number of disordered sublattices\n! sites, constituents and fractions in each disordered constituents\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n! write(*,*)'No subch composition set'\n gx%bmperr=4072; goto 1000\n elseif(ics.eq.0) then\n ics=1\n endif\n lokcs=phlista(lokph)%linktocs(ics)\n call get_phase_name(iph,ics,phname)!\n if(btest(phlista(lokph)%status1,PHQCE) .or. &\n btest(phlista(lokph)%status1,PHCVMCE) .or. &\n! btest(phlista(lokph)%status1,PHFACTCE) .or. &\n btest(phlista(lokph)%status1,PHMQMQA) .or. &\n btest(phlista(lokph)%status1,PHSROT) .or. &\n btest(phlista(lokph)%status1,PHTISR)) then\n! this is for the quasichemical models, qce, cvmqe, mqmqa, tisr, srot\n write(lut,111)phname,phlista(lokph)%models(1:40),&\n ceq%phase_varres(lokcs)%qcbonds,phlista(lokph)%status1,&\n ceq%phase_varres(lokcs)%status2\n111 format(a,' model: ',a/' Number of bonds: ',F8.2,&\n ', status: ',z8,1x,z8,5x)\n else\n write(lut,110)phname,phlista(lokph)%models(1:40),&\n phlista(lokph)%noofsubl,phlista(lokph)%status1,&\n ceq%phase_varres(lokcs)%status2\n110 format(a,' model: ',a/' Number of sublattices: ',i2,&\n ', status: ',z8,1x,z8,2x,a)\n L78=' '\n knr=0\n if(btest(phlista(lokph)%status1,PHFORD)) then\n! Phases as FCC or BCC permutations\n L78=' FCC permutations.'\n knr=20\n elseif(btest(phlista(lokph)%status1,PHBORD)) then\n L78=' BCC permutations'\n knr=20\n endif\n if(btest(phlista(lokph)%status1,PHMFS)) then\n! This phase has a disordered fraction set\n if(btest(phlista(lokph)%status1,PHSORD)) then\n L78(knr:)=' Ordered part not subtrated.'\n else\n L78(knr:)=' Ordered part subracted.'\n endif\n knr=len_trim(L78)\n endif\n if(knr.gt.0) write(lut,'(a)')trim(L78)\n endif\n addrec=>phlista(lokph)%additions\n lastadd: do while(associated(addrec))\n call list_addition(lut,CHTD,phname,ftyp,addrec)\n addrec=>addrec%nextadd\n enddo lastadd\n! return here if more composition sets\n200 continue\n rl=zero\n knr=0\n kmr=0\n! return here for each sublattice\n do ll=1,phlista(lokph)%noofsubl\n rl=rl+one\n kmr=kmr+phlista(lokph)%nooffr(ll)\n l78='Subl. '; ip=7\n call wrinum(l78,ip,2,0,rl)\n! if(btest(phlista(lokph)%status1,PHFACTCE)) then\n if(btest(phlista(lokph)%status1,PHMQMQA)) then\n l78(ip:)=', bonds: '; ip=ip+9\n else\n l78(ip:)=', sites: '; ip=ip+9\n endif\n! call wrinum(l78,ip,6,0,phlista(lokph)%sites(ll))\n call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%sites(ll))\n l78(ip:)=', const.: '; ip=ip+10\n! return here for each new constituent in this sublattice\n320 continue\n knr=knr+1\n if(phlista(lokph)%constitlist(knr).gt.0) then\n l78(ip:)=splista(phlista(lokph)%constitlist(knr))%symbol\n else\n l78(ip:)='*'\n endif\n ip=len_trim(l78)+2\n l78(ip-1:ip-1)='='\n! The fractions for normal sublattice done by list result or list phase-const\n call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr))\n l78(ip:ip+1)=', '\n ip=ip+2\n if(ip.gt.60) then\n write(lut,330)l78(1:ip-3)\n330 format(2x,a)\n l78=' '\n ip=4\n endif\n if(knr.lt.kmr) goto 320\n if(ip.gt.4) write(lut,330)l78(1:ip-3)\n enddo\n if(btest(phlista(lokph)%status1,PHMFS)) then\n! the phase has disordered fractions\n! ?? does the = here make a copy? I just want a pointer ...\n disfra=ceq%phase_varres(lokcs)%disfra\n lokcs=disfra%varreslink\n if(disfra%ndd.eq.1) then\n write(lut,410)disfra%latd\n410 format(4x,'Disordred fractions adding all fractions from all ',&\n i2,' sublattices together')\n else\n write(lut,420)disfra%latd\n420 format(4x,'Disordred fractions adding fractions from first ',i2,&\n ' sublattices together in'/&\n 4x,'the first disordered sublattice',&\n ' and the remaining fractions in the second.')\n endif\n! write the disordered constituents and fractions\n ll=0\n rl=zero\n knr=0\n kmr=0\n! return here for second sublattice (if any)\n430 continue\n ll=ll+1\n rl=rl+one\n kmr=kmr+disfra%nooffr(ll)\n l78='Subl. '; ip=7\n call wrinum(l78,ip,2,0,rl)\n l78(ip:)=', sites: '; ip=ip+9\n call wrinum(l78,ip,6,0,disfra%dsites(ll))\n l78(ip:)=', const.: '; ip=ip+10\n! return here for each new constituent in this sublattice\n440 continue\n knr=knr+1\n l78(ip:)=splista(disfra%splink(knr))%symbol\n! list fractions in disordered sublattice as this is the only place for that\n ip=len_trim(l78)+2\n l78(ip-1:ip-1)='='\n call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr))\n l78(ip:)=','\n ip=ip+2\n if(ip.gt.60) then\n write(lut,450)l78(1:ip-3)\n450 format(4x,a)\n l78=' '\n ip=4\n endif\n if(knr.lt.kmr) goto 440\n if(ip.gt.4) write(lut,330)l78(1:ip-3)\n if(ll.lt.disfra%ndd) goto 430\n endif\n1000 continue\n return\n end subroutine list_phase_model\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_phase_data\n!\\begin{verbatim}\n subroutine list_phase_data(iph,CHTD,lut)\n! list parameter data for a phase on unit lut\n implicit none\n integer iph,lut\n character CHTD*1\n!\\end{verbatim} %+\n integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs\n integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik\n integer intpq,linkcon,ftyp,prplink,topline,warning_endmzero\n! integer con1,con2,con3\n character text*3000,phname*24,prop*32,funexpr*1024,ternex(3)*24,ch1*1\n character special*4,modelid*24,typedefchar*1\n! integer, dimension(2,3) :: lint\n! ?? increased dimension of lint ??\n integer, dimension(2,5) :: lint\n integer, dimension(maxsubl) :: endm,ilist\n logical subref,noelin1\n type(gtp_fraction_set), pointer :: disfrap\n! possible different gadditions for each composition sets\n! double precision gadd(9)\n!--------------\n! special reference state for MQMQA liquids\n logical mqmqa\n!--------------\n! used to list Toop/Kohler extrapolations\n type(gtp_tooprec), pointer :: tooprec\n!---------------\n! a smart way to have an array of pointers\n TYPE intrecarray \n type(gtp_interaction), pointer :: p1\n end TYPE intrecarray\n integer, parameter :: maxstack=20\n type(intrecarray), dimension(maxstack) :: intrecstack\n type(gtp_property), pointer :: proprec\n type(gtp_interaction), pointer :: intrec\n type(gtp_endmember), pointer :: endmemrec\n TYPE(gtp_fraction_set) :: disfra\n TYPE(gtp_phase_add), pointer :: addrec\n integer powpqr(3),iiz\n character mqmqxchar*2\n logical mqmqxess\n!\n! write(*,*)'3C in list_phase_data',iph\n! modelid should be used to identify the model\n modelid=' '\n mqmqa=.FALSE.\n mqmqxess=.false.\n! this specifies the top line\n topline=1\n! modelid='123456789.123456789.1234'\n! output on screen\n ftyp=1\n if(iph.lt.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n elseif(noofel.eq.0) then\n! this needed as there is a reference phase with iph=0 when there are elements\n goto 1000\n endif\n! write(*,*)'lpd 1:',iph,phases(iph)\n if(iph.gt.0) then\n lokph=phases(iph)\n else\n lokph=0\n endif\n ics=1\n phname=phlista(lokph)%name\n nsl=phlista(lokph)%noofsubl\n special=' '\n! indicate some status bit specially\n! these bits are mutually exclusive\n if(btest(phlista(lokph)%status1,PHFORD)) then\n special(1:1)='F'; modelid='FCC permutation ordering'\n! 123456789.123456789.1234\n elseif(btest(phlista(lokph)%status1,PHBORD)) then\n special(1:1)='B'; modelid='BCC permutation ordering'\n! elseif(btest(phlista(lokph)%status1,PHSORD)) then\n! special(1:1)='S'; modelid='Intermetallic ordering'\n elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then\n special(1:1)='I'; modelid='Ionic 2-sblattice liquid'\n! 123456789.123456789.1234\n! added 20201128/BoS, FACTCE, QCE and UNIQUAC\n! added 20201128/BoS, MQMQA, QCE and UNIQUAC\n elseif(btest(phlista(lokph)%status1,PHMQMQX)) then\n! modelid is just locally. this is with new excess sooftware 20251119/BoS\n special(1:1)='Q'; modelid='MQMQX'\n if(.not.btest(phlista(lokph)%status1,PHMQMQX)) then\n write(*,*)'3C Error, missing bit PHMQMQA'\n endif\n mqmqa=btest(phlista(lokph)%status1,PHMQMQA)\n! 123456789.123456789.1234\n elseif(btest(phlista(lokph)%status1,PHMQMQA)) then\n special(1:1)='Q'; modelid='MQMQA'\n mqmqa=btest(phlista(lokph)%status1,PHMQMQA)\n! 123456789.123456789.1234\n! Topline 2 means bonds rather than sites ...\n topline=2\n elseif(btest(phlista(lokph)%status1,PHQCE)) then\n special(1:1)='C'; modelid='QCE'\n topline=2\n elseif(btest(phlista(lokph)%status1,PHCVMCE)) then\n special(1:1)='K'; modelid='CVMCE'\n topline=2\n! elseif(btest(phlista(lokph)%status1,PHTISR)) then\n! special(1:1)='E'; modelid='TISR'\n elseif(btest(phlista(lokph)%status1,PHSROT)) then\n special(1:1)='E'; modelid='SROT'\n topline=2\n elseif(btest(phlista(lokph)%status1,PHUNIQUAC)) then\n special(1:1)='U'; modelid='UNIQAC polymer model'\n! 123456789.123456789.1234\n endif\n! end of exclusive bits\n kkk=2\n! if(btest(phlista(lokph)%status1,PHMFS)) then\n! this indicates if there is a disordered fraction set\n! write(*,*)'3C skipping suffix D, first time'\n! special(kkk:kkk)='D'; kkk=kkk+1\n! endif\n lokcs=phlista(lokph)%linktocs(ics)\n! wrong use of CSORDER, it is set if the ordered part already disordered\n! no need to calculate it again\n! if(btest(firsteq%phase_varres(lokcs)%status2,CSORDER)) then\n! PHSORD is the correct bit to test if the ordered part should not be subrracted\n if(.not.btest(phlista(lokph)%status1,PHSORD)) then\n! this indicates if ordered part should be subtracted as ordered\n special(kkk:kkk)='S'; kkk=kkk+1\n endif\n! if(associated(phlista(lokph)%tooplast)) then\n! no attemp to include TYPE:DEF here\n! endif\n! special is max 4 characters\n! This subroutine is independent of current equilibrium, use firsteq\n! write(lut,10)phname,phlista(lokph)%status1,special,&\n! nsl,(phlista(lokph)%sites(ll),ll=1,nsl)\n! lokcs=phlista(lokph)%linktocs(ics)\n!-----------------------------------------------------------------\n if(topline.eq.1) then\n write(lut,10)phname,phlista(lokph)%status1,special,modelid,&\n nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl)\n10 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a/' Subl:',I3,10(1x,F7.3))\n elseif(topline.eq.2) then\n! for the quasichemical models\n write(lut,11)phname,phlista(lokph)%status1,special,trim(modelid),&\n firsteq%phase_varres(lokcs)%sites(1)\n! firsteq%phase_varres(lokcs)%qcbonds\n! firsteq%phase_varres(lokcs)%sites(1)\n!11 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a,', Bonds/at:',F7.3)\n! qcbonds not used for MQMQA\n11 format(/'Phase: ',A,', Status: ',Z8,1x,a,1x,a,', sites:',F7.3)\n endif\n warning_endmzero=0\n nk=0\n text='Constituents: '\n ip=15\n sublatloop: do ll=1,nsl\n constloop: do ik=1,phlista(lokph)%nooffr(ll)\n nk=nk+1\n jnr=phlista(lokph)%constitlist(nk)\n if(jnr.gt.0) then\n text(ip:)=splista(jnr)%symbol\n else\n text(ip:)='*'\n endif\n ip=len_trim(text)+1\n if(len(text)-ip.lt.30) then\n! text is 3000 characters ....\n write(kou,'(a,i6)')'Warning: very long onstituent list truncated',ip\n exit sublatloop\n endif\n! text(ip:ip)=','\n text(ip:ip)=' '\n ip=ip+1\n enddo constloop\n text(ip-1:ip)=': '\n ip=ip+1\n enddo sublatloop\n call wrice2(lut,2,4,78,-1,text)\n! write(lut,17)text(1:ip)\n!17 format(A)\n! additions\n addrec=>phlista(lokph)%additions\n lastadd: do while(associated(addrec))\n call list_addition(lut,CHTD,phname,ftyp,addrec)\n addrec=>addrec%nextadd\n enddo lastadd\n60 continue\n! A fixed addition? gadd Can be different for each composition set !!!\n do ll=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ll)\n if(btest(firsteq%phase_varres(lokcs)%status2,CSADDG)) then\n! if no addition then addg is not allocated!\n! if(allocated(firsteq%phase_varres(lokcs)%addg)) then\n write(lut,33)ll,firsteq%phase_varres(lokcs)%addg(1)\n33 format(' + Addition to G in composition set ',i2,': ',1pe14.6,' J/FU')\n endif\n enddo\n! parameters for end members using site fractions\n if(btest(phlista(lokph)%status1,PHMFS)) then\n subref=.FALSE.\n else\n subref=.TRUE.\n endif\n parlist=1\n! write(*,*)'3C check if listing allowed',privilege,notallowlisting(privilege)\n if(notallowlisting(privilege)) then\n write(*,*)'3C You are not allowed to list data'\n goto 1000\n endif\n! warning for reference state of the MQMQA phase \n if(btest(phlista(lokph)%status1,PHMQMQA)) then\n write(lut,90)\n90 format(' ** MQMQA endmembers such as AB/X-Q etc have',&\n ' contributions from the endmembers'/&\n ' ** A/X, B/X for their reference state even if AB/X-Q',&\n ' has no parameter!')\n endif\n!--------------------------------------------------\n! return here to list disordered parameters\n100 continue\n! parlist changed below for disordered fraction set\n if(parlist.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n if(ocv()) write(*,*)'Listing disordred parameters ',nsl\n endmemrec=>phlista(lokph)%disordered\n disfrap=>firsteq%phase_varres(lokcs)%disfra\n endif\n endmemberlist: do while(associated(endmemrec))\n do ll=1,nsl\n! ilist(ll)=emlista(lokem)%fraclinks(ll,1)\n ilist(ll)=endmemrec%fraclinks(ll,1)\n if(ilist(ll).gt.0) then\n if(parlist.eq.2) then\n! what is disfra here??!!\n! write(*,*)'3C disfra?: ',disfra%splink(ilist(ll)),&\n! disfrap%splink(ilist(ll))\n! endm(ll)=disfra%splink(ilist(ll))\n endm(ll)=disfrap%splink(ilist(ll))\n else\n endm(ll)=phlista(lokph)%constitlist(ilist(ll))\n endif\n else\n! wildcard, write '*'\n endm(ll)=-99\n endif\n enddo\n nint=0\n ideg=0\n call encode_constarr(text,nsl,endm,nint,lint,ideg)\n if(gx%bmperr.ne.0) goto 1000\n proprec=>endmemrec%propointer\n ptyloop: do while(associated(proprec))\n ij=proprec%proptype\n if(ij.ge.100) then\n typty=ij/100\n typspec=mod(ij,100)\n else\n typty=ij\n endif\n if(typty.gt.0 .and. typty.le.ndefprop) then\n prop=propid(typty)%symbol\n! if(parlist.eq.2) then\n! disordered endmember parameter\n! write(*,*)'3C skipping suffix D 2nd case'\n! kk=len_trim(prop)+1\n! prop(kk:kk)='D'\n! endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! property like ZZ&(phase,constituent array)\n! the element index should be in typsepc\n iel=typspec\n if(iel.ge.0 .and. iel.le.noofel) then\n! prop=propid(typty)%symbol\n prop=prop(1:len_trim(prop))//'&'&\n //ellista(elements(iel))%symbol\n else\n gx%bmperr=4082; goto 1000\n endif\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! property like mobility, MQ&(phase,constituent array)\n! the suffix is a constituent\n iel=typspec\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\n if(parlist.eq.2) then\n! we must consider parlist, take disordered constituent list\n! we have no current equilibrium record but can use firsteq!!\n! lokcs=phlista(lokph)%linktocs(1)\n! write(*,*)'3C: endmember typspec 1: ',iel\n! write(*,*)'3C splink: ',disfrap%splink\n linkcon=disfrap%splink(iel)\n! write(*,*)'3C: endmember typspec 2: ',linkcon\n ll=0\n! ll=1\n! linkcon has nothing to do with which sublattice, ignore ll\n! if(linkcon.gt.disfrap%nooffr(1)) ll=2\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n write(*,*)'3C We are here',linkcon,disfrap%nooffr(1),ll\n prop=prop(1:len_trim(prop))\n! goto 120\n goto 121\n else\n linkcon=phlista(lokph)%constitlist(iel)\n if(linkcon.le.0) then\n write(*,*)'Illegal use of wildcard 1'\n gx%bmperr=4286; goto 1000\n endif\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n! also add the sublattice number ...\n ncsum=0\n do ll=1,phlista(lokph)%noofsubl\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\n if(iel.le.ncsum) goto 120\n enddo\n endif\n! error if sublattice not found\n write(kou,*)'Error in constituent depended parameter id'\n gx%bmperr=4287; goto 1000\n! jump here to append sublattice\n120 continue\n! write(*,*)'property 1: ',prop(1:10),ll\n if(ll.gt.1) then\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\n! else\n! prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\n endif\n121 continue\n else\n write(kou,*)'lpd 7B: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n endif\n else\n! unknown property ...\n write(*,*)'unknown property type xx: ',ij,typty,typspec\n prop='ZZ'\n endif\n! note changes here must be repeated for interaction parameters below\n write(funexpr,200)prop(1:len_trim(prop)),&\n phname(1:len_trim(phname)),text(1:len_trim(text))\n200 format(A,'(',A,',',A,') ')\n ip=len_trim(funexpr)+1\n! check if FNN MQMQA parameter ...\n if(mqmqa) then\n! ilist is index in fraction list, same as index in mqmqa_data%contyp\n! intpq=ilist(1)\n! write(*,*)'3C check if SNN parameter',intpq,&\n! mqmqa_data%contyp(5,intpq)\n if(mqmqa_data%contyp(5,ilist(1)).le.0) goto 203\n endif\n! subtract reference states\n if(subref .and. typty.eq.1) then\n call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1)\n if(noelin1) then\n! this can happen for ionic liquids with just neutrals in sublattice 2\n! replace the constituent in sublattice 1 with \"*\" !!!\n! write(*,*)'before: ',funexpr(1:ip)\n kk=index(funexpr,',')\n ik=index(funexpr,':')\n funexpr(kk+1:)='*'//funexpr(ik:)\n ip=len_trim(funexpr)+2\n! write(*,*)'after: ',funexpr(1:ip)\n endif\n endif\n203 continue\n! this writes the expression\n call list_tpfun(proprec%degreelink(0),1,funexpr(ip:))\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' '//proprec%reference\n ip=len_trim(funexpr)\n! nice output over several lines if needed with indentation 12 spaces\n call wrice2(lut,2,12,78,1,funexpr(1:ip))\n proprec=>proprec%nextpr\n enddo ptyloop\n if(btest(phlista(lokph)%status1,PHFORD).or. &\n btest(phlista(lokph)%status1,PHBORD)) then\n! if(endmemrec%noofpermut.gt.1) then\n intpq=0\n if(associated(endmemrec%intpointer)) then\n intpq=endmemrec%intpointer%antalint\n endif\n prplink=0\n if(associated(endmemrec%propointer)) prplink=1\n! keep this output for the moment\n! if(parlist.eq.1) write(kou,207)endmemrec%antalem,&\n if(parlist.eq.1) then\n if(prplink.eq.1) then\n write(kou,207)endmemrec%antalem,&\n endmemrec%noofpermut,intpq,prplink\n elseif(intpq.gt.0) then\n write(kou,208)endmemrec%antalem,&\n endmemrec%noofpermut,intpq,prplink\n207 format('3C Endmember check: id, permut, inter, pty: ',4i5)\n208 format('3C Link to excesss: id, permut, inter, pty: ',4i5)\n endif\n endif\n endif\n endmemrec=>endmemrec%nextem\n enddo endmemberlist\n!-----------------------------------------------------------------------\n! parameters for interactions using site fractions\n! write(*,*)'3C list excess model parameters'\n if(parlist.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n endmemrec=>phlista(lokph)%disordered\n endif\n intlist1: do while(associated(endmemrec))\n intrec=>endmemrec%intpointer\n if(associated(intrec)) then\n! write(*,*)'intlist 1B: ',intrec%status\n do ll=1,nsl\n kkx=endmemrec%fraclinks(ll,1)\n if(kkx.eq.-99) then\n! wildcard\n endm(ll)=-99\n elseif(parlist.eq.2) then\n endm(ll)=disfra%splink(kkx)\n else\n endm(ll)=phlista(lokph)%constitlist(kkx)\n endif\n enddo\n endif\n nint=0\n intlist2: do while(associated(intrec))\n nint=nint+1\n if(nint.gt.maxstack) then\n write(*,*)'3C overflow in intrecstack 1'\n gx%bmperr=4399; goto 1000\n endif\n intrecstack(nint)%p1=>intrec\n lint(1,nint)=intrec%sublattice(1)\n kkk=intrec%fraclink(1)\n if(parlist.eq.2) then\n lint(2,nint)=disfra%splink(kkk)\n else\n lint(2,nint)=phlista(lokph)%constitlist(kkk)\n endif\n proprec=>intrec%propointer\n! loop for all properties with this composition dependence\n ptyloop2: do while(associated(proprec))\n! typty=proprec%proptype\n ij=proprec%proptype\n if(ij.ge.100) then\n typty=ij/100\n typspec=mod(ij,100)\n else\n typty=ij\n endif\n! typspec=proprec%proptype\n! if(typspec.gt.100) then\n! typty=typspec/100\n! typspec=mod(typty,100)\n! else\n! typty=typspec\n! endif\n! one should fix ndefprop to 33 but as typty is 34-36 for MQMQA excess SUCK\n! write(*,*)'value of ndefprop',ndefprop\n if(typty.gt.0 .and. typty.le.ndefprop) then\n if(typty.ge.34 .and. typty.le.36) then\n! extracting MQMQA, MQMQX powers\n! write(*,*)'3C listing parameters',typty,proprec%extra\n! extra=230 \n if(typty.eq.34) mqmqxchar='G,'\n if(typty.eq.35) mqmqxchar='Q,'\n if(typty.eq.36) mqmqxchar='B,'\n! if(typty.eq.34) prop='G'\n! if(typty.eq.35) prop='Q'\n! if(typty.eq.36) prop='B'\n prop='G'\n mqmqxess=.true.\n powpqr(1)=proprec%extra/100\n! 2; 30\n powpqr(2)=(proprec%extra-100*powpqr(1))/10\n! 2; 3\n powpqr(3)=proprec%extra-100*powpqr(1)-10*powpqr(2)\n! write(*,55)typty,proprec%extra,powpqr\n55 format('3C listing 2370 MQMQA/MQMQX parameters ',i2,i5,3i4)\n! the powpqr is used when listing degree below\n do iiz=1,3\n powpqr(iiz)=powpqr(iiz)+ichar('0')\n enddo\n else\n prop=propid(typty)%symbol\n endif\n! if(parlist.eq.2) then\n! disordered interaction parameter\n! write(*,*)'3C skipping suffix D 3rd time'\n! kk=len_trim(prop)+1\n! prop(kk:kk)='D'\n! endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! property like ZZ&(phase,constituent array)\n! the element index should be in typsepc\n iel=typspec\n if(iel.ge.0 .and. iel.le.noofel) then\n prop=prop(1:len_trim(prop))//'&'&\n //ellista(elements(iel))%symbol\n else\n! write(*,*)'lpd 7: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! property like mobility MQ&(phase,constituent array)\n! the suffix is a constituent\n iel=typspec\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\n if(parlist.eq.2) then\n! we must consider parlist, take disordered constituent list\n! we have no current equilibrium record but can use firsteq!!\n! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10)\n linkcon=disfrap%splink(iel)\n! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10)\n ll=1\n if(iel.gt.disfrap%nooffr(1)) ll=2\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n goto 220\n else\n linkcon=phlista(lokph)%constitlist(iel)\n if(linkcon.le.0) then\n! write(*,*)'Illegal use of wildcard 2'\n gx%bmperr=4286; goto 1000\n endif\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n! also add the sublattice number ...\n ncsum=0\n do ll=1,phlista(lokph)%noofsubl\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\n if(iel.le.ncsum) goto 220\n enddo\n endif\n! there cannot be any errors here ....\n! write(*,*)'Never never error 2'\n gx%bmperr=4288; goto 1000\n220 continue\n! write(*,*)'property 2: ',prop(1:10),ll\n! add sublattice index only if not unity\n if(ll.gt.1) then\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\n endif\n else\n! write(*,*)'lpd 7: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n endif\n else\n! unknown property ...\n write(*,*)'unknown property type yy: ',typty\n prop='ZZ'\n endif\n! if disordered fraction set add D, already set above ??!!\n! if(parlist.eq.2) then\n! prop=prop(1:len_trim(prop))//'D'\n! endif\n! note changes here must be repeated for endmember parameters above\n degree: do jdeg=0,proprec%degree\n if(proprec%degreelink(jdeg).eq.0) then\n! write(*,*)'Ignoring function link'\n cycle degree\n endif\n call encode_constarr(text,nsl,endm,nint,lint,jdeg)\n if(mqmqxess) then\n! MQMQA excess replace degree after ; in text by G,p,q,0 for binary \n! G,p,q,r for ternary\n! write(*,*)'3C parameter 1: ',nint,trim(text)\n iiz=index(text,';')\n text(iiz+1:)=mqmqxchar//char(powpqr(1))//','//char(powpqr(2))\n iiz=iiz+5\n if(nint.eq.3) then\n text(iiz+1:)=','//char(powpqr(3))\n endif\n! write(*,*)'3C parameter 2: ',iiz,trim(text)\n endif\n write(funexpr,300)trim(prop),trim(phname),trim(text)\n300 format(A,'(',A,',',A,') ')\n ip=len_trim(funexpr)+1\n call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:))\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' '//proprec%reference\n ip=len_trim(funexpr)\n call wrice2(lut,4,12,78,1,funexpr(1:ip))\n enddo degree\n proprec=>proprec%nextpr\n enddo ptyloop2\n! list temporarily the number of permutations for FCC and BCC ordering\n if(btest(phlista(lokph)%status1,PHFORD).or. &\n btest(phlista(lokph)%status1,PHBORD)) then\n! if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then\n if(nint.eq.1) then\n nz=intrec%noofip(2)\n else\n nz=size(intrec%sublattice)\n lqq=intrec%noofip(size(intrec%noofip))\n if(lqq.ne.nz) then\n write(*,*)'3C Not same 1: ',intrec%antalint,nz,lqq\n endif\n! write(*,301)nz,intrec%noofip\n301 format('noofip: ',10i3)\n! nz=intrec%noofip(intrec%noofip(1)+2)\n endif\n iqnext=0\n iqhigh=0\n if(associated(intrec%highlink)) then\n iqhigh=intrec%highlink%antalint\n endif\n if(associated(intrec%nextlink)) then\n iqnext=intrec%nextlink%antalint\n endif\n prplink=0\n if(associated(intrec%propointer)) prplink=1\n! keep this output for the moment\n if(parlist.eq.1) write(*,302)intrec%antalint,&\n nz,nint,iqhigh,iqnext,prplink\n302 format('3C Inter check 1: id, permut, level, high, next, pty: ',&\n i5,i3,i3,i4,i4,i2)\n endif\n intrec=>intrec%highlink\n empty: do while(.not.associated(intrec))\n if(nint.gt.0) then\n! restore pointers in same clumsy way\n intrec=>intrecstack(nint)%p1\n intrec=>intrec%nextlink\n! write(*,*)'poping a pointer from intrecstack',ninit\n nint=nint-1\n else\n exit intlist2\n endif\n enddo empty\n enddo intlist2\n endmemrec=>endmemrec%nextem\n enddo intlist1\n! check if there are other fraction lists\n! parlist=parlist+1, hm parlist can only be 1 or 2\n! write(*,*)'checking for disordered parameters'\n if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then\n subref=.TRUE.\n! lokcs=phlista(lokph)%cslink\n lokcs=phlista(lokph)%linktocs(ics)\n! does this make a copy? Maybe it should be a pointer\n disfra=firsteq%phase_varres(lokcs)%disfra\n write(lut,810)disfra%fsites\n810 format('Disordered fraction set parameters, factor: ',F10.4,2x,10('-'))\n nsl=disfra%ndd\n parlist=2\n if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist\n goto 100\n endif\n! Check if there are toop/kohler ternaries\n tooprec=>phlista(lokph)%tooplast\n if(associated(tooprec)) then\n write(*,'(a)')'3C Some ternaries have Toop/Kohler extrapolations methods'\n text=' '\n kk=1\n nsl=0\n tkloop: do while(associated(tooprec))\n! interacive ? listing of Toop/Kohler extrapolations taken from tooprec%amend\n! loop through all records, the extrapolations are some of the reconds.\n! on TDB files the subrouine list_tdb_formats is used\n if(len(tooprec%amend1).gt.1) then\n if(nsl.eq.0) then\n text(kk:)=' AMEND '//tooprec%amend1\n nsl=1\n else\n! remove phase name and TERNARY_EXTRA \n ij=index(tooprec%amend1,'_EXTRA')\n text(kk:)=tooprec%amend1(ij+7:)\n endif\n kk=len_trim(text)+2\n! write(*,997)1,text(1:kk),kk\n997 format('3C ternary: ',i1,' \"',a,'\"',i4)\n! This text is written by the commands list data and list phase xxx data\n! Output from \"save tdb\" is written by list_phase_data2\n endif\n! there can be several AMEND !!!\n if(len(tooprec%amend2).gt.1) then\n ij=index(tooprec%amend2,'_EXTRA')\n text(kk:)=tooprec%amend2(ij+7:)\n kk=len_trim(text)+2\n! write(*,997)2,text(1:kk),kk\n endif\n if(len(tooprec%amend3).gt.1) then\n ij=index(tooprec%amend3,'_EXTRA')\n text(kk:)=tooprec%amend3(ij+7:)\n kk=len_trim(text)+2\n! write(*,997)3,text(1:kk),kk\n endif\n if(kk.gt.5) then\n! This text is written by the commands list data and list phase xxx data\n! Output from \"save tdb\" is written by list_phase_data2\n write(*,*)'3C ',text(1:kk)\n text=' Y'\n kk=5\n endif\n tooprec=>tooprec%nexttoop\n enddo tkloop\n if(kk.gt.6) write(*,*)'3C ',text(1:kk)\n endif\n! write(*,*)'3C listing by list_phase_data'\n1000 continue\n return\n END subroutine list_phase_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_phase_data2\n!\\begin{verbatim} %-\n subroutine list_phase_data2(iph,ftyp,CHTD,lut)\n!\n! this subroutine is USED by the command SAVE TDB\n!\n! list parameter data for a phase on unit lut in ftyp format, ftyp=2 is TDB\n implicit none\n integer iph,lut,ftyp\n character CHTD*1\n!\\end{verbatim}\n integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs,isp\n integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik\n integer intpq,linkcon\n character text*1024,phname*24,prop*32,funexpr*1024\n character special*8\n character,save :: ctop*1='K'\n! integer, dimension(2,3) :: lint insufficient for MQMQX\n integer, dimension(2,4) :: lint\n integer, dimension(maxsubl) :: endm,ilist\n logical subref,noelin1\n type(gtp_fraction_set), pointer :: disfrap\n! a smart way to have an array of pointers\n TYPE intrecarray \n type(gtp_interaction), pointer :: p1\n end TYPE intrecarray\n integer, parameter :: maxstack=20\n type(intrecarray), dimension(maxstack) :: intrecstack\n type(gtp_property), pointer :: proprec\n type(gtp_interaction), pointer :: intrec\n type(gtp_endmember), pointer :: endmemrec\n TYPE(gtp_fraction_set) :: disfra\n TYPE(gtp_phase_add), pointer :: addrec\n TYPE(gtp_tooprec), pointer :: tooprec\n! MQMQAX\n logical :: mqmqax=.false.\n character*1 mqmqxchar*7\n integer ppow,temp,rpow\n! G,1,1,1\n! an empty line first\n write(lut,*)\n! for type definitions\n if(iph.lt.0 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n elseif(noofel.eq.0) then\n! this needed as there is a reference phase with iph=0 when there are elements\n goto 1000\n endif\n! write(*,*)'lpd 1:',iph,phases(iph)\n if(iph.gt.0) then\n lokph=phases(iph)\n else\n lokph=0\n endif\n ics=1\n phname=phlista(lokph)%name\n nsl=phlista(lokph)%noofsubl\n special=' '\n special(1:1)='%'\n isp=1\n! indicate some status bit specially, not useful for TDB files ...\n! if(btest(phlista(lokph)%status1,PHFORD)) then\n! special(2:2)='F'\n! isp=2\n! elseif(btest(phlista(lokph)%status1,PHBORD)) then\n! special(2:2)='B'\n! isp=2\n! elseif(btest(phlista(lokph)%status1,PHSORD)) then\n! special(2:2)='S'\n! isp=2\n! elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! special(2:2)='I'\n! isp=2\n! endif\n! here isp can be 1 or 2\n! if(btest(phlista(lokph)%status1,PHMFS)) then\n! isp=isp+1\n! special(isp:isp)='D'\n! endif\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n lokcs=len_trim(phname)+1\n phname(lokcs:)=':Y'\n elseif(btest(phlista(lokph)%status1,PHGAS)) then\n phname='GAS:G'\n elseif(btest(phlista(lokph)%status1,PHMQMQX)) then\n lokcs=len_trim(phname)+1\n phname(lokcs:)=':X'\n elseif(btest(phlista(lokph)%status1,PHLIQ)) then\n phname='LIQUID:L'\n endif\n if(btest(phlista(lokph)%status1,PHMFS)) then\n! write(*,*)'3C typedef character 1 ',ichar(CHTD),' \"',chtd,'\"'\n CHTD=char(ichar(CHTD)+1)\n isp=isp+1\n special(isp:isp)=CHTD\n if(.not.btest(globaldata%status,GSSILENT)) then\n write(kou,53)\n53 format('Disordered fraction sets need manual editing',&\n ' to be used by Thermo-Calc')\n endif\n! wow, written before I learned to use trim(character) ...\n! write(lut,55)CHTD,phname(1:len_trim(phname)),phname(1:len_trim(phname))\n write(lut,55)CHTD,trim(phname),trim(phname)\n55 format('$ *** Warning: disordered fraction sets need manual editing!'/&\n ' TYPE_DEFINITION ',a,' GES A_P_D ',a,' DIS_PART DIS_',a,' !')\n endif\n! additions\n addrec=>phlista(lokph)%additions\n lastadd: do while(associated(addrec))\n! no need to increment CHTD except for magnetism\n if(addrec%type.eq.1) then\n! write(*,*)'3C typedef character 2 ',ichar(CHTD),' \"',chtd,'\"'\n CHTD=char(ichar(CHTD)+1)\n isp=isp+1\n special(isp:isp)=CHTD\n endif\n call list_addition(lut,CHTD,phname,ftyp,addrec)\n addrec=>addrec%nextadd\n enddo lastadd\n60 continue\n write(*,*)'3C Not saving any asymmetric data for ',trim(phname)\n! This subroutine is independent of current equilibrium, use firsteq\n! write(lut,10)phname,phlista(lokph)%status1,special,&\n! nsl,(phlista(lokph)%sites(ll),ll=1,nsl)\n! write(*,*)'3C phase: ',phname,special\n lokcs=phlista(lokph)%linktocs(ics)\n if(associated(phlista(lokph)%tooplast)) then\n isp=isp+1\n! this is to refer to the ternary_extrapolations later\n special(isp:isp)=ctop\n!\n write(lut,10,advance='no')phname(1:len_trim(phname)),special(1:isp),&\n nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl)\n else\n write(lut,10,advance='no')phname(1:len_trim(phname)),special(1:isp),&\n nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl)\n endif\n10 format(' PHASE ',A,1x,a,1x,I2,10(1x,F7.3))\n mqmqax=.false.\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n write(*,*)'3C Listing MQMQA phase'\n mqmqax=.true.\n endif\n write(lut,11)\n11 format('!')\n nk=0\n! lqq=0\n! if(btest(phlista(lokph)%status1,PHMQMQX)) lqq=-1\n text='CONSTITUENT '//phname(1:len_trim(phname))//' :'\n ip=len_trim(text)+1\n sublatloop: do ll=1,nsl\n constloop: do ik=1,phlista(lokph)%nooffr(ll)\n nk=nk+1\n jnr=phlista(lokph)%constitlist(nk)\n if(jnr.gt.0) then\n if(mqmqax) then\n kkk=index(splista(jnr)%symbol,'-Q')\n text(ip:)=splista(jnr)%symbol(1:kkk+1)\n else\n text(ip:)=splista(jnr)%symbol\n endif\n else\n text(ip:)='*'\n endif\n ip=len_trim(text)+1\n! text(ip:ip)=','\n text(ip:ip)=' '\n ip=ip+1\n enddo constloop\n text(ip-1:ip)=': '\n ip=ip+1\n enddo sublatloop\n text(ip-2:)=':!'\n call wrice2(lut,2,4,78,-1,text)\n! write(lut,17)text(1:ip)\n!17 format(A)\n! remove any :Y, :L or :G\n ip=index(phname,':')\n if(ip.gt.0) phname(ip:)=' '\n! parameters for end members using site fractions\n if(btest(phlista(lokph)%status1,PHMFS)) then\n subref=.FALSE.\n else\n subref=.TRUE.\n endif\n parlist=1\n!--------------------------------------------------\n! return here to list disordered parameters\n100 continue\n! check if encrypted database\n if(notallowlisting(privilege)) then\n write(*,*)'3C You are not allowed to list data'\n goto 1000\n endif\n! parlist changed below for disordered fraction set\n if(parlist.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n if(ocv()) write(*,*)'Listing disordred parameters ',nsl\n endmemrec=>phlista(lokph)%disordered\n disfrap=>firsteq%phase_varres(lokcs)%disfra\n endif\n endmemberlist: do while(associated(endmemrec))\n do ll=1,nsl\n! ilist(ll)=emlista(lokem)%fraclinks(ll,1)\n ilist(ll)=endmemrec%fraclinks(ll,1)\n if(ilist(ll).gt.0) then\n if(parlist.eq.2) then\n! what is disfra here??!!\n endm(ll)=disfra%splink(ilist(ll))\n else\n endm(ll)=phlista(lokph)%constitlist(ilist(ll))\n endif\n else\n! wildcard, write '*'\n endm(ll)=-99\n endif\n enddo\n nint=0\n ideg=0\n if(btest(phlista(lokph)%status1,PHMQMQX)) ideg=-1\n! supress digits after -Q for MQMQX phases, works\n call encode_constarr(text,nsl,endm,nint,lint,ideg)\n if(gx%bmperr.ne.0) goto 1000\n ideg=0\n proprec=>endmemrec%propointer\n ptyloop: do while(associated(proprec))\n ij=proprec%proptype\n if(ij.ge.100) then\n typty=ij/100\n typspec=mod(ij,100)\n else\n typty=ij\n endif\n if(typty.gt.0 .and. typty.le.ndefprop) then\n prop=propid(typty)%symbol\n! if(parlist.eq.2) then\n! disordered endmember parameter\n! write(*,*)'3C skipping suffix D, 4:th time'\n! kk=len_trim(prop)+1\n! prop(kk:kk)='D'\n! endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! property like ZZ&(phase,constituent array)\n! the element index should be in typsepc\n iel=typspec\n if(iel.ge.0 .and. iel.le.noofel) then\n! prop=propid(typty)%symbol\n prop=prop(1:len_trim(prop))//'&'&\n //ellista(elements(iel))%symbol\n else\n gx%bmperr=4082; goto 1000\n endif\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! property like mobility, MQ&(phase,constituent array)\n! the suffix is a constituent\n iel=typspec\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\n if(parlist.eq.2) then\n! we must consider parlist, take disordered constituent list\n! we have no current equilibrium record but can use firsteq!!\n! lokcs=phlista(lokph)%linktocs(1)\n! write(*,*)'3C: endmember typspec 1: ',iel\n linkcon=disfrap%splink(iel)\n! write(*,*)'3C: endmember typspec 2: ',linkcon\n ll=1\n if(linkcon.gt.disfrap%nooffr(1)) ll=2\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n goto 120\n else\n linkcon=phlista(lokph)%constitlist(iel)\n if(linkcon.le.0) then\n! write(*,*)'Illegal use of wildcard 1'\n gx%bmperr=4286; goto 1000\n endif\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n! also add the sublattice number ...\n ncsum=0\n do ll=1,phlista(lokph)%noofsubl\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\n if(iel.le.ncsum) goto 120\n enddo\n endif\n! error if sublattice not found\n write(kou,*)'Error in constituent depended parameter id'\n gx%bmperr=4287; goto 1000\n! jump here to append sublattice\n120 continue\n! write(*,*)'property 1: ',prop(1:10),ll\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\n else\n write(kou,*)'lpd 7B: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n endif\n else\n! unknown property ...\n write(*,*)'unknown property type xx: ',ij,typty,typspec\n prop='ZZ'\n endif\n! if disordered fraction set add D, already done above\n! if(parlist.eq.2) then\n! prop=prop(1:len_trim(prop))//'D'\n! endif\n! note changes here must be repeated for interaction parameters below\n write(funexpr,200)prop(1:len_trim(prop)),&\n phname(1:len_trim(phname)),text(1:len_trim(text))\n200 format(' PARAMETER ',A,'(',A,',',A,') ')\n ip=len_trim(funexpr)+1\n!-------------------------------- this is not done for TDB files\n! subtract reference states\n! if(subref .and. typty.eq.1) then\n! call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1)\n! if(noelin1) then\n! this can happen for ionic liquids with just neutrals in sublattice 2\n! replace the constituent in sublattice 1 with \"*\" !!!\n! write(*,*)'before: ',funexpr(1:ip)\n! kk=index(funexpr,',')\n! ik=index(funexpr,':')\n! funexpr(kk+1:)='*'//funexpr(ik:)\n! ip=len_trim(funexpr)+2\n! write(*,*)'after: ',funexpr(1:ip)\n! endif\n! endif\n! this writes the expression, problem if function is zero\n call list_tpfun(proprec%degreelink(0),1,funexpr(ip:))\n! remove = sign\n ip=index(funexpr,'=')\n funexpr(ip:ip)=' '\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' '//proprec%reference\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' !'\n! nice output over several lines if needed with indentation 12 spaces\n call wrice2(lut,2,12,78,1,funexpr(1:ip+2))\n proprec=>proprec%nextpr\n enddo ptyloop\n if(endmemrec%noofpermut.gt.1) then\n intpq=0\n if(associated(endmemrec%intpointer)) then\n intpq=endmemrec%intpointer%antalint\n endif\n! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq\n207 format('@$ Endmember, permutations, interaction: ',3i5)\n endif\n endmemrec=>endmemrec%nextem\n enddo endmemberlist\n!-----------------------------------------------------------------------\n! parameters for interactions using site fractions\n if(parlist.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n endmemrec=>phlista(lokph)%disordered\n endif\n write(*,210)\n! write(lut,210)\n210 format('$ 3C list_phase_data2 for TDB?XTDB files')\n intlist1: do while(associated(endmemrec))\n intrec=>endmemrec%intpointer\n if(associated(intrec)) then\n! write(*,*)'intlist 1B: ',intrec%status\n do ll=1,nsl\n kkx=endmemrec%fraclinks(ll,1)\n if(kkx.eq.-99) then\n! wildcard\n endm(ll)=-99\n elseif(parlist.eq.2) then\n endm(ll)=disfra%splink(kkx)\n else\n endm(ll)=phlista(lokph)%constitlist(kkx)\n endif\n enddo\n endif\n nint=0\n intlist2: do while(associated(intrec))\n nint=nint+1\n if(nint.gt.maxstack) then\n write(*,*)'3C overflow in intrecstack 2'\n gx%bmperr=4399; goto 1000\n endif\n intrecstack(nint)%p1=>intrec\n lint(1,nint)=intrec%sublattice(1)\n kkk=intrec%fraclink(1)\n if(parlist.eq.2) then\n lint(2,nint)=disfra%splink(kkk)\n else\n lint(2,nint)=phlista(lokph)%constitlist(kkk)\n endif\n proprec=>intrec%propointer\n ptyloop2: do while(associated(proprec))\n! typty=proprec%proptype\n ij=proprec%proptype\n if(ij.ge.100) then\n typty=ij/100\n typspec=mod(ij,100)\n else\n typty=ij\n endif\n! typspec=proprec%proptype\n! if(typspec.gt.100) then\n! typty=typspec/100\n! typspec=mod(typty,100)\n! else\n! typty=typspec\n! endif\n if(typty.gt.0 .and. typty.le.ndefprop) then\n prop=propid(typty)%symbol\n! if(parlist.eq.2) then\n! disordered interaction parameter\n! write(*,*)'3C skipping suffix D, 5th time'\n! kk=len_trim(prop)+1\n! prop(kk:kk)='D'\n! endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! property like ZZ&(phase,constituent array)\n! the element index should be in typsepc\n iel=typspec\n if(iel.ge.0 .and. iel.le.noofel) then\n prop=prop(1:len_trim(prop))//'&'&\n //ellista(elements(iel))%symbol\n else\n! write(*,*)'lpd 7: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! property like mobility MQ&(phase,constituent array)\n! the suffix is a constituent\n iel=typspec\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\n if(parlist.eq.2) then\n! we must consider parlist, take disordered constituent list\n! we have no current equilibrium record but can use firsteq!!\n! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10)\n linkcon=disfrap%splink(iel)\n! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10)\n ll=1\n if(iel.gt.disfrap%nooffr(1)) ll=2\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n goto 220\n else\n linkcon=phlista(lokph)%constitlist(iel)\n if(linkcon.le.0) then\n! write(*,*)'Illegal use of wildcard 2'\n gx%bmperr=4286; goto 1000\n endif\n prop=prop(1:len_trim(prop))//'&'&\n //splista(linkcon)%symbol\n! also add the sublattice number ...\n ncsum=0\n do ll=1,phlista(lokph)%noofsubl\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\n if(iel.le.ncsum) goto 220\n enddo\n endif\n! there cannot be any errors here ....\n! write(*,*)'Never never error 2'\n gx%bmperr=4288; goto 1000\n220 continue\n! write(*,*)'property 2: ',prop(1:10),ll\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\n else\n! write(*,*)'lpd 7: ',iel,typty\n gx%bmperr=4082; goto 1000\n endif\n endif\n else\n! unknown property ...\n write(*,*)'unknown property type yy: ',typty\n prop='ZZ'\n endif\n! if disordered fraction set add D, already set above ??!!\n! if(parlist.eq.2) then\n! prop=prop(1:len_trim(prop))//'D'\n! endif\n if(mqmqax) then\n! this is just for mqmqax excess parameters\n if(typty.ge.34 .and. typty.le.36) then\n! MQMQX excess parameter with additional data after ;\n! initial parameter symbol is G\n! write(*,*)'3C line 3071 MQMQX excess: ',proprec%extra\n if(typty.eq.34) mqmqxchar(1:2)='G,'\n if(typty.eq.35) mqmqxchar(1:2)='Q,'\n if(typty.eq.36) mqmqxchar(1:2)='B,'\n prop='G'\n! we have to add powers after the letter 100*p + 10*p + r\n ppow=proprec%extra/100\n mqmqxchar(3:4)=char(ppow+ichar('0'))//','\n temp=(proprec%extra-100*ppow)/10\n mqmqxchar(5:6)=char(temp+ichar('0'))//','\n rpow=proprec%extra-100*ppow-10*temp\n mqmqxchar(7:7)=char(rpow+ichar('0'))\n else\n write(*,298)typty\n298 format('3C illegal excess parameter for MQMQX phase',i7)\n endif\n! excess constituents should also be listed with just -Q NO DIGITS! \n jdeg=-1\n call encode_constarr(text,nsl,endm,nint,lint,jdeg)\n write(funexpr,300)prop(1:len_trim(prop)), &\n phname(1:len_trim(phname)),text(1:len_trim(text))\n300 format('PARAMETER ',A,'(',A,',',A,') ')\n! the expression ends with \";0)\" replace \"0) by mqmqxchar!\n ip=len_trim(funexpr)-1\n funexpr(ip:)=mqmqxchar//')'\n ip=ip+8\n! add expression after ip, there is just one\n jdeg=0\n call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:))\n! remove = sign\n ip=index(funexpr,'=')\n funexpr(ip:ip)=' '\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' '//proprec%reference\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' !'\n call wrice2(lut,4,12,78,1,funexpr(1:ip+2))\n else\n! note changes below must be repeated for endmember parameters above\n! all other phases\n degree: do jdeg=0,proprec%degree\n if(proprec%degreelink(jdeg).eq.0) then\n! write(*,*)'Ignoring function link'\n cycle degree\n endif\n call encode_constarr(text,nsl,endm,nint,lint,jdeg)\n write(funexpr,300)prop(1:len_trim(prop)), &\n phname(1:len_trim(phname)),text(1:len_trim(text))\n!300 format('PARAMETER ',A,'(',A,',',A,') ')\n ip=len_trim(funexpr)+1\n call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:))\n! remove = sign\n ip=index(funexpr,'=')\n funexpr(ip:ip)=' '\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' '//proprec%reference\n ip=len_trim(funexpr)\n funexpr(ip+1:)=' !'\n call wrice2(lut,4,12,78,1,funexpr(1:ip+2))\n enddo degree\n endif\n proprec=>proprec%nextpr\n enddo ptyloop2\n! list temporarily the number of permutations\n if(btest(phlista(lokph)%status1,PHFORD).or. &\n btest(phlista(lokph)%status1,PHBORD)) then\n! if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then\n if(nint.eq.1) then\n nz=intrec%noofip(2)\n else\n nz=size(intrec%sublattice)\n lqq=intrec%noofip(size(intrec%noofip))\n if(lqq.ne.nz) then\n write(*,*)'3C Not same 2: ',intrec%antalint,nz,lqq\n endif\n! write(*,301)nz,intrec%noofip\n301 format('noofip: ',10i3)\n! nz=intrec%noofip(intrec%noofip(1)+2)\n endif\n iqnext=0\n iqhigh=0\n if(associated(intrec%highlink)) then\n iqhigh=intrec%highlink%antalint\n endif\n if(associated(intrec%nextlink)) then\n iqnext=intrec%nextlink%antalint\n endif\n write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext\n302 format('3C Interaction check 2: permut, level, high, next: ',5i4)\n endif\n intrec=>intrec%highlink\n empty: do while(.not.associated(intrec))\n if(nint.gt.0) then\n! restore pointers in same clumsy way\n intrec=>intrecstack(nint)%p1\n intrec=>intrec%nextlink\n! write(*,*)'poping a pointer from intrecstack',ninit\n nint=nint-1\n else\n exit intlist2\n endif\n enddo empty\n enddo intlist2\n endmemrec=>endmemrec%nextem\n enddo intlist1\n! check if there are other fraction lists\n! parlist=parlist+1, hm parlist can only be 1 or 2\n! write(*,*)'checking for disordered parameters'\n if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then\n write(lut,810)\n810 format('$ Disordered fraction parameters:',20('-'))\n subref=.TRUE.\n! lokcs=phlista(lokph)%cslink\n lokcs=phlista(lokph)%linktocs(ics)\n! does this make a copy? Maybe it should be a pointer\n disfra=firsteq%phase_varres(lokcs)%disfra\n nsl=disfra%ndd\n parlist=2\n if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist\n goto 100\n endif\n1000 continue\n! add ternary extrapolations as commands, not TYPE_DEF\n! This listing is not for TDB files ??\n tooprec=>phlista(lokph)%tooplast\n if(associated(tooprec)) then\n! this is writing a TDB database file\n text='TYPE_DEFINITION '//ctop//' GES A_P_D '\n ik=30\n! increment ctop for next phase ...\n ctop=char(ichar(ctop)+1)\n nsl=0\n do while(associated(tooprec))\n if(len(tooprec%amend1).gt.1) then\n if(nsl.eq.0) then\n! keep phase if nsl=0\n text(ik:)=tooprec%amend1\n ik=len_trim(text)+2\n nsl=nsl+1\n else\n! otherwise remove phase and \"TERNARY_EXTRA\" as alredy set\n ij=index(tooprec%amend1,'_EXTRA')\n! ij will be position of \"_\", add 7 ??\n text(ik:)=tooprec%amend1(ij+7:)\n ik=len_trim(text)+2\n endif\n endif\n! there can be 3 amends ...\n if(len(tooprec%amend2).gt.1) then\n ij=index(tooprec%amend2,'_EXTRA')\n text(ik:)=tooprec%amend2(ij+7:)\n ik=len_trim(text)+2\n endif\n if(len(tooprec%amend3).gt.1) then\n ij=index(tooprec%amend3,'_EXTRA')\n text(ik:)=tooprec%amend3(ij+7:)\n ik=len_trim(text)+2\n endif\n! write if too long\n if(ik.gt.70) then\n write(lut,1100)text(1:ik)\n text=' '\n ik=1\n endif\n tooprec=>tooprec%nexttoop\n1100 format(a)\n enddo\n write(lut,1100)' !'\n endif\n! write(*,*)'3C listing by list_phase_data2'\n return\n END subroutine list_phase_data2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine subrefstates\n!\\begin{verbatim}\n subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1)\n! list a sum of reference states for a G parameter\n! like \"-H298(BCC_A2,FE)-3*H298(GRAPITE,C)\"\n implicit none\n integer jp,lokph,parlist,endm(*)\n character funexpr*(*)\n logical noelin1\n!\\end{verbatim}\n! special care for ionic liquid as sites varies ...\n character text*80,els*2\n integer element(maxel),lokel\n double precision coef(maxel),xx,pqval(2),bonds\n! TYPE(gtp_fraction_set) :: disfra\n TYPE(gtp_fraction_set), pointer :: disfra\n integer nsl,lokcs,ie,ll,jsp,nrel,ik,je,more,is,ip\n!\n noelin1=.FALSE.\n lokcs=phlista(lokph)%linktocs(1)\n if(btest(phlista(lokph)%status1,PHIONLIQ)) goto 210\n if(parlist.eq.1) then\n nsl=phlista(lokph)%noofsubl\n else\n! for disordered fraction set always use 1 as factor ??\n! How about bcc with C? the second sublattice should count ...\n! CONCLUSION: If disordered fraction set has 2 sublattices calculate\n! should disfra be a pointer?? It seems to work like this ....\n! disfra=firsteq%phase_varres(lokcs)%disfra \n disfra=>firsteq%phase_varres(lokcs)%disfra\n nsl=disfra%ndd\n endif\n ie=0\n! do not multiply swith sites for models PHCVMCQ, TISR, MQMQA, CRC, SROT\n if(nsl.eq.1 .and. &\n (btest(phlista(lokph)%status1,PHCVMCE) .or.&\n! btest(phlista(lokph)%status1,PHFACTCE) .or.&\n btest(phlista(lokph)%status1,PHMQMQA) .or.&\n btest(phlista(lokph)%status1,PHQCE) .or.&\n btest(phlista(lokph)%status1,PHSROT) .or.&\n btest(phlista(lokph)%status1,PHTISR))) then\n bonds=firsteq%phase_varres(lokcs)%sites(1)\n firsteq%phase_varres(lokcs)%sites(1)=one\n endif\n sublat: do ll=1,nsl\n jsp=endm(ll)\n if(jsp.gt.0) then\n nrel=splista(jsp)%noofel\n elem: do ik=1,nrel\n do je=1,ie\n if(splista(jsp)%ellinks(ik).eq.element(je)) then\n if(parlist.eq.1) then\n coef(je)=coef(je)+&\n firsteq%phase_varres(lokcs)%sites(ll)*&\n splista(jsp)%stoichiometry(ik)\n! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik)\n else\n coef(je)=coef(je)+&\n disfra%dsites(ll)*splista(jsp)%stoichiometry(ik)\n endif\n goto 200\n endif\n enddo\n! new element, increment ie and initiate coef\n! ignore the element VA with element index 0\n if(splista(jsp)%ellinks(ik).eq.0) goto 200\n ie=ie+1\n element(ie)=splista(jsp)%ellinks(ik)\n if(parlist.eq.1) then\n coef(ie)=&\n firsteq%phase_varres(lokcs)%sites(ll)*&\n splista(jsp)%stoichiometry(ik)\n! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik)\n else\n! if a single disordered sublattice ignore the number of sites !!!\n if(nsl.eq.1) then\n coef(ie)=splista(jsp)%stoichiometry(ik)\n else\n coef(ie)=disfra%dsites(ll)*splista(jsp)%stoichiometry(ik)\n endif\n endif\n200 continue\n enddo elem\n else\n! wildcard, ignore references\n continue\n endif\n enddo sublat\n goto 300\n!------------------------------------------------------------\n! ionic liquid special, 2 sublattices but sites varies with charges\n210 continue\n ie=0\n jsp=endm(1)\n if(jsp.gt.0) then\n pqval(2)=splista(jsp)%charge\n else\n pqval(2)=one\n endif\n jsp=endm(2)\n if(jsp.gt.0) then\n if(btest(splista(jsp)%status,SPVA)) then\n pqval(1)=one\n else\n pqval(1)=-splista(jsp)%charge\n if(pqval(1).eq.zero) then\n noelin1=.TRUE.\n pqval(2)=one\n endif\n endif\n else\n! write(*,*)'Illegal with wildcards in 2nd sublattice'\n gx%bmperr=4262; goto 1000\n endif\n ionsl: do ll=1,2\n jsp=endm(ll)\n if(jsp.lt.0) cycle\n nrel=splista(jsp)%noofel\n ionel: do ik=1,nrel\n do je=1,ie\n if(splista(jsp)%ellinks(ik).eq.element(je)) then\n coef(je)=coef(je)+&\n pqval(ll)*splista(jsp)%stoichiometry(ik)\n cycle ionel\n endif\n enddo\n! new element, increment ie and initiate coef\n! ignore the element VA with element index 0\n if(splista(jsp)%ellinks(ik).ne.0) then\n ie=ie+1\n element(ie)=splista(jsp)%ellinks(ik)\n coef(ie)=&\n pqval(ll)*splista(jsp)%stoichiometry(ik)\n endif\n enddo ionel\n enddo ionsl\n!------------------------------------------------------------\n! sort the elements\n300 continue\n more=0\n do je=1,ie-1\n if(element(je).gt.element(je+1)) then\n is=element(je)\n element(je)=element(je+1)\n element(je+1)=is\n xx=coef(je)\n coef(je)=coef(je+1)\n coef(je+1)=xx\n more=1\n endif\n enddo\n! restore bonds in sites(1) ....\n if(btest(phlista(lokph)%status1,PHCVMCE) .or.&\n! btest(phlista(lokph)%status1,PHFACTCE) .or.&\n btest(phlista(lokph)%status1,PHMQMQA) .or.&\n btest(phlista(lokph)%status1,PHQCE) .or.&\n btest(phlista(lokph)%status1,PHSROT) .or. &\n btest(phlista(lokph)%status1,PHTISR)) then\n firsteq%phase_varres(lokcs)%sites(1)=bonds\n endif\n if(more.gt.0) goto 300\n! list the elements as -10*H298(SER,element)\n! write(*,*)'subrefstate 2:',ie,(element(i),i=1,ie)\n ip=1\n text=' '\n do je=1,ie\n if(coef(je).ne.one) then\n call wrinum(text,ip,10,6,-coef(je))\n text(ip:ip)='*'\n else\n text(ip:ip)='-'\n endif\n ip=ip+1\n lokel=element(je)\n els=ellista(lokel)%symbol\n if(ellista(lokel)%refstatesymbol.eq.0) then\n text(ip:)='H298(SER,'//els(1:len_trim(els))//')'\n else\n text(ip:)='G(SER,'//els(1:len_trim(els))//')'\n endif\n ip=len_trim(text)+1\n enddo\n! write(*,*)'subrefstate 9: ',ip,text(1:ip)\n funexpr(jp:)=text\n jp=jp+ip\n1000 continue\n return\n end subroutine subrefstates\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine encode_stoik\n!\\begin{verbatim}\n subroutine encode_stoik(text,ipos,mdig,spno)\n! generate a stoichiometric formula of species from element list\n! mdig is max number of digits in stoichiometry\n implicit none\n integer ipos,mdig,spno\n character text*(*)\n!\\end{verbatim}\n character elnam*2,ltext*60\n integer eli,noelx,iel,isto,jpos,ich,nlen,iq,tdb\n double precision stoi,charge\n if(spno.lt.1 .or. spno.gt.noofsp) then\n! write(*,*)'3C in encode_stoik, no species: ',spno\n gx%bmperr=4051\n goto 1000\n endif\n ipos=1\n noelx=splista(spno)%noofel\n! write(6,*)'3C encode_stoik 1: ',spno,noelx\n ltext=splista(spno)%symbol\n iq=index(ltext,'/')\n! if(iq.gt.0 .and. (ichar(ltext(iq+1:iq+1)).gt.ichar('9'))) then\n! this is a quas, special output in TDB files ...\n! write(*,*)'3C next species is a quad \"',trim(ltext),'\"'\n! endif\n loop1: do iel=1,noelx\n eli=splista(spno)%ellinks(iel)\n elnam=ellista(eli)%symbol\n! write(6,*)'3C encode_stoik 2: ',eli,elnam\n if(elnam(2:2).ne.' ') then\n ltext(ipos:ipos+1)=elnam\n nlen=2\n else\n ltext(ipos:ipos)=elnam\n nlen=1\n endif\n ipos=ipos+nlen\n stoi=splista(spno)%stoichiometry(iel)\n isto=int(stoi)\n if(abs(dble(isto)-stoi).lt.1.0D-3) then\n! try to handle integer stoichiometries nicely\n if(isto.gt.99) then\n write(ltext(ipos:ipos+2),200)isto\n200 format(I3)\n ipos=ipos+3\n elseif(isto.gt.9) then\n write(ltext(ipos:ipos+1),205)isto\n205 format(I2)\n ipos=ipos+2\n elseif(isto.gt.1) then\n write(ltext(ipos:ipos),210)isto\n210 format(i1)\n ipos=ipos+1\n! write(6,*)'3C encode_stoik 4B: ',ltext(ipos-3:ipos)\n elseif(nlen.eq.1 .and. iel.ne.noelx) then\n ltext(ipos:ipos)='1'\n ipos=ipos+1\n endif\n else\n! stoichiometry is a non-integer value, max mdig digits\n jpos=ipos\n! call wrinum(ltext,ipos,8,0,stoi)\n call wrinum(ltext,ipos,mdig,0,stoi)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n! remove trailing zeroes\n300 continue\n if(ltext(ipos:ipos).eq.'0') then\n ipos=ipos-1; goto 300\n endif\n endif\n enddo loop1\n charge=splista(spno)%charge\n ich=int(charge)\n! write(6,*)'3C encode_stoik 5: ',ich,charge\n if(ich.lt.zero) then\n! limit output to integer charges <10\n ltext(ipos:ipos+3)='/-'//char(ichar('0')-ich)\n ipos=ipos+3\n elseif(charge.gt.zero) then\n ltext(ipos:ipos+3)='/+'//char(ichar('0')+ich)\n ipos=ipos+3\n endif\n text=ltext\n ipos=ipos-1\n! write(6,*)'encode_stoik 6: ',ipos,ltext(1:ipos)\n1000 continue\n return\n END subroutine encode_stoik\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine decode_stoik\n!\\begin{verbatim}\n subroutine decode_stoik(name,noelx,elsyms,stoik)\n! decode a species stoichiometry in name to element index and stoichiometry\n! all in upper case\n implicit none\n character name*(*),elsyms(*)*2\n double precision stoik(*)\n integer noelx\n!\\end{verbatim}\n character lname*72,ch2*2\n double precision xx\n integer ip,jp,ii\n lname=name\n call capson(lname)\n noelx=0\n ip=1\n! expect element symbol\n! write(*,'(a,a,i2)')'3C decode_stoik 1: ',lname,ip\n if(eolch(lname,ip)) then\n! empty line, expected species stoichiometry\n gx%bmperr=4083; goto 1000\n endif\n100 continue\n ch2=lname(ip:ip+1)\n! write(*,*)'Looking for element: ',ip,ch2\n if(ch2(2:2).ge.'A' .and. ch2(2:2).le.'Z') then\n noelx=noelx+1\n elsyms(noelx)=ch2\n ip=ip+2\n elseif(ch2(1:1).ge.'A' .and. ch2(1:1).le.'Z') then\n noelx=noelx+1\n elsyms(noelx)=ch2(1:1)\n ip=ip+1\n elseif(ch2(1:1).eq.'/') then\n! electron is always /-, if /+ is given change sign in lname\n noelx=noelx+1\n elsyms(noelx)='/-'\n if(ch2(2:2).eq.'+') then\n lname(ip+1:ip+1)='-'\n ip=ip+1\n elseif(ch2(2:2).eq.'-') then\n ip=ip+2\n else\n! Hm, how come A/X is accepted? 211119/BoS\n! do not accept Fe/2 for Fe/+2, always require + or -\n! write(*,*)'Charge must always be given as /+ or /-'\n gx%bmperr=4289; goto 1000\n endif\n! write(*,*)'Found charge: ',ip,noelx,'>',lname(ip:ip+5),'<'\n else\n goto 900\n endif\n! an element found, no stoichiometry number means stoik=1\n! write(*,17)'3C decode_stoik 2: ',ip,ch2,lname(ip:ip+5)\n17 format(a,i3,'>',a,'<>',a,'<')\n if(lname(ip:ip).eq.' ') then\n stoik(noelx)=one\n else\n jp=ip\n call getrel(lname,ip,xx)\n! write(*,*)'decode_stoik 3: ',jp,ip,buperr,xx\n if(buperr.eq.0) then\n stoik(noelx)=xx\n else\n! Strange error entering stoichiometry U1EUO3.83, ip=4, jp=2 and buperr=1937\n! getrel evidently did not find the \"1\". Check explictly if lname(jp:jp)\n! is a number!\n if(lname(jp:jp).ge.'1' .and. lname(jp:jp).le.'9') then\n stoik(noelx)=dble(ichar(lname(jp:jp))-ichar('0'))\n ip=jp+1\n buperr=0\n goto 100\n else\n! accept missing stoichiometry value as 1, it is accepted to write cao as cao\n stoik(noelx)=one\n! buperr=0\n! the error can be due to another element follows directly, restore ip an check\n! ip=jp\n! goto 100\n endif\n endif\n! in one case of missing stoichiometry ip exceeded length of lname\n! write(*,*)'3C decode_stoik 4: ',stoik(noelx),buperr\n fraction: if(buperr.eq.0 .and. lname(ip:ip).eq.'/') then\n! a stoichiometric factor followed by / without sign will be interpreted\n! as a fraction like AL2/3O. Note AL2/+3 means AL2 with charge +3\n jp=ip+1\n if(.not.(lname(jp:jp).eq.'+' .or. lname(jp:jp).eq.'-')) then\n call getrel(lname,jp,xx)\n! write(*,*)'decode_stoik 5: ',ip,jp,buperr,xx\n if(buperr.eq.0) then\n stoik(noelx)=stoik(noelx)/xx\n ip=jp\n else\n buperr=0\n endif\n! else\n! write(*,*)'Interpret / as charge!'\n endif\n else\n! write(*,*)'3C decode: ',ip,trim(lname)\n buperr=0\n endif fraction\n if(ip.lt.len(lname)) goto 100\n endif\n900 continue\n if(noelx.eq.0) then\n write(*,*)'3C error in species stoichiometry: ',trim(name),ip\n gx%bmperr=4084\n endif\n! write(*,19)(stoik(ii),ii=1,noelx)\n19 format('3C decode_stoik 5: ',5(1PE12.3))\n1000 continue\n return\n end subroutine decode_stoik\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine encode_constarr\n!\\begin{verbatim}\n subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg)\n! creates a constituent array\n implicit none\n character constarr*(*)\n character dummy*24\n integer, dimension(*) :: endm\n integer nsl,nint,ideg,rp\n integer, dimension(2,*) :: lint\n!\\end{verbatim}\n integer ip,mint,ll,l2\n ip=1\n constarr=' '\n mint=1\n! special MQMQX\n! if(ideg.lt.0) write(*,*)'3C line 3665 removing digits after -Q'\n! if(nint.gt.0) then\n! write(*,*)'encode_contarr ',lint(1,1),lint(2,1)\n! endif\n do ll=1,nsl\n if(endm(ll).gt.0) then\n if(ideg.lt.0) then\n! this is for TDB files using the MQMQA model. Remove 2 digits after -Q. WORKS\n rp=index(splista(endm(ll))%symbol,'-Q')\n! write(*,*)'3C in encode_constarr no digits after -Q',rp\n if(rp.le.0) then\n write(*,*)'3C Warning, MQMQA constituent missing \"-Q\"'\n endif\n constarr(ip:)=splista(endm(ll))%symbol(1:rp+1)\n else\n constarr(ip:)=splista(endm(ll))%symbol\n endif\n else\n constarr(ip:)='*'\n endif\n ip=len_trim(constarr)\n if(mint.le.nint) then\n! write(*,*)'encode_contarr ',lint(1,1),lint(2,1)\n do l2=mint,nint\n if(lint(1,mint).eq.ll) then\n constarr(ip+1:ip+1)=','\n ip=ip+2\n if(ideg.lt.0) then\n rp=index(splista(lint(2,mint))%symbol,'-Q')\n! take into account the ,\n constarr(ip:)=splista(lint(2,mint))%symbol(1:rp+1)\n else\n constarr(ip:)=splista(lint(2,mint))%symbol\n endif\n ip=len_trim(constarr)\n mint=mint+1\n endif\n enddo\n endif\n constarr(ip+1:ip+1)=':'\n ip=ip+2\n enddo\n! for MQMQA phases the part after \";\" is replaced on TDB files ... (ideg -1)\n constarr(ip-1:ip-1)=';'\n constarr(ip:ip)='0'\n if(ideg.gt.0) constarr(ip:ip)=char(ideg+ichar('0'))\n return\n end subroutine encode_constarr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine decode_constarr\n!\\begin{verbatim}\n subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg)\n! deconde a text string with a constituent array\n! a constituent array has separated by , or : and ; before degree\n implicit none\n character constarr*(*)\n integer endm(*),lint(2,*)\n integer nsl,nint,ideg,lokph,lord\n!\\end{verbatim}\n character const*24,ch1*1\n integer ll,ip,jp,isep,loksp,mord,isp,jsp,nord,mqmqa1\n integer constlist(5),klok(5),knr(2)\n!\n nint=0; ideg=0; ll=1\n endm(ll)=0\n ip=1\n! write(*,*)'3C decode_constarr 1: ',ip,trim(constarr)\n if(eolch(constarr,ip)) then\n gx%bmperr=4061; goto 1000\n endif\n jp=ip-1\n! write(*,*)'3C decode_constarr 2: ',ip,jp\n loop: do while(.true.)\n! find separators between constituents, no spaces allowed\n jp=jp+1\n ch1=biglet(constarr(jp:jp))\n! write(*,*)'decode_constarr 3: ',jp,ch1\n letter: if(ch1.eq.',') then\n isep=1\n elseif(ch1.eq.':') then\n isep=2\n elseif(ch1.eq.';') then\n isep=3\n elseif(ch1.eq.' ') then\n isep=4\n elseif(.not.(ch1.ge.'A' .and. ch1.le.'Z')) then\n! write(*,*)'3C decode_constarr 3B: ',jp,ip,ch1\n if(jp.gt.ip) then\n! accept 0-9 and _ and . and / and + and - \n! after the first character of a constituent\n! write(*,24)'decode constarr 24A: \"',ch1\n if(.not.((ch1.ge.'0' .and. ch1.le.'9') .or. &\n ch1.eq.'_' .or. ch1.eq.'.' .or. &\n ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-')) then\n! write(*,24)'3C: decode constarr 24B: \"',ch1\n24 format(a,a,'\"')\n gx%bmperr=4062; goto 1000\n endif\n elseif(ch1.ne.'*') then\n! last possibility: wildcard\n! write(*,24)'decode constarr 24C: \"',ch1\n gx%bmperr=4062; goto 1000\n endif\n! write(*,24)'decode constarr 24D: \"',ch1\n cycle\n else\n cycle\n endif letter\n! we have a species name between ip and jp\n const=constarr(ip:jp-1)\n! write(*,*)'3C decode_constarr species: \"',trim(const),'\"'\n call find_species_record_exact(const,loksp)\n if(gx%bmperr.ne.0) then\n if(const(1:2).eq.'* ') then\n! wildcard, the parameter is independent of the fraction in this sublattice\n loksp=-99; gx%bmperr=0\n else\n goto 1000\n endif\n endif\n! write(*,11)'decode constarr 11: ',ip,jp,loksp,const\n!11 format(a,3i4,'\"',a,'\"')\n place: if(endm(ll).eq.0) then\n! first constituent of sublattice ll independent of separator\n endm(ll)=loksp\n else\n lint(1,nint)=ll\n lint(2,nint)=loksp\n endif place\n next: if(isep.eq.1) then\n! separator was a , next constituent an interaction\n nint=nint+1\n elseif(isep.eq.2) then\n! separator was a \":\" meaning new sublattice\n ll=ll+1\n endm(ll)=0\n elseif(isep.eq.3) then\n! this is the end of a constituent array, normally followed by a degree 0-9\n if(btest(phlista(lokph)%status1,PHMQMQX)) then\n! begin MQMQA special: phase with asymmetrical excess with more data after ;\n! typically G,1,1. position jp indicate the \";\"\n ch1=constarr(jp+1:jp+1)\n if(ch1.eq.'0') then\n! MQMQA endmember parameter\n ideg=0; exit loop\n endif\n jp=jp+2\n! write(*,50)1,jp,ch1,trim(constarr),ideg\n50 format('3C MQMQA excess ',i1,i5,' \"',a,'\" \"',a,'\" ideg',i5)\n call capson(ch1)\n if(ch1.eq.'G') then\n ideg=1000\n elseif(ch1.eq.'Q') then\n ideg=2000\n elseif(ch1.eq.'B') then\n ideg=3000\n else\n write(*,*)'3C *** Error: illegal MQMQA excess letter: \"',ch1,'\"'\n gx%bmperr=4063; goto 1000\n endif\n! write(*,50)2,jp,ch1,trim(constarr(jp:)),ideg\n! there will be one or more integers after the letter\n! skip the \",\"\n jp=jp+1\n call getint(constarr,jp,mqmqa1)\n if(buperr.ne.0) then\n! write(*,50)3,jp,ch1,trim(constarr),mqmqa1\n! gx%bmperr=4399; goto 1000\n endif\n ideg=ideg+100*mqmqa1\n! write(*,*)'3C first value of ideg: ',ideg\n! skip the \",\" character\n jp=jp+1\n call getint(constarr,jp,mqmqa1)\n if(buperr.ne.0) then\n! write(*,50)4,jp,ch1,trim(constarr(jp:)),mqmqa1\n! it is not an error, there may be just a single number\n! gx%bmperr=4399; goto 1000\n buperr=0\n else\n ideg=ideg+10*mqmqa1\n endif\n! write(*,*)'3C second value of ideg: ',ideg,mqmqa1\n! skip the \",\" character\n jp=jp+1\n call getint(constarr,jp,mqmqa1)\n if(buperr.ne.0) then\n! write(*,50)4,jp,ch1,trim(constarr(jp:)),mqmqa1\n! it is not an error, there may be just a single number\n! gx%bmperr=4399; goto 1000\n buperr=0\n else\n ideg=ideg+mqmqa1\n endif\n! write(*,*)'3C final ideg: ',ideg,mqmqa1\n! end of special MQMQA excess\n else\n! normally a digit 0 to 9 is allowed after the \";\"\n ideg=ichar(constarr(jp+1:jp+1))-ichar('0')\n if(ideg.lt.0 .or. ideg.gt.9) then\n! a degree must be between 0 and 9\n gx%bmperr=4063; goto 1000\n endif\n endif\n exit loop\n elseif(isep.eq.4) then\n exit loop\n endif next\n! beginning of next constituent\n ip=jp+1\n enddo loop\n! number of sublattices\n nsl=ll\n! make sure the constituents are in alphabetcal order for each sublattice.\n!--------------------------------------------------------\n! Special order of constituents for ionic liquid ....\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n constlist(1)=endm(1)\n if(nsl.ne.2) then\n if(nsl.eq.1) then\n! when ionic liquid parameters entered from TDB-TC files parameters\n! with just neutrals may have only one sublattice. Error cleared by\n! the readtdb subroutine. \n! BUT we must sort constituents on the sublattice, must be only neutrals ...\n! I hope that will be chacked later ...\n do jsp=1,nint\n constlist(1+jsp)=lint(2,jsp)\n enddo\n! simple bubble sort of constlist\n44 continue\n do jsp=1,nint\n if(constlist(jsp+1).lt.constlist(jsp)) then\n lord=constlist(jsp)\n constlist(jsp)=constlist(jsp+1)\n constlist(jsp+1)=lord\n goto 44\n endif\n enddo\n endif\n endm(1)=constlist(1)\n do jsp=1,nint\n lint(2,jsp)=constlist(1+jsp)\n enddo\n! if(ocv()) write(*,*)'Ionic liquid has always 2 sublattices'\n gx%bmperr=4255; goto 1000\n endif\n lord=1\n do jsp=1,nint\n if(lint(1,jsp).eq.1) then\n lord=lord+1\n constlist(lord)=lint(2,jsp)\n endif\n enddo\n knr(1)=lord\n lord=lord+1\n constlist(lord)=endm(2)\n do jsp=1,nint\n if(lint(1,jsp).eq.2) then\n lord=lord+1\n constlist(lord)=lint(2,jsp)\n endif\n enddo\n knr(2)=lord-knr(1)\n call sort_ionliqconst(lokph,1,knr,constlist,klok)\n if(gx%bmperr.ne.0) then\n write(*,*)'3C Error return from sort_ionliqconst ',gx%bmperr\n! write(*,65)lord,(klok(ll),ll=1,lord)\n!65 format('3C constarr: ',i5,5x,5i3)\n write(*,64)trim(constarr)\n64 format('3C constarr: ',a)\n goto 1000\n endif\n lord=0\n endm(1)=klok(1)\n do jsp=2,knr(1)\n lord=lord+1\n lint(1,lord)=1\n lint(2,lord)=klok(lord+1)\n enddo\n endm(2)=klok(lord+2)\n do jsp=2,knr(2)\n lord=lord+1\n lint(1,lord)=2\n lint(2,lord)=klok(lord+2)\n enddo\n! write(*,66)endm(1),endm(2),(lint(1,ll),lint(2,ll),ll=1,nint)\n66 format('decode: ',2i5,5x,3(2i3,2x))\n goto 1000\n endif\n!--------------------------------------------------------\n! first the endmember must be in order of the constituents, except wildcard\n order1: do mord=1,nint\n ll=lint(1,mord)\n isp=lint(2,mord)\n jsp=endm(ll)\n! we can have isp or jsp or both negative if wildcard, WILDCARD ALWAYS IN ENDM\n if(isp.lt.0 .and. jsp.lt.0) then\n! only one wildcard in each sublattice\n gx%bmperr=4032; goto 1000\n elseif(isp.lt.0 .and. jsp.gt.0) then\n endm(ll)=isp\n lint(2,mord)=jsp\n elseif(isp.gt.0 .and. jsp.lt.0) then\n endm(ll)=jsp\n lint(2,mord)=isp\n elseif(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then\n endm(ll)=isp\n lint(2,mord)=jsp\n endif\n enddo order1\n! then order if there are two interacting in same sublattice\n! There are almost never more than 3 constituents interacting in one sublattice\n order2: do mord=1,nint\n ll=lint(1,mord)\n order3: do nord=mord+1,nint\n if(lint(1,nord).eq.ll) then\n isp=lint(2,nord)\n jsp=lint(2,mord)\n if(isp.lt.0 .or. jsp.lt.0) then\n gx%bmperr=4032; goto 1000\n endif\n if(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then\n lint(2,mord)=isp\n lint(2,nord)=jsp\n endif\n endif\n enddo order3\n enddo order2\n! write(*,77)(splista(endm(i))%alphaindex,i=1,nsl), &\n! (lint(1,j),lint(2,j),j=1,nint)\n!77 format('decode_contarr 7: ',3I3,5x,2i2)\n1000 continue\n return\n end subroutine decode_constarr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_bibliography\n!\\begin{verbatim}\n subroutine list_bibliography(bibid,lut)\n! list bibliographic references\n implicit none\n integer lut\n character bibid*(*)\n!\\end{verbatim}\n character longline*2048\n integer ir,jp,nl,ll,maxl\n if(lut.eq.kou) then\n write(lut,10)reffree-1\n! else\n! write(lut,11)reffree-1\n endif\n10 format('There are ',i5,' bibliographic references')\n11 format('$ There are ',i5,' bibliographic references')\n maxl=0\n do ir=1,reffree-1\n if(bibid(1:1).ne.' ' .and. &\n .not.compare_abbrev(bibid,bibrefs(ir)%reference)) cycle\n longline=bibrefs(ir)%reference\n longline(17:17)=\"'\"\n jp=18\n! nl=size(bibrefs(ir)%refspec)\n! do ll=1,nl\n! longline(jp:)=bibrefs(ir)%refspec(ll)\n! jp=jp+64\n! enddo\n! this require Fortran standard 2003/2008 \n! longline(jp:)=bibrefs(ir)%nyrefspec\n ll=bibrefs(ir)%wprefspec(1)\n! loadc/storc are WPACK routines to store/load characters in integer arrays\n call loadc(2,bibrefs(ir)%wprefspec,longline(jp:jp+ll-1))\n jp=len_trim(longline)+1\n longline(jp:jp)=\"'\"\n call wrice(lut,0,17,78,longline(1:jp))\n maxl=maxl+1\n if(lut.ne.kou .and. maxl.gt.50) then\n! Thermo-Calc limit is 150 lines for each LIST_OF_REFERENCES on a TDB file\n write(lut,17)\n17 format(' !'//' ADD_REFERENCES'/' NUMBER SOURCE'/\" dummy ' '\")\n maxl=0\n endif\n enddo\n! write(*,*)'3C refs: ',reffree,maxl\n1000 continue\n return\n end subroutine list_bibliography\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_conditions\n!\\begin{verbatim}\n subroutine list_conditions(lut,ceq)\n! lists conditions on lut\n implicit none\n integer lut\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character*1024 text\n integer kl\n text=' '\n call get_all_conditions(text,0,ceq)\n if(gx%bmperr.ne.0) goto 1000\n kl=index(text,'CRLF')\n if(kl.gt.1) then\n call wrice2(lut,2,4,78,1,text(1:kl-1))\n endif\n write(lut,50)text(kl+4:len_trim(text))\n50 format(a)\n1000 continue\n return\n end subroutine list_conditions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_one_condition\n!\\begin{verbatim}\n subroutine get_one_condition(ip,text,seqz,ceq)\n! list the condition with the index seqz into text\n! It lists also fix phases (and conditions that are not active?)\n implicit none\n integer ip,seqz\n character text*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer jl,iterm,indx(4)\n TYPE(gtp_condition), pointer :: last,current\n type(gtp_state_variable), pointer :: svrrec\n double precision wone\n!\n if(ip.le.0) ip=1\n text(ip:)=' '\n if(.not.associated(ceq%lastcondition)) then\n! write(*,*)'3C No conditions at all'\n gx%bmperr=4143; goto 1000\n endif\n last=>ceq%lastcondition\n current=>last\n70 continue\n! write(*,*)'3C get_one_cond: ',current%seqz\n if(current%seqz.eq.seqz) goto 100\n current=>current%next\n if(.not.associated(current,last)) goto 70\n! no condition with this index found\n gx%bmperr=4131; goto 1000\n!\n100 continue\n iterm=1\n! return here for each term if several\n150 continue\n do jl=1,4\n indx(jl)=current%indices(jl,iterm)\n enddo\n! write(*,*)'3C g1c: ',indx\n if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then\n wone=current%condcoeff(iterm)+one\n if(abs(wone).lt.1.0D-10) then\n text(ip:ip)='-'\n ip=ip+1\n else\n! not +1 or -1, write number\n! if iterm=1 no not write a positive sign\n if(iterm.eq.1) then\n call wrinum(text,ip,8,1,current%condcoeff(iterm))\n else\n call wrinum(text,ip,8,0,current%condcoeff(iterm))\n endif\n text(ip:ip)='*'\n ip=ip+1\n endif\n elseif(iterm.gt.1) then\n! must be a + in front of second and later terms even if coeff is +1\n text(ip:ip)='+'\n ip=ip+1\n endif\n! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! \n! call encode_state_variable2(text,ip,current%statev,indx,&\n! current%iunit,current%iref,ceq)\n svrrec=>current%statvar(1)\n call encode_state_variable(text,ip,svrrec,ceq)\n if(iterm.lt.current%noofterms) then\n iterm=iterm+1; goto 150\n endif\n! write = followed by the value \n if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='='\n ip=ip+1\n! write(*,*)'3C symlink: ',current%symlink1,current%prescribed\n if(current%symlink1.gt.0) then\n! the value is a symbol\n text(ip:)=svflista(current%symlink1)%name\n ip=len_trim(text)+1\n else\n call wrinum(text,ip,10,0,current%prescribed)\n endif\n1000 continue\n return\n end subroutine get_one_condition\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_one_experiment\n!\\begin{verbatim}\n subroutine get_one_experiment(ip,text,seqz,eval,ceq)\n! list the experiment with the index seqz into text\n! It lists also experiments that are not active ??\n! UNFINISHED current value should be appended\n implicit none\n integer ip,seqz\n character text*(*)\n logical eval\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jl,iterm,indx(4),symsym\n TYPE(gtp_condition), pointer :: last,current\n type(gtp_state_variable), pointer :: svrrec\n double precision wone,xxx\n character actual_arg*16\n!\n if(ip.le.0) ip=1\n text(ip:)=' '\n if(.not.associated(ceq%lastexperiment)) then\n! write(*,*)'3C No experiments'\n gx%bmperr=4249; goto 1000\n endif\n last=>ceq%lastexperiment\n current=>last\n! write(*,*)'3C index of last experiment: ',current%seqz\n70 continue\n! write(*,*)'3C experiment number: ',seqz,current%seqz\n if(current%seqz.eq.seqz) goto 100\n current=>current%next\n if(.not.associated(current,last)) goto 70\n! no experiment with this index found or it is inactivated\n gx%bmperr=4131; goto 1000\n!\n100 continue\n if(current%active.eq.1) then\n! write(*,*)'3C Experiment not active '\n gx%bmperr=4218; goto 1000\n endif\n iterm=1\n150 continue\n! write(*,*)'3C Testing is symbol or state variable record',&\n! allocated(current%statvar)\n nostv: if(.not.allocated(current%statvar)) then\n! an experiment is a symbol!!! Then statvar is not allocated\n symsym=current%statev\n! write(*,*)'3C A symbol, not a state variable for this experiment',symsym\n! get the symbol name\n text=svflista(symsym)%name\n ip=len_trim(text)+1\n! text(ip-1:ip-1)='='\n! write(*,*)'3C experiment: ',text(1:ip),ip\n else\n! write(*,*)'3C This experiment has a state variable record',&\n! allocated(current%statvar),allocated(current%indices),iterm\n symsym=0\n! these are not needed??\n! do jl=1,4\n! indx(jl)=current%indices(jl,iterm)\n! enddo\n! if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then\n! wone=current%condcoeff(iterm)+one\n! if(abs(wone).lt.1.0D-10) then\n! text(ip:ip)='-'\n! ip=ip+1\n! else\n! not +1 or -1, write number\n! call wrinum(text,ip,8,1,current%condcoeff(iterm))\n! text(ip:ip)='*'\n! ip=ip+1\n! endif\n! elseif(iterm.gt.1) then\n! must be a + in front of second and later terms\n! text(ip:ip)='+'\n! ip=ip+1\n! endif\n! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! \n! call encode_state_variable2(text,ip,current%statev,indx,&\n! current%iunit,current%iref,ceq)\n svrrec=>current%statvar(1)\n call encode_state_variable(text,ip,svrrec,ceq)\n if(iterm.lt.current%noofterms) then\n iterm=iterm+1; goto 150\n endif\n endif nostv\n! write(*,*)'3C ok here',symsym\n if(current%experimenttype.eq.0 .or. current%experimenttype.eq.100) then\n! write = followed by the value \n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='='\n ip=ip+1\n elseif(current%experimenttype.eq.-1) then\n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='<'\n ip=ip+1\n elseif(current%experimenttype.eq.1) then\n! if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='>'\n ip=ip+1\n endif\n! write(*,*)'3C experiment line 2: ',text(1:ip),ip\n if(current%symlink1.gt.0) then\n! the value is a symbol\n text(ip:)=svflista(current%symlink1)%name\n ip=len_trim(text)+1\n else\n! call wrinum(text,ip,10,0,current%prescribed)\n call wrinum(text,ip,8,0,current%prescribed)\n endif\n! uncertainty can also be a symbol\n text(ip:ip)=':'\n ip=ip+1\n! write(*,*)'3C experiment line 3: ',text(1:ip),ip\n! write(*,*)'3C uncertainty: ',current%symlink2\n if(current%symlink2.gt.0) then\n! the value is a symbol\n text(ip:)=svflista(current%symlink2)%name\n ip=len_trim(text)+1\n else\n! call wrinum(text,ip,10,0,current%uncertainty)\n call wrinum(text,ip,8,0,current%uncertainty)\n endif\n! write(*,*)'3C ok here 2',symsym,text(1:ip)\n! write(*,*)'3C experiment line 2: ',text(1:ip),ip\n if(current%experimenttype.eq.100) then\n text(ip:ip)='%'\n ip=ip+1\n endif\n! write(*,*)'3C ok here 3',symsym\n! if eval TRUE add the current value of the experiment after a $ sign\n! TROUBLE GETTING WRONG VALUE HERE WHEN USER DEFINED REFERENCE STATES\n if(.not.eval) then\n text(ip+2:)='$ ?? '\n goto 1000\n endif\n if(symsym.eq.0) then\n call state_variable_val(svrrec,xxx,ceq)\n else\n! write(*,*)'3C ok here 4',symsym\n actual_arg=' '\n xxx=evaluate_svfun_old(symsym,actual_arg,1,ceq)\n endif\n if(gx%bmperr.ne.0) then\n! it is maybe a derivative ... \n write(*,*)'3C we cannot evaluate a derivative here ...',gx%bmperr\n! but meq_evaluate_svfun not available here ... it is part of the minimizer\n! gx%bmperr=0\n! xxx=meq_evaluate_svfun(symsym,actual_arg,0,ceq)\n! endif\n! if(gx%bmperr.ne.0) then\n write(*,*)'3C Error evaluating symbol: ',gx%bmperr\n text(ip:)=' $ ?? '\n ip=ip+5\n gx%bmperr=0\n else\n! write(*,*)'3C experimental state variable current value: ',xxx\n text(ip:)=' $'\n ip=ip+3\n! call wrinum(text,ip,12,0,xxx)\n call wrinum(text,ip,8,0,xxx)\n! write(*,*)'3C experiment line 3: ',text(1:ip),ip\n endif\n! write(*,*)'3C ok here 5'\n1000 continue\n! write(*,*)'3C experiment line 4: ',text(1:ip),ip,gx%bmperr\n return\n end subroutine get_one_experiment\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_all_conditions\n!\\begin{verbatim}\n subroutine get_all_conditions(text,mode,ceq)\n! list all conditions if mode=0, experiments if mode=1, -1 if no numbers\n implicit none\n integer mode\n character text*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_condition), pointer :: last,current,first\n type(gtp_state_variable), pointer :: svrrec\n character phname*32\n integer ntot,nc,ip,iterm,iph,ics,jl\n double precision value,wone\n integer indx(4)\n ntot=0\n text=' '\n if(mode.eq.1) then\n! cannot enter experiments yet\n goto 1000\n endif\n if(noofel.eq.0) then\n! The CRLF indicates CR+LF at output\n text='CRLF No elements'\n goto 1000\n endif\n last=>ceq%lastcondition\n if(.not.associated(last)) then\n if(mode.eq.-1) then\n text=' '\n else\n! The CRLF indicates CR+LF at output\n write(text,50)noofel+2\n50 format('CRLF Degrees of freedom are ',i3)\n endif\n goto 1000\n endif\n current=>last%next\n first=>current\n nc=1\n ip=1\n100 continue\n! conditions can also be fixed phases !!!\n ntot=ntot+1\n if(current%active.ne.0) then\n! if active is nonzero the condition is not active\n goto 200\n endif\n if(mode.ne.-1) then\n! no condition numbers for mode=-1\n call wriint(text,ip,nc)\n! number the conditions\n text(ip:)=':'\n! ip=ip+2\n! No space after :\n ip=ip+1\n endif\n iterm=1\n if(current%statev.lt.0) then\n! handle FIX phases\n iph=-current%statev\n ics=current%iref\n call get_phase_name(iph,ics,phname)\n if(gx%bmperr.ne.0) then\n write(*,*)'3C list condition error for phase ',iph,ics\n gx%bmperr=4178; goto 1000\n endif\n text(ip:)='<'//phname\n ip=len_trim(text)+3\n text(ip-2:ip-1)='>='\n value=current%prescribed\n if(value.lt.1.0d-8) then\n value=zero\n endif\n call wrinum(text,ip,4,0,value)\n goto 190\n endif\n! return here for each term if several\n150 continue\n do jl=1,4\n indx(jl)=current%indices(jl,iterm)\n enddo\n! if(iterm.gt.1) write(*,152)'3C 150: ',iterm,indx,current%condcoeff(iterm)\n152 format(a,5i4,1pe12.4)\n if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then\n wone=current%condcoeff(iterm)+one\n if(abs(wone).lt.1.0D-10) then\n text(ip:ip)='-'\n ip=ip+1\n else\n! not +1 or -1, write number\n! write(*,*)'3C list cond: ',current%condcoeff(iterm),one,wone\n if(iterm.eq.1) then\n! do not write a + in front of first term\n call wrinum(text,ip,8,0,current%condcoeff(iterm))\n else\n call wrinum(text,ip,8,1,current%condcoeff(iterm))\n endif\n text(ip:ip)='*'\n ip=ip+1\n endif\n elseif(iterm.gt.1) then\n! must be a + or - in front of second and later terms\n text(ip:ip)='+'\n ip=ip+1\n endif\n! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! \n! write(*,*)'3C encode: ',current%statev,indx\n! call encode_state_variable2(text,ip,current%statev,indx,&\n! current%iunit,current%iref,ceq)\n! svrrec=>current%statvar(1)\n svrrec=>current%statvar(iterm)\n if(svrrec%argtyp.eq.3) then\n! write(*,153)svrrec%argtyp,svrrec%phase,svrrec%compset,svrrec%component\n153 format('3C gac 2: ',4i4)\n endif\n call encode_state_variable(text,ip,svrrec,ceq)\n if(iterm.lt.current%noofterms) then\n iterm=iterm+1; goto 150\n endif\n! problem with current position ... LNAC(CR) had the last ) overwritten ...\n! write(*,157)ip,text(1:ip)\n157 format('3C gc: ',i2,'\"',a,'\"')\n if(text(ip:ip).ne.' ') ip=ip+1\n text(ip:)='='\n ip=ip+1\n if(current%symlink1.gt.0) then\n! the value is a symbol\n! write(*,*)'3C value is a symbol: ',current%symlink1\n text(ip:)=svflista(current%symlink1)%name\n ip=len_trim(text)+1\n else\n call wrinum(text,ip,10,0,current%prescribed)\n endif\n190 continue\n if(ip.ge.len(text)) then\n write(*,*)'3C text: \"',text,'\" ',ip,len(text)\n endif\n text(ip:ip)=', '\n ip=ip+2\n nc=nc+1\n200 continue\n current=>current%next\n if(.not.associated(current,first)) goto 100\n! there can be non-active conditions only\n if(nc.gt.1) then\n! write without the last ,\n text(ip-2:)=' '\n! write(kou,99)text(1:ip-3)\n!99 format(a)\n endif\n if(mode.eq.0) then\n! the degrees of freedoms \n write(text(ip:),50)noofel+3-nc\n endif\n1000 return\n end subroutine get_all_conditions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable integer function degrees_of_freedom\n!\\begin{verbatim}\n integer function degrees_of_freedom(ceq)\n! returns the degrees of freedom\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_condition), pointer :: last,current,first\n integer ntot\n!\n ntot=-noofel-2\n last=>ceq%lastcondition\n if(.not.associated(last)) then\n goto 1000\n elseif(last%active.eq.0) then\n ntot=ntot+1\n endif\n current=>last%next\n100 do while(.not.associated(current,last))\n if(current%active.eq.0) ntot=ntot+1\n current=>current%next\n enddo\n1000 continue\n! write(*,*)'3C degrees of freedom: ',ntot,noofel\n degrees_of_freedom=ntot\n return\n end function degrees_of_freedom\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine list_defined_properties\n!\\begin{verbatim}\n subroutine list_defined_properties(lut)\n! lists all parameter identifiers allowed\n implicit none\n integer lut\n!\\end{verbatim}\n! character special*32,tdep*1,pdep*1\n character special*26,tdep*1,pdep*1\n integer typty,kk\n write(lut,10)\n10 format('Indx Ident T P Specification',15x,' Status Note')\n!10 format('Index Ident T P Specification',23x,' Status Note')\n!10 format('Index Symbol Specification',26x,' Status Note')\n do typty=1,ndefprop\n special=' '\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n special='&'\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n special='&'\n endif\n kk=len_trim(special)\n if(kk.gt.0) then\n special(kk+1:)=';'\n kk=kk+2\n else\n kk=1\n endif\n tdep='T'\n pdep='P'\n if(btest(propid(typty)%status,IDNOTP)) then\n! special(kk:)='Not T- and P-dependent'\n tdep='-'\n pdep='-'\n elseif(btest(propid(typty)%status,IDONLYP)) then\n! special(kk:)='Not T-dependant'\n tdep='-'\n elseif(btest(propid(typty)%status,IDONLYT)) then\n! special(kk:)='Not P-dependant'\n pdep='-'\n endif\n write(lut,50)typty,propid(typty)%symbol,tdep,pdep,special,&\n propid(typty)%status,trim(propid(typty)%note)\n50 format(i4,1x,a,2x,a,1x,a,1x,a,1x,z8,1x,a)\n enddo\n1000 continue\n return\n end subroutine list_defined_properties\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine find_defined_property\n!\\begin{verbatim}\n subroutine find_defined_property(symbol,mode,typty,iph,ics)\n! searches the propid list for one with symbol or identifiction typty\n! if mode=0 then symbol given, if mode=1 then typty given\n! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be \n! given in symbol as otherwise it is impossible to find the consititent!!!\n! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA)\n implicit none\n integer mode,typty,iph,ics\n character symbol*(*)\n!\\end{verbatim}\n character phsym*24,specid*24,nude*4\n integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj\n integer jtyp\n! write(*,7)'3C fdp 1: ',symbol(1:5),mode,typty,iph,ics\n7 format(a,a,5i5)\n if(mode.eq.0) then\n! parameter identifier given, can include & # and ( ) like MQ&FE#3(SIGMA)\n lattice=0\n nude=' '\n specid=' '\n k1=index(symbol,'&')\n if(k1.gt.0) then\n nude=symbol(1:k1-1)\n k2=index(symbol,'#')\n if(k2.eq.0) then\n k2=index(symbol,'(')\n if(k2.eq.0) then\n! write(*,*)'3C: Missing phase specifier in property symbol 1'\n! write(*,*)'Error in symbol: ',symbol\n gx%bmperr=4290; goto 1000\n endif\n else\n lattice=ichar(symbol(k2+1:k2+1))-ichar('0')\n if(lattice.le.0 .or. lattice.gt.9) then\n! write(*,*)'3C Sublattice outside range in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n endif\n specid=symbol(k1+1:k2-1)\n call capson(specid)\n endif\n! there must be a phase name within ( )\n k1=index(symbol,'(')\n if(k1.gt.0) then\n k2=index(symbol,')')\n if(k2.lt.k1) then\n! write(*,*)'3C Missing phase specifier in property symbol 2'\n! write(*,*)'Symbol: ',symbol\n gx%bmperr=4291; goto 1000\n endif\n phsym=symbol(k1+1:k2-1)\n call find_phase_by_name(phsym,iph,ics)\n if(gx%bmperr.ne.0) goto 1000\n lokph=phases(iph)\n if(nude(1:1).eq.' ') nude=symbol(1:k1-1)\n elseif(mode.ne.0) then\n write(*,*)'3C Missing phase specifier in property symbol 3'\n write(*,*)'Symbol: ',symbol,mode\n gx%bmperr=4291; goto 1000\n! else\n! mode=0 means just ignore\n! write(*,*)'3C mode: ',mode,iph,ics\n! goto 1000\n endif\n! now nude is the property id, lokph is phase location, specid is element or\n! constituent symbol, lattice is sublattice number\n! skip index 1 as G is a state variable\n call capson(nude)\n! write(*,*)'3C fdp 2: ',iph,ics,nude\n do ityp=2,ndefprop\n! write(*,*)'3C fdp 3: ',ityp,nude,propid(ityp)%symbol\n if(propid(ityp)%symbol.ne.nude) cycle\n if(btest(propid(ityp)%status,IDELSUFFIX)) then\n! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons)\n! write(*,*)'3C fdp 4: element: ',specid\n call find_element_by_name(specid,iel)\n if(gx%bmperr.ne.0) goto 1000\n typty=100*ityp+iel\n goto 200\n elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then\n! constituent specifier, for example: MQ&FE#3(SIGMA)\n! write(*,*)'3C fdp 5: constituent: ',specid\n kk=0\n do ll=1,phlista(lokph)%noofsubl\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n splink=phlista(lokph)%constitlist(kk)\n if(splink.le.0) then\n! write(*,*)'3C Illegal use of woildcard 3'\n gx%bmperr=4286; goto 1000\n endif\n if(specid.eq.splista(splink)%symbol .and. &\n (lattice.eq.0 .or. lattice.eq.ll)) then\n typty=100*ityp+kk\n goto 200\n endif\n enddo\n enddo\n else\n! property without specifier like TC(FCC)\n typty=ityp\n goto 200\n endif\n enddo\n! if we come here we have not found the constituent or element or property\n! it may be OK anyway if this is a call to test if symbol exists ??\n! write(*,*)'3C Illegal property symbol'\n gx%bmperr=4290; goto 1000\n! we must return property number, phase location, element\n! the value TYPTY stored in property records is \"idprop\" or\n! if IDELSUFFIX set then 100*\"idprop\"+ellista index of element\n! if IDCONSUFFIX set then 100*\"idprop\"+constituent index\n200 continue\n else\n! indices given, typty, iph and ics, construct the symbol\n! if typty>100 there is also an element or constituent specifier\n lokph=phases(iph)\n! write(*,*)'3C fdp 10: ',typty,iph,ics,lokph\n ityp=typty\n jtyp=-1\n if(ityp.gt.100) then\n ityp=typty/100\n jtyp=typty-100*ityp\n endif\n if(ityp.le.1 .or. ityp.gt.ndefprop) then\n! write(*,*)'3C Property number outside range ',ityp,typty\n gx%bmperr=4292; goto 1000\n endif\n symbol=propid(ityp)%symbol\n if(btest(propid(ityp)%status,IDELSUFFIX)) then\n! could one have /- as specifier??? NO !! But maye Va\n if(jtyp.lt.0) then\n! write(*,*)'3C Missing element index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n if(jtyp.lt.0 .or. jtyp.gt.noofel) then\n! write(*,*)'3C Too high element index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol\n elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then\n if(jtyp.lt.0) then\n! write(*,*)'3C Missing constituent index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n if(iph.le.0 .or. iph.gt.noofph) then\n! write(*,*)'3C Illegal phase location in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n kk=0\n do ll=1,phlista(lokph)%noofsubl\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n if(kk.eq.jtyp) then\n splink=phlista(lokph)%constitlist(kk)\n if(splink.le.0) then\n! write(*,*)'3C Illegal use of woildcard 4'\n gx%bmperr=4286; goto 1000\n endif\n specid=splista(splink)%symbol\n if(ll.gt.1) then\n specid=specid(1:len_trim(specid))//&\n '#'//char(ichar('0')+ll)\n endif\n goto 400\n endif\n enddo\n enddo\n! we come here is we failed to find the constituent\n write(*,*)'3C Illegal constituent index in property symbol'\n gx%bmperr=4290; goto 1000\n400 continue\n symbol=symbol(1:len_trim(symbol))//'&'//specid\n elseif(jtyp.gt.0) then\n write(*,*)'3C This property has no specifier'\n gx%bmperr=4290; goto 1000\n endif\n! add the phase\n! write(*,*)'3C fdp 11: ',lokph,ics\n symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n! write(*,*)'3C No such composition set'\n gx%bmperr=4072; goto 1000\n endif\n if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics)\n symbol=symbol(1:len_trim(symbol))//')'\n! write(*,*)'3C fdp 12: ',symbol(1:20)\n endif\n1000 continue\n return\n end subroutine find_defined_property\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine find_defined_property3\n!\\begin{verbatim}\n subroutine find_defined_property3(symbol,mode,typty,iph,ics)\n! Revised version of old routine called by get_many_svar\n! allows wildcards in some cases and should handle # and * better ...\n! searches the propid list for one with symbol or identifiction typty\n! if mode=0 then symbol given, if mode=1 then typty given\n! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be \n! given in symbol as otherwise it is impossible to find the consititent!!!\n! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA)\n implicit none\n integer mode,typty,iph,ics\n character symbol*(*)\n!\\end{verbatim}\n character phsym*24,specid*24,nude*4,mpi*32\n integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj\n integer jtyp\n! write(*,7)'3C fdp 1: ',symbol(1:5),mode,typty,iph,ics\n7 format(a,a,5i5)\n lokph=0\n if(mode.eq.0) then\n! parameter identifier given, can include & # and ( ) like MQ&FE#3(SIGMA)\n lattice=0\n nude=' '\n specid=' '\n! extract the part before (\n k1=index(symbol,'(')\n mpi=symbol(1:k1-1)\n k1=index(mpi,'&')\n if(k1.gt.0) then\n! there is a component included in the mpi, extract it\n nude=mpi(1:k1-1)\n k2=index(symbol,'#')\n if(k2.gt.0) then\n! there is a sublattice indication\n! k2=index(symbol,'(')\n! if(k2.eq.0) then\n! write(*,*)'3C: Missing phase specifier in property symbol 1'\n! write(*,*)'Error in symbol: ',symbol\n! gx%bmperr=4290; goto 1000\n! endif\n! else\n lattice=ichar(symbol(k2+1:k2+1))-ichar('0')\n if(lattice.le.0 .or. lattice.gt.9) then\n! write(*,*)'3C Sublattice outside range in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n endif\n specid=symbol(k1+1:k2-1)\n call capson(specid)\n endif\n k1=index(symbol,'(')\n if(k1.gt.0) then\n! there must be a phase name within ( ) unless mode=0\n k2=index(symbol,')')\n if(k2.lt.k1) then\n! write(*,*)'3C Missing phase specifier in property symbol 2'\n! write(*,*)'Symbol: ',symbol\n gx%bmperr=4291; goto 1000\n endif\n! we should allow phase name * and maybe #\n phsym=symbol(k1+1:k2-1)\n if(phsym(1:1).eq.'*') then\n iph=-1; ics=-1\n elseif(phsym(1:1).eq.'#') then\n iph=-100; ics=-100\n else\n call find_phase_by_name(phsym,iph,ics)\n if(gx%bmperr.ne.0) goto 1000\n lokph=phases(iph)\n endif\n if(nude(1:1).eq.' ') nude=symbol(1:k1-1)\n! elseif(mode.ne.0) then\n else\n! we are here because mode=0\n write(*,*)'3C Missing phase specifier in property symbol 3'\n write(*,*)'Symbol: ',symbol,mode\n gx%bmperr=4291; goto 1000\n! else\n! mode=0 means just ignore\n! write(*,*)'3C mode: ',mode,iph,ics\n! goto 1000\n endif\n! now nude is the property id, lokph is phase location, specid is element or\n! constituent symbol, lattice is sublattice number\n call capson(nude)\n! write(*,*)'3C fdp 2: ',iph,ics,nude\n do ityp=2,ndefprop\n! skip index 1 as G is a state variable\n! write(*,*)'3C fdp 3: ',ityp,nude,propid(ityp)%symbol\n if(propid(ityp)%symbol.ne.nude) cycle\n if(btest(propid(ityp)%status,IDELSUFFIX)) then\n! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons)\n! write(*,*)'3C fdp 4: element: ',specid\n call find_element_by_name(specid,iel)\n if(gx%bmperr.ne.0) goto 1000\n typty=100*ityp+iel\n goto 200\n elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then\n! constituent specifier, for example: MQ&FE#3(SIGMA)\n! in this case \n! write(*,*)'3C fdp 5: constituent: ',specid\n if(lokph.eq.0) then\n write(*,*)'3C phase specification needed for: ',trim(mpi)\n gx%bmperr=4399; goto 1000\n endif\n kk=0\n do ll=1,phlista(lokph)%noofsubl\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n splink=phlista(lokph)%constitlist(kk)\n if(splink.le.0) then\n! write(*,*)'3C Illegal use of woildcard 3'\n gx%bmperr=4286; goto 1000\n endif\n if(specid.eq.splista(splink)%symbol .and. &\n (lattice.eq.0 .or. lattice.eq.ll)) then\n typty=100*ityp+kk\n goto 200\n endif\n enddo\n enddo\n else\n! property without specifier like TC(FCC)\n typty=ityp\n goto 200\n endif\n enddo\n! if we come here we have not found the constituent or element or property\n! it may be OK anyway if this is a call to test if symbol exists ??\n! write(*,*)'3C Illegal property symbol'\n gx%bmperr=4290; goto 1000\n! we must return property number, phase location, element\n! the value TYPTY stored in property records is \"idprop\" or\n! if IDELSUFFIX set then 100*\"idprop\"+ellista index of element\n! if IDCONSUFFIX set then 100*\"idprop\"+constituent index\n200 continue\n else\n! indices given, typty, iph and ics, construct the symbol\n! if typty>100 there is also an element or constituent specifier\n lokph=phases(iph)\n! write(*,*)'3C fdp 10: ',typty,iph,ics,lokph\n ityp=typty\n jtyp=-1\n if(ityp.gt.100) then\n ityp=typty/100\n jtyp=typty-100*ityp\n endif\n if(ityp.le.1 .or. ityp.gt.ndefprop) then\n! write(*,*)'3C Property number outside range ',ityp,typty\n gx%bmperr=4292; goto 1000\n endif\n symbol=propid(ityp)%symbol\n if(btest(propid(ityp)%status,IDELSUFFIX)) then\n! could one have /- as specifier??? NO !! But maye Va\n if(jtyp.lt.0) then\n! write(*,*)'3C Missing element index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n if(jtyp.lt.0 .or. jtyp.gt.noofel) then\n! write(*,*)'3C Too high element index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol\n elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then\n if(jtyp.lt.0) then\n! write(*,*)'3C Missing constituent index in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n if(iph.le.0 .or. iph.gt.noofph) then\n! write(*,*)'3C Illegal phase location in property symbol'\n gx%bmperr=4290; goto 1000\n endif\n kk=0\n do ll=1,phlista(lokph)%noofsubl\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n if(kk.eq.jtyp) then\n splink=phlista(lokph)%constitlist(kk)\n if(splink.le.0) then\n! write(*,*)'3C Illegal use of woildcard 4'\n gx%bmperr=4286; goto 1000\n endif\n specid=splista(splink)%symbol\n if(ll.gt.1) then\n specid=specid(1:len_trim(specid))//&\n '#'//char(ichar('0')+ll)\n endif\n goto 400\n endif\n enddo\n enddo\n! we come here is we failed to find the constituent\n write(*,*)'3C Illegal constituent index in property symbol'\n gx%bmperr=4290; goto 1000\n400 continue\n symbol=symbol(1:len_trim(symbol))//'&'//specid\n elseif(jtyp.gt.0) then\n write(*,*)'3C This property has no specifier'\n gx%bmperr=4290; goto 1000\n endif\n! add the phase\n! write(*,*)'3C fdp 11: ',lokph,ics\n symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name\n if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then\n! write(*,*)'3C No such composition set'\n gx%bmperr=4072; goto 1000\n endif\n if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics)\n symbol=symbol(1:len_trim(symbol))//')'\n! write(*,*)'3C fdp 12: ',symbol(1:20)\n endif\n1000 continue\n return\n end subroutine find_defined_property3\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine line_with_phases_withdgm0\n!\\begin{verbatim}\n subroutine line_with_phases_withdgm0(line,ceq)\n! used in amend lines with stored STEP/MAP results\n! enter first 6, two .. and last 2 characters of phase names with abs(dgm)<1-8\n! line LIQUID#2, PHYRRO..#2 \n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n character line*(*)\n!\\end{verbatim}\n integer iph,ik,jk,tup\n character name*32\n ik=1\n! number of phases is equal to number of phase tuples?? no\n do iph=1,noofph\n! iph=phasetuple(phtupx(isort(jd)))%phaseix\n! ics=phasetuple(phtupx(isort(jd)))%compset\n! call get_phase_compset(iph,ics,lokph,lokcs)\n tup=iph\n100 continue\n if(abs(ceq%phase_varres(phasetuple(tup)%lokvares)%dgm).lt.1.0D-9) then\n call get_phasetup_name(tup,name)\n if(gx%bmperr.ne.0) goto 1000\n jk=len_trim(name)\n if(ik+10.gt.len(line)) then\n line(ik:)=' ...'\n elseif(jk.gt.8) then\n line(ik:)=name(1:6)//'..'\n line(ik+8:)=name(jk-1:jk)\n ik=ik+11\n else\n line(ik:)=name\n ik=len_trim(line)+2\n endif\n! else\n! continue\n endif\n! find higher composition sets of this phase\n tup=phasetuple(tup)%nextcs\n if(tup.gt.0) goto 100\n enddo\n! write(*,*)'3C phaseline: ',line\n1000 continue\n return\n end subroutine line_with_phases_withdgm0\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine list_equilibria_details\n!\\begin{verbatim}\n subroutine list_equilibria_details(mode,teq)\n! not used yet ... ??\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: teq\n integer mode\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq\n! TYPE(gtp_phase_varres) :: varres\n integer ieq,noofeq,iph\n noofeq=noeq()\n select case(mode)\n case default\n write(*,*)'3C No such mode: ',mode\n!--------------------------------------------------\n case(1) ! list equilibria and some general data\n write(*,10)noofeq\n10 format('3C Number of equilibria: ',i3)\n do ieq=1,noofeq\n ceq=>eqlista(ieq)\n write(*,11)ceq%eqno,ceq%eqname\n11 format('3C Equilibrium ',i3,', ',a)\n enddo\n!--------------------------------------------------\n case(100:199) ! list phase varres data for phase mod(mode,100)\n iph=mod(mode,100)\n if(iph.eq.0) then\n write(*,*)'3C all phases'\n else\n write(*,*)'3C phase ',iph\n endif\n end select\n1000 continue\n return\n end subroutine list_equilibria_details\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function gtp_error_message\n!\\begin{verbatim}\n logical function gtp_error_message(reset)\n! tests the error code and writes the error message (if any) \n! and reset error code if reset=0\n! if reset >0 that is set as new error message\n! if reset <0 the error code is not changed\n! return TRUE if error code set, FALSE if error code is zero\n implicit none\n integer reset\n!\\end{verbatim}\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,10)gx%bmperr,bmperrmess(gx%bmperr)\n10 format(' *** Error ',i5/a)\n elseif(gx%bmperr.ne.0) then\n write(*,20)gx%bmperr\n20 format('3C Error without message: ',i7)\n endif\n if(reset.eq.0) then\n! if reset zero reset error code\n gx%bmperr=0\n elseif(gx%bmperr.gt.0) then\n! if reset positive set this as error code\n gx%bmperr=reset\n endif\n! if reset negative do not change error code. Set function to TRUE\n gtp_error_message=.TRUE.\n else\n! no error, return false\n gtp_error_message=.FALSE.\n endif\n1000 continue\n return\n end function gtp_error_message\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine listoptcoeff\n!\\begin{verbatim}\n subroutine listoptcoeff(mexp,error2,done,lut)\n! listing of optimizing coefficients\n integer lut,mexp\n! error2 is an array with 1: old error, 2: new error; 3: normalized error\n double precision error2(*)\n logical done\n! integer lut,mexp\n! double precision errs(*)\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: neweq\n integer i1,i2,j1,j2,j3,k1,nvcoeff\n character name1*24,where*80\n double precision xxx\n logical rescale\n!\n rescale=.false.\n write(lut,610)\n610 format(/'List of coefficients with non-zero values'/&\n 'Name Current value Start value Scaling factor RSD',10x,&\n 'Used in')\n name1=' '\n nvcoeff=0\n do i1=0,size(firstash%coeffstate)-1\n! write(*,*)'3C coeffstate: ',i1,firstash%coeffstate(i1)\n coeffstate: if(firstash%coeffstate(i1).ge.10) then\n! optimized variable, read from TP constant array\n call get_value_of_constant_index(firstash%coeffindex(i1),xxx)\n call makeoptvname(name1,i1)\n call findtpused(firstash%coeffindex(i1),where)\n! write(lut,615)name1(1:3),xxx,&\n write(lut,615)name1(1:3),xxx,&\n! firstash%coeffvalues(i1)*firstash%coeffscale(i1),&\n firstash%coeffstart(i1),firstash%coeffscale(i1),&\n firstash%coeffrsd(i1),trim(where)\n615 format(a,2x,4(1pe14.5),2x,a)\n if(abs(xxx-firstash%coeffscale(i1)).gt.1.0D-4*abs(xxx)) then\n! write(*,*)'3C why?:'\n rescale=.true.\n endif\n! if(abs(xxx-firstash%coeffvalues(i1)*firstash%coeffscale(i1))&\n! .gt.1e-4) then\n! write(*,*)'3C scaled and current: ',xxx,&\n! firstash%coeffvalues(i1)*firstash%coeffscale(i1)\n! endif\n if(firstash%coeffstate(i1).eq.11) then\n! there is a prescribed minimum\n write(lut,616)' minimum ',firstash%coeffmin(i1)\n616 format(6x,'Prescribed ',a,': ',1pe12.4)\n nvcoeff=nvcoeff+1\n elseif(firstash%coeffstate(i1).eq.12) then\n! there is a prescribed maximum\n write(lut,616)' maximum ',firstash%coeffmax(i1)\n nvcoeff=nvcoeff+1\n elseif(firstash%coeffstate(i1).eq.13) then\n! there are prescribed minimum and maximum\n write(lut,617)firstash%coeffmin(i1),firstash%coeffmax(i1)\n617 format(6x,'Prescribed min and max: ',2(1pe12.4))\n nvcoeff=nvcoeff+1\n elseif(firstash%coeffstate(i1).gt.13) then\n write(lut,*)'Wrong coefficient state, set to 10'\n!?? \n! firstash%coeffstate(i2)=10\n firstash%coeffstate(i1)=10\n endif\n nvcoeff=nvcoeff+1\n elseif(firstash%coeffstate(i1).gt.0) then\n! coefficient is fix with non-zero value\n call get_value_of_constant_index(firstash%coeffindex(i1),xxx)\n call makeoptvname(name1,i1)\n call findtpused(firstash%coeffindex(i1),where)\n write(lut,618)name1(1:3),xxx,trim(where)\n618 format(a,2x,1pe14.5,44x,a)\n! elseif(firstash%coeffscale(i1).ne.0) then\n! No idea why this code exits why check coeffscale ??\n! coefficient with negative status, status set to 1 ?why?\n! call get_value_of_constant_index(firstash%coeffindex(i1),xxx)\n! write(lut,619)i1,firstash%coeffscale(i1),xxx,zero\n!619 format('Wrong state for coefficient ',i3,4(1pe12.4))\n! firstash%coeffstate(i1)=1\n endif coeffstate\n enddo\n! give a warning if parameters need to be rescaled\n if(rescale) then\n write(lut,717)\n717 format(/'In order to have correct RSD values use the command',&\n ' AMEND OPT_COEF Y'/'and optimize again.'/)\n endif\n! sum=zero\n! do j1=1,mexp\n! sum=sum+errs(j1)**2\n! enddo\n! IGNORE DONE and repeat results ...\n! if(done) then\n! only if there are results\n j1=mexp-nvcoeff\n! if(j1.gt.0) then\n write(lut,621)error2(2),mexp,nvcoeff,j1,error2(3)\n! else\n! write(lut,621)error2(2),mexp,nvcoeff,0,zero\n! endif\n621 format(/'Final sum of squared errors: ',1pe16.5/&\n 'using ',i4,' experiments and ',i3,' coefficients.'/&\n 'Degrees of freedom: ',i4,', normalized error: ',1pe13.4/)\n! endif\n1000 continue\n return\n end subroutine listoptcoeff\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n \n" }, { "path": "src/models/gtp3D.F90", "content": "!\n! gtp3D included in gtp3.F90\n!\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 8. Interactive things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ask_phase_constitution\n!\\begin{verbatim}\n subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq)\n! interactive input of a constitution of phase iph\n implicit none\n integer last,iph,ics,lokcs\n character cline*(*)\n!\\end{verbatim} %+\n! NOTE a strange bug when calculating a phase \n! the result is different if one sets the constitution explicitly the same!!\n character name1*24,quest*32\n double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef\n integer knl(maxsubl),knr(maxcons2)\n character line*64,ch1*1,crest*24\n character :: lastph*24=' '\n! changed default to N\n! character*1 :: chd='Y'\n character*1 :: chd='N'\n integer qph,lokph,nsl,kkk,loksp,ip,ll,nr,yrest\n TYPE(gtp_equilibrium_data), pointer :: ceq\n logical once\n! save here to use the same default as last time\n save chd,lastph\n call gparcdx('Phase name: ',cline,last,1,name1,lastph,'?Amend phase constit')\n if(name1(1:2).eq.'* ') then\n! this means all phases and composition sets\n! If iph is -1 than this is not allowed!!\n if(iph.lt.0) then\n write(kou,*)'Wildcard not allowed in this case'\n goto 1000\n endif\n qph=-1\n iph=1\n ics=1\n call get_phase_name(iph,ics,name1)\n if(gx%bmperr.ne.0) goto 1000\n else\n qph=0\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 1000\n! remember the phase name\n lastph=name1\n endif\n100 continue\n! write(*,*)'3D spc 1',qph,iph,ics,name1\n! skip hidden and suspended phases, test_phase_status return\n! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed\n if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200\n! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.&\n! phase_status(iph,ics,PHIMHID,ceq) .or.&\n! (phase_status(iph,ics,CSSUS,ceq) .and. &\n! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200\n! lokph=phases(iph)\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!--------------------\n! strange error 2026.02.10\n! write(*,55)(yarr(ll),ll=1,knr(1))\n!55 format(' bug: ',15(f8.5))\n!--------------------\n! ask for amount of formula units, default is current amount\n yyy=ceq%phase_varres(lokcs)%amfu\n quest='Amount of '//name1\n call gparrdx(quest,cline,last,xxx,yyy,'?Amend phase constit')\n! if input error quit asking more\n if(buperr.ne.0) then\n buperr=0; goto 1000\n endif\n ceq%phase_varres(lokcs)%amfu=xxx\n! ask if we should set the current constitution, ignore default\n! write(*,*)'3D we are here!'\n call gparcdx('Current (Y), default (D) or new (N) constitution?',&\n cline,last,1,ch1,chd,'?Amend phase constit')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n chd='Y'\n! set the old constitution explicitly!!\n! without this seemingly unnecessary call to set the same constution the\n! calculate phase gives sometimes wrong values!\n call set_constitution(iph,ics,yarr,qq,ceq)\n goto 200\n elseif(ch1.eq.'d' .or. ch1.eq.'D') then\n chd='D'\n call set_default_constitution(iph,ics,ceq)\n goto 200\n else\n! constitution entered interactivly\n chd='N'\n endif\n! ask for constitution\n write(kou,'(a,a)')'NOTE: For a constituent which should be the rest,',&\n ' give \"rest\"'\n kkk=0\n nylat: do ll=1,nsl\n yrest=0\n! ydef=one\n sss=one\n if(knl(ll).eq.1) then\n kkk=kkk+1; cycle nylat\n else\n! default new constitution is 1/(constituents in sublattice)\n ydef=one/real(knl(ll))\n endif\n nycon: do nr=1,knl(ll)\n if(nr.eq.knl(ll) .and. yrest.eq.0) then\n cycle nycon\n endif\n kkk=kkk+1\n loksp=phlista(lokph)%constitlist(kkk)\n line='Fraction of '//splista(loksp)%symbol\n ip=len_trim(line)+1\n if(ll.gt.1) then\n line(ip:)='#'//char(ll+ichar('0'))\n ip=ip+2\n endif\n once=.true.\n20 continue\n ydef=min(yarr(kkk),ydef)\n call gparrdx(line(1:ip+2),cline,last,xxx,ydef,'?Amend phase constit')\n if(buperr.ne.0) then\n! write(*,*)'3D Allow REST: ',trim(cline),last,buperr,yrest\n buperr=0\n if(yrest.eq.0) then\n crest=cline(last:last+3)\n call capson(crest)\n if(crest(1:4).eq.'REST') then\n yrest=nr\n last=len(cline)\n crest=splista(loksp)%symbol\n cycle nycon\n endif\n endif\n endif\n if(xxx.lt.zero) then\n if(once) then\n write(*,*)'A fraction must be greater than zero'\n yarr(kkk)=1.0D-12\n once=.false.\n goto 20\n else\n gx%bmperr=4146; goto 1000\n endif\n endif\n sss=sss-xxx\n if(sss.lt.zero) then\n xxx=max(sss+xxx,1.0D-12)\n sss=-1.0D12\n write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx\n21 format(a,1pe12.4)\n ydef=1.0D-12\n else\n! ydef=sss\n! reduce by dividing with the remaining constituents\n ydef=sss/real(knl(ll)-nr)\n endif\n! write(*,*)'ydef: ',ydef,sss\n yarr(kkk)=xxx\n enddo nycon\n! if yrest is zero the last constituent is set to the rest, otherwise yrest\n if(yrest.eq.0) then\n kkk=kkk+1\n yarr(kkk)=max(sss,1.0D-12)\n write(*,21)'Last fraction set to: ',yarr(kkk)\n else\n yarr(yrest)=max(sss,1.0D-12)\n write(*,21)'Fraction of '//trim(crest)//' set to: ',yarr(yrest)\n endif\n enddo nylat\n! set the new constitution\n call set_constitution(iph,ics,yarr,qq,ceq)\n! if all phases loop\n200 continue\n if(qph.lt.0) then\n if(gx%bmperr.eq.4050) then\n! error no such phase, quit\n gx%bmperr=0; goto 1000\n elseif(gx%bmperr.eq.4072) then\n! error no such composition set, take next phase\n gx%bmperr=0\n iph=iph+1\n ics=1\n else\n ics=ics+1\n endif\n call get_phase_name(iph,ics,name1)\n if(gx%bmperr.ne.0) goto 200\n goto 100\n endif\n1000 continue\n! return -1 as phase number of loop for all phases made\n if(qph.lt.0) iph=-1\n return\n end subroutine ask_phase_constitution\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ask_phase_new_constitution\n!\\begin{verbatim} %-\n subroutine ask_phase_new_constitution(cline,last,iph,ics,lokcs,ceq)\n! interactive input of a constitution of phase iph\n implicit none\n integer last,iph,ics,lokcs\n character cline*(*)\n!\\end{verbatim}\n character name1*24,quest*32\n double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef\n integer knl(maxsubl),knr(maxcons2)\n character line*64,ch1*1\n character*1 :: chd='Y'\n integer qph,lokph,nsl,kkk,loksp,ip,ll,nr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n logical once\n! save here to use the same default as last time\n save chd\n qph=0\n! call gparc('Phase name: ',cline,last,1,name1,' ',q1help)\n! if(name1(1:2).eq.'* ') then\n! this means all phases and composition sets\n! qph=-1\n! iph=1\n! ics=1\n! call get_phase_name(iph,ics,name1)\n! if(gx%bmperr.ne.0) goto 1000\n! else\n! qph=0\n! call find_phase_by_name(name1,iph,ics)\n! if(gx%bmperr.ne.0) goto 1000\n! endif\n100 continue\n! write(*,*)'3D spc 1',qph,iph,ics,name1\n! skip hidden and suspended phases, test_phase_status return\n! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed\n! if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200\n! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.&\n! phase_status(iph,ics,PHIMHID,ceq) .or.&\n! (phase_status(iph,ics,CSSUS,ceq) .and. &\n! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200\n! lokph=phases(iph)\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! ask for amount of formula units, default is current amount\n! yyy=ceq%phase_varres(lokcs)%amfu\n! quest='Amount of '//name1\n! NOTE name is not set!\n! call gparrd(quest,cline,last,xxx,yyy,q1help)\n! if input error quit asking more\n! if(buperr.ne.0) then\n! buperr=0; goto 1000\n! endif\n! ceq%phase_varres(lokcs)%amfu=abs(xxx)\n! ask if we should set the default constitution\n! write(*,*)'3D we are really here?'\n call gparcdx('Default constitution?',cline,last,1,ch1,chd,&\n '?Amend phase constit')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call set_default_constitution(iph,ics,ceq)\n if(gx%bmperr.ne.0) goto 1000\n chd='Y'\n goto 200\n else\n chd='N'\n endif\n! ask for constitution\n kkk=0\n nylat: do ll=1,nsl\n sss=one\n ydef=one\n nycon: do nr=1,knl(ll)-1\n kkk=kkk+1\n loksp=phlista(lokph)%constitlist(kkk)\n line='Fraction of '//splista(loksp)%symbol\n ip=len_trim(line)+1\n if(ll.gt.1) then\n line(ip:)='#'//char(ll+ichar('0'))\n ip=ip+2\n endif\n once=.true.\n20 continue\n ydef=min(yarr(kkk),ydef)\n call gparrdx(line(1:ip+2),cline,last,xxx,ydef,'?Amend phase constit')\n if(xxx.lt.zero) then\n if(once) then\n write(*,*)'A fraction must be greater than zero'\n yarr(kkk)=1.0D-12\n once=.false.\n goto 20\n else\n gx%bmperr=4146; goto 1000\n endif\n endif\n sss=sss-xxx\n if(sss.lt.zero) then\n xxx=max(sss+xxx,1.0D-12)\n sss=-1.0D12\n write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx\n21 format(a,1pe12.4)\n ydef=1.0D-12\n else\n ydef=sss\n endif\n! write(*,*)'ydef: ',ydef,sss\n yarr(kkk)=xxx\n enddo nycon\n! the last constituent is set to the rest\n kkk=kkk+1\n yarr(kkk)=max(sss,1.0D-12)\n write(*,21)'Last fraction set to: ',yarr(kkk)\n enddo nylat\n! set the new constitution\n call set_constitution(iph,ics,yarr,qq,ceq)\n! if all phases loop\n200 continue\n! if(qph.lt.0) then\n! if(gx%bmperr.eq.4050) then\n! error no such phase, quit\n! gx%bmperr=0; goto 1000\n! elseif(gx%bmperr.eq.4072) then\n! error no such composition set, take next phase\n! gx%bmperr=0\n! iph=iph+1\n! ics=1\n! else\n! ics=ics+1\n! endif\n! call get_phase_name(iph,ics,name1)\n! if(gx%bmperr.ne.0) goto 200\n! goto 100\n! endif\n1000 continue\n! return -1 as phase number of loop for all phases made\n if(qph.lt.0) iph=-1\n return\n end subroutine ask_phase_new_constitution\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_parameter_interactivly\n!\\begin{verbatim}\n subroutine enter_parameter_interactivly(cline,ip,mode)\n! enter a parameter from terminal or macro\n! NOTE both for ordered and disordered fraction set !!\n! mode = 0 for entering\n! 1 for listing on screen (kou)\n implicit none\n integer ip,mode\n character cline*(*)\n!\\end{verbatim}\n character name1*24,name2*24,longline*256,refx*16,elnam*24\n! funame only 16 first characters will be used\n character name3*64,ch1*1,line*64,parname*64,funame*24\n integer typty,lint(2,5),fractyp,typty1,kp,lp1,kel,kq,iel,isp,lk3,lp2\n integer jph,ics,lokph,ll,k4,nint,jp,lsc,ideg,kk,lfun,nsl,loksp\n integer, dimension(maxsubl) :: endm(maxsubl)\n double precision xxx\n!\n lk3=0\n10 continue\n if(mode.eq.1) then\n call gparcx('Parameter name: ',cline,ip,7,parname,' ','?Amend parameter')\n else\n call gparcx('Parameter name: ',cline,ip,7,parname,' ','?Enter parameter')\n endif\n! simple parameter names are like G(SIGMA,FE:CR:FE,CR;1)\n! no spaces allowed ....\n kp=index(parname,' ')\n jp=index(parname,')')\n! check if there is ext after space\n if(jp.eq.0) then\n write(*,*)'A parameter name must be terminated by ), please reenter'\n gx%bmperr=4028; goto 1000\n elseif(kp.lt.jp) then\n write(*,*)'No spaces allowed in a parameter name, please reenter'\n gx%bmperr=4028; goto 1000\n endif\n! this has been here since the beginning, keep it\n parname(kp:)=' '\n!\n! extract symbol, normally G or L but TC and others can occur \n! for example a mobility like MQ&FE+2#3 where FE+2#3 is a constinuent\n! in sublattice 3\n! NO ABBREVIATION IS ACCEPTED, for example not BM for BMAGN\n lp1=index(parname,'(')\n! write(*,*)'3D in parname: ',trim(parname),lp1\n if(lp1.le.1) then\n gx%bmperr=4027; goto 1000\n endif\n! name1 is everything up to (\n name1=parname(1:lp1-1)\n call capson(name1)\n! It can be a mobility with a & inside\n kel=index(name1,'&')\n if(kel.gt.0) then\n! note that elnam may contain sublattice specification like Fe+2#2\n elnam=name1(kel+1:)\n name1=name1(1:kel-1)\n! write(*,*)'3D elnam: ',elnam\n endif\n kq=len_trim(name1)\n! write(*,*)'3D: fractyp: ',kq,name1(1:kq)\n! if(name1(kq:kq).eq.'D') then\n! A final \"D\" on the paramer symbol indicates fractyp=2\n! THIS FEATURE NO LONGER SUPPORTED\n! name1(kq:kq)=' '\n! fractyp=2\n! else\n! fractyp=1\n! endif\n! the fractyp must be checked inside enter_parameter\n fractyp=1\n! find the property associated with this symbol\n do typty=1,ndefprop\n! write(*,*)'Property symbol: \"',propid(typty)%symbol,'\"'\n if(name1(1:4).eq.propid(typty)%symbol) then\n goto 70\n endif\n enddo\n! no matching symbol\n write(kou,*)'3D unknown parameter type, please reenter: ',&\n name1(1:len_trim(name1))\n parname=' '; goto 10\n! typty is the parameter symbol index\n70 continue\n typty1=typty\n iel=0; isp=0\n! the beginning of the TP function name\n! funame='_'//propid(typty1)%symbol(1:1)\n funame='_'//propid(typty1)%symbol\n if(kel.gt.0) then\n! there is a specifier, check if correct element or species\n kel=index(elnam,'#')\n if(kel.gt.0) then\n! extract sublattice number 1-9 specification\n lk3=ichar(elnam(kel+1:kel+1))-ichar('0')\n! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3\n!73 format('3D sublattice: \"',a,'\" position: ',i3,' in ',a,' : ',i3)\n elnam(kel:)=' '\n endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam\n call find_element_by_name(elnam,iel)\n if(gx%bmperr.ne.0) then\n write(kou,*)'3D Unknown element ',elnam,&\n ' in parameter type MQ, please reenter'\n goto 1000\n! parname=' '; gx%bmperr=0; goto 10\n endif\n typty=100*typty+iel\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! to know the constituents we must know the phase but as we do not know \n! the phase name yet but check the species exists !!!\n! write(*,*)'3D: conname: ',kel,lk3,typty,elnam\n call find_species_by_name(elnam,isp)\n if(gx%bmperr.ne.0) then\n! This is not an error, the species may simply not be selected !!!\n write(kou,*)'Unknown species ',trim(elnam),&\n ' in parameter type MQ, please reenter',gx%bmperr\n goto 1000\n! parname=' '; gx%bmperr=0; goto 10\n endif\n! convert from index to location, loksp\n loksp=species(isp)\n if(lk3.eq.0) then\n! sublattice after # saved in lk3 above, if none (0) assume 1\n lk3=1\n endif\n else\n write(kou,*)'3D This model parameter identifier has no specifier'\n gx%bmperr=4168; goto 1000\n endif\n! this is the property type stored in property record\n else\n! check if there should be a specifier !!\n if(btest(propid(typty)%status,IDELSUFFIX) .or. &\n btest(propid(typty)%status,IDCONSUFFIX)) then\n write(*,*)'3D Parameter specifier missing'\n gx%bmperr=4169; goto 1000\n endif\n endif\n! 4027?\n! extract phase name and constituent array\n lp1=index(parname,'(')\n lp2=index(parname,',')\n if(lp2.lt.lp1) then\n gx%bmperr=4028; goto 1000\n endif\n name2=parname(lp1+1:lp2-1)\n! write(*,*)'enter_parameter_inter 1: ',lp1,lp2,name2\n call find_phase_by_name_exact(name2,jph,ics)\n if(gx%bmperr.ne.0) then\n! special case for reference phase\n gx%bmperr=0;\n call capson(name2)\n if(name2.eq.'SELECT_ELEMENT_REFERENCE') then\n jph=0; ics=1\n else\n write(kou,*)'Unknown phase name, please reenter'\n kp=len(cline)\n goto 10\n endif\n endif\n lokph=phases(jph)\n! add the full phase name to the function name. Remove any _ or numbers ,,,\n! ll=len_trim(funame)+1\n! funame(3:)=phlista(lokph)%name\n! only save first letter of parameter type, no problem with duplicate names\n ll=3\n funame(ll:)=phlista(lokph)%name\n! write(*,*)'3D funame 1: ',trim(funame),', ',name2\n ll=4\n74 continue\n if(funame(ll:ll).eq.'_') then\n funame(ll:)=funame(ll+1:)\n goto 74\n elseif(ll.lt.9) then\n ll=ll+1\n goto 74\n endif\n! eliminate anything from position 9 MODIFIED when adding MQMQA\n! eliminate anything from position 7\n funame(7:)=' '\n! write(*,*)'3D funame 2: ',trim(funame)\n! if the parameter symbol has a constituent specification check that now\n! write(*,*)'3D lk3 and isp: ',lk3,isp\n if(lk3.gt.0 .and. isp.gt.0) then\n! No check for elements ...\n k4=0\n do ll=1,phlista(lokph)%noofsubl\n! careful ll is double letter l, not 11 (eleven)\n if(lk3.eq.0 .or. lk3.eq.ll) then\n do kk=1,phlista(lokph)%nooffr(ll)\n k4=k4+1\n if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80\n enddo\n elseif(ll.lt.lk3) then\n k4=k4+phlista(lokph)%nooffr(ll)\n endif\n enddo\n! constituent not found\n write(kou,*)'3D Parameter symbol contains unknown constituent'\n gx%bmperr=4066; goto 1000\n! constituent found in right sublattice\n80 continue\n typty=100*typty+k4\n! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp\n81 format(a,10i4)\n endif\n! write(*,*)'enter_parameter_inter 2: ',jph,lokph\n! extract constituent array, remove final ) and decode\n name3=parname(lp2+1:)\n lp1=len_trim(name3)\n! this removes the final )\n name3(lp1:)=' '\n!\n! write(*,*)'3D decoding constituent array'\n call decode_constarr(lokph,name3,nsl,endm,nint,lint,ideg)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,83)'3D after d_c: ',name3(1:lp1),nint,(lint(2,kp),kp=1,nint)\n83 format(a,a,i5,2x,5i4)\n kp=len_trim(funame)\n funame(kp+1:)=name3\n call capson(funame)\n! finally remove all non-alphabetical characters in the function name by _\n kp=3\n100 continue\n kp=kp+1\n105 continue\n! ch1=parname(kp:kp)\n ch1=funame(kp:kp)\n! should use ??\n! if(ucletter(ch1)) goto 100\n if(ch1.ge.'A' .and. ch1.le.'Z') goto 100\n if(ch1.ne.' ') then\n! parname(kp:)=parname(kp+1:)\n funame(kp:)=funame(kp+1:)\n if(kp.lt.16) goto 105\n endif\n funame(17:)=' '\n kp=len_trim(funame)\n if(kp.lt.16) funame(kp+1:kp+1)=char(ideg+ichar('0'))\n! write(*,*)'3D funame 3: ',trim(funame),', ',trim(name3)\n! parname='_'//parname\n!-------------------------------------------------\n! if mode=0 enter the parameter, \n! if mode=1 just list the parameter\n! if mode=2 maybe amending (does FOOLED) work?\n if(mode.eq.1) then\n lfun=-1\n! write(*,*)'3D calling enter_parameter with lfun=',lfun\n call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,&\n lfun,refx)\n! this error means illegal reference ... \n! irrelevant but I am not sure where it is set ...\n if(gx%bmperr.eq.4154) gx%bmperr=0\n goto 1000\n endif\n! continue here to enter the parameter\n! If parameter has no T dependendence just ask for value\n if(btest(propid(typty1)%status,IDNOTP)) then\n write(kou,*)'This parameter can only be a constant'\n call gparrx('Value: ',cline,ip,xxx,zero,'?Enter parameter')\n if(buperr.ne.0) then\n xxx=zero; buperr=0\n endif\n! the tpfun always want a low-T, expression; high-T N\n write(longline,110)xxx\n110 format(' 1 ',1pe16.7,'; 20000 N ')\n jp=len_trim(longline)+2\n goto 200\n endif\n if(btest(propid(typty1)%status,IDONLYP)) then\n write(kou,*)'This parameter may not depend on T, only on P'\n endif\n!-------------------------------------------------\n! now read the function.\n call gparrx('Low temperature limit /298.15/:',cline,ip,xxx,2.9815D2,&\n '?Enter parameter')\n if(buperr.ne.0) then\n buperr=0; longline=' 298.15 '\n jp=8\n else\n longline=' '\n jp=1\n call wrinum(longline,jp,8,0,xxx)\n if(buperr.ne.0) goto 1000\n jp=jp+1\n endif\n! write(*,152)-1,jp,longline(1:jp)\n!-----------------------------------------------\n! return here for new expression in another range\n lsc=1\n115 continue\n call gparcx('Expression, end with \";\":',cline,ip,6,line,';',&\n '?Enter parameter')\n if(buperr.ne.0) then\n buperr=0; line=';'\n endif\n120 continue\n longline(jp:)=line\n jp=len_trim(longline)+1\n! write(*,152)0,jp,longline(1:jp)\n if(index(longline(lsc:),';').le.0) then\n call gparcx('&',cline,ip,6,line,';','?Enter parameter')\n if(buperr.ne.0) then\n buperr=0; line=';'\n endif\n goto 120\n! else\n! write(*,*)'Found ; at ',index(longline,';')\n endif\n150 continue\n jp=jp+1\n! write(*,152)0,jp,longline(1:jp)\n! lsc is positioned after the ; of previous ranges\n lsc=jp\n! write(*,152)1,ip,cline(1:ip)\n call gparrx('Upper temperature limit /6000/:',cline,ip,xxx,6.0D3,&\n '?Enter parameter')\n if(buperr.ne.0) then\n buperr=0; xxx=6.0D3\n endif\n call wrinum(longline,jp,8,0,xxx)\n if(buperr.ne.0) goto 1000\n call gparcdx('Any more ranges',cline,ip,1,ch1,'N','?Enter parameter')\n if(ch1.eq.'n' .or. ch1.eq.'N') then\n longline(jp:)=' N'\n jp=jp+3\n else\n longline(jp:)='Y'\n jp=jp+2\n goto 115\n endif\n! jump here for parameters that are constants\n200 continue\n call gparcdx('Reference symbol:',cline,ip,1,refx,'UNKNOWN',&\n '?Enter parameter')\n call capson(refx)\n longline(jp:)=refx\n jp=len_trim(longline)+1\n! write(*,252)2,jp,longline(1:jp)\n252 format('3D ep: ',2i3,'>',a,'<')\n!\n call capson(longline(1:jp))\n! write(*,*)'3D epi: ',longline(1:jp)\n! call enter_tpfun(parname,longline,lfun,.FALSE.)\n! write(*,*)'3D funame: ',trim(funame)\n! call store_tpfun(funame,longline,lfun,.FALSE.)\n! last argumnent -1 means not reading from TDB file\n call store_tpfun(funame,longline,lfun,-1)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,290)'3D enter_par 7: ',lokph,nsl,nint,ideg,lfun,refx\n290 format(a,5i4,1x,a)\n!\n call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,lfun,refx)\n!\n1000 continue\n return\n end subroutine enter_parameter_interactivly\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine amend_global_data\n!\\begin{verbatim}\n subroutine amend_global_data(cline,ipos)\n implicit none\n character cline*(*)\n integer ipos\n!\\end{verbatim}\n character name*24,current*24,ch1*1,chd*1\n current=globaldata%name\n! write(*,*)'entering amend_global_data: ',cline(1:30)\n call gparcdx('System name: ',cline,ipos,1,name,current,'?Amend general')\n if(proper_symbol_name(name,0)) then\n globaldata%name=name\n else\n write(kou,*)'Illegal name ignored'\n goto 1000\n endif\n100 continue\n chd='N'\n if(btest(globaldata%status,GSBEG)) then\n chd='B'\n elseif(btest(globaldata%status,GSADV)) then\n chd='E'\n else\n chd='F'\n endif\n call gparcdx('I am a beginner (B), frequent user (F) or expert (E): ',&\n cline,ipos,1,ch1,chd,'?Amend general')\n call capson(ch1)\n globaldata%status=ibclr(globaldata%status,GSBEG)\n globaldata%status=ibclr(globaldata%status,GSADV)\n globaldata%status=ibclr(globaldata%status,GSOCC)\n if(ch1.eq.'B') then\n globaldata%status=ibset(globaldata%status,GSBEG)\n elseif(ch1.eq.'E') then\n globaldata%status=ibset(globaldata%status,GSADV)\n else\n! set as frequent (occational?) user\n globaldata%status=ibset(globaldata%status,GSOCC)\n endif\n120 continue\n! is global minimization allowed?\n chd='Y'\n if(btest(globaldata%status,GSNOGLOB)) chd='N'\n call gparcdx('Global gridminimization allowed: ',&\n cline,ipos,1,ch1,chd,'?Amend general')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n globaldata%status=ibclr(globaldata%status,GSNOGLOB)\n else\n globaldata%status=ibset(globaldata%status,GSNOGLOB)\n endif\n! allow merging gridpoints after global?\n chd='Y'\n if(btest(globaldata%status,GSNOMERGE)) chd='N'\n call gparcdx('Merging gridpoints in same phase allowed: ',&\n cline,ipos,1,ch1,chd,'?Amend general')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n globaldata%status=ibclr(globaldata%status,GSNOMERGE)\n else\n globaldata%status=ibset(globaldata%status,GSNOMERGE)\n endif\n! GSNOACS can be changed interactivly, 0 means allowed\n chd='Y'\n if(btest(globaldata%status,GSNOACS)) chd='N'\n call gparcdx('Composition sets can be created automatically? ',&\n cline,ipos,1,ch1,chd,'?Amend general')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n globaldata%status=ibclr(globaldata%status,GSNOACS)\n else\n globaldata%status=ibset(globaldata%status,GSNOACS)\n endif\n! GSNOREMCS can be changed interactivly, 0 means not remove\n chd='Y'\n if(btest(globaldata%status,GSNOREMCS)) chd='N'\n call gparcdx('Delete unnecessary composition sets automatically? ',&\n cline,ipos,1,ch1,chd,'?Amend general')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n globaldata%status=ibclr(globaldata%status,GSNOREMCS)\n else\n globaldata%status=ibset(globaldata%status,GSNOREMCS)\n endif\n1000 continue\n return\n end subroutine amend_global_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_bibliography_interactivly\n!\\begin{verbatim}\n subroutine enter_bibliography_interactivly(cline,last,mode,iref)\n! enter a reference for a parameter interactivly\n! mode=0 means enter, =1 amend\n implicit none\n character cline*(*)\n integer last,mode,iref\n logical twotries\n!\\end{verbatim}\n! stupid with a variable called CHAR80\n character line*256,refid*16,CHAR80*80\n integer jl,ip\n call gparcx('Reference identifier:',cline,last,1,refid,' ',&\n '?Amend bibliography')\n if(buperr.ne.0 .or. refid(1:1).eq.' ') then\n! write(kou,*)'There must be an identifier'\n gx%bmperr=4155; goto 1000\n endif\n call capson(refid)\n! check if unique, if mode=0 illegal\n do jl=1,reffree-1\n if(refid.eq.bibrefs(jl)%reference) then\n if(mode.eq.0) then\n! write(kou,*)'Reference identifier not unique'\n gx%bmperr=4156;goto 1000\n else\n goto 70\n endif\n endif\n enddo\n! if mode=1 one should have found the reference\n if(mode.eq.1) then\n write(kou,*)'No such reference'\n goto 1000\n endif\n70 continue\n ip=0\n line=' '\n twotries=.TRUE.\n100 continue\n! call gparc('Reference text, end with \";\":',cline,last,5,char80,';',q1help)\n call gparcx('Reference text, end with \";\":',cline,last,5,char80,';',&\n '?Amend bibliography')\n line(ip+1:)=char80\n ip=len_trim(line)\n if(ip.le.1 .and. twotries) then\n twotries=.FALSE.\n write(kou,*)'There must be some bibilograpic text!'\n ip=1; goto 100\n elseif(line(ip:ip).ne.';') then\n twotries=.FALSE.\n write(*,*)'Terminate text with a \";\"'\n ip=ip+1; goto 100\n elseif(ip.le.1 .and. .not.twotries) then\n if(mode.eq.1) then\n write(*,*)'Bibliogaphic reference unchanged'\n else\n write(*,*)'Bibliogaphic reference not entered'\n endif\n goto 1000\n else\n line(ip:)=' '\n endif\n call tdbrefs(refid,line,1,iref)\n1000 continue\n return\n end subroutine enter_bibliography_interactivly\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_experiment\n!\\begin{verbatim}\n subroutine enter_experiment(cline,ip,ceq)\n! enters an experiment, almost the same as set_condition \n implicit none\n character cline*(*)\n integer ip\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! New is set to the new condition or experiment\n! in set_condition new is not used for anything.\n! in this subroutine the new variable is removed from the condition list\n! and instead added to the experimenal list\n integer kp,jc,istv,qp\n type(gtp_condition), pointer :: new,temp\n! integer nidlast,nidfirst,nidpre\n double precision xxx,yyy\n character usymbol*16,ch1*1\n! do not allow experiments in first equilibrium!!\n if(ceq%eqno.eq.1) then\n write(kou,16)\n16 format('Experiments are not allowed in the default equilibrium')\n goto 1000\n endif\n!\n! return here if more experiments\n17 continue\n! inside here things are done\n! write(*,*)'3D exp1: ',trim(cline),ip\n call set_cond_or_exp(cline,ip,new,1,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,a,2i4)')'3D exp2: ',trim(cline),ip,new%active\n if(new%active.ne.1) then\n! the experiment is removed (inactivated) if activate is 1\n! otherwise read the uncertainty to be set\n! write(*,*)'3D after set_c_or_e:',ip,': ',trim(cline),new%uncertainty\n! set the default uncertainty to 10% of value \n if(new%uncertainty.gt.zero) then\n yyy=1.0D-1*abs(new%prescribed)\n else\n yyy=new%uncertainty\n endif\n kp=ip\n! bug reading the value after : ??\n! write(*,*)'3D uncertanity 2: ',ip,'\"'//trim(cline)//'\"'\n! NOTE that gparcd increments ip before seaching for value\n! write(*,*)'3D Calling gparcd: ',trim(cline),ip\n call gparcdx('Uncertainty: ',cline,ip,1,usymbol,'1.0',&\n '?Enter experiment')\n! write(*,*)'3D extracted uncertainity: ',ip,buperr,'\"'//usymbol//'\"'\n jc=1\n call getrel(usymbol,jc,xxx)\n! read(*,'(a)')ch1\n! if(ch1.eq.'q') stop 'wrong place ...'\n! write(*,*)'3D even more: ',xxx,buperr\n if(buperr.eq.0) then\n! usymbol is a numeric value !!\n if(xxx.le.zero) then\n write(*,*)'Uncertainty must not be zero, set to 0.1 of value'\n xxx=0.1*new%prescribed\n endif\n new%symlink2=0\n new%uncertainty=abs(xxx)\n else\n! we should check that the symbol is not an expression ... how?\n buperr=0\n call capson(usymbol)\n call find_svfun(usymbol,istv)\n! write(*,*)'3D uncertainty symbol: ',usymbol,istv\n if(gx%bmperr.ne.0) then\n write(*,*)'3D No such symbol: ',usymbol,&\n ' uncertainty set to 0.1 of value'\n xxx=0.1*new%prescribed\n new%symlink2=0\n new%uncertainty=abs(xxx)\n else\n! check that the symbol is a constant\n if(.not.btest(svflista(istv)%status,SVCONST)) then\n write(*,*)'3D Experimental uncertainty symbol must be a value'\n gx%bmperr=4399; goto 1000\n endif\n new%symlink2=istv\n endif\n endif\n! this is for relative errors, if last character is % it is a relative error!!\n! write(*,*)'3D relative errors: ',ip,len_trim(cline),'\"',trim(cline),'\"'\n if(ip.lt.len(cline)) then\n qp=len_trim(cline)\n if(cline(ip:ip).eq.'%' .or. cline(qp:qp).eq.'%') then\n if(new%experimenttype.eq.0) then\n new%experimenttype=100\n! write(*,*)'3D error is relative!'\n else\n! the experiment is an inequality\n write(kou,*)'3D *** Inequalites must have absolute uncertainty'\n! new%experimenttype=101*new%experimenttype ???\n endif\n endif\n endif\n! if weight is negative (meaning first experiment) set to unity\n if(ceq%weight.lt.zero) then\n ceq%weight=one\n endif\n endif\n! any more experiments?\n! write(*,*)'3D exp4: ',trim(cline),ip,kp,len(cline),len_trim(cline)\n if(kp.le.ip .and. len_trim(cline).gt.ip) then\n! write(*,*)'3D more experiments',trim(cline),kp,ip\n goto 17\n endif\n1000 continue\n end subroutine enter_experiment\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function same_statevariable\n!\\begin{verbatim} %-\n logical function same_statevariable(svr1,svr2)\n! returns TRUE if the state variable records are identical\n type(gtp_state_variable), pointer :: svr1,svr2\n!\\end{verbatim}\n logical same\n same=.FALSE.\n if(svr1%statevarid.ne.svr2%statevarid) goto 1000\n if(svr1%unit.ne.svr2%unit) goto 1000\n if(svr1%phref.ne.svr2%phref) goto 1000\n if(svr1%argtyp.ne.svr2%argtyp) goto 1000\n if(svr1%argtyp.gt.0) then\n if(svr1%phase.ne.svr2%phase) goto 1000\n if(svr1%argtyp.gt.1) then\n if(svr1%compset.ne.svr2%compset) goto 1000\n if(svr1%argtyp.gt.2) then\n if(svr1%component.ne.svr2%component) goto 1000\n if(svr1%argtyp.gt.3) then\n if(svr1%constituent.ne.svr2%constituent) goto 1000\n endif\n endif\n endif\n endif\n! they are the same !!!\n same=.TRUE.\n1000 continue\n same_statevariable=same\n return\n end function same_statevariable\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_condition\n!\\begin{verbatim}\n subroutine set_condition(cline,ip,ceq)\n! to set a condition\n implicit none\n character cline*(*)\n integer ip\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! New is set to the new condition or experiment\n! in this subroutine new is not used for anything.\n! in enter_experiment the new variable is removed from the condition list\n! and instead added to the experimenal list\n type(gtp_condition), pointer :: new\n! write(*,*)'3D set_cond: ',cline(1:len_trim(cline)),ip\n call set_cond_or_exp(cline,ip,new,0,ceq)\n1000 continue\n! always mark that current equilibrium may not be consistent with conditions\n ceq%status=ibset(ceq%status,EQINCON)\n nullify(new)\n end subroutine set_condition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_cond_or_exp\n!\\begin{verbatim} %-\n subroutine set_cond_or_exp(cline,ip,new,notcond,ceq)\n! decode an equilibrium condition, can be an expression with + and -\n! the expression should be terminated with an = or value supplied on next line\n! like \"T=1000\", \"x(liq,s)-x(pyrrh,s)=0\", \"mu(cr)-1.5*mu(o)=muval\"\n! Illegal with number before first state variable !!!\n! It can also be a \"NOFIX=\" or \"FIX= value\"\n! The routine should also accept conditions identified with the \":\"\n! where is that preceeding each condition in a list_condition\n! It should also accept changing conditions by :=new_value\n! The pointer to the (most recent) condition or experiment is returned in new\n! notcond is 0 if a condition should be created, otherwise an experiment\n implicit none\n integer ip,notcond\n character cline*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_condition), pointer :: new\n!\\end{verbatim} %+\n integer nterm,kolon,iqz,krp,jp,istv,iref,iunit,jstv,jref,junit,jl,ks\n integer linkix,norem,ics,kstv,iph,nidfirst,nidlast,nidpre,qp,firstc,lpos\n! a long line with conditions can create overflow and lost values ...\n character stvexp*500,stvrest*500,textval*32,c5*5,ch1\n character svtext*500,encoded*60,defval*18,actual_arg*24,svfuname*16\n integer indices(4),allterms(4,10),seqz,experimenttype\n integer ich,back,condvalsym,symsym,nextexp,colon\n double precision coeffs(10),xxx,value,ccc\n logical inactivate\n! memory leak\n type(gtp_state_variable), target :: svrvar\n type(gtp_state_variable), pointer :: svr,svr2\n type(gtp_state_variable), dimension(10), target :: svrarr\n TYPE(gtp_condition), pointer :: temp\n! safeguard: call old messy routine\n! call set_cond_or_exp_old(cline,ip,new,notcond,ceq)\n! return\n!=========================================================================\n if(len_trim(cline).gt.400) then\n write(*,*)'3D *** Too long line with conditions:',len_trim(cline)\n gx%bmperr=4399; goto 1000\n endif\n!\n nullify(temp)\n xxx=zero\n symsym=0\n iunit=0\n iref=0\n actual_arg=' '\n! write(*,*)'3D set cond or enter exper: ',trim(cline),ip\n! return here to deconde another condition on the same line\n50 continue\n nterm=0\n allterms=0\n!==========================================================================\n! return here to decode anther state variable term for condition\n! step 1 extract the state variable termintade by + - = > < or :=\n! NOT SUFFICIENT, a constituent can have a + or - !!!\n55 continue\n experimenttype=0\n nullify(new)\n if(nterm.eq.0) then\n! for second and later term coeffs already set below after call to termterm\n coeffs(1)=one\n endif\n indices=0\n! the list of experiments changes ???\n! NOTE we can have several conditions on the same line!!\n! argument 4 equal to 5 of gpar* means extract the whole line\n stvexp=' '\n nextexp=ip\n! write(*,56)'3D scoe: ',nterm,ip,trim(cline)\n56 format(a,2i3,' \"',a,'\" ')\n if(nterm.eq.0) then\n! the whole line is read into stvexp, ip is increemented by 1\n call gparcdx('State variable: ',cline,ip,5,stvexp,'T','?Set condition')\n else\n! the whole expression must have been entered on the same line\n! note cline is updated below !!\n ip=ip-1\n call gparcdx(' ',cline,ip,5,stvexp,'!','?Set condition')\n endif\n if(stvexp(1:1).eq.' ') then\n! if an expression is terminated with an empty line ask for value\n if(nterm.gt.0) goto 67\n! if no terms and the line empty return error code for no condition\n gx%bmperr=4126; goto 1000\n elseif(stvexp(1:1).eq.'!') then\n! this is an error while continuing reading an expression\n gx%bmperr=4126; goto 1000\n elseif(stvexp(1:3).eq.'FIX') then\n! special case when called internally for setting phase fix\n inactivate=.FALSE.\n ip=5\n goto 299\n elseif(stvexp(1:5).eq.'NOFIX') then\n inactivate=.TRUE.\n! write(*,*)'3D Inactivate phase fix condition'\n ip=7\n goto 299\n endif\n! this can be a condition or experiment ... and have several terms\n! check for +, -, =, <, >, or := \n! previous value of ip irrelevant, \n! ip points at terminator inside stvexp for current state variable\n! if lpos>0 is where to start for next term\n call termterm(stvexp,ich,ip,lpos,ccc)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,48)'3D tt: ',ich,ip,lpos,trim(stvexp),stvexp(1:ip),ccc\n48 format(a,3i4,' \"',a,'\" >',a,'< ',1pe12.4)\n if(ich.eq.6) then\n! special case when condition number provided, extract the number, can be *\n! meaning \"all conditions\", for example *:=NONE\n if(notcond.ne.0) then\n! write(*,*)'Experiments have no number'\n gx%bmperr=4131; goto 1000\n endif\n qp=1\n if(stvexp(qp:qp).eq.'*') then\n! write(*,*)'3D Special case of deleting all conditions'\n! 0 means only conditions deleted, not the equilibrium\n call delete_all_conditions(0,ceq)\n goto 1000\n endif\n call getrel(stvexp,qp,xxx)\n if(buperr.ne.0) then\n! write(*,*)'No such condition number'\n gx%bmperr=4131; goto 1000\n endif\n! the condition number must be an integer\n qp=-int(xxx)\n! search for condition with number -qp\n! write(*,*)'3D looking for condition: ',-qp\n! UNFINISHED: one should look for the qp:th ACTIVE condition ....\n temp=>ceq%lastcondition\n! write(*,*)'3D calling get_condition A'\n call get_condition(qp,svr,temp)\n! write(*,*)'3D Back from calling get_condition A'\n if(gx%bmperr.ne.0) goto 1000\n! save link to old condition in new\n new=>temp\n xxx=new%prescribed\n nterm=1\n! write(*,*)'Found condition',-qp,xxx\n! jump from here to 67 if condition specified as number:=value\n goto 67\n elseif(ich.lt.3 .and. nterm.eq.0) then\n! first term of state variable which is an expression,\n! this term is terminated by + or -\n! if(stvexp(1:1).ge.'0' .and. stvexp(1:1).le.'9') then\n! write(*,*)'3D extract coeff for first term, if none set to 1',ich\n firstc=1\n call getrel(stvexp,firstc,coeffs(1))\n if(buperr.ne.0) then\n! write(*,*)'3D error in coefficient for first condition term',buperr\n! ignore error, means no coefficient\n buperr=0\n coeffs(1)=one\n else\n! character after coefficient must be a *\n if(stvexp(firstc:firstc).ne.'*') then\n write(*,*)'3D coefficient is not terminated by *: ',&\n stvexp(firstc:firstc)\n gx%bmperr=4130\n else\n! update stvexp for next term, we must also update lpos ... lousy coding\n stvexp=stvexp(firstc+1:)\n lpos=lpos-firstc\n endif\n endif\n endif\n!---------------------------------\n! check it is a legal state variable, ignore terminator \n svtext=stvexp(1:ip-1)\n symsym=0\n! write(*,*)'3D calling decode for \"',trim(svtext),'\" upt to:',ip-1\n! memory leak\n svr=>svrvar\n call decode_state_variable(svtext,svr,ceq)\n! write(*,*)'3D state var: ',trim(svtext),gx%bmperr\n if(gx%bmperr.ne.0) then\n! Experiments can be symbols\n! write(*,*)'3D not a state variable: ',svtext(1:5),gx%bmperr,notcond\n if(notcond.ne.0) then\n gx%bmperr=0\n svfuname=svtext\n call capson(svfuname)\n! write(*,*)'3D Searching for symbol: ',svfuname\n! call find_svfun(svfuname,symsym,ceq)\n call find_svfun(svfuname,symsym)\n if(gx%bmperr.ne.0) then\n write(*,*)'3D Experimental symbol neither state variable nor symbol'\n goto 1000\n endif\n! write(*,*)'3D experiment is a symbol ',symsym\n! we do not have a state variable ... bypass some checks\n nullify(svr)\n goto 77\n else\n goto 1000\n endif\n endif\n! convert to old state variable format\n! write(*,12)svr%argtyp,svr%phase,svr%compset,svr%component,svr%constituent\n12 format('3D Decoded: ',5i5)\n indices=0\n if(svr%argtyp.eq.1) then\n indices(1)=svr%component\n elseif(svr%argtyp.eq.2) then\n indices(1)=svr%phase\n indices(2)=svr%compset\n elseif(svr%argtyp.eq.3) then\n indices(1)=svr%phase\n indices(2)=svr%compset\n indices(3)=svr%component\n elseif(svr%argtyp.eq.4) then\n indices(1)=svr%phase\n indices(2)=svr%compset\n indices(3)=svr%constituent\n endif\n! write(*,12)svr%argtyp,indices\n! do ks=1,4\n! allterms(nterm,ks)=indices(ks)\n! enddo\n! write(*,*)'3D newcond: ',svtext(1:20),ip\n!----------------------------------------------------\n77 continue\n! write(*,*)'3D error search ',notcond,ich,associated(temp)\n! check that we we have a legal state variable for conditions\n if(notcond.eq.0) then\n! it is a condition, check if allowed as condition\n istv=svr%oldstv\n if(istv.lt.0) then\n! this means a symbol like TC or BMAGN, not allowed\n gx%bmperr=4127; goto 1000\n endif\n kstv=(svr%oldstv+1)/10+5\n if(kstv.eq.14 .or. kstv.eq.15) then\n! this means state variables Q or DGM which cannot be used as condition\n gx%bmperr=4127; goto 1000\n endif\n if(istv.ge.3 .and. istv.le.5) then\n! this is MU, AC and LNAC, do not allow with phase index (at present at least)\n if(indices(2).ne.0) then\n write(*,*)'Phase specific chemical potentials not allowed',&\n ' as conditions'\n gx%bmperr=4127; goto 1000\n endif\n endif\n! state variables with a single term will be prompted with current value\n encoded=' '\n call get_state_var_value(svtext,xxx,encoded,ceq)\n if(gx%bmperr.ne.0) then\n! This error occurs when setting the first compositions before any calculations\n gx%bmperr=0; xxx=zero\n endif\n else\n! It is an experiment, search for old value if experiment already entered\n! write(*,*)'3D experiment 1',notcond,ich\n if(ich.eq.4) then\n experimenttype=-1\n elseif(ich.eq.5) then\n experimenttype=1\n endif\n temp=>ceq%lastexperiment\n if(.not.associated(temp)) then\n xxx=zero\n else\n! new is nullified, temp set above for search of conditions or experiments, \n88 continue\n temp=>temp%next\n if(symsym.eq.0) then\n! new experiment is a state variable, what about temp?\n! write(*,*)'3D oldexp 1: ',symsym,temp%statev\n if(temp%statev.eq.0) then\n svr2=>temp%statvar(1)\n if(same_statevariable(svr,svr2) .and. &\n experimenttype.eq.temp%experimenttype) then\n xxx=temp%prescribed\n! found experimental record, save link in new\n new=>temp\n endif\n endif\n if(.not.associated(temp,ceq%lastexperiment)) goto 88\n else\n! experiment is a symbol compare with other experiments for symbols\n! write(*,*)'3D oldexp 2: ',symsym,temp%statev\n if(symsym.eq.temp%statev .and. &\n experimenttype.eq.temp%experimenttype) then\n xxx=temp%prescribed\n! we have found a record for this experiment\n new=>temp\n else\n if(.not.associated(temp,ceq%lastexperiment)) goto 88\n endif\n endif\n endif\n endif\n! write(*,*)'3D Found old condition or experiment?',notcond\n if(notcond.eq.0) then\n!----------------------------------------------------------------\n! Only for conditions: save current term if several\n nterm=nterm+1\n! write(*,*)'3D several terms: ',nterm\n svrarr(nterm)=svr\n! write(*,*)'3D segfault search 3',nterm\n! convert to old format, currently we need to store both formats ....\n! istv=svr%oldstv\n iref=svr%phref\n iunit=svr%unit\n do ks=1,4\n allterms(ks,nterm)=indices(ks)\n enddo\n! write(*,*)'3D segfault search 4',nterm,ich\n! write(*,*)'3D old indices:',nterm,indices\n if(ich.eq.1 .or. ich.eq.2) then\n! terminator + or - means state variable expression with several terms\n if(nterm.gt.1) then\n! UNFINISHED check the second or later state variable of same type as first\n continue\n endif\n! multiterm expression, jump back to 55\n! write(*,*)'3D problems entering expression: ',trim(stvexp),lpos\n coeffs(nterm+1)=ccc\n! cline=stvexp(ip-1:); ip=1\n cline=stvexp(lpos:); ip=1\n goto 55\n endif\n else\n! it is an existing experiment, we have only one term for experiments\n nterm=1\n! write(*,*)'3D segfault search 2C',nterm,associated(svr),notcond\n if(associated(svr)) then\n svrarr(nterm)=svr\n! else\n! write(*,*)'3D svr not associated, experiment is a symbol'\n endif\n endif\n! jump here for qp:= or if several terms are terminated with empty line\n67 continue\n!==================================================================\n! Step 2 ask for the numerical value or symbol, first insert a default value\n jp=1\n defval=' '\n! write(*,*)'3D default value: ',xxx,ip,' \"',stvexp(ip:ip+5),'\" '\n call wrinum(defval,jp,10,0,xxx)\n if(buperr.ne.0) then\n buperr=0; defval=' '\n endif\n!157 continue\n! stvexp is the whole line after the command\n colon=index(stvexp,':')\n! colon=index(cline,':')\n! write(*,*)'3D value: ',ip,' \"',trim(stvexp),'\" ',defval,colon\n call gparcdx('Value: ',stvexp,ip,1,textval,defval,'?Set condition')\n! write(*,*)'3D value: ',textval\n c5=textval(1:5)\n call capson(c5)\n none: if(c5.eq.'NONE ' .or. c5.eq.'NONE') then\n inactivate=.true.\n! write(*,158)'Inactivate condition: ',-qp,value,xxx\n158 format(a,i5,2(1pe12.4))\n value=xxx\n else\n if(notcond.ne.0) then\n if(textval(1:1).eq.'<') then\n experimenttype=-1\n textval(1:1)=' '\n elseif(textval(1:1).eq.'<') then\n experimenttype=-1\n textval(1:1)=' '\n endif\n endif\n linkix=-1\n inactivate=.FALSE.\n jp=1\n call getrel(textval,jp,value)\n if(buperr.ne.0) then\n! it can be a symbol\n buperr=0\n svfuname=textval\n call capson(svfuname)\n! call find_svfun(svfuname,condvalsym,ceq)\n call find_svfun(svfuname,condvalsym)\n! write(*,*)'3D Symbol link: ',textval(1:10),condvalsym,gx%bmperr\n if(gx%bmperr.ne.0) then\n write(*,*)'Condition value must be numeric or a symbol'; goto 1000\n endif\n! only allowed if symbol is constant SVCONST or SVFVAL set \n! check we actually have correct symbol!!\n! write(*,*)'Symbol name: ',svflista(condvalsym)%name\n if(btest(svflista(condvalsym)%status,SVCONST) .or. &\n btest(svflista(condvalsym)%status,SVFVAL)) then\n linkix=condvalsym\n value=evaluate_svfun_old(linkix,actual_arg,1,ceq)\n else\n write(*,*)'3D Symbol must be constant or \"evaluate explicit\"'\n gx%bmperr=4293; goto 1000\n endif\n endif\n! we must update ip in cline for uncertainty and another experiment\n if(colon.gt.0) then\n ip=colon\n istv=0\n! write(*,*)'3D changed experiment 1: ',ip,'\"',trim(stvexp),'\"',value \n endif\n endif none\n!\n findrecord: if(notcond.eq.0) then\n! remove a condition\n! write(*,*)'3D avoiding creating expression:',associated(new)\n if(.not.associated(new)) then\n! search if condition already exist\n! write(*,*)'3D searching for condition or experiment?'\n temp=>ceq%lastcondition\n if(nterm.eq.1) then\n call get_condition(nterm,svr,temp)\n else\n call get_condition_expression(nterm,svrarr,temp)\n endif\n if(gx%bmperr.ne.0 .and. inactivate) then\n write(kou,140)\n140 format('Attempt to remove a non-existing condition')\n goto 1000\n endif\n! the error code it will be tested below to create a condition record\n endif\n else\n! remove or change an experiment\n if(.not.associated(new)) then\n! write(*,*)'3D First experiment: ',associated(temp)\n! search for an experiment with state variable svr or symbol symsym\n temp=>ceq%lastexperiment\n142 continue\n! write(*,*)'3D searching for experiment'\n if(symsym.eq.0) then\n istv=symsym\n! if(associated(temp)) then\n! write(*,*)'3D Calling get_condition C',allocated(temp%condcoeff)\n! else\n! write(*,*)'3D Calling get_condition C with temp null'\n! endif\n call get_condition(nterm,svr,temp)\n! write(*,*)'3D Back from calling get_condition C',gx%bmperr\n if(gx%bmperr.eq.0) then\n! we must also test eperimenttype, if not same continue search\n if(temp%experimenttype.eq.experimenttype) goto 142\n else\n! ensure temp is OK\n temp=>ceq%lastexperiment\n! write(*,*)'3D We are here',associated(temp),gx%bmperr\n endif\n else\n! write(*,*)'3D searching for experiment with symbol'\n! temp is changed inside !!\n new=>temp\n! call get_experiment_with_symbol(symsym,experimenttype,temp)\n call get_experiment_with_symbol(symsym,experimenttype,new)\n endif\n! else\n! write(*,*)'We have a condition record in new', gx%bmperr\n endif\n endif findrecord\n!======================================================\n! step 3 create condition or experiment record, jump here from fix phase\n199 continue\n! write(*,*)'3D at 199: ',associated(new),associated(temp),gx%bmperr,ip\n createrecord: if(gx%bmperr.eq.0) then\n! no error code means we have found the condition/experiment\n if(.not.associated(new)) then\n! the existing condition/experiment is in temp\n new=>temp\n endif\n if(inactivate) then\n new%active=1\n! write(*,*)'Inactivating condition',new%prescribed,new%active\n else\n! write(*,*)'3D looking for missing % ...'\n! set the new value in the old condition/experiment remove any previous link!!\n! linkix is link to symbol representing the value\n new%active=0\n new%prescribed=value\n new%symlink1=linkix\n! write(*,*)'3D Changing value of condition',istv,linkix,value\n! special if istv=1 or 2 as ceq%tpfun should be updated\n if(istv.eq.1) then\n! Save new T also locally in ceq\n! write(*,*)'3D we are here 1',ceq%tpval(1)\n! if(linkix.gt.0) then\n! write(*,*)'Cannot handle symbol as T value'\n! it is allowed now\n! gx%bmperr=4293; goto 1000\n! endif\n ceq%tpval(1)=value\n elseif(istv.eq.2) then\n! if(linkix.gt.0) then\n! write(*,*)'Cannot handle symbol as P value'\n! it is allowed now\n! gx%bmperr=4293; goto 1000\n! endif\n ceq%tpval(2)=value\n endif\n! the uncertainty for experiments will be asked for later\n! To avoid that valgrind compains uncertainty is not initiallized ...\n! write(*,*)'3D initiallizing uncertainty 2'\n! write(*,*)'3D changed experiment: ',ip,'\"',trim(cline),'\"',value\n new%uncertainty=zero\n endif\n else\n! If we have an error from findrecord then create condition/experiment record\n! write(*,113)inactivate,gx%bmperr,nterm,istv,iunit,iref,linkix,&\n! allterms(1,1),value\n113 format('Creating condition record',l2,2x,7i4,1pe12.4)\n gx%bmperr=0\n if(notcond.eq.0) then\n if(associated(ceq%lastcondition)) then\n seqz=ceq%lastcondition%seqz+1\n else\n seqz=1\n endif\n temp=>ceq%lastcondition\n allocate(ceq%lastcondition)\n new=>ceq%lastcondition\n! write(*,*)'3D new condition ',istv,symsym\n else\n! it is an experiment ... ip OK here\n! write(*,13)'3D Creating new experiment record: ',symsym,value,linkix,ip\n13 format(a,i5,1pe12.4,5i5)\n if(associated(ceq%lastexperiment)) then\n seqz=ceq%lastexperiment%seqz+1\n else\n seqz=1\n endif\n temp=>ceq%lastexperiment\n allocate(ceq%lastexperiment)\n new=>ceq%lastexperiment\n! write(*,*)'3D new experiment 2',istv,symsym,seqz\n istv=symsym\n endif\n! write(*,*)'3D we are here 3'\n! for new conditions and experiments\n new%noofterms=nterm\n new%statev=istv\n new%iunit=iunit\n new%iref=iref\n new%active=0\n new%seqz=seqz\n! To avoid that valgrind compains uncertainty is not initiallized ...\n! write(*,*)'3D initiallizing uncertainty 3',value\n new%uncertainty=zero\n! write(*,*)'3D experimenttype: ',experimenttype,symsym,nterm\n new%experimenttype=experimenttype\n! write(*,*)'3D symsym: ',symsym,nterm\n if(symsym.eq.0) then\n! DO NOT allocate terms for condcoeff and indices if symbol\n allocate(new%condcoeff(nterm))\n allocate(new%indices(4,nterm))\n! write(*,*)'3D allocations ok',linkix,value\n do jl=1,nterm\n new%condcoeff(jl)=coeffs(jl)\n! write(*,111)'3D allterms: ',istv,jl,(allterms(ks,jl),ks=1,4)\n do ks=1,4\n new%indices(ks,jl)=allterms(ks,jl)\n enddo\n! write(*,111)'3D in record: ',istv,jl,(new%indices(ks,jl),ks=1,4)\n111 format(a,i3,i5,2x,4i4)\n enddo\n! Only experiments can be symbols, what to do next?\n endif\n! write(*,*)'3D storing value: ',value,linkix\n if(linkix.lt.0) then\n new%prescribed=value\n new%symlink1=-1\n else\n new%symlink1=linkix\n value=evaluate_svfun_old(linkix,actual_arg,1,ceq)\n! write(*,*)'3D evaluating condition sysmbol ',linkix,value\n if(gx%bmperr.ne.0) then\n goto 1000\n endif\n new%prescribed=value\n! write(*,*)'3D prescribed condition value: ',new%prescribed\n endif\n! first test if condition on P or T is larger than 0.1\n if(istv.eq.1 .or. istv.eq.2) then\n if(value.lt.0.1D0) then\n gx%bmperr=4187; goto 1000\n endif\n endif\n! special for T and P, change the local value and mark tpres\n! write(*,*)'3D set condition/enter experiment ',istv,value\n if(istv.eq.1) then\n ceq%tpval(1)=value\n! Force recalculation of all TP functions but only in current equilibrium\n ceq%eq_tpres%tpused(1)=ceq%tpval(1)+one\n! write(*,*)'3D Changing tpused: ',ceq%eq_tpres%tpused(1)\n elseif(istv.eq.2) then\n ceq%tpval(2)=value\n! Force recalculation of all TP functions. Is there a better way?\n ceq%eq_tpres%tpused(2)=ceq%tpval(2)+one\n endif\n! Another way to force recalculation of all TP functions by incrementing\n! an integer in the tpfuns record of all TPFUN. Used during assessments\n! do jl=1,freetpfun-1\n! tpfuns(jl)%forcenewcalc=tpfuns(jl)%forcenewcalc+1\n! enddo\n! write(*,*)'3D allocation of statvar ',symsym,istv,nterm\n if(symsym.eq.0) then\n! store the state variable record in the condition, if symbol do not allocate\n allocate(new%statvar(nterm))\n do jl=1,nterm\n new%statvar(jl)=svrarr(jl)\n enddo\n! else\n! experiment is a symbol, no statvar record !!\n! The index to the state variable symbol is symsym stored in new%statev\n! write(*,*)'3D experiment is a symbol 2',istv,symsym,linkix\n! allocate(new%statvar(1))\n! new%statvar(1)%statevarid=0\n! new%statvar(1)%argtyp=-symsym\n endif\n! link the new record into the condition list\n! write(*,*)'3D linking condition or experiment'\n if(associated(temp)) then\n! write(*,*)'Second or later condition'\n nidlast=temp%next%nid\n nidfirst=temp%nid\n nidpre=temp%previous%nid\n new%nid=nidlast+1\n temp%next%previous=>new\n new%next=>temp%next\n temp%next=>new\n new%previous=>temp\n else\n! create the circular list\n new%nid=1\n new%next=>new\n new%previous=>new\n endif\n if(notcond.ne.0) then\n! STRANGE ERRORS HERE\n! we are actually entering an experiment, terminate here\n! if textval(jp:jp) is \":\" we have to step back ip one position\n! increment ip with nextexp!\n ip=ip+nextexp\n! write(*,*)'3D exit? \"',trim(cline),'\" \"',trim(textval),'\"',&\n! ip,jp,nextexp\n if(cline(ip:ip).eq.':') then\n! the colon should be the character at ip to extract uncertainty by getrel\n goto 1000\n endif\n200 continue\n ip=ip+1\n! write(*,*)'3D looking for \":\"',trim(cline),ip\n if(cline(ip:ip).eq.':' .or. ip.gt.len(cline)) goto 1000\n goto 200\n! if(ip.lt.len_trim(cline)) goto 200\n! confusion of subtexts ... move ip forward to point at colon\n! write(*,*)'3D where is :? ',cline(ip+1:ip+1),ip\n! if(cline(ip+1:ip+1).ne.':') then\n! ip=ip+1; if(ip.lt.70) goto 200\n! endif\n! ip=ip+1 very confused !!\n! ip=ip-1\n! endif\n! stop here so I can check\n! read(*,'(a)')ch1\n! if(ch1.eq.'q') stop 'cannot find \":\"'\n! allow for more experiments on the same line ...\n! cline=textval(jp:)\n! ip=1\n! goto 1000\n endif\n endif createrecord\n! write(*,*)'3D end of createrecord',ip,'\"',trim(stvexp),'\"'\n!----------------------------------------------------------------\n! if there is more in stvexp go back to label 50 ...\n if(.not.eolch(stvexp,ip)) then\n! write(*,*)'3d first character: \"',stvexp(ip:ip),'\" ' \n! NOTE gparc skips the first character in cline\n if(stvexp(ip:ip).eq.':') then\n! if experiment there can be an uncertainty ...\n! write(*,*)'3D where is the value?'\n cline=stvexp(ip:)\n cline(ip:ip)=' '\n ip=1\n goto 1000\n elseif(stvexp(ip:ip).eq.',') then\n cline=stvexp(ip:)\n else\n cline=stvexp(ip-1:)\n endif\n! write(*,*)'3d next condition: \"',stvexp(ip:ip+20),'\"'\n ip=1; goto 50\n endif\n goto 1000\n!====================================================================\n! Special below is for fix/unfix phases\n299 continue\n if(notcond.ne.0) then\n write(kou,*)'3D Illegal to set a fix phase as experiment'\n gx%bmperr=4294; goto 1000\n endif\n! write(*,*)'3D fix phase 2: ',ip,stvexp(ip:40)\n call find_phase_by_name(stvexp(ip:),iph,ics)\n if(gx%bmperr.ne.0) then\n goto 1000\n endif\n! write(*,*)'3D Phase index: ',iph,ics\n nterm=1\n istv=-iph\n iref=ics\n iunit=0\n linkix=-1\n coeffs(1)=1.0D0\n do jl=1,4\n allterms(jl,1)=0\n enddo\n! convert to state variable\n! write(*,*)'3D Setting svrarr(1) values'\n svrarr(1)%statevarid=istv\n svrarr(1)%oldstv=istv\n svrarr(1)%phase=ics\n svrarr(1)%unit=0\n svrarr(1)%argtyp=0\n svrarr(1)%phase=iph\n svrarr(1)%compset=ics\n svrarr(1)%component=0\n svrarr(1)%constituent=0\n!\n temp=>ceq%lastcondition \n! if not inactivate get value\n if(inactivate) then\n! bypass phase name\n ip=index(stvexp,' ')\n else\n ip=index(stvexp,'==')+2\n call getrel(stvexp,ip,value)\n if(buperr.ne.0) then\n write(*,*)'3D error setting fix amount ',ip,stvexp(1:40)\n gx%bmperr=4100; goto 1000\n endif\n endif\n svr=>svrarr(1)\n! write(*,*)'3D set_cond_or_exp for fix phase: ',svr%statevarid,svr%phase\n! new must be unassociated, for inactivate temp will be set to condition.\n nullify(new)\n call get_condition(nterm,svr,temp)\n! write(*,*)'3D Back from get_condition ',gx%bmperr,ip\n goto 199\n!\n! finally, for conditions T or P copy value to ceq%tpval\n! This may be a bit inconsistent .... but??\n900 continue\n if(istv.eq.1 .and. iunit.eq.0 .and. iref.eq.0) then\n ceq%tpval(1)=value\n elseif(istv.eq.2 .and. iunit.eq.0 .and. iref.eq.0) then\n ceq%tpval(2)=value\n endif\n! mark that any current results may be inconsistent with new conditions\n! globaldata%status=ibset(globaldata%status,GSINCON)\n ceq%status=ibset(ceq%status,EQINCON)\n1000 continue\n! write(*,*)'exit set_condition, T= ',ceq%tpval(1)\n! possible memory leaks\n nullify(svr)\n nullify(svr2)\n! nullify(svrarr)\n nullify(temp)\n return\n end subroutine set_cond_or_exp !svr ip\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_experiment_with_symbol\n!\\begin{verbatim} %-\n subroutine get_experiment_with_symbol(symsym,experimenttype,temp)\n! finds an experiment with s symbol index symsym and exp.type\n implicit none\n integer symsym,experimenttype\n type(gtp_condition), pointer :: temp\n! NOTE: temp must have been set to ceq%lastcondition before calling this\n!\\end{verbatim}\n! pcond: pointer, to a gtp_condition record for this equilibrium\n type(gtp_condition), pointer :: pcond,last\n if(.not.associated(temp)) goto 900\n last=>temp\n pcond=>last\n100 continue\n if(pcond%statev.eq.symsym .and. pcond%experimenttype.eq.experimenttype) then\n! the index of the symbol is stored in statev, we have found the experiment\n goto 1000\n else\n! Wow = here instead of => created a lot of problems!!!\n pcond=>pcond%next\n! this is true unless we have circulated the whole list\n if(.not.associated(pcond,last)) goto 100\n endif\n! we have not found this experiment\n900 continue\n gx%bmperr=4131\n1000 continue\n return\n end subroutine get_experiment_with_symbol\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_condition_expression\n!\\begin{verbatim}\n subroutine get_condition_expression(nterm,svrarr,pcond)\n! I do not want to change get_condition ,,,,, suck\n! finds a condition/experiment record with the given state variable expression\n! If nterm<0 svr is irrelevant, the absolute value of nterm is the sequential\n! number of the ACTIVE conditions\n implicit none\n integer nterm\n type(gtp_state_variable), dimension(*), target :: svrarr\n! NOTE: pcond must have been set to ceq%lastcondition before calling this\n! pcond: pointer, to a gtp_condition record for this equilibrium\n type(gtp_condition), pointer :: pcond\n!\\end{verbatim} %+\n type(gtp_condition), pointer :: last\n type(gtp_state_variable), pointer :: svr,condvar\n integer jj\n!\n! write(*,*)'3D get_condition_expression: ',nterm\n! start from first equilibrium in circular list\n! write(*,*)'3D one more line ...'\n! this write statement caused crash if first condition had 2 terms ...\n! write(*,*)'3D size of pcond%statvar: ',size(pcond%statvar)\n if(nterm.gt.1) then\n write(*,*)'3D A condition with several terms sometimes causes crash'\n gx%bmperr=4399; goto 1000\n endif\n pcond=>pcond%next\n last=>pcond\n100 continue\n write(*,*)'3D at label 100'\n ploop: do while(.true.)\n terms: do jj=1,nterm\n svr=>svrarr(jj)\n! write(*,*)'3D gce: ',jj,svr%component\n if(jj.gt.size(pcond%statvar)) then\n write(*,*)'3D too many terms in condition',jj,size(pcond%statvar)\n write(*,*)'3D more:',nterm,pcond%statvar(1)%oldstv\n gx%bmperr=4399; goto 1000\n endif\n condvar=>pcond%statvar(jj)\n! write(*,*)'3D get_condition: ',jj,condvar%oldstv,condvar%argtyp\n! dissapointment, one cannot compare two structures ... unless pointers same\n if(condvar%oldstv.ne.svr%oldstv) goto 200\n if(condvar%argtyp.ne.svr%argtyp) goto 200\n if(condvar%phase.ne.svr%phase) goto 200\n if(condvar%compset.ne.svr%compset) goto 200\n! skip fix phases\n if(condvar%statevarid.lt.0) goto 1000\n! most conditions with 2 terms are x(a)-x(b) ore similar\n! write(*,*)'3D component: ',condvar%component,svr%component\n if(condvar%component.ne.svr%component) goto 200\n if(condvar%constituent.ne.svr%constituent) goto 200\n if(condvar%norm.ne.svr%norm) goto 200\n if(condvar%unit.ne.svr%unit) goto 200\n enddo terms\n! we have found a condition with these state variables\n! write(*,*)'3D Found condition',pcond%active\n goto 1000\n200 continue\n pcond=>pcond%next\n if(associated(pcond,last)) exit ploop\n enddo ploop\n! we did not find this condition, maybe create it?\n gx%bmperr=4131; goto 1000\n1000 continue\n return\n end subroutine get_condition_expression\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_condition\n!\\begin{verbatim}\n subroutine get_condition(nterm,svr,pcond)\n! finds a condition/experiment record with the given state variable expression\n! If nterm<0 svr is irrelevant, the absolute value of nterm is the sequential\n! number of the ACTIVE conditions\n implicit none\n integer nterm\n type(gtp_state_variable), pointer :: svr\n! NOTE: pcond must have been set to ceq%lastcondition before calling this\n! pcond: pointer, to a gtp_condition record for this equilibrium\n type(gtp_condition), pointer :: pcond\n!\\end{verbatim} %+\n type(gtp_condition), pointer :: last\n type(gtp_state_variable), pointer :: condvar\n integer j1,num,iact\n if(.not.associated(pcond)) goto 900\n! write(*,*)'3D in get_condition: ',svr%statevarid,svr%oldstv,svr%argtyp,nterm\n! if(nterm.lt.0) write(*,*)'3D Condition number: ',-nterm\n! last=>pcond\n! start from first equilibrium in circular list\n pcond=>pcond%next\n last=>pcond\n num=0\n iact=0\n100 continue\n num=num+1\n! iact is incremented with the active conditions\n if(pcond%active.eq.0) iact=iact+1\n if(nterm.lt.0) then\n! we have found the active condition with number -nterm\n! write(*,102)'Cond #: ',pcond%active,nterm,iact,num,pcond%prescribed\n!102 format(a,4i3,1pe12.4)\n! pcond starts with the last equilibria, not the first ...\n if(iact+nterm.eq.0) goto 1000\n elseif(.not.allocated(pcond%condcoeff)) then\n! problem when experiment is a symbol ...\n! elseif(.not.allocated(pcond%condcoeff) .and. istv.ne.0) then\n! no coefficients allocated, it must be an experiment with a symbol as variable\n!- write(*,*)'3D experiment as symbol',pcond%statev,pcond%seqz,num\n! we must transfer the symbol index ...\n! if(pcond%statev.eq. )then\n! goto 1000\n! endif\n! goto 200\n continue\n elseif(pcond%noofterms.eq.nterm) then\n! we should never be here if nterm>1\n if(nterm.gt.1) then\n write(*,*)'3D call to get_contition with nterm: ',nterm\n gx%bmperr=4399; goto 1000\n endif\n! write(*,*)'3D nterm: ',nterm,pcond%noofterms\n! experiments that are symbols have not allocated any coefficent record\n do j1=1,nterm\n! if nterm>1 compare just nterm as this routine called for each term!!\n condvar=>pcond%statvar(j1)\n! write(*,*)'3D get_condition: ',j1,num,condvar%oldstv,condvar%argtyp\n! dissapointment, one cannot compare two structures ... unless pointers same\n! if(condvar.ne.svr) goto 200\n if(condvar%oldstv.ne.svr%oldstv) goto 200\n if(condvar%argtyp.ne.svr%argtyp) goto 200\n if(condvar%phase.ne.svr%phase) goto 200\n if(condvar%compset.ne.svr%compset) goto 200\n if(condvar%statevarid.lt.0) goto 1000\n! for fix phase the remaining have no importance\n! write(*,*)'3D component: ',condvar%component,svr%component\n if(condvar%component.ne.svr%component) goto 200\n if(condvar%constituent.ne.svr%constituent) goto 200\n if(condvar%norm.ne.svr%norm) goto 200\n if(condvar%unit.ne.svr%unit) goto 200\n! we must have experimenttype=0 ??\n! if(condvar%experimenttype.ne.0) goto 200\n enddo\n! we have found a condition with these state variables\n! write(*,*)'3D Found condition',pcond%active\n goto 1000\n! else\n! write(*,*)'3D ignoring condition with wrong number of terms',&\n! nterm,pcond%noofterms\n endif\n200 continue\n! write(*,*)'Conditions not same'\n pcond=>pcond%next\n if(.not.associated(pcond,last)) goto 100\n900 continue\n! write(*,*)'3D get_condition: No such condition or experiment'\n gx%bmperr=4131; goto 1000\n1000 continue\n return\nend subroutine get_condition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_condition2\n!\\begin{verbatim} %-\n subroutine get_condition2(nterm,coeffs,istv,indices,iref,iunit,pcond)\n! finds a condition record with the given state variable expression\n! nterm: integer, number of terms in the condition expression\n! istv: integer, state variable used in the condition\n! indices: 2D integer array, state variable indices used in the condition\n! iref: integer, reference state of the condition (if applicable)\n! iunit: integer, unit of the condition value\n! NOTE: pcond must have been set to ceq%lastcond before calling this routine!!!\n! pcond: pointer, to a gtp_condition record for this equilibrium\n! NOTE: conditions like expressions x(mg)-2*x(si)=0 not implemeneted\n! fix phases as conditions have negative condition variable\n implicit none\n TYPE(gtp_condition), pointer :: pcond\n integer, dimension(4,*) :: indices\n integer nterm,istv,iref,iunit\n double precision coeffs(*)\n!\\end{verbatim} %+\n TYPE(gtp_condition), pointer :: current,first\n! integer, dimension(4) :: indx\n integer ncc,nac,j1,j2\n! write(*,*)'looking for condition'\n! pcond must have been set to ceq%lastcond before calling this routine!!!\n if(.not.associated(pcond)) goto 900\n first=>pcond%next\n current=>first\n! write(*,*)'get_condition start: ',current%statev,current%active\n ncc=1\n nac=0\n if(ocv()) write(*,98)'new:',0,nterm,istv,(indices(j1,1),j1=1,4),iref,iunit\n98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3)\n100 continue\n if(ocv()) write(*,98)'old:' ,current%nid,current%noofterms,current%statev,&\n (current%indices(j1,1),j1=1,4),current%iref,current%iunit\n if(nterm.eq.0) then\n! why nterm=0? Check!!!\n if(ocv()) write(*,*)'3D get_condition: ',istv,ncc,nac\n if(current%active.eq.0) then\n! this call just looks for active condition istv\n nac=nac+1\n! why should fix phase conditions have istv=nac?? Check!!\n if(nac.eq.istv) then\n! a condition specified like this must not be a phase status change\n if(current%statev.lt.0) then\n write(kou,*)'You must use \"set phase status\" to change fix status'\n else\n goto 150\n endif\n endif\n endif\n goto 200\n endif\n if(ocv()) write(*,103)'Checking terms, istv, iref and unit ',&\n nac,ncc,nterm,current%noofterms\n103 format(a,6i5)\n if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. &\n current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200\n if(ocv()) write(*,*)'Checking indices'\n do j1=1,nterm\n do j2=1,4\n if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200\n enddo\n enddo\n150 continue\n! found condition\n pcond=>current\n! write(*,*)'Found condition: ',pcond%nid,ncc\n goto 1000\n200 continue\n current=>current%next\n ncc=ncc+1\n if(.not. associated(current,first)) goto 100\n900 continue\n! no such condition\n gx%bmperr=4131; goto 1000\n1000 continue\n return\n end subroutine get_condition2\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine extract_stvr_of_condition\n!\\begin{verbatim} %-\n subroutine extract_stvr_of_condition(pcond,nterm)\n! finds a condition record with the given state variable record\n! returns it as a state variable record !!!\n! nterm: integer, number of terms in the condition expression\n! pcond: pointer, to a gtp_condition record\n implicit none\n TYPE(gtp_condition), pointer :: pcond\n integer nterm\n!\\end{verbatim}\n TYPE(gtp_condition), pointer :: current,first\n! integer, dimension(4) :: indx\n integer ncc,nac,j1,istv,iref,iunit\n!\n! write(*,*)'not implemented!!'\n gx%bmperr=4078; goto 1000\n!--------------------------------------------------------\n if(.not.associated(pcond)) goto 900\n first=>pcond%next\n current=>first\n! write(*,*)'get_condition start: ',current%statev,current%active\n ncc=1\n nac=0\n! write(*,98)'new:',0,nterm,istv,(indices(i,1),i=1,4),iref,iunit\n98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3)\n100 continue\n! write(*,98)'old:' ,current%nid,current%noofterms,current%statev,&\n! (current%indices(i,1),i=1,4),current%iref,current%iunit\n if(nterm.eq.0) then\n! write(*,*)'get_condition: ',istv,ncc,nac\n if(current%active.eq.0) then\n! this call just looks for active condition istv\n nac=nac+1\n! why should fix phase conditions have istv=nac?? Check!!\n if(nac.eq.istv) then\n! a condition specified like this must not be a phase status change\n if(current%statev.lt.0) then\n write(kou,*)'You must use \"set phase status\" to change fix status'\n else\n goto 150\n endif\n endif\n endif\n goto 200\n endif\n if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. &\n current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200\n do j1=1,nterm\n! do j2=1,4\n! if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200\n! enddo\n enddo\n150 continue\n! found condition\n pcond=>current\n! write(*,*)'Found condition: ',pcond%nid,ncc\n goto 1000\n200 continue\n current=>current%next\n ncc=ncc+1\n if(.not. associated(current,first)) goto 100\n900 continue\n! no such condition\n gx%bmperr=4131; goto 1000\n1000 continue\n return\n end subroutine extract_stvr_of_condition\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine locate_condition\n!\\begin{verbatim}\n subroutine locate_condition(seqz,pcond,ceq)\n! locate a condition using a sequential number\n implicit none\n integer seqz\n type(gtp_condition), pointer :: pcond\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ij\n! write(*,*)'In locate_condition 1'\n pcond=>ceq%lastcondition\n! write(*,*)'In locate_condition 2',seqz\n do ij=1,seqz\n pcond=>pcond%next\n! segmentation faults in this routine when locating ceq saved during step/map\n! write(*,*)'In locate_condition 3',ij\n if(seqz.gt.ij .and. associated(pcond,ceq%lastcondition)) then\n! write(*,*)'Locate condition called with illegal index: ',seqz\n gx%bmperr=4295; goto 1000\n endif\n enddo\n1000 continue\n return\n end subroutine locate_condition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine apply_condition_value\n!\\begin{verbatim}\n subroutine apply_condition_value(current,what,value,cmix,ccf,ceq)\n! This is called when calculating an equilibrium.\n! It returns a condition at each call, at first call current must be nullified?\n! When all conditions done the current is nullified again\n! If what=-1 then return degrees of freedoms and maybe something more\n! what=0 means calculate current values of conditions\n! calculate the value of a condition, used in minimizing G\n! ccf are the coefficients for conditions with several terms\n implicit none\n integer what,cmix(*)\n double precision value,ccf(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq \n TYPE(gtp_condition), pointer :: current\n!\\end{verbatim} %+\n! ceq is actually redundant as current is a pointer to condition list in ceq\n integer, dimension(4) :: indices\n integer iref,iunit,jx,istv,ip,linkix,nterms\n character encoded*60,actual_arg*60\n double precision xxx\n!\n100 continue\n if(current%active.ne.0) then \n! return 0 for inactive conditions\n cmix(1)=0; goto 1000\n endif\n if(what.ge.0) goto 200\n!----------------------------------------------------------\n! Here we should return information about conditions on potentials (T, P, MU)\n! and fix phases\n cmix(1)=0\n if(current%noofterms.gt.1) then\n if(current%statev.eq.111 .or.current%statev.eq.110) then\n! allow several terms for mole fractions and \\sum_i a_i*N(i)=0 !!\n! write(*,69)'3D in apply: ',current%statev,current%noofterms,&\n! ((current%indices(jx,nterms),jx=1,4),nterms=1,current%noofterms)\n69 format(a,i4,i2,3(2x,4i5))\n nterms=current%noofterms\n do jx=1,nterms\n ccf(jx)=current%condcoeff(jx)\n enddo\n! write(*,68)nterms,(ccf(jx),jx=1,nterms)\n!68 format('3D coeff: ',i2,6(1pe12.4))\n! VERY CLUMSY but maybe good for the moment\n elseif(current%statev.eq.21 .or. &\n current%statev.eq.130) then\n! implement S-S for EET calculations ...\n! and y-y for constitutions ....\n! write(*,*)'3D Apply_condition with several terms 1',current%statev,&\n! current%iref,current%iunit\n nterms=current%noofterms\n do jx=1,current%noofterms\n ccf(jx)=current%condcoeff(jx)\n! write(*,*)'3D: ',jx,(current%indices(istv,jx),istv=1,4)\n enddo\n! gx%bmperr=4207; goto 900\n else\n! cannot handle other conditions with several terms\n write(*,*)'3D Apply_condition with several terms 2',current%statev,&\n current%noofterms\n gx%bmperr=4207; goto 900\n endif\n else\n! one term with coefficient one\n ccf(1)=one\n nterms=1\n endif\n! for debugging\n istv=current%statev\n do jx=1,4\n indices(jx)=current%indices(jx,1)\n enddo\n iref=current%iref\n iunit=current%iunit\n ip=1\n encoded=' '\n actual_arg=' '\n! fetch value of symbol link if any\n if(current%symlink1.gt.0) then\n linkix=current%symlink1\n! if(btest(svflista(linkix)%status,SVFVAL)) then\n if(btest(svflista(linkix)%status,SVCONST)) then\n xxx=svflista(linkix)%linkpnode%value\n! wrong xxx=svflista(linkix)%svfv\n ceq%svfunres(linkix)=xxx\n! write(*,*)'3D SVFVAL apply: ',linkix,xxx\n else\n actual_arg=' '\n! no pointer to equilibrim record ... use firsteq ??\n! NOTE if symbol has bit SVCONST set then do not evaluate, use\n xxx=evaluate_svfun_old(linkix,actual_arg,1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3D error evaluate symbolic link as condition',linkix,xxx\n goto 1000\n endif\n endif\n current%prescribed=xxx\n endif\n!------------------\n if(current%statev.lt.0) then\n! a FIX PHASE condition has state variable equal to -iph, ics is stored in iref\n cmix(1)=4\n cmix(2)=-current%statev\n cmix(3)=current%iref\n value=current%prescribed\n! write(*,*)'3D Fix phase: ',-current%statev,current%iref,value\n elseif(current%statev.eq.1) then\n! temperature\n cmix(1)=1\n value=current%prescribed\n! write(*,*)'3D conditon on T'\n elseif(current%statev.eq.2) then\n! pressure\n cmix(1)=2\n value=current%prescribed\n! write(*,*)'3D conditon on P'\n elseif(current%statev.le.5) then\n! potentials has statev=1..5 (T, P, MU, AC, LNAC)\n cmix(1)=3\n cmix(2)=current%statev\n cmix(3)=current%indices(1,1)\n value=current%prescribed\n! write(*,*)'3D condition on MU/AC/LNAC'\n elseif(current%statev.ge.10) then\n! other condition must be on (normalized) extensive properties (N, X, H etc)\n cmix(1)=5\n! write(*,*)'3D Extensive condition: ',current%statev\n! SPECIAL FOR CONDITIONS ON Y to inhibit grid minimizer\n if(current%statev.eq.130) cmix(1)=6\n else\n! write(*,*)'3D Illegal condition',current%statev\n gx%bmperr=4208; goto 1000\n endif\n goto 900\n!--------------------------------------\n! Here we should return extensive condition, maybe calculate value\n200 if(what.ne.0) goto 300\n cmix(1)=0\n! for debugging\n istv=current%statev\n do jx=1,4\n indices(jx)=current%indices(jx,1)\n enddo\n iref=current%iref\n iunit=current%iunit\n ip=1\n encoded=' '\n actual_arg=' '\n!------------------\n if(current%statev.lt.10) goto 900\n! condition must be on extensive properties (N, X, B, W, H etc)\n cmix(1)=5\n cmix(2)=current%statev\n! indices are dimensioned (4,nterms)\n cmix(3)=current%indices(1,1)\n cmix(4)=current%indices(2,1)\n cmix(5)=current%indices(3,1)\n cmix(6)=current%indices(4,1)\n! for one term set coefficient to one\n ccf(1)=one\n! more than one term ... this is very clumy ...\n if(current%noofterms.gt.1) then\n do nterms=2,current%noofterms\n! 7, 8, 9 10 for second term, 11, 12, 13 14 for third etc\n cmix(4*nterms-1)=current%indices(1,nterms)\n cmix(4*nterms)=current%indices(2,nterms)\n cmix(4*nterms+1)=current%indices(3,nterms)\n cmix(4*nterms+2)=current%indices(4,nterms)\n enddo\n ip=current%noofterms\n do jx=1,ip\n ccf(jx)=current%condcoeff(jx)\n enddo\n! write(*,211)'3D Many terms: ',(cmix(jx),jx=1,4*ip+2)\n! write(*,212)'3D more: ',(ccf(jx),jx=1,ip)\n211 format(a,2i4,4(2x,44i3))\n212 format(a,4(1pe12.4))\n endif\n! if(current%noofterms.gt.2) then\n! write(*,*)'3D Apply_condition with more than 2 terms',current%noofterms\n! gx%bmperr=4207; goto 1000\n! endif\n value=current%prescribed\n if(iunit.eq.100) then\n! Prescribed value is in percent, divide value by 100\n value=1.0D-2*value\n! write(*,*)'3D iunit: ',iunit,value\n endif\n goto 900\n!--------------------------------------\n! this part is redundant ....\n300 continue\n! write(*,*)'Calling apply_condition with illegal option'\n gx%bmperr=4296; goto 1000\n!-----------------------------------------------------------\n! maybe something common\n900 continue\n!\n1000 continue\n return\n end subroutine apply_condition_value\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine condition_value\n!\\begin{verbatim} %-\n subroutine condition_value(mode,pcond,value,ceq)\n! set (mode=0) or get (mode=1) a new value of a condition. Used in mapping\n implicit none\n integer mode\n type(gtp_condition), pointer :: pcond\n type(gtp_equilibrium_data), pointer :: ceq\n double precision value\n!\\end{verbatim}\n if(mode.eq.0) then\n! set the value\n pcond%prescribed=value\n! special for T and P\n if(pcond%statev.eq.1) then\n ceq%tpval(1)=value\n elseif(pcond%statev.eq.2) then\n ceq%tpval(2)=value\n endif\n elseif(mode.eq.1) then\n value=pcond%prescribed\n else\n write(*,*)'Condition value called with illegal mode'\n endif\n1000 continue\n return\n end subroutine condition_value\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine ask_default_constitution\n!\\begin{verbatim}\n subroutine ask_default_constitution(cline,last,iph,ics,ceq)\n! set values of default constitution interactivly\n! phase and composition set already given\n implicit none\n character cline*(*)\n integer last,iph,ics\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokph,lokcs,ky,ll,iy,jy,is,ip,abel,subl\n real mmyfr(maxconst)\n character quest*32,name*24,vdef*4,fdef*8\n double precision xxx,mass\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n! if PHNOCV set the composition is fixed\n if(btest(phlista(lokph)%status1,PHNOCV)) goto 1000\n write(*,10)ics\n10 format('Give min or max fractions for composition set ',i2/&\n ' use < or negative value for max, > or positive for min',&\n ' or NONE for no default')\n name=' '\n ky=0\n do ll=1,phlista(lokph)%noofsubl\n if(phlista(lokph)%nooffr(ll).gt.1) then\n! more than one constituent\n do iy=1,phlista(lokph)%nooffr(ll)\n ky=ky+1\n! call get_phase_constituent_name(iph,ky,name,subl)\n call get_constituent_name(iph,ky,name,mass)\n if(gx%bmperr.ne.0) then\n write(*,*)'3D default: ',iph,ky,iy\n goto 1000\n endif\n quest='Default for '//name(1:len_trim(name))//&\n '#'//char(ichar('0')+ll)\n! use current value as default if nonzero\n vdef=' '\n abel=10*abs(ceq%phase_varres(lokcs)%mmyfr(ky))\n! write(*,*)'3D abel:',ky,abel,ceq%phase_varres(lokcs)%mmyfr(ky)\n if(abel.ge.10) then\n vdef=' 1.0'\n elseif(abel.le.0) then\n vdef=' 0.1'\n else\n vdef=' 0.'//char(ichar('0')+abel)\n endif\n if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.0.0) then\n vdef(1:1)='<'\n elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.0.0) then\n vdef(1:1)='>'\n else\n vdef='NONE'\n endif\n! modified for new online help\n! call gparcd(quest,cline,last,1,fdef,vdef,q1help)\n call gparcdx(quest,cline,last,1,fdef,vdef,&\n '?Amend phase default constit')\n jy=1\n if(fdef(1:4).eq.'NONE') then\n xxx=0\n is=1\n elseif(eolch(fdef,jy)) then\n xxx=-1.0D-1\n else\n is=1\n if(fdef(jy:jy).eq.'<') then\n is=-1\n jy=jy+1\n elseif(fdef(jy:jy).eq.'>') then\n jy=jy+1\n endif\n! write(*,*)'3D def1: ',fdef,jy\n call getrel(fdef,jy,xxx)\n if(buperr.ne.0) then\n! write(*,*)'3D buperr ',buperr\n buperr=0\n endif\n if(is.lt.0) xxx=-xxx\n endif\n if(abs(xxx).gt.one) xxx=sign(xxx,one)\n! write(*,*)'3D default: ',xxx\n mmyfr(ky)=real(xxx)\n enddo\n else\n! a single constituent, we must increment ky as there may be more\n ky=ky+1\n mmyfr(ky)=1.0\n endif\n enddo\n call enter_default_constitution(iph,ics,mmyfr,ceq)\n! write(*,99)(mmyfr(jy),jy=1,ky)\n99 format('3D defy: ',15(f5.1))\n1000 continue\n return\n end subroutine ask_default_constitution\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine enter_default_constitution\n!\\begin{verbatim}\n subroutine enter_default_constitution(iph,ics,mmyfr,ceq)\n! user specification of default constitution for a composition set\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer iph,ics\n real mmyfr(*)\n!\\end{verbatim}\n integer lokph,lokcs,jl,jk\n! write(*,*)'3D In enter_default_constitution ',iph,ics\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n jk=size(ceq%phase_varres(lokcs)%yfr)\n! write(*,909)lokph,lokcs,phlista(lokph)%tnooffr,ceq%eqno,&\n! size(ceq%phase_varres),size(ceq%phase_varres(lokcs)%mmyfr),jk\n909 format('3D 2699: ',10i4)\n! write(*,46)'3D y: ',(ceq%phase_varres(lokcs)%yfr(jl),jl=1,jk)\n46 format(a,10(F7.3))\n if(.not.allocated(ceq%phase_varres(lokcs)%mmyfr)) then\n! for some reason I have not always allocated this ...\n allocate(ceq%phase_varres(lokcs)%mmyfr(phlista(lokph)%tnooffr))\n endif\n do jl=1,phlista(lokph)%tnooffr\n ceq%phase_varres(lokcs)%mmyfr(jl)=mmyfr(jl)\n! write(*,47)'3D jl: ',jl,mmyfr(jl),&\n! firsteq%phase_varres(lokcs)%mmyfr(jl),&\n! ceq%phase_varres(lokcs)%mmyfr(jl)\n enddo\n47 format(a,i2,10F7.3)\n! set bit indicating that this composition set has a default constitution\n! write(*,*)'3D enter_default_constitution?? ',lokcs,&\n! ceq%phase_varres(lokcs)%mmyfr(phlista(lokph)%tnooffr)\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSDEFCON)\n1000 continue\n return\n end subroutine enter_default_constitution\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_input_amounts\n!\\begin{verbatim}\n subroutine set_input_amounts(cline,lpos,ceq)\n! set amounts like n(specie)=value or b(specie)=value\n! value can be negative removing amounts\n! values are converted to moles and set or added to conditions\n implicit none\n integer lpos\n character cline*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_state_variable), target :: svr1\n TYPE(gtp_state_variable), pointer :: svr\n TYPE(gtp_condition), pointer :: current,first,last\n character species*32,cval*16,statevar*4,condline*32\n integer ielno(10)\n double precision addval(maxel)\n integer k,loksp,istv,jel,ip\n double precision xval,sumstoi,xmols\n! repeat reading until empty line\n100 continue\n addval=zero\n call gparcx('Species and amount as N(..)= or B(...)= : ',&\n cline,lpos,1,species,' ','?Set input amounts')\n call capson(species)\n statevar=species(1:1)\n if(statevar.ne.' ') then\n if(.not.(statevar(1:1).ne.'N' .or. statevar(1:1).ne.'B')) then\n write(*,*)'Illegal state variable for input amounts'\n goto 1000\n endif\n k=index(species,')')\n if(k.le.3) then\n write(*,*)'Species must be surrounded by ( )'\n gx%bmperr=4297; goto 1000\n endif\n cval=species(k+1:)\n! this line gave compilation warning moving 32 bytes from a space of (max) 30\n species=species(3:k-1)//' '\n! write(*,*)'3D Species: ',trim(species),' <',trim(cval),'> '\n if(index(species,',').gt.0 .or. index(species,'(').gt.0) then\n write(*,*)'Use only N(species) or B(species) in input amounts'\n goto 1000\n endif\n else\n goto 1000\n endif\n call find_species_record(species,loksp)\n! not needed as we can access splista\n! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp)\n if(gx%bmperr.ne.0) goto 1000\n! if user writes N(C)=2 the =2 will be in cval, if a space after = in cline\n if(cval(1:1).eq.'=') goto 300\n! goto 300\n200 continue\n! the user can also give values without = or with a space before =\n! but no space allowed after =\n! write(*,*)'3D cline: ',trim(cline),lpos\n call gparcx('Amount: ',cline,lpos,1,cval,' ','?Set input amounts')\n300 continue\n if(cval(1:1).eq.'=') cval(1:1)=' '\n ip=1\n! write(*,*)'3D cval: ',trim(cval),ip\n call getrel(cval,ip,xval)\n if(buperr.ne.0) then\n write(*,*)'Amount must be a real number'\n goto 1000\n endif\n! write(*,*)'3D xval: ',xval\n! this return the internal code for N\n! BUG here as svr is no longer allocated in decode_state_variable to avoid\n! memory leaks\n svr=>svr1\n call decode_state_variable('N ',svr,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error decoding N in set_input_amounts'\n goto 1000\n endif\n istv=svr%oldstv\n! if B convert to N: moles of species = input_mass/mass_of_species\n! moles of element = stoiciometry_of_element/total_number_of_elements\n if(statevar(1:1).eq.'B') then\n write(kou,*)'Note: set input in mass converted to moles'\n xmols=xval/splista(loksp)%mass\n else\n xmols=xval\n endif\n sumstoi=zero\n do jel=1,splista(loksp)%noofel\n ielno(jel)=splista(loksp)%ellinks(jel)\n addval(ielno(jel))=splista(loksp)%stoichiometry(jel)*xmols\n sumstoi=sumstoi+splista(loksp)%stoichiometry(jel)\n enddo\n! now create or att to existing conditions\n last=>ceq%lastcondition\n jel=1\n if(.not.associated(last)) goto 600\n! return here to look for condition for another element\n500 continue\n! write(*,*)'At 500',last%nid,last%next%nid \n first=>last%next\n current=>first\n! loop for all condition\n510 continue\n! write(*,*)'loop: ',current%nid,current%indices(1,1),ielno(jel)\n! check if this condition match amount of element jel\n if(current%noofterms.eq.1) then\n if(current%statev.eq.istv) then\n if(current%indices(1,1).eq.ielno(jel) .and. &\n current%indices(2,1).eq.0) then\n! we have found an identical contition, add the new amount\n! if condition not active (active=/=0) then activate and zero prescibed amount\n if(current%active.ne.0) then\n current%active=0\n current%prescribed=zero\n endif\n current%prescribed=current%prescribed+addval(ielno(jel))\n goto 700\n endif\n endif\n endif\n current=>current%next\n! write(*,*)'next: ',current%nid,first%nid\n if(.not.associated(current,first)) goto 510\n600 continue\n! new condition needed\n condline='N('//ellista(ielno(jel))%symbol&\n (1:len_trim(ellista(ielno(jel))%symbol))//')='\n ip=len_trim(condline)+1\n call wrinum(condline,ip,10,0,addval(ielno(jel)))\n! write(*,*)'new condition: ',condline\n! set_condition starts by incementing ip\n ip=0\n call set_condition(condline,ip,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(.not.associated(last)) then\n! if ceq%lastcondition was not associated above the call to set_condition\n! will have set link in ceq%lastcondition\n last=>ceq%lastcondition\n! write(*,*)'condition id: ',last%nid\n endif\n700 continue\n jel=jel+1\n if(jel.le.splista(loksp)%noofel) goto 500\n! all elements for this species set as conditions, check if any more\n if(.not.eolch(cline,lpos)) goto 100\n!\n1000 continue\n! possible memory leaks. Maybe also current, last\n nullify(svr)\n return\n end subroutine set_input_amounts\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n" }, { "path": "src/models/gtp3E.F90", "content": "!\n! gtp3E included in gtp3.F90\n!\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 9A. Section: read and save on files using TDB/UNFORMATTED MM\n!> The XML read/write is in gtp3EX.F90\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsave\n!\\begin{verbatim}\n subroutine gtpsave(filename,str)\n! save all data on file: unformatted, direct, TDB, LaTeX, XTDB or macro\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n!\n implicit none\n character*(*) filename,str\n!\\end{verbatim}\n! separate UNFORMATTED, DIRECT, TDB, MACRO or LaTeX or XTDB\n if(str(1:1).eq.'U') then\n! unformatted\n call gtpsaveu(filename,str(3:))\n elseif(str(1:1).eq.'D') then\n! direct (random access) ..... not implemented\n call gtpsavedir(filename,str(3:))\n elseif(str(1:1).eq.'T') then\n! TDB format\n write(*,*)'In gtpsave '\n call gtpsavetdb(filename,str(3:))\n elseif(str(1:1).eq.'L') then\n! LaTeX format NOT IMPLEMENTED\n call gtpsavelatex(filename,str(3:))\n elseif(str(1:1).eq.'X') then\n! XTDB format\n call write_xtdbformat(filename,str(3:))\n else\n! macro format\n call gtpsavetm(filename,str)\n endif\n1000 continue\n return\n end subroutine gtpsave\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsavelatex\n!\\begin{verbatim}\n subroutine gtpsavelatex(filename,specification)\n! save all data on LaTeX format on a file (for publishing)\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n! equilibrium record(s) with conditions, componenets, phase_varres records etc\n! anything else?\n implicit none\n character*(*) filename,specification\n!\\end{verbatim} %+\n1000 continue\n return\n end subroutine gtpsavelatex\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsavedir\n!\\begin{verbatim} %-\n subroutine gtpsavedir(filename,specification)\n! save all data on a direct file (random access)\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n! equilibrium record(s) with conditions, componenets, phase_varres records etc\n! anything else?\n implicit none\n character*(*) filename,specification\n!\\end{verbatim} %+\n1000 continue\n return\n end subroutine gtpsavedir\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsavetm\n!\\begin{verbatim}\n subroutine gtpsavetm(filename,str)\n! save all data on file in macro format\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n!\n implicit none\n character*(*) filename,str\n!\\end{verbatim} %+\n logical tdbmode\n if(str(1:1).eq.'T') then\n! TDB file\n tdbmode=.true.\n else\n! MACRO mode\n tdbmode=.false.\n endif\n write(*,*)'TDB and MACRO save not implemented yet'\n goto 1000\n! UNFINISHED ....\n! open file and write a macro file\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n!\n! For inspiration look at the LIST subroutines in pmod25E.F90\n!\n1000 continue\n return\n end subroutine gtpsavetm\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsavetdb\n!\\begin{verbatim}\n subroutine gtpsavetdb(filename,specification)\n! save all data in TDB format on an file UNFINISHED\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n! equilibrium record(s) with conditions, componenets, phase_varres records etc\n! anything else?\n implicit none\n character*(*) filename,specification\n!\\end{verbatim}\n write(*,*)'Save TDB using gtpsavetdb not implemented'\n1000 continue\n return\n end subroutine gtpsavetdb\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpsaveu\n!\\begin{verbatim}\n subroutine gtpsaveu(filename,specification)\n! save all data unformatted on an file\n! First move it to an integer workspace, then write that on a file\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! state variable functions\n! references\n! equilibrium record(s) with conditions, componenets, phase_varres records etc\n! anything else?\n implicit none\n character*(*) filename,specification\n!\\end{verbatim} %+\n!\n character id*40,comment*72\n! size of workspace for unformatted storage\n integer miws\n integer, allocatable, dimension(:) :: iws\n integer i,isp,jph,lokph,lut,last,lok,rsize,displace,ibug,ffun,lokeq,ccc\n integer nspx,check\n! these depend on hardware, bytes/word and words/double. Defined in metlib3\n! integer, parameter :: nbpw=4,nwpr=2\n! integer function nwch calculates the number of words to store a character\n! write(*,*)'3E In gtpsaveu: ',trim(specification),' version: ',trim(savefile)\n!\n! positions reserved in the beginning of the workspace\n! 3 element list\n! 4 element version\n! 5 species list\n! 6 species version\n! 7 tpfun list \n! 8 tpfun version\n! 9 phlista lista\n! 10 phase version\n! 11 endmember version\n! 12 interaction version\n! 13 property version\n! 14 phase tuples lista\n! 15 phase tuples version\n! 16 equilibrium lista\n! 17 equilibrium data version\n! 18 component version\n! 19 phase_varres version\n! 20 global data record\n! 21 global data version (not saved?)\n! 22 bibliography lista\n! 23 bibliography version\n! 24 svfun lista\n! 25 svfun version\n! 26 assessment record list\n! 27 assessment version\n! 28 zero for unencypted, nonzero for encrypted\n! 29\n! 30\n! missing: parameter_id_lista ... step/map/plot data\n! range record? experiments ...\n!----------------------------------------------------------------------\n! allocate the workspace, words 3-102 for pointers and things listed above\n! write(*,*)'3E allocating iws',miws\n if(btest(globaldata%status,GSNOPHASE)) then\n write(*,1)\n1 format('There is no data to save!')\n goto 1001\n endif\n! dimension iws depending on number of equuilibria stored\n! 7000 is for a 6 component system with 50 phases\n! steel1 with 6 elements: 30000 static and 6000 per equilibrium\n! TAFID 15 elements: 90000 for static and 30000 per equilibrium\n! TAFID 41 elements, 350 phases: 300000 for static and 120000 per equilibrium\n! estimate static: nel*nph*x; x=30: static=100000+nel*nph*30\n! equilibrium: 40*350*10 ... too small when few elements\n ccc=max(20*noofel*noofph,10000)\n! eqfree may not be the higest used equilibrium record!!\n i=eqfree\n last=eqfree\n do while(eqlista(i)%nexteq.gt.0)\n if(eqlista(i)%nexteq.ne.i+1) then\n! if eqlista(i)%nexteq does not increment sequentially there are some holes!\n last=eqlista(i)%nexteq\n write(*,*)'3E Beware: unused equilibria before the last used,'//&\n ' cannot be saved'\n gx%bmperr=4399; goto 1000\n endif\n i=eqlista(i)%nexteq\n enddo\n! \n miws=100000+noofel*noofph*30+ccc*last\n! miws=2000000+50000*eqfree\n! write(*,*)'3E allocating workspace: ',miws\n write(*,7)'3E allocating workspace: ',miws,30*noofel*noofph,ccc,last\n7 format(a,i10,10x,'(',i7,', ',i7,', ',i4,')')\n allocate(iws(miws))\n call winit(miws,100,iws)\n if(buperr.ne.0) goto 1100\n!----------------------------------------------------------------------\n! note the use of gtp_xxx_version to handle versions of data structures\n!----------------------------------------------------------------------\n!\n!>>>>> 1: elementlist\n! write(*,*)'3E nbpw and nwpr: ',nbpw,nwpr,nwch(1)\n! rsize=1+1+12/nbpw+24/nbpw+3*nwpr+4 should be enough but ....\n rsize=1+1+nwch(12)+nwch(24)+3*nwpr+5\n! write(*,*)'3E Storing elements',noofel,rsize\n last=3\n iws(last+1)=gtp_element_version\n do i=1,noofel\n! next, symbol*2, name*12, ref_state*24, mass, h298, s298,\n! splink, status, alphaindex, refstatesymbol\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving element record'\n gx%bmperr=4356; goto 1100\n endif\n call storc(lok+1,iws,ellista(i)%symbol)\n call storc(lok+2,iws,ellista(i)%name)\n displace=3+nwch(12)\n call storc(lok+displace,iws,ellista(i)%ref_state)\n displace=displace+nwch(24)\n call storr(lok+displace,iws,ellista(i)%mass)\n call storr(lok+displace+nwpr,iws,ellista(i)%h298_h0)\n call storr(lok+displace+2*nwpr,iws,ellista(i)%s298)\n displace=displace+3*nwpr\n iws(lok+displace)=ellista(i)%splink\n iws(lok+displace+1)=ellista(i)%status\n iws(lok+displace+2)=ellista(i)%alphaindex\n iws(lok+displace+3)=ellista(i)%refstatesymbol\n! write(*,*)'3E element: ',i,displace+3,rsize,ellista(i)%refstatesymbol\n! link sequentially in first word\n iws(last)=lok\n last=lok\n ibug=lok+displace+3\n! write(*,*)'3E refstatesymbol 0: ',ibug,iws(ibug),iws(1)\n enddo\n! bug??\n! added one saved integer for size of spextra (normally zero)\n ibug=lok+displace+4\n! write(*,*)'3E refstatesymbol 1: ',ibug,iws(ibug),iws(1)\n!-----------\n!>>>>> 2: specieslist\n rsize=1+nwch(24)+3*nwpr+3\n! next, symbol*24, mass, charge, extra, noofel, status, alphaindex\n! (allocated) ellinks, stoichiometry\n! write(*,*)'3E storing species',noofsp,rsize,'+ellinks'\n last=5\n iws(last+1)=gtp_species_version\n do isp=1,noofsp\n if(allocated(splista(isp)%spextra)) then\n nspx=size(splista(isp)%spextra)\n else\n nspx=0\n endif\n check=rsize+splista(isp)%noofel*(1+nwpr)+nspx*nwpr\n call wtake(lok,rsize+splista(isp)%noofel*(1+nwpr)+nspx*nwpr,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving species record'\n gx%bmperr=4356; goto 1100\n endif\n! write(*,*)'3E refstatesymbol 2: ',ibug,iws(ibug),lok\n call storc(lok+1,iws,splista(isp)%symbol)\n displace=2+nwch(24)\n call storr(lok+displace,iws,splista(isp)%mass)\n call storr(lok+displace+nwpr,iws,splista(isp)%charge)\n iws(lok+displace+2*nwpr)=splista(isp)%noofel\n iws(lok+displace+2*nwpr+1)=splista(isp)%status\n iws(lok+displace+2*nwpr+2)=splista(isp)%alphaindex\n iws(lok+displace+2*nwpr+3)=nspx\n! displace one less as the index i is added\n displace=displace+2*nwpr+3\n do i=1,splista(isp)%noofel\n iws(lok+displace+i)=splista(isp)%ellinks(i)\n enddo\n displace=displace+splista(isp)%noofel+1\n! storing splista(isp)%noofel doubles in iws(lok+displace)\n! write(*,*)'3E displace store: ',lok,displace\n! storrn starts storing in iws(lok+displace)\n call storrn(splista(isp)%noofel,&\n iws(lok+displace),splista(isp)%stoichiometry)\n! if nspx>0 save also all double variables in spextra\n if(nspx.gt.0) then\n displace=displace+splista(isp)%noofel*nwpr\n call storrn(nspx,iws(lok+displace),splista(isp)%spextra)\n! write(*,*)'3E species with extra data: ',isp,nspx\n endif\n! write(*,'(a,2i5)')'3E species record check: ',check,&\n! displace+nspx*nwpr\n! write(*,*)'3E refstatesymbol 3: ',ibug,iws(ibug),lok+displace\n! do i=1,splista(isp)%noofel\n! call storr(lok+displace+(i-1)*nwpr,iws,\n! enddo\n! write(*,*)'3E stored species ',isp,lok,displace+splista(isp)%noofel*nwpr\n! link records sequentially in first word\n iws(last)=lok\n last=lok\n enddo\n! write(*,*)'3E last species link: ',last,lok,iws(lok),iws(1)\n!\n!------------- tpfuns\n!>>>>> 20: tpfuns\n call wtake(lok,freetpfun,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving tpfun record'\n gx%bmperr=4356; goto 1100\n endif\n iws(7)=lok\n iws(8)=tpfun_expression_version\n iws(lok)=freetpfun\n! write(*,*)'3E saving TPfuns: ',iws(7),iws(iws(7))\n do i=1,freetpfun-1\n! store all TPfuns here. In parameters just store an index!\n! we have to pass iws also ....\n call save0tpfun(ffun,iws,i)\n if(gx%bmperr.ne.0) goto 1100\n! write(*,*)'3E TPfun: ',i,' stored in ',iws(lok+i),iws(iws(lok+i))\n iws(lok+i)=ffun\n enddo\n! write the record for TP function 3 as check\n! call wrttprec(3,iws)\n! All seems OK this far\n!------------- phases and parameters, static data\n!>>>>> 3: phaselist, start from 0 (reference phase)\n! including sublattces, endmembers, interactions, properties etc\n! save version of various records\n! write(*,*)'3E saving phases',noofph\n last=9\n iws(last+1)=gtp_phase_version\n iws(last+2)=gtp_endmember_version\n iws(last+3)=gtp_interaction_version\n iws(last+4)=gtp_property_version\n call savephases(last,iws)\n if(gx%bmperr.ne.0) goto 1100\n! save all phase tuples in a single reord\n last=14\n iws(last+1)=gtp_phasetuple_version\n! write(*,*)'3E Saving tuples: ',nooftuples\n if(nooftuples.gt.0) then\n call wtake(lok,1+nooftuples*5,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving phase tuple record'\n gx%bmperr=4356; goto 1100\n endif\n iws(lok)=nooftuples\n do i=0,nooftuples-1\n iws(lok+5*i+1)=phasetuple(i+1)%lokph\n iws(lok+5*i+2)=phasetuple(i+1)%compset\n iws(lok+5*i+3)=phasetuple(i+1)%ixphase\n iws(lok+5*i+4)=phasetuple(i+1)%lokvares\n iws(lok+5*i+5)=phasetuple(i+1)%nextcs\n enddo\n iws(last)=lok\n else\n! no phase tuples\n iws(last)=0\n endif\n! write(*,*)'3E tuples saved: '\n!------------------------------------\n! save link to the global data record and version in 20-21\n last=20\n! extended globaldata record 190317/BoS\n rsize=1+nwch(24)+3*nwpr+11+5*nwpr\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving globaldata record'\n gx%bmperr=4356; goto 1100\n endif\n iws(last)=lok\n iws(lok+1)=globaldata%status\n call storc(lok+2,iws,globaldata%name)\n! BUG name was ovewritten by rgas etc !!!\n displace=2+nwch(24)\n call storr(lok+displace,iws,globaldata%rgas)\n call storr(lok+displace+nwpr,iws,globaldata%rgasuser)\n call storr(lok+displace+2*nwpr,iws,globaldata%pnorm)\n! extended globaldata record 190317/BoS\n displace=displace+3*nwpr\n! these used for testing when reading\n! globaldata%sysparam(1)=987\n! globaldata%sysparam(10)=17\n do i=0,9\n iws(lok+displace+i)=globaldata%sysparam(i+1)\n enddo\n displace=displace+10\n! globaldata%sysreal(5)=12345678.9D0\n call storrn(5,iws(lok+displace),globaldata%sysreal)\n! write(*,*)'3E globalsave:: ',rsize,displace+5*nwpr\n! write(*,*)'3E name: \"',globaldata%name,'\"'\n! goto 900\n! unfinished\n!------------- state variable functions\n!>>>>> 30: svfuns\n! write(*,*)'3E saving state variable functions'\n call svfunsave(lok,iws,firsteq)\n if(gx%bmperr.ne.0) goto 1100\n iws(24)=lok\n iws(25)=gtp_putfun_lista_version\n!------------- references\n!>>>>> 40: bibliographic references\n! write(*,*)'3E saving bibliography'\n! link to bibliography is stored in 22\n call bibliosave(lok,iws)\n if(gx%bmperr.ne.0) goto 1100\n iws(22)=lok\n iws(23)=gtp_biblioref_version\n! document use of workspace\n call wrkchk(rsize,miws,iws)\n write(*,*)'3E used ',rsize,' words out of ',miws,' for storing static data'\n!-------------------------------------------------------\n! write the equilibrium records\n! conditions, components, phase_varres for all composition sets etc\n!>>>>> 50: equilibria\n! write(*,*)'3E saving equilibria'\n! write(lut)gtp_equilibrium_data_version,gtp_component_version,&\n! gtp_phase_varres_version\n lokeq=0\n! all equilibria are saved here\n call saveequil(lokeq,iws)\n if(gx%bmperr.ne.0) goto 1100\n! finished saving equilibria\n! write(*,*)'3E first saved equilibrium at: ',lokeq\n iws(16)=lokeq\n iws(17)=gtp_equilibrium_data_version\n iws(18)=gtp_component_version\n iws(19)=gtp_phase_varres_version\n! disfra record version??\n!-------------------------------------------------------\n! assessment head record\n write(*,*)'3E Saving assessment record'\n if(associated(firstash)) then\n iws(27)=gtp_assessment_version\n lok=26\n call saveash(lok,iws)\n if(gx%bmperr.ne.0) goto 1100\n endif\n! free list for phase_varres records\n! write(*,*)'3E Phase_varres first free/highcs: ',csfree,highcs\n! UNFINISHED we should write assessment records and step/map/plot records\n!-------------------------------------------------------\n! finally write the workspace to the file ...\n900 continue\n if(index(filename,'.').eq.0) then\n filename(len_trim(filename)+1:)='.OCU'\n endif\n lut=21\n!**********************************************************\n! IMPORTANT savefile\n! is a variable in gtp3.F90\n! which MUST BE CHANGED whenever there is a change in the unformatted\n! file layout\n!***********************************************************\n open(lut,file=filename,access='sequential',status='unknown',&\n form='unformatted',iostat=gx%bmperr,err=1000)\n id='This is a save file for OC version: '\n comment=specification\n call wrkchk(rsize,miws,iws)\n! NOTE: savefile is a character*8 in gtp3.F90\n last=5+nwch(40)+nwch(8)+nwch(72)\n!----------------------------------------------------------------------\n! write(*,*)'3E save unformatted:',rsize,globaldata%encrypted\n if(globaldata%encrypted.ne.0) then\n iws(rsize+1)=18\n else\n! not encrypted\n iws(rsize+1)=0\n endif\n!----------------------------------------------------------------------\n write(lut)id,savefile,comment,noofel,noofsp,noofph,nooftuples,rsize+5\n write(lut)(iws(i),i=1,rsize+5)\n close(lut)\n if(buperr.ne.0) then\n write(kou,990)buperr\n990 format(/' *** WARNING *** , workspace save error: ',i7/)\n endif\n write(kou,989)rsize+5+last,miws,1.0D2*real(rsize+5+last)/real(miws)\n989 format('Used ',i8,' words out of ',i8,', ',&\n F6.2,'% for unformatted memory save')\n write(kou,991)nbpw*(rsize+5+last),trim(filename)\n991 format('Written workspace ',i10,' bytes unformatted on ',a)\n1000 continue\n deallocate(iws)\n1001 continue\n return\n1100 continue\n write(*,*)'3E Error storing record, nothing written on file',buperr,gx%bmperr\n gx%bmperr=4357\n goto 1000\n end subroutine gtpsaveu\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine savephases\n!\\begin{verbatim}\n subroutine savephases(phroot,iws)\n! save data for all phases and store pointer in iws(phroot)\n! For phases with disordered set of parameters we must access the number of\n! sublattices via firsteq\n implicit none\n integer phroot,iws(*)\n!\\end{verbatim} %+\n integer doneord,i,j,level,lokcs,nem,noi,nop,nox,nsl,nup,noendm,fipsize\n integer iph,lok,rsize,displace,lokph,iwsph,lokem,lastem,lokpty,last\n integer phreclink\n type(gtp_endmember), pointer :: emrec\n type(gtp_interaction), pointer :: intrec\n type(gtp_property), pointer :: proprec\n character*8 dummy\n logical higher\n! to keep track of interaction records\n type saveint\n type(gtp_interaction), pointer :: p1\n integer lok\n end type saveint\n type(saveint), dimension(:), pointer :: stack\n type(gtp_phase_add), pointer :: addlink\n allocate(stack(5))\n! do not save the phases array, regenerate it on read\n! call wtake(lok,noofph+1,iws)\n! do i=1,noofph\n! iws(lok+i)=phases(i)\n! enddo\n! store this link in last and set link to next in first word\n! iws(last)=lok\n! last=lok\n! loop for all phases\n iwsph=phroot\n! phases start from 0, the SER phase\n do iph=0,noofph\n! lokph=phases(iph)\n lokph=iph\n!>>>>> 5: phase header\n! link,name*24,model*72,phletter*1,status1,alphaindex,noofcs,nooffs,additionlink\n rsize=1+nwch(24)+nwch(72)+nwch(1)+5\n! the endmember_ord, endmember_dis and endmemrecarray is not used ...\n! noofsubl,tnooffr,linktocs(9),nooffr(subl),constlist(tnooffr),i2slx\n rsize=rsize+2+9+phlista(lokph)%noofsubl+phlista(lokph)%tnooffr+2\n! we must also have links to two endmember lists and addtions\n rsize=rsize+3\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving phase record',trim(phlista(lokph)%name),&\n buperr\n gx%bmperr=4356; goto 1000\n endif\n! link all phase records sequentially from phroot using iwsph\n iws(iwsph)=lok\n iwsph=lok\n! store phase data\n! write(*,*)'3E creating record for ',trim(phlista(lokph)%name),lok\n call storc(lok+1,iws,phlista(lokph)%name)\n displace=1+nwch(24)\n call storc(lok+displace,iws,phlista(lokph)%models)\n displace=displace+nwch(72)\n! we should store at least 4 characters ...\n dummy=phlista(lokph)%phletter\n call storc(lok+displace,iws,dummy(1:4))\n displace=displace+1\n iws(lok+displace)=phlista(lokph)%status1\n iws(lok+displace+1)=phlista(lokph)%alphaindex\n iws(lok+displace+2)=phlista(lokph)%noofcs\n iws(lok+displace+3)=phlista(lokph)%nooffs\n! mark there are additions, it is handled below\n! if(associated(phlista(lokph)%additions)) then\n! iws(lok+displace+4)=1\n! endif\n if(allocated(phlista(lokph)%oendmemarr)) then\n write(*,*)'3E Attention!! ignoring endmemberrec array!'\n endif\n!>>>>> 6: sublattice and constituent info\n nsl=phlista(lokph)%noofsubl\n iws(lok+displace+4)=nsl\n j=phlista(lokph)%tnooffr\n iws(lok+displace+5)=j\n! displace one less as loops starts from 1\n displace=displace+5\n do i=1,9\n iws(lok+displace+i)=phlista(lokph)%linktocs(i)\n enddo\n displace=displace+9\n do i=1,nsl\n iws(lok+displace+i)=phlista(lokph)%nooffr(i)\n enddo\n displace=displace+nsl\n do i=1,j\n iws(lok+displace+i)=phlista(lokph)%constitlist(i)\n enddo\n displace=displace+j+1\n! saving i2sl is probably not necessary as it is calculated each time ??\n iws(lok+displace)=phlista(lokph)%i2slx(1)\n iws(lok+displace+1)=phlista(lokph)%i2slx(2)\n! links to endmembers and additions to be stored here and afterwards\n! iws(phreclink) ordered, iws(phreclink+1) disordered, iws(phreclink+2) addition\n phreclink=lok+displace+2\n! write(*,*)'3E phreclink 1: ',phreclink,iws(1)\n!--------- endmember list, interaction tree and property records\n! save all parameter data starting from the endmember list\n doneord=0\n emrec=>phlista(lokph)%ordered\n! write(*,*)'3E saving endmembers',doneord,nsl\n! there can be phases without any ordered parameters ...\n if(.not.associated(emrec)) goto 400\n! The start of the sequentail list of endmember records (for ordered fractions)\n lokem=phreclink\n! we come back here if there are disordered parameters\n200 continue\n! if doneord=1 then we have listed the ordered parameters\n if(doneord.eq.1) then\n emrec=>phlista(lokph)%disordered\n if(ocv()) write(*,*)'3E Saving disordered parameters'\n endif\n emlista: do while(associated(emrec))\n proprec=>emrec%propointer\n intrec=>emrec%intpointer\n! nop=0\n! noi=0\n! nem=0\n! if(associated(proprec)) nop=1\n! if(associated(intrec)) noi=1\n! if(associated(emrec%nextem)) nem=1\n!>>>>> 7: endmember record (basic or disordered)\n! write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem\n! do j=1,emrec%noofpermut\n! write(lut)(emrec%fraclinks(i,j),i=1,nsl)\n! enddo\n! In the endmember recorde we store:\n! link to next endmember, link to interaction, link to property record : 3\n! link to phase record, number of permutations, seq.order of creation? : 3\n! for each permutation nsl indices to fractions : perm*nsl\n!\n rsize=6+emrec%noofpermut*nsl\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving endmember record'\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E emrec: ',emrec%noofpermut,lok,rsize,emrec%antalem\n! maintain the sequential link between all endmember records\n iws(lokem)=lok\n lokem=lok\n! iws(lok) to next, iws(nop=lok+1) to property, iws(noi=lok+2) to intercation, \n! these are nem, noi, nop\n! write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem\n iws(lok+3)=emrec%noofpermut\n iws(lok+4)=emrec%phaselink\n iws(lok+5)=emrec%antalem\n displace=5\n do j=1,emrec%noofpermut\n do i=1,nsl\n iws(lok+displace+i)=emrec%fraclinks(i,j)\n enddo\n displace=displace+nsl\n! write(lut)(emrec%fraclinks(i,j),i=1,nsl)\n enddo\n! this is the place to store the start of property records\n nop=lok+1\n level=nop\n emproplista: do while(associated(proprec))\n! if(associated(proprec%nextpr)) nox=1\n!>>>>> 8: endmember property record (loop) add place for %modelparamid\n! rsize=5+nwch(16)+proprec%degree+1\n rsize=5+nwch(20)+proprec%degree+1\n call wtake(lokpty,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving endmember record'\n gx%bmperr=4356; goto 1000\n endif\n! link the property recordds sequentially\n iws(nop)=lokpty\n! write(*,*)'3E endmem property record',iws(nop),lokpty,&\n! proprec%proptype,proprec%degree\n level=nop\n nop=lokpty\n! write(lut)proprec%reference,proprec%proptype,&\n! proprec%degree,proprec%extra,proprec%antalprop,nox\n iws(lokpty+1)=proprec%proptype\n iws(lokpty+2)=proprec%degree\n iws(lokpty+3)=proprec%extra\n iws(lokpty+4)=proprec%antalprop\n call storc(lokpty+5,iws,proprec%reference)\n displace=5+nwch(16)\n! write(*,*)'place to save modelparamid 1: ',&\n! proprec%modelparamid,lokpty+displace\n call storc(lokpty+displace,iws,proprec%modelparamid)\n displace=displace+nwch(4)\n do i=0,proprec%degree\n! store a link in iws(lokpty+displace+i) to the TP fun stored as a text\n! we have to pass iws also ....\n! call save1tpfun(lut,.FALSE.,proprec%degreelink(i))\n! third argument 1 means do not store function name\n! call save2tpfun(lokpty+displace+i,iws,1,proprec%degreelink(i))\n! if(gx%bmperr.ne.0) goto 1000\n iws(lokpty+displace+i)=proprec%degreelink(i)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3E place of function: ',iws(lokpty+displace+i),&\n! ' stored in ',lokpty+displace+i,iws(1)\n enddo\n proprec=>proprec%nextpr\n enddo emproplista\n! at the end of the propoerty list iws(lokpty)=0 (zero)\n! start interaction tree\n level=0\n noi=lokem+2\n! return here for new interaction record\n300 continue\n intlista: do while(associated(intrec))\n! noi is next, nup is higher, nop is property\n310 continue\n!>>>>> 9: interaction record\n! next, higher,property,status,antalint,order,fipsize :7\n! very complex for permutations ...\n! look in gtp3G, create_interaction, for use of intrec%noofip\n! noofip,sublattice(noofip),fraclink(noofip) \n! write(*,*)'3E save link: ',intrec%antalint,intrec%noofip(2)\n fipsize=size(intrec%noofip)\n! 2020.06.08/BoS problem handling interactions permutations ???\n! should there be something separate for level=2 ???\n! Sometimes error when reading a parameter level=2 WITHOUT any permutations\n if(level.eq.1) then\n rsize=7+fipsize+2*intrec%noofip(fipsize)\n else\n rsize=7+fipsize+2*intrec%noofip(2)\n endif\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving interaction record',&\n buperr,rsize,fipsize\n gx%bmperr=4356; goto 1000\n endif\n! store data\n iws(lok+3)=intrec%status\n iws(lok+4)=intrec%antalint\n iws(lok+5)=intrec%order\n iws(lok+6)=fipsize\n displace=6\n do i=1,fipsize\n iws(lok+displace+i)=intrec%noofip(i)\n enddo\n displace=displace+fipsize\n! intrec%noofip(2) is OK for 1st order, for 2nd order we must use\n! intrec%noofip(fipsize)\n! write(*,*)'3E fipsize: ',level,fipsize,&\n! intrec%noofip(2),intrec%noofip(fipsize)\n if(level.ne.1) then\n do i=1,intrec%noofip(2)\n iws(lok+displace+2*i-1)=intrec%sublattice(i)\n iws(lok+displace+2*i)=intrec%fraclink(i)\n enddo\n elseif(level.eq.1) then\n do i=1,intrec%noofip(fipsize)\n iws(lok+displace+2*i-1)=intrec%sublattice(i)\n iws(lok+displace+2*i)=intrec%fraclink(i)\n enddo\n endif\n! write(*,11)'3E interaction: ',intrec%antalint,higher,lok,noi,&\n! intrec%noofip(2),intrec%sublattice(1),intrec%fraclink(1)\n11 format(a,i3,l3,10i5)\n! link from previous, iws(lok+1) is link to higher, iws(lok+2) is property\n iws(noi)=lok\n noi=lok\n! Any Toop/Kohler records should be saved here ... gtp_tooprec\n if(associated(intrec%tooprec)) then\n write(*,*)'3E 20240731: *** WARNING Toop/Kohler records not saved'\n endif\n! interaction property, link from nop\n proprec=>intrec%propointer\n nop=lok+2\n intproplista: do while(associated(proprec))\n!>>>>> 10: interaction property record (loop)\n! rsize=5+nwch(16)+proprec%degree+1\n rsize=5+nwch(20)+proprec%degree+1\n call wtake(lokpty,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving inteaction property record'\n gx%bmperr=4356; goto 1000\n endif\n! link the property records sequentially\n iws(nop)=lokpty\n nop=lokpty\n! write(*,*)'3E interact property record',lokpty,&\n! proprec%proptype\n! write(lut)proprec%reference,proprec%proptype,&\n! proprec%degree,proprec%extra,proprec%antalprop,nox\n iws(lokpty+1)=proprec%proptype\n iws(lokpty+2)=proprec%degree\n iws(lokpty+3)=proprec%extra\n iws(lokpty+4)=proprec%antalprop\n call storc(lokpty+5,iws,proprec%reference)\n displace=5+nwch(16)\n! write(*,*)'place to save modelparamid 2: ',&\n! proprec%modelparamid,lokpty+displace\n call storc(lokpty+displace,iws,proprec%modelparamid)\n displace=displace+nwch(4)\n do i=0,proprec%degree\n! store a link in iws(lokpty+displace+i) to the TP fun stored as a text\n! we have to pass iws also ....\n! call save2tpfun(lokpty+displace+i,iws,1,&\n! proprec%degreelink(i)) \n iws(lokpty+displace+i)=proprec%degreelink(i)\n enddo\n proprec=>proprec%nextpr \n enddo intproplista\n! save on stack and check if higher level\n level=level+1\n if(level.gt.5) then\n! write(*,*)'3E Too many interaction levels'\n gx%bmperr=4164; goto 1000\n endif\n! save this interaction record and take link to higher\n stack(level)%p1=>intrec\n stack(level)%lok=lok\n intrec=>intrec%highlink\n! link to higher should be in lok+1\n noi=lok+1\n if(associated(intrec)) higher=.true.\n enddo intlista\n! we come here when there is no higher level\n! pop previous intrec and take link to next interaction (on same level)\n higher=.false.\n if(level.gt.0) then\n intrec=>stack(level)%p1\n noi=stack(level)%lok\n intrec=>intrec%nextlink\n level=level-1\n goto 300\n endif\n!---- next endmember\n emrec=>emrec%nextem\n enddo emlista\n! no more endmembers, check if the disordered (if any) has been written\n400 continue\n! take link to higher higher interaction\n if(doneord.eq.0) then\n if(ocv()) write(*,*)'3E any disordered endmembers?'\n if(associated(phlista(lokph)%disordered)) then\n! there are also disordered parameters\n! the disfra record is written in saveequil??\n! we have to change nsl ...three % vojvoj\n doneord=1\n lokcs=phlista(lokph)%linktocs(1)\n nsl=firsteq%phase_varres(lokcs)%disfra%ndd\n!>>>>> 11A: write disordered endmemebers\n! write(lut)2,nsl\n! emrec should already be null but for security ....\n nullify(emrec)\n lokem=phreclink+1\n goto 200\n endif\n endif\n!------ save additions list, use lokpty...\n500 continue\n! iws error check\n addlink=>phlista(lokph)%additions\n lokpty=phreclink+2\n addition: do while(associated(addlink))\n! WHEN SAVING MORE ADDITION YOU MUST ALSO CHANGE READING UNFORMATTED readphases\n! integer, public, parameter :: INDENMAGNETIC=1\n! integer, public, parameter :: XIONGMAGNETIC=2\n! integer, public, parameter :: DEBYECP=3\n! integer, public, parameter :: EINSTEINCP=4\n! integer, public, parameter :: TWOSTATEMODEL1=5\n! integer, public, parameter :: ELASTICMODEL1=6\n! integer, public, parameter :: VOLMOD1=7\n! integer, public, parameter :: UNUSED_CRYSTALBREAKDOWNMOD=8\n! integer, public, parameter :: SECONDEINSTEIN=9\n! integer, public, parameter :: SCHOTTKYANOMALY=10\n! integer, public, parameter :: DIFFCOEFS=11\n! with composition independent G2 parameter\n! if(addlink%type.eq.1) then\n if(addlink%type.eq.INDENMAGNETIC) then\n!>>>>> 12A: additions id, regenerate all when reading this\n! rsize=3\n! also saving status\n rsize=4\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving addition record'\n gx%bmperr=4356; goto 1000\n endif\n iws(lokpty)=lok\n lokpty=lok\n iws(lok+1)=addlink%type\n iws(lok+2)=addlink%aff\n iws(lok+3)=addlink%status\n! write(*,*)'3E saving additions in: ',phreclink+2,lok,iws(lok+1),&\n! iws(lok+2)\n elseif(addlink%type.eq.XIONGMAGNETIC) then ! 2\n!>>>>> 12A: additions id, regenerate all when reading this\n! rsize=3\n! also saving status, there is a real\n rsize=4\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving addition record'\n gx%bmperr=4356; goto 1000\n endif\n iws(lokpty)=lok\n lokpty=lok\n iws(lok+1)=addlink%type\n! we have no aff but for xiongmagnetic we specify -1 for BCC\n! write(*,*)'3E xiongmagnetic: ',addlink%status,ADDBCCMAG\n if(btest(addlink%status,ADDBCCMAG)) then\n iws(lok+2)=-1\n else\n iws(lok+2)=0\n endif\n! there is no need to save this because record is will be regenerated\n iws(lok+3)=addlink%status\n! addrecord typ 3 not used\n! link the property recordds sequentially\n elseif(addlink%type.eq.EINSTEINCP) then ! 4\n! write(*,*)'Not saving Einstein addition' \n rsize=4\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E error saving addition record'\n gx%bmperr=4356; goto 1000\n endif\n iws(lokpty)=lok\n lokpty=lok\n iws(lok+1)=addlink%type\n iws(lok+3)=addlink%status\n elseif(addlink%type.eq.TWOSTATEMODEL1) then ! 5\n! write(*,*)'Not saving liquid two-state addition'\n rsize=4\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E error saving addition record'\n gx%bmperr=4356; goto 1000\n endif\n iws(lokpty)=lok\n lokpty=lok\n iws(lok+1)=addlink%type\n iws(lok+3)=addlink%status\n! addrecord typ 6 not used\n elseif(addlink%type.eq.VOLMOD1) then ! 7 \n!>>>>> 12A: additions id, regenerate all when reading this\n! rsize=3\n rsize=4\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving addition record'\n gx%bmperr=4356; goto 1000\n endif\n iws(lokpty)=lok\n lokpty=lok\n iws(lok+1)=addlink%type\n! save also the status word\n iws(lok+3)=addlink%status\n! iws(lok+2)=addlink%aff\n! write(*,*)'3E saving additions in: ',phreclink+2,lok,iws(lok+1),&\n! iws(lok+2)\n elseif(addlink%type.eq.DIFFCOEFS) then ! 11\n write(*,*)'Not saving Diffusion addition'\n else\n write(*,99)addlink%type\n99 format(78('*')/'3E *** NOT SAVED addition record type ',i3/78('*')/)\n endif\n addlink=>addlink%nextadd\n enddo addition\n enddo\n! write(*,*)'3E phreclink 2: ',phreclink,iws(phreclink),iws(phreclink+1),&\n! iws(phreclink+2)\n1000 continue\n return\n end subroutine savephases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine saveequil\n!\\begin{verbatim}\n subroutine saveequil(lok1,iws)\n! subroutine saveequil(lok1,iws,ceq)\n! save data for equilibrium record ceq including phase_varres\n implicit none\n integer lok1,iws(*),jeq\n!\\end{verbatim} %+\n character text*1024\n type(gtp_phase_varres), pointer :: firstvarres\n TYPE(gtp_fraction_set), pointer :: fslink\n! TYPE(gtp_condition), pointer :: condrec\n integer i,isp,j,k,kl,lokcs,lokph,mc,mc2,nsl,lokeq,rsize,displace,lokvares\n integer lokdis,disz,lok,qsize,eqdis,iws1,dcheck,lokcc,seqz,offset,dmc\n integer loklast,eqnumber,lokhighcs,ceqsize,ceqsize2\n type(gtp_equilibrium_data), pointer :: ceq\n! loop to save all equilibria\n eqnumber=0\n ceqsize2=ceqrecsize()\n17 continue\n eqnumber=eqnumber+1\n if(eqnumber.eq.1) then\n! calculate the size of the first equilibrium record saved\n ceqsize=iws(1)\n elseif(eqnumber.eq.2) then\n ceqsize=iws(1)-ceqsize\n write(*,18)ceqsize,ceqsize2\n18 format(' 3E Saving an equilibrium record requires ',2i8,' words')\n endif\n ceq=>eqlista(eqnumber)\n! check if enything entered ...\n if(.not.allocated(ceq%complist)) then\n write(*,*)'3E not storing unused equilibria from: ',eqnumber\n goto 1000\n! else\n! write(*,*)'3E storing equilibrium number: ',eqnumber\n endif\n!>>>>> 50:\n! write(lut)ceq%eqname,ceq%eqno,ceq%status,ceq%next\n! status,multi,eqno,next,name,comment,tpval(2),rtn,weight,\n! (links to cond,exper), complist(nel),(link to compstoi*(nel*nel))\n! old: highcs, (link to phase_varres), mu(nel), xconc,gmind,eqextra,maxiter\n! highcs, (link to phase_varres),mu(nel),xconc, gdconv(2),gmind,eqextra,maxiter\n! rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+3*nwpr\n rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+5*nwpr\n call wtake(lokeq,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving equilibrium record'\n gx%bmperr=4356; goto 1000\n endif\n if(lok1.eq.0) then\n! return pointer to first\n lok1=lokeq\n else\n! else link from previous\n! write(*,*)'Linking equilibria: ',lok1,loklast,lokeq\n iws(loklast)=lokeq\n endif\n loklast=lokeq\n! iws(lokeq) is pointer to next\n! write(*,16)lokeq,ceq%status\n16 format('3E equilibrium status word: ',i8,1x,z8)\n iws(lokeq+1)=ceq%status\n iws(lokeq+2)=ceq%multiuse\n iws(lokeq+3)=ceq%eqno\n iws(lokeq+4)=ceq%nexteq\n call storc(lokeq+5,iws,ceq%eqname)\n displace=5+nwch(24)\n call storc(lokeq+displace,iws,ceq%comment)\n displace=displace+nwch(72)\n call storrn(2,iws(lokeq+displace),ceq%tpval)\n call storr(lokeq+displace+2*nwpr,iws,ceq%weight)\n displace=displace+3*nwpr\n! svfunres not stored\n!---- conditions, write as text and recreated when reading file\n call get_all_conditions(text,0,ceq)\n if(gx%bmperr.ne.0) goto 1000\n kl=index(text,'CRLF')-1\n! write(*,*)'3E cond: ',trim(text),kl\n if(kl.gt.1) then\n call wtake(lok,1+nwch(kl),iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving condition record'\n gx%bmperr=4356; goto 1000\n endif\n call storc(lok+1,iws,text(1:kl))\n iws(lok)=kl\n iws(lokeq+displace)=lok\n else\n! no conditions\n iws(lokeq+displace)=0\n endif\n!---- save experiments as text\n! a bit strange one has to loop incrementing seqz until there is an error ...\n iws(lokeq+displace+1)=0\n seqz=0\n lokcc=lokeq+displace+1\n133 continue\n seqz=seqz+1\n j=1\n text=' '\n call get_one_experiment(j,text,seqz,.FALSE.,ceq)\n if(gx%bmperr.ne.0) then\n! no or no more experiments\n gx%bmperr=0\n else\n! do not save the \"current value\" after the $\n! write(*,*)'3E save experiment: \"',trim(text),'\"'\n kl=index(text,'$')-1\n if(kl.le.0) then\n kl=len_trim(text)\n endif\n if(kl.gt.0) then\n! write(*,*)'3E experiment: ',text(1:kl),seqz\n call wtake(lok,2+nwch(kl),iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving experiments record'\n gx%bmperr=4356; goto 1000\n endif\n call storc(lok+2,iws,text(1:kl))\n iws(lok+1)=kl\n! create a linear list\n iws(lokcc)=lok\n lokcc=lok\n endif\n goto 133\n endif\n! write(*,*)'3E buperr 1: ',buperr\n!---- if components different from elements\n if(btest(globaldata%status,GSNOTELCOMP)) then\n write(*,*)'3E Not implemented saving other components than elements'\n gx%bmperr=4399; goto 1000\n! do i=1,noofel\n! isp=ceq%complist(i)%splink\n! write(lut)isp\n! write(lut)ceq%complist(i)%phlink,ceq%complist(i)%status,&\n! ceq%complist(i)%refstate,ceq%complist(i)%tpref,&\n! ceq%complist(i)%mass\n! enddo\n! do i=1,noofel\n! if(ocv()) write(*,99)'comp.matrix: ',(ceq%invcompstoi(j,i),j=1,noofel)\n! enddo\n!99 format(a,7e11.3)\n! do i=1,noofel\n! write(lut)(ceq%compstoi(j,i),j=1,noofel)\n! enddo\n else\n! save component records in a linked list NEEDED FOR MANY THINGS\n! like reference state etc\n lokcc=lokeq+displace+2\n rsize=5+nwch(16)+1+6*nwpr\n do j=1,noofel\n if(allocated(ceq%complist(j)%endmember)) then\n! this component has a user defined reference state\n kl=size(ceq%complist(j)%endmember)\n else\n kl=0\n endif\n call wtake(lok,rsize+kl,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving varres record 1',j,rsize+kl\n gx%bmperr=4356; goto 1000\n endif\n! sequential link\n iws(lokcc)=lok\n lokcc=lok\n! data\n iws(lok+1)=ceq%complist(j)%splink\n iws(lok+2)=ceq%complist(j)%phlink\n iws(lok+3)=ceq%complist(j)%status\n call storc(lok+4,iws,ceq%complist(j)%refstate)\n disz=4+nwch(16)\n iws(lok+disz)=kl\n if(kl.gt.0) then\n do mc=1,kl\n iws(lok+disz+mc)=ceq%complist(j)%endmember(mc)\n enddo\n disz=disz+kl+1\n else\n disz=disz+1\n endif\n! write(*,*)'3E refstate 1: ',ceq%complist(j)%tpref\n call storrn(2,iws(lok+disz),ceq%complist(j)%tpref)\n disz=disz+2*nwpr\n call storrn(2,iws(lok+disz),ceq%complist(j)%chempot)\n disz=disz+2*nwpr\n call storr(lok+disz,iws,ceq%complist(j)%mass)\n! write(*,*)'3E saving component mass',lok,disz,j,ceq%complist(j)%mass\n call storr(lok+disz+nwpr,iws,ceq%complist(j)%molat)\n! write(*,*)'3e comprec size: ',lok,lok+disz+nwpr,iws(1)\n enddo\n endif\n117 continue\n! LINKED LIST of phase_varres records stored from lokeq+lokvares\n lokhighcs=lokeq+displace+3\n! write(*,118)'3E highcs: ',eqnumber,highcs,csfree,lokhighcs\n118 format(a,3i5,i10)\n iws(lokhighcs)=highcs\n lokvares=lokhighcs+1\n eqdis=displace+5\n! write(*,*)'3E buperr 2: ',buperr\n! write(*,*)'3E link to first phase_varres in ',lokvares,highcs\n!--------------------------------------------------------- below is varres\n!---- varres records, one for each composition set of the phases and sometimes\n! one for disordered fraction sets ....\n! write them in records linked from lokvares as they can be very different\n compset: do j=1,highcs\n! loop for all composition sets\n firstvarres=>ceq%phase_varres(j)\n if(.not.allocated(firstvarres%yfr)) then\n! if this phase_varres is no longer used this should be unallocated\n call wtake(lok,4,iws)\n if(buperr.ne.0) then\n gx%bmperr=4356; goto 1000\n endif\n write(*,*)'3E unused phase_varres:',j,highcs,lok\n! this is the free list\n iws(lok+1)=firstvarres%nextfree\n! this should be phlink but set to illegal value\n iws(lok+2)=-1\n! this links all phase varres records together\n iws(lokvares)=lok\n lokvares=lok\n cycle compset\n endif\n lokph=firstvarres%phlink\n if(btest(firstvarres%status2,CSDFS)) then\n! this phase_varres/parres record belong to disordered fraction_set\n! A bit tricky to find the number of sublattices and constituents ....\n lokcs=phlista(lokph)%linktocs(1)\n nsl=ceq%phase_varres(lokcs)%disfra%ndd\n mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr\n else\n! lokcs=0\n nsl=phlista(firstvarres%phlink)%noofsubl\n! mc=phlista(firstvarres%phlink)%tnooffr\n! if this phase_varres has been removed this may be unallocated\n if(.not.allocated(firstvarres%yfr)) then\n write(*,*)'3E highcs not updated when removing compset!',j,highcs\n! we should update?? iws(lokeq+displace+3)=highcs\n cycle compset\n endif\n! wow, firstvarres%yfr is dimensioned to 1000\n mc=phlista(firstvarres%phlink)%tnooffr\n! write(*,*)'3E mc: ',trim(phlista(lokph)%name),mc,size(firstvarres%yfr)\n endif\n if(btest(firstvarres%status2,CSDLNK)) then\n! the offset here shold be the place to store the disfra record ...\n offset=6+2*nwch(4)+3*nwpr+mc*(1+2*nwpr)+nsl*nwpr\n! write(*,202)'3E offset 0: ',j,highcs,lokph,nsl,mc,offset\n endif\n mc2=mc*(mc+1)/2\n! nextfree,phlink,status2,phstate,phtupx,abnorm(3),prefix*4,suffix*4\n! constat(mc),yfr(mc),mmyfr(mc)+2 extra for nsl and mc \n rsize=6+2*nwch(4)+3*nwpr+mc+2*mc*nwpr\n! sites(nsl),disfralink,amfu,netcharge,dgm and link to ionliq dpqdy record!!\n! also added qcbonds!!\n! rsize=rsize+nsl*nwpr+1+4*nwpr+2\n rsize=rsize+nsl*nwpr+1+5*nwpr+2\n! results g, dg, d2g some exra space\n rsize=rsize+6*nwpr+3*mc*nwpr+mc2*nwpr+5+2\n qsize=rsize\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving varres record 2',j,rsize,nsl,mc\n gx%bmperr=4356; goto 1000\n endif\n iws1=iws(1)\n! lokph=firstvarres%phlink\n! write(*,107)'3E saving: ',j,lok,rsize,mc,nsl,trim(phlista(lokph)%name)\n! write(*,107)'3E saving: ',j,phasetuple(j)%ixphase,nsl,0,0\n107 format(a,i3,2i10,i4,i3,2x,a)\n! link from lokvares and use iws(lok) to link to next\n iws(lokvares)=lok\n lokvares=lok\n! data\n iws(lok+1)=firstvarres%nextfree\n iws(lok+2)=firstvarres%phlink\n iws(lok+3)=firstvarres%status2\n iws(lok+4)=firstvarres%phstate\n iws(lok+5)=firstvarres%phtupx\n iws(lok+6)=nsl\n iws(lok+7)=mc\n call storc(lok+8,iws,firstvarres%prefix)\n displace=8+nwch(4)\n call storc(lok+displace,iws,firstvarres%suffix)\n displace=displace+nwch(4)\n call storrn(3,iws(lok+displace),firstvarres%abnorm)\n displace=displace+3*nwpr\n! write(*,*)'3E sizes:',allocated(firstvarres%constat),&\n! size(firstvarres%constat),size(firstvarres%yfr),mc\n do i=1,mc\n iws(lok+displace+i-1)=firstvarres%constat(i)\n enddo\n displace=displace+mc\n call storrn(mc,iws(lok+displace),firstvarres%yfr)\n displace=displace+mc*nwpr\n! mmyfr is just reals ... do not bother (although space for double reserved)\n! write(lut)(firstvarres%mmyfr(i),i=1,mc)\n displace=displace+mc*nwpr\n! write(*,*)'3E sites:',lok,displace,lok+displace\n call storrn(nsl,iws(lok+displace),firstvarres%sites)\n displace=displace+nsl*nwpr\n! do not save the cmuval array\n! dsitesdy is interesting only for ionic liquids\n! if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! call wtake(mc+mc2,iws\n! call storrn(mc,iws(lok+displace),firstvarres%dpqdy)\n! displace=displace+mc\n! call storrn(mc2,iws(lok+displace),firstvarres%d2pqdvay)\n! displace=displace+mc2\n! write(*,*)'3E odd: ',lok,displace\n! else\n! iws(\n! endif\n fsrec: if(btest(firstvarres%status2,CSDLNK)) then\n! we need a record for a disordered fraction_set record\n! latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis, id*1, dsites(nsl), \n! nooffr(mc), splink(mc), y2x(mc), dxidyj(mc),fsites\n fslink=>firstvarres%disfra\n nsl=fslink%ndd\n! dmc because we store G and dG/dy later for original mc\n dmc=fslink%tnoofxfr\n rsize=8+nwch(1)+nsl+dmc+1+mc*(1+nwpr)+nsl*nwpr+nwpr\n call wtake(lokdis,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving disordered varres record',rsize\n gx%bmperr=4356; goto 1000\n endif\n! write(*,202)'3E disfracset 1: ',j,lok,displace,lokdis,nsl,dmc\n202 format(a,10i6)\n! set link from varres record\n iws(lok+displace)=lokdis\n! store data\n iws(lokdis)=fslink%latd\n iws(lokdis+1)=fslink%ndd\n iws(lokdis+2)=fslink%tnoofxfr\n iws(lokdis+3)=fslink%tnoofyfr\n iws(lokdis+4)=fslink%totdis\n iws(lokdis+5)=fslink%varreslink\n call storc(lokdis+6,iws,fslink%id)\n! write(*,202)'3E disfracset 2: ',j,iws(lokdis+1),iws(lokdis+2),&\n! iws(lokdis+5)\n! set disz to one less as i starts from 1\n disz=6+nwch(1)\n! number of constituents in each sublattice\n do i=1,nsl\n iws(lokdis+disz+i)=fslink%nooffr(i)\n enddo\n disz=disz+nsl\n! write(*,*)'3E disfra 1: ',lokdis,disz\n! species index for all constituents\n do i=1,dmc\n iws(lokdis+disz+i)=fslink%splink(i)\n enddo\n disz=disz+dmc+1\n iws(lokdis+disz)=mc\n disz=disz\n! NOTE y2x and dxidy1 has dimension mc!!\n! write(*,*)'3E disfra 2: ',lokdis,disz,dmc,mc,size(fslink%y2x)\n! This has to do with the fractions that should be added together\n do i=1,mc\n iws(lokdis+disz+i)=fslink%y2x(i)\n enddo\n disz=disz+mc+1\n! write(*,*)'3E disfra 3: ',lokdis,disz\n! number of sites in each sublattice\n call storrn(nsl,iws(lokdis+disz),fslink%dsites)\n disz=disz+nsl*nwpr\n! write(*,*)'3E disfra 4: ',lokdis,disz,dmc,mc,size(fslink%y2x)\n! converting ordered fractions to disordered fractions\n call storrn(mc,iws(lokdis+disz),fslink%dxidyj)\n! formula unit factor\n disz=disz+mc*nwpr\n! write(*,*)'3E disfra 5: ',lokdis,disz\n call storr(lokdis+disz,iws,fslink%fsites)\n! write(*,*)'3E disfra: ',lokdis+disz+nwpr,iws(1)\n else\n! mark no link to disordered record\n! write(*,*)'3E no disorderd record',lok+displace,iws(1),iws(2)\n iws(lok+displace)=0\n endif fsrec\n! write(*,*)'3E buperr 7: ',buperr,lok,displace\n!------------------------------------- end of disorderd record\n! save some results stored in the phase_varres record\n displace=displace+1\n call storr(lok+displace,iws,firstvarres%amfu)\n call storr(lok+displace+nwpr,iws,firstvarres%netcharge)\n call storr(lok+displace+2*nwpr,iws,firstvarres%dgm)\n! record size increased to save qcbonds ... and increment of displace below\n call storr(lok+displace+3*nwpr,iws,firstvarres%qcbonds)\n! Maybe firstvarres%nprop is not always initiated??\n! it seems that additional compsets have an arbitrary value ...\n if(firstvarres%nprop.ne.20) then\n iws(lok+displace+4*nwpr)=20\n else\n iws(lok+displace+4*nwpr)=firstvarres%nprop\n endif\n! write(*,303)'3E saving nprop: ',lok,displace+3*nwpr,lok+displace+3*nwpr,&\n! iws(lok+displace+3*nwpr),trim(phlista(lokph)%name)\n303 format(a,4i8,2x,a)\n displace=displace+4*nwpr+1\n! only save G and derivatives\n do i=1,6\n call storr(lok+displace+nwpr*(i-1),iws,firstvarres%gval(i,1))\n enddo\n! problem here with SELECT_ELEMENT_REFERENCE phase ...\n! write(*,304)'3E bug: ',trim(phlista(lokph)%name),mc,&\n! size(firstvarres%dgval)\n!304 format(a,a,5i5)\n! in the ENTER_EQUILIBRIUM the incorrect size of dgval was allocated !!! fixed\n displace=displace+6*nwpr\n do i=1,3\n do k=1,mc\n! write(*,*)'indices: ',i,k\n call storr(lok+displace,iws,firstvarres%dgval(i,k,1))\n displace=displace+nwpr\n enddo\n enddo\n do i=1,mc2\n call storr(lok+displace+nwpr*(i-1),iws,firstvarres%d2gval(i,1))\n enddo\n! write(*,*)'3E last values used ',j,lok+displace+mc2*nwpr,lok+qsize,iws1\n enddo compset\n!----------------------------------------\n! we must set csfree to highcs+1\n! as new composition sets will use that as the free list pointer\n csfree=highcs+1\n!-----------------------------------------\n! mu(nel), xconc,gmind,eqextra,maxiter\n! MODIFIED: mu(nel), xconc, gdconv(2), gmind,eqextra,maxiter\n iws(lokeq+eqdis)=ceq%maxiter\n call storrn(noofel,iws(lokeq+eqdis+1),ceq%cmuval)\n eqdis=eqdis+1+noofel*nwpr\n call storr(lokeq+eqdis,iws,ceq%xconv)\n call storr(lokeq+eqdis+nwpr,iws,ceq%gdconv(1))\n call storr(lokeq+eqdis+2*nwpr,iws,ceq%gdconv(2))\n call storr(lokeq+eqdis+3*nwpr,iws,ceq%gmindif)\n! last use of lokeq !!\n! write(*,*)'3E NOT saving the character eqextra!'\n! call storc(lokeq+displace+2*nwpr,iws,ceq%eqextra)\n! write(*,*)'3E check rsize: ',rsize,eqdis+2*nwpr\n!>>>>>> 64: savesysmat\n! write(*,*)'3E not saving sysmat?',ceq%sysmatdim,ceq%nfixmu,ceq%nfixph\n! NOTE:: ceq%sysmatdim negative, not initiallized??\n! NOTE:: phasetuples not saved !!!\n! write(lut)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph\n! if(ceq%nfixmu.gt.0) write(lut)(ceq%fixmu(kl),kl=1,ceq%nfixmu)\n! if(ceq%nfixph.gt.0) write(lut)&\n! (ceq%fixph(1,kl),ceq%fixph(2,kl),kl=1,ceq%nfixph)\n! if(ceq%sysmatdim.gt.0) then\n! do mc=1,ceq%sysmatdim\n! write(lut)(ceq%savesysmat(mc,kl),kl=1,ceq%sysmatdim)\n! enddo\n! endif\n! loop for all entered equilibria\n goto 17\n!----------\n1000 continue\n return\n end subroutine saveequil\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine svfunsave\n!\\begin{verbatim}\n subroutine svfunsave(loksvf,iws,ceq)\n! saves all state variable functions as texts in iws\n implicit none\n integer iws(*),loksvf\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n character text*512,symbols(20)*32,afterdot*32\n integer ip,ipos,istv,js,jt,kl,ks,lrot,rsize,lok\n type(gtp_state_variable), target :: svr2\n type(gtp_state_variable), pointer :: svrrec\n rsize=nsvfun+5\n call wtake(loksvf,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving state variable function record',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(loksvf)=nsvfun\n iws(loksvf+1)=3\n! do not save the first three, R, RT and T_C\n symbols=' '\n write(*,*)'3E saving ',nsvfun,' symbols as texts'\n do lrot=4,nsvfun\n ipos=1\n text=' '\n call list_svfun(text,ipos,lrot,ceq)\n rsize=1+nwch(ipos)\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving state variable func record',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E storing svfun: ',text(1:ipos)\n iws(lok)=ipos\n! NOTE position 1-7 is equilibrium number and status\n call storc(lok+1,iws,text(1:ipos))\n iws(loksvf+lrot)=lok\n enddo\n1000 continue\n return\n end subroutine svfunsave\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine bibliosave\n!\\begin{verbatim}\n subroutine bibliosave(bibhead,iws)\n! saves references on a file\n implicit none\n integer bibhead,iws(*)\n!\\end{verbatim} %+\n character longline*2048\n integer ir,jp,ll,nl,lok,rsize\n!>>>>> 40:\n! write(*,*)'3E Saving reference version and number of:',&\n! gtp_biblioref_version,reffree-1\n rsize=3+reffree-1\n call wtake(bibhead,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving biblographiic record',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(bibhead)=reffree-1\n do ir=1,reffree-1\n! a bibliographic reference contains 16 character identifier and a variable\n! characters text. Concatinate that into a single text and save one\n! reference in each record linked from bibhead\n longline=bibrefs(ir)%reference\n jp=17\n! This require Fortran 2003/2008 standard, not available in GNU Fortran 4.8 \n! longline(17:)=bibrefs(ir)%nyrefspec\n ll=bibrefs(ir)%wprefspec(1)\n call loadc(2,bibrefs(ir)%wprefspec,longline(17:ll+16))\n! nl=size(bibrefs(ir)%refspec)\n! do ll=1,nl\n! longline(jp:)=bibrefs(ir)%refspec(ll)\n! jp=jp+64\n! enddo\n jp=len_trim(longline)\n rsize=1+nwch(jp)\n call wtake(lok,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving biblographiic record',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok)=jp\n call storc(lok+1,iws,longline(1:jp))\n iws(bibhead+ir)=lok\n enddo\n1000 continue\n return\n end subroutine bibliosave\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine saveash\n!\\begin{verbatim}\n subroutine saveash(lok,iws)\n! saving assessment records\n integer lok,iws(*)\n!\\end{verbatim} %+\n integer lok1,lok2,last,rsize,i1,i2,disp\n type(gtp_assessmenthead), pointer :: assrec\n! type(gtp_equilibrium_data), pointer :: ceq\n!\n assrec=>firstash%nextash\n if(.not.allocated(assrec%eqlista)) then\n write(kou,*)'3E No experimental equilibrium range set'\n! iws(lok)=0\n! goto 1000\n endif\n20 continue\n! next, status, varcoef, first, and 8 allocatable arrays\n! rsize=4+2*nwch(64)+10\n! added one location for pointer to RSD values\n! rsize=4+2*nwch(64)+11\n rsize=5+2*nwch(64)+11\n write(*,*)'3E allocating assessment head record',rsize\n call wtake(lok1,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n if(iws(lok).eq.0) then\n iws(lok)=lok1\n last=lok1\n else\n iws(last)=lok1\n last=lok1\n endif\n iws(lok1+1)=assrec%status\n iws(lok1+2)=assrec%varcoef\n iws(lok1+3)=assrec%firstexpeq\n iws(lok1+4)=assrec%lwam\n! call storc(lok1+4,iws,assrec%general)\n call storc(lok1+5,iws,assrec%general)\n disp=5+nwch(64)\n call storc(lok1+disp,iws,assrec%special)\n disp=disp+nwch(64)\n! eqlista CAN BE EMPTY!\n if(allocated(assrec%eqlista)) then\n i1=size(assrec%eqlista)\n rsize=1+i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E in saveash 1:',lok,lok1,lok2,i1\n iws(lok2)=i1\n if(i1.gt.0) then\n! Hm assrec%eqlista(i2)%p1 is a pointer to an element in the global eqlists\n! ceq=>assrec%eqlista(1)%p1\n do i2=1,i1\n iws(lok2+i2)=assrec%eqlista(i2)%p1%eqno\n enddo\n endif\n else\n! mark that no experimental records\n lok2=0\n endif\n iws(lok1+disp+1)=lok2\n! coeffvalues\n if(allocated(assrec%coeffvalues)) then\n i1=size(assrec%coeffvalues)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E in saveash 2:',lok2,i1,rsize\n iws(lok2)=i1\n call storrn(i1,iws(lok2+1),assrec%coeffvalues)\n iws(lok1+disp+2)=lok2\n! relative standard deviation\n i1=size(assrec%coeffvalues)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E in saveash 2 RSD:',lok2,i1,rsize\n iws(lok2)=i1\n call storrn(i1,iws(lok2+1),assrec%coeffrsd)\n iws(lok1+disp+3)=lok2\n! coeffscale\n i1=size(assrec%coeffscale)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n! write(*,*)'3E in saveash 3:',lok2,i1\n call storrn(i1,iws(lok2+1),assrec%coeffscale)\n! iws(lok1+disp+3)=lok2\n iws(lok1+disp+4)=lok2\n! coeffstart\n i1=size(assrec%coeffstart)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n! write(*,*)'3E in saveash 4:',lok2,i1\n call storrn(i1,iws(lok2+1),assrec%coeffstart)\n! iws(lok1+disp+4)=lok2\n iws(lok1+disp+5)=lok2\n! coeffmin\n i1=size(assrec%coeffmin)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n! write(*,*)'3E in saveash 5:',lok2,i1\n call storrn(i1,iws(lok2+1),assrec%coeffmin)\n! iws(lok1+disp+5)=lok2\n iws(lok1+disp+6)=lok2\n! coeffmax\n i1=size(assrec%coeffmax)\n rsize=1+nwpr*i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n call storrn(i1,iws(lok2+1),assrec%coeffmax)\n! iws(lok1+disp+6)=lok2\n iws(lok1+disp+7)=lok2\n! coeffindices\n i1=size(assrec%coeffindex)\n rsize=1+i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n! write(*,*)'3E in saveash 6:',lok2,i1\n iws(lok2)=i1\n do i2=1,i1\n iws(lok2+i2)=assrec%coeffindex(i2-1)\n enddo\n! iws(lok1+disp+7)=lok2\n iws(lok1+disp+8)=lok2\n! coeffstate\n i1=size(assrec%coeffstate)\n rsize=1+i1\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n do i2=1,i1\n iws(lok2+i2)=assrec%coeffstate(i2-1)\n enddo\n! iws(lok1+disp+8)=lok2\n iws(lok1+disp+9)=lok2\n else\n! pointers are zero\n write(*,*)'3E no coefficients allocated'\n endif\n! maybe work array should not be saved?\n if(allocated(assrec%wopt)) then\n i1=size(assrec%wopt)\n rsize=1+nwpr*i1\n write(*,*)'3E saving assessment record: (assrec%wopt)',lok1,rsize\n call wtake(lok2,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'3E Error reserving assessment record array',rsize,iws(1)\n gx%bmperr=4356; goto 1000\n endif\n iws(lok2)=i1\n call storrn(i1,iws(lok2+1),assrec%wopt)\n! iws(lok1+disp+9)=lok2\n iws(lok1+disp+10)=lok2\n else\n write(*,*)'3E no work array (assrec%wopt) allocated'\n! iws(lok1+disp+9)=0\n iws(lok1+disp+10)=0\n endif\n! check if there are several assessment records\n if(.not.associated(assrec,firstash)) then\n assrec=>assrec%nextash\n write(*,*)'3E more than one assessment records'\n goto 20\n endif\n1000 continue\n return\n end subroutine saveash\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function ceqrecsize\n!\\begin{verbatim}\n integer function ceqrecsize()\n! calculates the number of words needed to save an equilibrium record\n!\\end{verbatim}\n integer rsize,jj,seqz,kl,dmc,mc,mc2,nsl\n type(gtp_equilibrium_data), pointer :: ceq\n type(gtp_phase_varres), pointer :: firstvarres\n TYPE(gtp_fraction_set), pointer :: fslink\n character text*512\n!\n write(*,*)'ceqrecsize not implemented',highcs\n rsize=0\n goto 1000\n ceq=>firsteq\n rsize=4+nwch(24)+nwch(72)+4*nwpr+2+2*noofel+4+5*nwpr\n text=' '\n call get_all_conditions(text,0,ceq)\n rsize=rsize+nwch(index(text,'CRLF'))\n100 continue\n text=' '\n call get_one_experiment(jj,text,seqz,.FALSE.,ceq)\n if(gx%bmperr.ne.0) then\n kl=index(text,'$')-1\n if(kl.le.0) then\n kl=len_trim(text)\n endif\n rsize=rsize+2+nwch(kl)\n goto 100\n endif\n gx%bmperr=0\n! ignore if a component has a defined reference state ...\n rsize=rsize+(5+nwch(16)+1+6*nwpr)*noofel\n do jj=1,highcs\n! loop for phase_varres records ..\n firstvarres=>ceq%phase_varres(jj)\n if(.not.allocated(firstvarres%yfr)) then\n rsize=rsize+4\n else\n rsize=rsize+6+2*nwch(4)+3*nwpr+mc+2*mc*nwpr\n rsize=rsize+6*nwpr+3*mc*nwpr+mc2*nwpr+5+2\n if(btest(firstvarres%status2,CSDLNK)) then\n! there is a disordered fraction set ...\n fslink=>firstvarres%disfra\n nsl=fslink%ndd\n rsize=8+nwch(1)+nsl+dmc+1+mc*(1+nwpr)+nsl*nwpr+nwpr\n endif\n endif\n enddo\n1000 continue\n ceqrecsize=rsize\n return\n end function ceqrecsize\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine gtpread\n!\\begin{verbatim}\n subroutine gtpread(filename,str)\n! read unformatted all data in the following order\n! header\n! element list\n! species list\n! phase list with sublattices, endmembers, interactions and parameters etc\n! tpfuns\n! references\n! first equilibrium record with conditions, componenets, phase_varres etc\n! state variable functions\n! equilibrium record(s) with conditions, componenets, phase_varres, experim etc\n! CCI changed to use iso_fortran_env to find file unit number for C++\n use :: iso_fortran_env\n! CCI\n implicit none\n character*(*) filename,str\n!\\end{verbatim} %+\n!\n character id*40,version*8,comment*72\n integer i,i1,i2,i3,isp,jph,kontroll,nel,ivers,lin,last,lok,displace,jfun\n integer nspx,saverr\n integer, allocatable :: iws(:)\n! CCI\n logical is_op\n! CCI\n! type(gtp_equilibrium_data), pointer :: ceq\n10 format(i8)\n if(index(filename,'.').eq.0) then\n filename(len_trim(filename)+1:)='.OCU'\n endif\n!CCI The previous commented lines are removed by the following lines \n!CCI that enable to find the first available logical unit. \n!CCI Such an approach can generalized in order to enable the \n!CCI opening file by several threads in the same time. \n!CCI To do this, the following lines should in a dedicated subroutine.\n!CCI lin=21\n lunit: do lin=8,99 \n inquire(lin,opened=is_op)\n if(.not.is_op) exit lunit\n enddo lunit \n if( lin.eq.100 ) then\n write(*,*)'3E Error, no logical unit available for opening file: ',&\n trim(filename)\n goto 1000\n endif\n! CCI end change \n open(lin,file=filename,access='sequential',status='old',&\n form='unformatted',iostat=gx%bmperr,err=1100)\n! write(*,*)'3E opening file: ',trim(filename),' for unformatted read'\n!\n read(lin)id,version,comment,noofel,noofsp,noofph,nooftuples,last\n!**********************************************************\n! IMPORTANT savefile\n! is a variable in gtp3.F90\n! which MUST BE CHANGED whenever there is a change in the unformatted\n! file layout\n!***********************************************************\n if(version.ne.savefile) then\n write(*,11)id,version,savefile\n11 format('File not same version as program: ',A/a,' : ',a)\n gx%bmperr=4299; goto 900\n endif\n write(*,12)id,version,trim(comment)\n12 format(/'Read unformatted file: ',a,a/'Generated: ',a/)\n str=comment\n! write(*,*)'3E numbers: ',noofel,noofsp,noofph,nooftuples,last\n!-------\n allocate(iws(last))\n read(lin)(iws(i),i=1,last)\n close(lin)\n!------------------------\n write(*,*)'3E reading unformatted: ',last,iws(last-4),globaldata%encrypted\n if(iws(last-4).ne.0 .and. globaldata%encrypted.eq.0) then\n write(*,*)'3E Illegal attempt to read an encrypted save file'\n stop\n endif\n!------------------------\n!>>>>> 2: elementlist, follow link from iws(3)\n if(iws(4).ne.gtp_element_version) then\n write(*,*)'3E Element data structure not same:',iws(4),gtp_element_version\n gx%bmperr=4355; goto 1000\n endif\n nel=0\n last=iws(3)\n do while(last.gt.0)\n nel=nel+1\n lok=last\n call loadc(lok+1,iws,ellista(nel)%symbol)\n call loadc(lok+2,iws,ellista(nel)%name)\n displace=3+nwch(12)\n call loadc(lok+displace,iws,ellista(nel)%ref_state)\n displace=displace+nwch(24)\n call loadr(lok+displace,iws,ellista(nel)%mass)\n call loadr(lok+displace+nwpr,iws,ellista(nel)%h298_h0)\n call loadr(lok+displace+2*nwpr,iws,ellista(nel)%s298)\n displace=displace+3*nwpr\n ellista(nel)%splink=iws(lok+displace)\n ellista(nel)%status=iws(lok+displace+1)\n ellista(nel)%alphaindex=iws(lok+displace+2)\n ellista(nel)%refstatesymbol=iws(lok+displace+3)\n! write(*,17)ellista(nel)%symbol,ellista(nel)%name,ellista(nel)%ref_state,&\n! ellista(nel)%mass,ellista(nel)%h298_h0,ellista(nel)%s298,&\n! ellista(nel)%splink,ellista(nel)%status,ellista(nel)%alphaindex,&\n! ellista(nel)%refstatesymbol\n17 format('3E ',a2,2x,a12,2x,a24,2x,3(1pe12.4),4i5)\n! do not forget the element array!\n elements(ellista(nel)%alphaindex)=nel\n!\n last=iws(last)\n! write(*,*)'3E elloop: ',nel,lok,last,iws(1)\n enddo\n if(nel.ne.noofel) then\n write(*,*)'3E Number of elements wrong: ',nel,noofel\n endif\n! write(*,*)'3E Now the species!!'\n!-------\n!>>>>> 3: specieslist NOTE ADDES SPEXTRA\n if(iws(6).ne.gtp_species_version) then\n write(*,*)'3E Species version wrong: ',iws(5),gtp_species_version\n gx%bmperr=4355; goto 1000\n endif\n last=iws(5)\n! VA is entered automatically at first index in splista when reinitiating \n! so keep that. We just skip the first species in iws and extract\n! its alphaindex\n splista(1)%alphaindex=iws(last+2+nwch(24)+2*nwpr+2)\n species(splista(1)%alphaindex)=1\n! skip the first species (this is VA)\n last=iws(last)\n isp=1\n do while(last.gt.0)\n isp=isp+1\n! write(*,*)'3E loop: ',last,isp,splista(isp-1)%symbol\n call loadc(last+1,iws,splista(isp)%symbol)\n displace=2+nwch(24)\n call loadr(last+displace,iws,splista(isp)%mass)\n call loadr(last+displace+nwpr,iws,splista(isp)%charge)\n splista(isp)%noofel=iws(last+displace+2*nwpr)\n splista(isp)%status=iws(last+displace+2*nwpr+1)\n splista(isp)%alphaindex=iws(last+displace+2*nwpr+2)\n! new spextra array\n nspx=iws(last+displace+2*nwpr+3)\n! if(nspx.ne.0) write(*,*)'3E nspx value: ',nspx\n allocate(splista(isp)%ellinks(splista(isp)%noofel))\n allocate(splista(isp)%stoichiometry(splista(isp)%noofel))\n displace=displace+2*nwpr+3\n do i=1,splista(isp)%noofel\n splista(isp)%ellinks(i)=iws(last+displace+i)\n enddo\n displace=displace+splista(isp)%noofel+1\n! write(*,*)'3E displace load: ',last,displace\n call loadrn(splista(isp)%noofel,&\n iws(last+displace),splista(isp)%stoichiometry)\n species(splista(isp)%alphaindex)=isp\n! handle spextra values if any\n if(nspx.gt.0) then\n! write(*,*)'We have nonzero nxsp: ',nspx\n allocate(splista(isp)%spextra(nspx))\n displace=displace+splista(isp)%noofel*nwpr\n call loadrn(nspx,iws(last+displace),splista(isp)%spextra)\n! new property ??\n! if(allocated(mqmqa1) then\n endif\n! next species\n last=iws(last)\n enddo\n if(isp.ne.noofsp) then\n write(*,*)'3E wrong number of species: ',isp,noofsp\n gx%bmperr=4399; goto 1000\n endif\n!---------- component record\n! read inside the equilibrium record \n!---------- tpfuns\n!>>>>> 20.. inside tpfunread, skip functions already read\n last=7\n if(iws(8).ne.tpfun_expression_version) then\n write(*,*)'3E tpfun_expression_version not same',iws(8),&\n tpfun_expression_version\n gx%bmperr=4355; goto 1000\n endif\n isp=iws(last)\n i3=iws(isp)\n! write(*,*)'3E tpfuns',iws(7),iws(8),i3\n if(isp.gt.0) then\n! skip first 2 (R and RTLNP)\n do i=3,i3-1\n call read0tpfun(iws(isp+i),iws,i)\n if(gx%bmperr.ne.0) then\n write(*,*)'3E Error reading TP function: ',gx%bmperr\n goto 1000\n endif\n enddo\n endif\n! we cannot update freetpfun before all functions are entered ....\n freetpfun=i3\n! hopefully the TP functions will keep the same index ... so for parameters\n! one just store the index!\n!-------\n!>>>>> 5: phaselist, starting from 0, the reference phase\n! zero number of phases etc\n noofph=0\n nooftuples=0\n noofem=0\n noofint=0\n! noofprop=0\n! link to phaselist is in 9 (+10, 11, 12, 13)\n call readphases(noofph,iws)\n if(gx%bmperr.ne.0) goto 1000\n!-----------\n! restore phase tuples\n! write(*,*)'3E Reading phase tuples',iws(14),noofph\n lok=iws(14)\n if(lok.gt.0) then\n if(iws(15).ne.gtp_phasetuple_version) then\n write(*,*)'3E wrong phasetuple version',gtp_phasetuple_version,iws(15)\n gx%bmperr=4355; goto 1000\n endif\n nooftuples=iws(lok)\n do i=1,nooftuples\n phasetuple(i)%lokph=iws(lok+5*i-4)\n phasetuple(i)%compset=iws(lok+5*i-3)\n phasetuple(i)%ixphase=iws(lok+5*i-2)\n phasetuple(i)%lokvares=iws(lok+5*i-1)\n phasetuple(i)%nextcs=iws(lok+5*i)\n enddo\n endif\n! restore the phases lista using phase tuples!\n do jph=1,noofph\n phases(jph)=phasetuple(jph)%lokph\n enddo\n!-------------------------------\n! the global status word in 20-21\n lok=iws(20)\n globaldata%status=iws(lok+1)\n! BUGFIX and extended\n call loadc(lok+2,iws,globaldata%name)\n displace=2+nwch(24)\n call loadr(lok+displace,iws,globaldata%rgas)\n call loadr(lok+displace+nwpr,iws,globaldata%rgasuser)\n call loadr(lok+displace+2*nwpr,iws,globaldata%pnorm)\n displace=displace+3*nwpr\n do i=0,9\n globaldata%sysparam(i+1)=iws(lok+displace+i)\n enddo\n! this was used to test record read correctly\n! if(globaldata%sysparam(1).ne.987 .or. &\n! globaldata%sysparam(10).ne.17) then\n! write(*,'(a,10i4)')'3E error globaldata: ',globaldata%sysparam\n! endif\n displace=displace+10\n call loadrn(5,iws(lok+displace),globaldata%sysreal)\n! if(abs(globaldata%sysreal(5)-12345678.9D0).gt.1.0D-12) then\n! this was used to test the storing\n! write(*,'(a,5(1pe12.4))')'3E error 2: ',globaldata%sysreal\n! endif\n! write(*,*)'3E name: \"',globaldata%name,'\"'\n! partly unfinished below\n!---------- bibliographic references\n!>>>>> 40.. inside refread\n! write(*,*)'3E reading bibliography'\n if(iws(23).ne.gtp_biblioref_version) then\n write(*,*)'3E Bibliography version wrong ',iws(23),gtp_biblioref_version\n else\n call biblioread(iws(22),iws)\n if(gx%bmperr.ne.0) goto 1000\n endif\n!---------- enter the first equilibrium record without experiments!!\n if(iws(17).ne.gtp_equilibrium_data_version) then\n write(*,*)'3E Wrong equilibrium data version',&\n iws(17),gtp_equilibrium_data_version\n gx%bmperr=4355; goto 1000\n elseif(iws(18).ne.gtp_component_version) then\n write(*,*)'3E Wrong component version',iws(18),gtp_component_version\n gx%bmperr=4355; goto 1000\n elseif(iws(19).ne.gtp_phase_varres_version) then\n write(*,*)'3E Wrong phase varres version',iws(19),gtp_phase_varres_version\n gx%bmperr=4355; goto 1000\n endif\n! link to first saved in equilibrium in iws(16). firsteq is eqlista(1)\n i=iws(16)\n! call readequil(i,iws,1,firsteq)\n call readequil(i,iws,1)\n if(gx%bmperr.ne.0) goto 1000\n!---------- state variable functions must be present when reading experiments\n! and the equilibria must\n!>>>>> 30... inside svfunread\n! write(*,*)'3E reading state variable functions',iws(24)\n if(iws(25).eq.gtp_putfun_lista_version) then\n call svfunread(iws(24),iws)\n if(gx%bmperr.ne.0) goto 1000\n else\n write(*,*)'3E state variable function version error',iws(25),&\n gtp_putfun_lista_version\n endif\n! we cannot list svfun as we have no ceq ...\n! call list_all_svfun(kou,ceq)\n! call list_some_svfun(kou)\n! write(*,*)'3E Now reading equilibria',iws(16)\n!--------------------------------------------------------------------\n! read remaining equilibria which may contain experiments\n! link to first saved in equilibrium in iws(16)\n i=iws(16)\n i3=2\n call readequil(i,iws,-1)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3E read all equilibria'\n!-------------------------------------------------------------------\n! read assessment head recods\n if(iws(27).ne.gtp_assessment_version) then\n write(*,*)'3E wrong assemmenst record version',iws(27),&\n gtp_assessment_version\n endif\n lok=26\n call readash(lok,iws)\n if(gx%bmperr.ne.0) goto 1000\n write(*,*)'3E Read assessment record'\n!------ read all ??\n800 continue\n! emergency exit\n900 continue\n! file already closed above\n! close(lin)\n!\n1000 continue\n!CCI free the iws memory (should be done automatically?)\n if(allocated(iws)) deallocate(iws)\n if(gx%bmperr.eq.4355) then\n write(*,*)'3E *** ERROR unformatted file wrong version'\n saverr=gx%bmperr; gx%bmperr=0\n! clear errr code to reinitiate ... it may not work as datastructure bad\n call new_gtp\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Failed to reinitiate',gx%bmperr\n! endif\n stop 'Cannot restore data structures'\n gx%bmperr=saverr\n endif\n return\n! error opening files\n1100 continue\n write(*,1110)gx%bmperr,trim(filename)\n1110 format('I/O error: ',i5,', opening file; ',a)\n goto 1000\n end subroutine gtpread\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readphases\n!\\begin{verbatim}\n subroutine readphases(kkk,iws)\n! read data for phlista and all endmembers etc\n! works for test case without disordered fraction test\n implicit none\n integer kkk,iws(*)\n!\\end{verbatim} %+\n integer firstendmem,i,i1,i2,i3,jph,level,nem,noi,nop,nox,nup,nsl,mult,lin\n integer lok,displace,totcon,phreclink,lokem,lokint\n character more*4\n type(gtp_endmember), allocatable, target :: nyemrec\n type(gtp_endmember), pointer :: emrec,lem\n type(gtp_interaction), pointer :: intrec\n type(gtp_property), pointer :: proprec\n logical ifbcc\n type saveint\n type(gtp_interaction), pointer :: p1\n integer noi\n end type saveint\n type(saveint), dimension(:), pointer :: stack\n type(gtp_phase_add), pointer :: addlink,nyaddlink\n!\n allocate(stack(5))\n! write(*,*)'3E in readphase:',iws(9),iws(10),iws(11),iws(12),iws(13),&\n! iws(7),iws(8)\n! as the phlista record contain pointers each item must be read separately\n! the phaes are stored sequentially from iws(9)\n lok=9\n if(iws(lok+1).ne.gtp_phase_version) then\n write(*,*)'3E phase version not the same ',iws(lok+1),gtp_phase_version\n gx%bmperr=4355; goto 1000\n elseif(iws(lok+2).ne.gtp_endmember_version) then\n write(*,*)'3E endmember not the same ',iws(lok+2),gtp_endmember_version\n gx%bmperr=4355; goto 1000\n elseif(iws(lok+3).ne.gtp_interaction_version) then\n write(*,*)'3E interaction not the same ',iws(lok+3),&\n gtp_interaction_version\n gx%bmperr=4355; goto 1000\n elseif(iws(lok+4).ne.gtp_property_version) then\n write(*,*)'3E property version not the same ',iws(lok+4),&\n gtp_property_version\n gx%bmperr=4355; goto 1000\n endif\n! first phase (number 0) is SER phase\n jph=-1\n lok=iws(lok)\n bigloop: do while(lok.gt.0)\n jph=jph+1\n call loadc(lok+1,iws,phlista(jph)%name)\n displace=1+nwch(24)\n call loadc(lok+1,iws,phlista(jph)%models)\n displace=displace+nwch(72)\n call loadc(lok+1,iws,phlista(jph)%phletter)\n displace=displace+1\n phlista(jph)%status1=iws(lok+displace)\n phlista(jph)%alphaindex=iws(lok+displace+1)\n phlista(jph)%noofcs=iws(lok+displace+2)\n phlista(jph)%nooffs=iws(lok+displace+3)\n! emergy fix for Kohler/Toop records gtp_tooprec, also for intrec !!!\n nullify(phlista(jph)%toopfirst)\n nullify(phlista(jph)%tooplast)\n! read(lin)jph,phlista(jph)%name,&\n! phlista(jph)%models,phlista(jph)%phletter,phlista(jph)%status1,&\n! phlista(jph)%alphaindex,phlista(jph)%noofcs,phlista(jph)%nooffs\n!>>>>> 6: sublattice info\n! read(lin)phlista(jph)%noofsubl,phlista(jph)%linktocs,phlista(jph)%tnooffr\n nsl=iws(lok+displace+4)\n phlista(jph)%noofsubl=nsl\n totcon=iws(lok+displace+5)\n phlista(jph)%tnooffr=totcon\n allocate(phlista(jph)%nooffr(nsl))\n allocate(phlista(jph)%constitlist(phlista(jph)%tnooffr))\n! read(lin)(phlista(jph)%nooffr(i),i=1,nsl),&\n! (phlista(jph)%constitlist(i),i=1,phlista(jph)%tnooffr),nem\n displace=displace+5\n do i=1,9\n phlista(jph)%linktocs(i)=iws(lok+displace+i)\n enddo\n! write(*,*)'3E Reading phase: ',trim(phlista(jph)%name),&\n! phlista(jph)%alphaindex,phlista(jph)%linktocs(1)\n displace=displace+9\n do i=1,nsl\n phlista(jph)%nooffr(i)=iws(lok+displace+i)\n enddo\n displace=displace+nsl\n do i=1,totcon\n phlista(jph)%constitlist(i)=iws(lok+displace+i)\n enddo\n displace=displace+totcon+1\n phlista(jph)%i2slx(1)=iws(lok+displace)\n phlista(jph)%i2slx(2)=iws(lok+displace+1)\n! here are stored endmember records and additions\n phreclink=lok+displace+2\n!------ endmember records, these must be allocated and linked now\n nullify(phlista(jph)%ordered)\n nullify(phlista(jph)%disordered)\n nullify(emrec)\n! if(associated(emrec)) then\n! write(*,*)'3E nullify does not work'\n! stop\n! endif\n! if nem=0 now there are no basic (ordered) endmember (can that happen?)\n! return here when endmember list empty and there is a disordered list\n firstendmem=1\n lokem=iws(phreclink)\n! write(*,*)'3E read endmember data',nsl,phreclink,iws(phreclink),lokem\n!------------------\n200 continue\n newendmem: do while(lokem.gt.0)\n! this could probably be made nicer ...\n if(associated(emrec)) then\n! emrec is allocated and the property record is also read\n! write(*,*)'3E next endmember',lokem,iws(lokem)\n call readendmem(lokem,iws,nsl,emrec%nextem)\n emrec=>emrec%nextem\n elseif(firstendmem.eq.1) then\n! write(*,*)'3E Read first endmember',jph\n call readendmem(lokem,iws,nsl,phlista(jph)%ordered)\n emrec=>phlista(jph)%ordered\n elseif(firstendmem.eq.2) then\n call readendmem(lokem,iws,nsl,phlista(jph)%disordered)\n emrec=>phlista(jph)%disordered\n endif\n! in iws(lokem+2=noi) is the location of interaction records (if any)\n lokint=iws(lokem+2)\n level=0\n inttree: if(lokint.gt.0) then\n!>>>>> 9A: first interaction record\n call readintrec(lokint,iws,level,emrec%intpointer)\n intrec=>emrec%intpointer\n! emergency fix for Kohler/Toop records gtp_tooprec\n nullify(intrec%tooprec)\n300 continue\n! push before going to higher\n level=level+1\n stack(level)%p1=>intrec\n stack(level)%noi=lokint\n! iws(lokint+1) is link to higher interaction\n higher: if(iws(lokint+1).gt.0) then\n call readintrec(iws(lokint+1),iws,level,intrec%highlink)\n intrec=>intrec%highlink\n! problem pushing ....\n lokint=iws(lokint+1)\n! lokint=lokint+1\n goto 300\n endif higher\n! There are no higher records, pop records from stack\n350 continue\n pop: if(level.le.0) then\n! no more interactions, take next endmember\n goto 390\n else\n! loosing parameters when comming back from higher level\n intrec=>stack(level)%p1\n lokint=iws(stack(level)%noi)\n level=level-1\n if(lokint.gt.0) then\n call readintrec(lokint,iws,level,intrec%nextlink)\n intrec=>intrec%nextlink\n else\n goto 350\n endif\n if(lokint.gt.0) goto 300\n goto 350\n endif pop\n endif inttree\n390 continue\n lokem=iws(lokem)\n enddo newendmem\n! list endmembers\n! emrec=>phlista(jph)%ordered\n! i1=1\n! do while(associated(emrec) .and. i1.lt.20)\n! write(*,*)'3E Found endmember ',i1\n! emrec=>emrec%nextem\n! i1=i1+1\n! enddo\n! make sure the list of endmember as a null ending\n if(associated(emrec)) then\n nullify(emrec%nextem)\n endif\n! we come here when no more endmembers in this list\n if(firstendmem.eq.1) then\n!>>>>> 11: if nem read here is zero there are no disordered endmembers\n if(ocv()) write(*,*)'3E checking for disordered endmembers'\n! read(lin)nem,nsl\n! we must nullify emrec to start a new list of endmembers\n nullify(emrec)\n lokem=iws(phreclink+1)\n if(lokem.ne.0) then\n firstendmem=2\n goto 200\n endif\n endif\n!------ restore additions list\n!500 continue\n lokem=phreclink+2\n! write(*,*)'3E Any addition for ',trim(phlista(jph)%name),lokem\n if(iws(lokem).gt.0) then\n lokem=iws(lokem)\n nullify(addlink)\n510 continue\n if(iws(lokem+1).ge.1 .and. iws(lokem+1).le.11) then\n! all phases has volume addition ...\n if(iws(lokem+1).ne.7) write(*,515)iws(lokem+1),&\n additioname(iws(lokem+1)),trim(phlista(jph)%name)\n515 format('3E Addition type ',i3,', ',a,' for ',a)\n elseif(iws(lokem+1).ne.0) then\n write(*,515)iws(lokem+1),'Unknown type ',&\n trim(phlista(jph)%name)\n endif\n if(iws(lokem+1).eq.INDENMAGNETIC) then\n call create_magrec_inden(nyaddlink,iws(lokem+2))\n if(gx%bmperr.ne.0) goto 1000\n elseif(iws(lokem+1).eq.XIONGMAGNETIC) then\n ifbcc=.FALSE.\n if(iws(lokem+2).eq.-1) ifbcc=.TRUE.\n! ibm .TRUE. not implemented, that require more(1:1)='I'\n! write(*,*)'3E creating xiomagnetic record for BCC ',ifbcc\n call create_xiongmagnetic(nyaddlink,more,ifbcc)\n if(gx%bmperr.ne.0) goto 1000\n elseif(iws(lokem+1).eq.VOLMOD1) then\n call create_volmod1(nyaddlink)\n if(gx%bmperr.ne.0) goto 1000\n! just set it as a link, do not care if there are other additions ...\n! Why this? it is done below ...\n! phlista(jph)%additions=>nyaddlink\n! nullify(nyaddlink%nextadd)\n elseif(iws(lokem+1).eq.EINSTEINCP) then\n call create_einsteincp(nyaddlink)\n if(gx%bmperr.ne.0) goto 1000\n elseif(iws(lokem+1).eq.TWOSTATEMODEL1) then\n call create_twostate_model1(nyaddlink)\n if(gx%bmperr.ne.0) goto 1000\n else\n write(*,*)'3E unknown addition'\n nullify(phlista(jph)%additions)\n goto 550\n endif\n! copy the old status word\n nyaddlink%status=iws(lokem+3)\n! link the additions sequentially\n \n if(associated(addlink)) then\n addlink%nextadd=>nyaddlink\n else\n phlista(jph)%additions=>nyaddlink\n endif\n nullify(nyaddlink%nextadd)\n addlink=>nyaddlink\n550 continue\n lokem=iws(lokem)\n if(lokem.gt.0) goto 510\n else\n nullify(phlista(jph)%additions)\n endif\n900 continue\n! take next phase\n lok=iws(lok)\n enddo bigloop\n! all data for the phase read\n1000 continue\n kkk=jph\n return\n end subroutine readphases\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readendmem\n!\\begin{verbatim}\n subroutine readendmem(lokem,iws,nsl,emrec)\n! allocates and reads an endmember record and its property record from iws\n! emrec is an un-allocated pointer in the parameter tree structure\n implicit none\n integer lokem,nsl,iws(*)\n type(gtp_endmember), pointer :: emrec\n!\\end{verbatim} %+\n integer i,j,displace,lokpty\n type(gtp_property), pointer :: proprec\n!\n allocate(emrec)\n! write(*,*)'3E Allocating endmember for',lokem,iws(lokem),iws(lokem+1),&\n! iws(lokem+2)\n! iws(lokem) is next endmember\n! iws(lokem+1) is property\n! iws(lokem+2) is interaction\n! read(lin)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem\n emrec%noofpermut=iws(lokem+3)\n emrec%phaselink=iws(lokem+4)\n emrec%antalem=iws(lokem+5)\n displace=5\n allocate(emrec%fraclinks(nsl,emrec%noofpermut))\n do j=1,emrec%noofpermut\n! read(lin)(emrec%fraclinks(i,j),i=1,nsl)\n do i=1,nsl\n emrec%fraclinks(i,j)=iws(lokem+displace+i)\n enddo\n displace=displace+nsl\n enddo\n nullify(emrec%nextem)\n nullify(emrec%intpointer)\n nullify(emrec%propointer)\n! called nop when storing in iws\n lokpty=lokem+1\n if(iws(lokpty).gt.0) then\n! property list loop inside readproprec\n call readproprec(lokpty,iws,emrec%propointer)\n! write(*,*)'3E Back from readproprec 1'\n endif\n1000 continue\n return\n end subroutine readendmem\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readproprec\n!\\begin{verbatim}\n subroutine readproprec(lokpty,iws,firstproprec)\n! allocates and a property record for both endmembers and interactions\n implicit none\n integer lokpty,iws(*)\n type(gtp_property), pointer :: firstproprec\n!\\end{verbatim} %+\n integer i,lokfun,displace\n! type(gtp_property), allocatable, target :: prec\n type(gtp_property), pointer :: proprec\n! lokpty is the location where there can be a property record pointer\n nullify(proprec)\n do while(iws(lokpty).gt.0)\n lokpty=iws(lokpty)\n if(associated(proprec)) then\n allocate(proprec%nextpr)\n proprec=>proprec%nextpr\n else\n allocate(firstproprec)\n proprec=>firstproprec\n endif\n! read(lin)proprec%reference,proprec%proptype,&\n! proprec%degree,proprec%extra,proprec%antalprop,nox\n! write(*,88)lokpty,iws(lokpty),iws(lokpty+1),iws(lokpty+2)\n proprec%proptype=iws(lokpty+1)\n proprec%degree=iws(lokpty+2)\n proprec%extra=iws(lokpty+3)\n proprec%antalprop=iws(lokpty+4)\n call loadc(lokpty+5,iws,proprec%reference)\n displace=5+nwch(16)\n call loadc(lokpty+displace,iws,proprec%modelparamid)\n! write(*,*)'3E place to find modelparamid: ',&\n! proprec%modelparamid,lokpty+displace\n! check that this is the same as the proptype!!\n i=proprec%proptype\n if(i.gt.100) i=i/100\n if(proprec%modelparamid.ne.propid(i)%symbol) then\n write(*,96)i,proprec%modelparamid,propid(i)%symbol\n96 format('3E Model property ',i2,' has changed from ',&\n a,' to ',a/'Please contact Bo Sundman for help!')\n! else\n! debug\n! write(*,96)i,proprec%modelparamid,propid(i)%symbol\n endif\n! lokfun=lokpty+5+nwch(16)\n lokfun=lokpty+displace+nwch(4)\n! links to function as stored as integer indices\n allocate(proprec%degreelink(0:proprec%degree))\n do i=0,proprec%degree\n! functions already read and hopefully stored with same index!\n proprec%degreelink(i)=iws(lokfun+i)\n enddo\n! write(*,*)'3E Allocated property record ',lokpty,iws(lokpty),&\n! proprec%proptype,proprec%degree\n! nullify(proprec%nextpr)\n enddo\n! make sure the list is terminated by a null pointer\n nullify(proprec%nextpr)\n1000 continue\n return\n end subroutine readproprec\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readintrec\n!\\begin{verbatim}\n subroutine readintrec(lokint,iws,level,intrec)\n! allocates and reads an interaction record\n implicit none\n integer lokint,iws(*),level\n type(gtp_interaction), pointer :: intrec\n!\\end{verbatim} %+\n integer fipsize,noofperm,i,displace,lokpty,lokalint\n type(gtp_property), pointer :: proprec\n! the storage of permutations in interaction records is complex ... one must\n! take into account the number of permutations in lower order intecations ...\n! for an fcc endmember A:A:A:B (4 perm) the binary interaction A:A:A,B:B has \n! 3; 3; 3 and 3 perms and the ternary A:A,B:A,B:B has 2; 2; 2; 2\n! mult may not be needed ...\n! one should never allocate a pointer ... but this is more or less permanent\n allocate(intrec)\n!>>>>> 9D: actually read the interaction record\n! lokalint=iws(lokint)\n lokalint=lokint\n intrec%status=iws(lokalint+3)\n intrec%antalint=iws(lokalint+4)\n intrec%order=iws(lokalint+5)\n! nullify Toop-Kohler link\n nullify(intrec%tooprec)\n fipsize=iws(lokalint+6)\n! write(*,'(a,5i5)')'3E readintrec 1:',intrec%antalint,lokalint,fipsize,level\n allocate(intrec%noofip(fipsize))\n! read(lin)intrec%noofip,intrec%status,noi,nup,nop\n displace=6\n do i=1,fipsize\n intrec%noofip(i)=iws(lokalint+displace+i)\n enddo\n displace=displace+fipsize\n! 2020.06.08/BoS error saving a parameter with level=2 ??? but when saveing\n! an interaction record there are only level=1 separate ???\n if(level.eq.1) then\n noofperm=intrec%noofip(fipsize)\n else \n noofperm=intrec%noofip(2)\n! else\n! I do not understand this error ...\n! write(*,*)'3E too many interaction levels for permutations',level\n! gx%bmperr=4399; goto 1000\n endif\n! if(level.eq.0) then\n! noofperm=intrec%noofip(2)\n! elseif(level.eq.1) then\n! noofperm=intrec%noofip(fipsize)\n! else\n! write(*,*)'3E too many interaction levels for permutations',level\n! gx%bmperr=4399; goto 1000\n! endif\n! end of code changes 2020.06.08/BoS\n allocate(intrec%sublattice(noofperm))\n allocate(intrec%fraclink(noofperm))\n! write(*,*)'3E allocate link: ',intrec%antalint,intrec%noofip(2)\n do i=1,noofperm\n intrec%sublattice(i)=iws(lokalint+displace+2*i-1)\n intrec%fraclink(i)=iws(lokalint+displace+2*i)\n enddo\n nullify(intrec%nextlink)\n nullify(intrec%highlink)\n nullify(intrec%propointer)\n! link to property record in lokalint+2\n lokpty=lokalint+2\n if(iws(lokpty).gt.0) then\n call readproprec(lokpty,iws,intrec%propointer)\n! write(*,*)'3E Back from readproprec 2'\n! if there are no property records proprec is still nullified\n endif\n1000 continue\n return\n end subroutine readintrec\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readequil\n!\\begin{verbatim}\n subroutine readequil(lokeq,iws,elope)\n! subroutine readequil(lokeq,iws,elope,ceq)\n! lokeq is index for equilibrium record in iws\n implicit none\n integer lokeq,iws(*),elope\n!\\end{verbatim} %+\n type(gtp_equilibrium_data), pointer :: ceq\n character text*2048,dum16*16,line*72,ctext*72\n type(gtp_phase_varres), pointer :: firstvarres\n TYPE(gtp_fraction_set), pointer :: fslink\n integer i,ierr,ip,isp,ivar,j,jp,k,lokcs,lokph,mc,mc2,nprop,nsl,kp,kl\n integer displace,llen,lok,lokvares,lokdiz,eqdis,lokcc,disz,conditionplace\n integer offset,lokd,dmc,eqnumber,fixph\n double precision, dimension(:,:), allocatable :: ca,ci\n double precision xxx\n! containing conditions, components and phase varres records for wach compset\n!>>>>> 50:\n! read(lin)ceq%eqname,ceq%eqno,ceq%status,ceq%next\n! write(*,*)'3E In readequil ',lokeq,elope\n! constat\n! elope=1 to read first equilibrium, -1 to read second or later\n eqnumber=1\n17 continue\n if(elope.lt.0) then\n! take next equilibrium and increment eqnumber\n lokeq=iws(lokeq)\n eqnumber=eqnumber+1\n endif\n ceq=>eqlista(eqnumber)\n if(lokeq.le.0) then\n if(elope.gt.0) then\n! if this is the first equilibrium this is an error, otherwise just end of list\n write(*,*)'3E Not an equilibrium record'\n gx%bmperr=4399\n endif\n goto 1000\n endif\n! write(*,12)'3E Reading equilibrium ',lokeq,eqnumber,iws(lokeq+3),&\n! iws(lokeq+1)\n12 format(a,3i5,1x,z8)\n ceq%status=iws(lokeq+1)\n! set that no calculation is made in status word to prevent listing ?? why ??\n! ceq%status=ibset(ceq%status,EQNOEQCAL)\n ceq%multiuse=iws(lokeq+2)\n! Hm, eqno should not be changed? By default arbitrary value!!\n if(eqnumber.ne.iws(lokeq+3)) then\n write(*,*)'3E Should be same equilibrium number ',eqnumber,iws(lokeq+3)\n endif\n ceq%eqno=iws(lokeq+3)\n ceq%nexteq=iws(lokeq+4)\n call loadc(lokeq+5,iws,ceq%eqname)\n! write(*,*)'3E Reading equilibrium with name: ',ceq%eqname\n displace=5+nwch(24)\n call loadc(lokeq+displace,iws,ceq%comment)\n! write(*,*)'3E comment: \"',trim(ceq%comment),'\" ',len_trim(ceq%comment)\n displace=displace+nwch(72)\n! values of T and P and weight\n call loadrn(2,iws(lokeq+displace),ceq%tpval)\n call loadr(lokeq+displace+2*nwpr,iws,ceq%weight)\n displace=displace+3*nwpr\n!----- components (must be elements). Must be entered before conditions\n! complist already allocated for 20\n if(allocated(ceq%complist)) then\n deallocate(ceq%complist)\n endif\n allocate(ceq%complist(noofel))\n if(eqnumber.gt.1) then\n allocate(ceq%compstoi(noofel,noofel))\n allocate(ceq%invcompstoi(noofel,noofel))\n endif\n ceq%compstoi=zero\n ceq%invcompstoi=zero\n do kl=1,noofel\n! when the elements are components ...\n ceq%compstoi(kl,kl)=one\n ceq%invcompstoi(kl,kl)=one\n enddo\n llen=0\n lokcc=iws(lokeq+displace+2)\n do while(lokcc.gt.0)\n llen=llen+1\n if(llen.gt.noofel) then\n write(*,*)'3E Too many components'\n gx%bmperr=4399; goto 1000\n endif\n ceq%complist(llen)%splink=iws(lokcc+1)\n ceq%complist(llen)%phlink=iws(lokcc+2)\n ceq%complist(llen)%status=iws(lokcc+3)\n call loadc(lokcc+4,iws,ceq%complist(llen)%refstate)\n disz=4+nwch(16)\n kl=iws(lokcc+disz)\n if(kl.gt.0) then\n allocate(ceq%complist(llen)%endmember(kl))\n do mc=1,kl\n ceq%complist(llen)%endmember(mc)=iws(lokcc+disz+mc)\n enddo\n! write(*,*)'3E endmem: ',kl,(ceq%complist(llen)%endmember(mc),mc=1,kl)\n disz=disz+kl+1\n else\n disz=disz+1\n endif\n call loadrn(2,iws(lokcc+disz),ceq%complist(llen)%tpref)\n! write(*,*)'3E refstate 2: ',ceq%complist(llen)%tpref\n disz=disz+2*nwpr\n call loadrn(2,iws(lokcc+disz),ceq%complist(llen)%chempot)\n disz=disz+2*nwpr\n call loadr(lokcc+disz,iws,ceq%complist(llen)%mass)\n! write(*,*)'3E loading component mass',lokcc,disz,llen,&\n! ceq%complist(llen)%mass\n call loadr(lokcc+disz+nwpr,iws,ceq%complist(llen)%molat)\n lokcc=iws(lokcc)\n enddo\n!----- conditions (note that inactive conditions not set)\n! conditions cannot be entered before the phase_varres for all phases\n conditionplace=displace\n!----------- phase_varres record\n!>>>>> 54:\n highcs=iws(lokeq+displace+3)\n if(ocv()) then\n write(*,*)'3E Number of phase_varres records: ',highcs\n write(*,*)'phase_varres size: ',size(ceq%phase_varres)\n endif\n! link to first varres record stored here\n lokvares=iws(lokeq+displace+4)\n! write(*,*)'3E lokvares: ',lokvares,highcs,lokeq,displace+4\n eqdis=displace+5\n! for equilibria 2 and higher phase_varees must be allocated!!\n if(eqnumber.gt.1) then\n! write(*,*)'3E allocating phase_varres for equilibrium: ',eqnumber\n allocate(ceq%phase_varres(highcs+5))\n! we should also allocate a few other things\n allocate(ceq%eq_tpres(maxtpf))\n allocate(ceq%svfunres(maxsvfun))\n do j=1,maxtpf\n ceq%eq_tpres(j)%forcenewcalc=0\n enddo\n ceq%tpval(1)=1.0D3\n ceq%tpval(2)=1.0D5\n endif\n compset: do j=1,highcs\n if(lokvares.le.100) then\n write(*,*)'3E error linking phase_varres records ...',lokvares,j\n goto 1000\n endif\n!------------------------------------------\n! DEBUGPROBLEM BEWARE, using = instead of => below took 2 days to find\n!------------------------------------------\n! >>> firstvarres=ceq%phase_varres(j) <<< error\n firstvarres=>ceq%phase_varres(j)\n!>>>>> 55:\n firstvarres%nextfree=iws(lokvares+1)\n lokph=iws(lokvares+2)\n if(lokph.lt.0) then\n! this means this phase_varres record is not used\n! we have already save the free list link, just skip the rest\n write(*,*)'3E found unused phase_varres record: ',j,lokvares\n lokvares=iws(lokvares)\n cycle compset\n endif\n firstvarres%phlink=lokph\n firstvarres%status2=iws(lokvares+3)\n firstvarres%phstate=iws(lokvares+4)\n firstvarres%phtupx=iws(lokvares+5)\n nsl=iws(lokvares+6)\n mc=iws(lokvares+7)\n! write(*,*)'3E read mc ',trim(phlista(lokph)%name),nsl,mc,j\n call loadc(lokvares+8,iws,firstvarres%prefix)\n displace=8+nwch(4)\n call loadc(lokvares+displace,iws,firstvarres%suffix)\n displace=displace+nwch(4)\n call loadrn(3,iws(lokvares+displace),firstvarres%abnorm)\n displace=displace+3*nwpr\n! we need these values here! but now they are stored in iws!!\n! nsl=phlista(lokph)%noofsubl\n! mc=phlista(lokph)%tnooffr\n mc2=mc*(mc+1)/2\n if(btest(firstvarres%status2,CSDLNK)) then\n! varres record with link to disordered varres record, some data to be stored\n! NOTE necessary data for nsl and mc stored later ...\n! we need these values here!\n! write(*,*)'3E varres with link to disordered fraction varres'\n offset=6+2*nwch(4)+3*nwpr+mc*(1+2*nwpr)+nsl*nwpr\n! write(*,202)'3E offset:',j,lokvares,displace,iws(lokvares+displace),&\n! nsl,mc,offset,iws(lokvares+offset),iws(lokvares+26)\n202 format(a,10i6)\n! stop\n! elseif(btest(firstvarres%status2,CSDFS)) then\n! write(*,*)'3E varres for disordered fraction set OK',j,nsl,mc\n! this phase_varres/parres record belong to disordered fraction_set\n! we should use nsl and mc from disordered fraction set!\n! but they are not yet created...\n endif\n! write(*,88)'3E reading phase_varres ',j,highcs,lokvares,nsl,mc,&\n! trim(phlista(lokph)%name)\n!88 format(a,5i7,2x,a)\n!\n! write(*,*)'3E allocating constat: ',j,mc\n allocate(firstvarres%constat(mc))\n do i=1,mc\n firstvarres%constat(i)=iws(lokvares+displace+i-1)\n enddo\n displace=displace+mc\n allocate(firstvarres%yfr(mc))\n call loadrn(mc,iws(lokvares+displace),firstvarres%yfr)\n displace=displace+mc*nwpr\n! write(*,*)'3E not allocating mmyfr'\n displace=displace+mc*nwpr\n allocate(firstvarres%sites(nsl))\n! write(*,*)'3E sites: ',lokvares,displace,lokvares+displace\n call loadrn(nsl,iws(lokvares+displace),firstvarres%sites)\n displace=displace+nsl*nwpr\n!-----------------------------------\n! BEWHERE allocation of the dpqdy and d2pqdvay!!! \n! They are not saved but should be allocated here! need lokph\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! write(*,*)'3E ionic liquid',lokph,eqnumber\n allocate(firstvarres%dpqdy(mc))\n allocate(firstvarres%d2pqdvay(mc))\n firstvarres%dpqdy=zero\n firstvarres%d2pqdvay=zero\n endif\n!-------------------------------------\n! write(*,*)'3E odd: ',lokvares,displace\n fsrec: if(btest(firstvarres%status2,CSDLNK)) then\n! write(*,*)'3E disfra record:',lokvares,displace,iws(lokvares+displace)\n! disfra record\n lokd=iws(lokvares+displace)\n fslink=>firstvarres%disfra\n fslink%latd=iws(lokd)\n nsl=iws(lokd+1)\n fslink%ndd=nsl\n dmc=iws(lokd+2)\n fslink%tnoofxfr=dmc\n fslink%tnoofyfr=iws(lokd+3)\n fslink%totdis=iws(lokd+4)\n fslink%varreslink=iws(lokd+5)\n call storc(lokd+6,iws,fslink%id)\n disz=6+nwch(1)\n allocate(fslink%nooffr(nsl))\n allocate(fslink%splink(dmc))\n allocate(fslink%y2x(mc))\n allocate(fslink%dsites(nsl))\n allocate(fslink%dxidyj(mc))\n disz=6+nwch(1)\n do i=1,nsl\n fslink%nooffr(i)=iws(lokd+disz+i)\n enddo\n disz=disz+nsl\n! write(*,202)'3E disfra 1: ',lokd,disz\n do i=1,dmc\n fslink%splink(i)=iws(lokd+disz+i)\n enddo\n disz=disz+dmc+1\n! we must use the ordered number of constituents here!!\n if(mc.ne.iws(lokd+disz)) then\n write(*,*)'3E constituent number error: ',mc,iws(lokd+disz)\n mc=iws(lokd+disz)\n endif\n! write(*,202)'3E disfra 2: ',lokd,disz\n do i=1,mc\n fslink%y2x(i)=iws(lokd+disz+i)\n enddo\n disz=disz+mc+1\n! write(*,202)'3E disfra 3: ',lokd,disz\n call loadrn(nsl,iws(lokd+disz),fslink%dsites)\n disz=disz+nsl*nwpr\n! write(*,202)'3E disfra 4: ',lokd,disz\n call loadrn(mc,iws(lokd+disz),fslink%dxidyj)\n disz=disz+mc*nwpr\n! write(*,202)'3E disfra 5: ',lokd,disz\n call loadr(lokd+disz,iws,fslink%fsites)\n! write(*,*)'3E disfra last: ',lokd+disz+nwpr\n else\n firstvarres%disfra%varreslink=0\n endif fsrec\n displace=displace+1\n call loadr(lokvares+displace,iws,firstvarres%amfu)\n call loadr(lokvares+displace+nwpr,iws,firstvarres%netcharge)\n call loadr(lokvares+displace+2*nwpr,iws,firstvarres%dgm)\n! NEW value of qcbonds for quasichemical model, increment of displace!!\n call loadr(lokvares+displace+3*nwpr,iws,firstvarres%qcbonds)\n displace=displace+4*nwpr\n nprop=iws(lokvares+displace)\n if(nprop.lt.20) then\n! write(*,303)'3E get nprop: ',lokvares,displace,lokvares+displace,&\n! nprop,trim(phlista(lokph)%name)\n nprop=20\n endif\n303 format(a,4i7,2x,a)\n firstvarres%nprop=nprop\n allocate(firstvarres%listprop(nprop))\n! calculated results, only G saved\n allocate(firstvarres%gval(6,nprop))\n displace=displace+1\n! we have saved only G values\n do i=1,6\n call loadr(lokvares+displace+nwpr*(i-1),iws,firstvarres%gval(i,1))\n enddo\n displace=displace+6*nwpr\n allocate(firstvarres%dgval(3,mc,nprop))\n do i=1,3\n do k=1,mc\n call loadr(lokvares+displace,iws,firstvarres%dgval(i,k,1))\n displace=displace+nwpr\n enddo\n enddo\n allocate(firstvarres%d2gval(mc2,nprop))\n do i=1,mc2\n call loadr(lokvares+displace+nwpr*(i-1),iws,firstvarres%d2gval(i,1))\n enddo\n! link to next stored phase_varres record\n lokvares=iws(lokvares)\n enddo compset\n! if(elope.lt.0) then\n csfree=highcs+1\n! endif\n! write(*,*)'3E csfree: ',highcs,csfree,elope\n! write(*,*)'3E All phase_varres records created for ',ceq%eqno\n!----- conditions (note that inactive conditions not set)\n! lok=iws(lokeq+displace)\n lok=iws(lokeq+conditionplace)\n nullify(ceq%lastcondition)\n nullify(ceq%lastexperiment)\n if(lok.gt.0) then\n llen=iws(lok)\n call loadc(lok+1,iws,text(1:llen))\n! write(*,*)'3E Conditions: \"',text(1:llen),'\"',llen\n if(llen.gt.0) then\n! set the conditions, kp will be incremented by 1 in enter_condition\n! the text contains \" number: variable expression=value, \"\n! we have to set each condition separately. There can be , but no :\n! in the variable expressions.\n jp=1; ip=llen\n cloop: do while(jp.lt.ip)\n k=index(text(jp:ip),':')\n if(k.le.0) exit cloop\n line=text(jp+k:ip)\n jp=jp+k+2\n! remove any commma followed by space \", \" as that indicates there are more \n! conditions on the same line\n kp=index(line,', ')\n if(kp.gt.0) then\n line(kp:)=' '\n else\n kp=index(line,' ')\n line(kp:)=' '\n endif\n! We must handle fix phases :: =value transforms to fix=phase == value\n if(line(1:1).eq.'<') then\n kp=index(line,'>')\n fixph=kp+1\n call getrel(line,fixph,xxx)\n if(buperr.ne.0) then\n buperr=0; xxx=zero\n endif\n ctext=' FIX='//line(2:kp-1)//' == '//line(fixph+1:)\n! write(*,*)'3E fixph: ',trim(ctext)\n line=ctext\n endif\n kp=0\n! write(*,*)'3E set condition \"',trim(line),'\"',jp,ip\n call set_condition(line,kp,ceq)\n! write(*,*)'3E back from set condition \"',gx%bmperr\n if(gx%bmperr.ne.0) then\n write(*,*)'3E Error setting conditions'\n write(*,*)'3E condition \"',trim(line),'\"',kp\n goto 1000\n endif\n enddo cloop\n endif\n! else\n! write(*,*)'3E no conditions on unformatted file'\n endif\n!----- experiments\n lok=iws(lokeq+conditionplace+1)\n733 continue\n kp=0\n if(lok.gt.0) then\n! experiments are stored individually in a linked list\n kp=kp+1\n llen=iws(lok+1)\n text=' '\n call loadc(lok+2,iws,text(1:llen))\n! write(*,*)'3E found experiment: \"',trim(text),'\"'\n llen=0\n call enter_experiment(text,llen,ceq)\n! write(*,*)'3E Back from enter_experiment'\n if(gx%bmperr.ne.0) then\n write(*,*)'3E error entering experiment ',gx%bmperr,' continuing'\n gx%bmperr=0\n endif\n lok=iws(lok)\n goto 733\n endif\n if(kp.gt.0) write(*,*)'3E Found ',kp,' experiments'\n!-------------------------- a few remaining things\n ceq%maxiter=iws(lokeq+eqdis)\n if(.not.allocated(ceq%cmuval)) then\n allocate(ceq%cmuval(noofel))\n endif\n call loadrn(noofel,iws(lokeq+eqdis+1),ceq%cmuval)\n eqdis=eqdis+1+noofel*nwpr\n call loadr(lokeq+eqdis,iws,ceq%xconv)\n! modifed 2018.05.28 by adding gdconv(2)\n call loadr(lokeq+eqdis+nwpr,iws,ceq%gdconv(1))\n call loadr(lokeq+eqdis+2*nwpr,iws,ceq%gdconv(2))\n call loadr(lokeq+eqdis+3*nwpr,iws,ceq%gmindif)\n! if elope negative continue reading next equilibrium\n if(elope.lt.0) then\n! write(*,*)'3E read the next equilibrium'\n! increment the index of first free equilibrium\n eqfree=eqfree+1\n goto 17\n endif\n!\n1000 continue\n if(eqfree.gt.2) write(*,1010)eqfree-1\n1010 format('3E Read ',i4,' equilibria')\n return\n end subroutine readequil\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine svfunread\n!\\begin{verbatim}\n subroutine svfunread(loksvf,iws)\n! read a state variable function from save file and store it.\n! by default there are some state variable functions, make sure\n! they are deleted. Done here just by setting nsvfun=0\n implicit none\n integer loksvf,iws(*)\n!\\end{verbatim} %+\n integer nsvfun,i,ip,lok,eqno\n character*512 text\n nsvfun=iws(loksvf)\n! first 3 symbols are R, RT and T_C\n do i=iws(loksvf+1)+1,nsvfun\n lok=iws(loksvf+i)\n ip=iws(lok)\n text=' '\n call loadc(lok+1,iws,text(1:ip))\n! write(*,*)'3E Entering saved svf: \"',text(1:ip),'\"'\n! NOTE: position 1-7 are equilibrium number and status\n ip=7\n call enter_svfun(text,ip,firsteq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3E Error entering saved svf',gx%bmperr\n if(gx%bmperr.ne.4136) goto 1000\n gx%bmperr=0\n endif\n! if this function should be evaluated at a particular equilibrium that is\n! in position 1-5. Extra status in position 6 and 7\n! write(*,*)'3E read symbol: ',i,': ',text(1:ip),ip\n! Letters used for the status bits:\n! A SVNOAM a function or constant that cannot be amended\n! C SVCONST a constant that can be amended\n! D SVFDOT a dot derivative (also SVFVAL set)\n! N SVFVAL symbol evaluated only if explitly referenced)\n! X SVFEXT only evaluated for a specific equilibrium (preceeded by eq.number)\n! I SVIMPORT import value from TP function (preceeded by TP index)\n! E SVEXPORT expert value to TP function constant (preceeded by TP index)\n! check if symbol is a constant (can be amended)\n if(text(5:5).eq.'C') then\n svflista(i)%status=ibset(svflista(i)%status,SVNOAM)\n elseif(text(5:5).eq.'C') then\n svflista(i)%status=ibset(svflista(i)%status,SVCONST)\n! check if symbol should only be evaluated when explicitly requested\n elseif(text(5:5).eq.'D') then\n! D means the symbol is a dot variable, evaluates only when explitly refered\n svflista(i)%status=ibset(svflista(i)%status,SVFDOT)\n svflista(i)%status=ibset(svflista(i)%status,SVFVAL)\n elseif(text(5:5).eq.'V') then\n svflista(i)%status=ibset(svflista(i)%status,SVFVAL)\n endif\n! extract any number before postion 5\n ip=0\n! ip is incremented in getint\n call getint(text,ip,eqno)\n if(buperr.ne.0) then\n buperr=0\n else\n if(text(5:5).eq.'X') then\n! symbol should be evaluated at a specific equilibrium (eqno)\n svflista(i)%status=ibset(svflista(i)%status,SVFEXT)\n svflista(i)%eqnoval=eqno\n elseif(text(5:5).eq.'I') then\n! symbol should be imported from TP function\n svflista(i)%status=ibset(svflista(i)%status,SVIMPORT)\n svflista(i)%tplink=eqno\n elseif(text(5:5).eq.'E') then\n! symbol should be exported to TP constant\n svflista(i)%status=ibset(svflista(i)%status,SVEXPORT)\n svflista(i)%tplink=eqno\n else\n! a number with no meaning!\n write(*,*)trim(text)\n100 format(' *** Warning, error reading symbol:'/a)\n endif\n endif\n enddo\n1000 continue\n return\n end subroutine svfunread\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine biblioread\n!\\begin{verbatim}\n subroutine biblioread(bibhead,iws)\n! read references from save file\n implicit none\n integer bibhead,iws(*)\n!\\end{verbatim} %+\n character text*2048\n integer i,iref,jp,nrefs,lok,kk,ir,nr\n!>>>>> 40: number of references\n! write(*,*)'3E Reading reference version and nummer of'\n nrefs=iws(bibhead)\n do i=1,nrefs\n lok=iws(bibhead+i)\n jp=iws(lok)\n call loadc(lok+1,iws,text(1:jp))\n call tdbrefs(text(1:16),text(17:jp),0,iref)\n enddo\n1000 continue\n return\n end subroutine biblioread\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\addtotable subroutine readash\n!\\begin{verbatim}\n subroutine readash(lok,iws)\n! reading assessment records\n integer lok,iws(*)\n!\\end{verbatim}\n integer lok1,lok2,last,rsize,i1,i2,disp,kk\n double precision xxx\n type(gtp_assessmenthead), pointer :: assrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\n lok1=lok\n assrec=>firstash%nextash\n20 continue\n if(iws(lok1).eq.0) goto 1000\n lok1=iws(lok1)\n assrec%status=iws(lok1+1)\n assrec%varcoef=iws(lok1+2)\n assrec%firstexpeq=iws(lok1+3)\n assrec%lwam=iws(lok1+4)\n call loadc(lok1+5,iws,assrec%general)\n disp=5+nwch(64)\n call loadc(lok1+disp,iws,assrec%special)\n disp=disp+nwch(64)\n lok2=iws(lok1+disp+1)\n if(lok2.gt.0) then\n! eqlista\n! lok2=iws(lok2)\n i1=iws(lok2)\n if(i1.gt.0) then\n! write(*,'(a,4i10)')'3E In readash 1: ',lok,lok1,lok2,i1\n allocate(assrec%eqlista(i1))\n! in iws(lok2+i2) the index to eqlista is stored, \n! assrec%eqlista(i2)%p1 is a pointer to this equilibrium\n do i2=1,i1\n ceq=>eqlista(iws(lok2+i2))\n assrec%eqlista(i2)%p1=>ceq\n enddo\n endif\n else\n write(*,*)'3E no experimental data'\n endif\n lok2=iws(lok1+disp+2)\n if(lok2.le.0) then\n write(*,*)'3E no coefficient values saved'\n goto 777\n else\n! coeffvalues\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 2: ',lok2,i1\n allocate(assrec%coeffvalues(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffvalues)\n endif\n lok2=iws(lok1+disp+3)\n! coeffrsd\n! lok2=iws(lok2)\n if(lok2.gt.0) then\n i1=iws(lok2)\n! write(*,*)'3E In readash RSD: ',lok2,i1\n allocate(assrec%coeffrsd(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffrsd)\n endif\n! lok2=iws(lok1+disp+3)\n lok2=iws(lok1+disp+4)\n if(iws(lok2).gt.0) then\n! coeffscale\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 3: ',lok2,i1\n allocate(assrec%coeffscale(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffscale)\n endif\n! lok2=iws(lok1+disp+4)\n lok2=iws(lok1+disp+5)\n if(iws(lok2).gt.0) then\n! coeffstart\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 4: ',lok2,i1\n allocate(assrec%coeffstart(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffstart)\n endif\n! lok2=iws(lok1+disp+5)\n lok2=iws(lok1+disp+6)\n if(iws(lok2).gt.0) then\n! coeffmin\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 5: ',lok2,i1\n allocate(assrec%coeffmin(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffmin)\n endif\n! lok2=iws(lok1+disp+6)\n lok2=iws(lok1+disp+7)\n if(iws(lok2).gt.0) then\n! coeffmax\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 6: ',lok2,i1\n allocate(assrec%coeffmax(0:i1-1))\n call loadrn(i1,iws(lok2+1),assrec%coeffmax)\n endif\n! lok2=iws(lok1+disp+7)\n lok2=iws(lok1+disp+8)\n if(iws(lok2).gt.0) then\n! coeffindices\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 7: ',lok2,i1\n allocate(assrec%coeffindex(0:i1-1))\n do i2=1,i1\n assrec%coeffindex(i2-1)=iws(lok2+i2)\n enddo\n! store these values in tpfun ...\n do kk=0,i1-1\n! write(*,333)'3E storing as TP funs ',kk,assrec%coeffindex(kk),&\n! assrec%coeffvalues(kk),assrec%coeffscale(kk)\n333 format(a,2i4,6(1pe12.4))\n! firstash or assrec??\n xxx=assrec%coeffvalues(kk)*assrec%coeffscale(kk)\n call change_optcoeff(assrec%coeffindex(kk),xxx)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n endif\n! lok2=iws(lok1+disp+8)\n lok2=iws(lok1+disp+9)\n if(iws(lok2).gt.0) then\n! coeffstate\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 8: ',lok2,i1\n allocate(assrec%coeffstate(0:i1-1))\n do i2=1,i1\n assrec%coeffstate(i2-1)=iws(lok2+i2)\n enddo\n endif\n777 continue\n! maybe work array has been daved also?\n! lok2=iws(lok1+disp+9)\n lok2=iws(lok1+disp+10)\n if(lok2.gt.0) then\n if(iws(lok2).gt.0) then\n! lok2=iws(lok2)\n i1=iws(lok2)\n! write(*,*)'3E In readash 9: ',lok2,i1\n allocate(assrec%wopt(i1))\n call loadrn(i1,iws(lok2+1),assrec%wopt)\n endif\n endif\n! check if there are several assessmentheads\n if(iws(lok1).gt.0) then\n! There are more records, try to create a circular list in both directions\n write(*,*)'3E In readash 10: ',lok1,iws(lok1)\n allocate(assrec%nextash)\n assrec%nextash%prevash=>assrec\n assrec=>assrec%nextash\n firstash%prevash=>assrec\n write(*,*)'3E more assessment records'\n goto 20\n endif\n1000 continue\n return\n end subroutine readash\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function iskeyword\n!\\begin{verbatim}\n logical function iskeyword(text,keyword,nextc)\n! compare a text with a given keyword. Abbreviations allowed\n! but the keyword and abbreviation must be surrounded by spaces\n! nextc set to space character in text after the (abbreviated) keyword\n implicit none\n character text*(*),keyword*(*),key*64\n integer nextc\n!\\end{verbatim} %+\n character word*64\n logical ok\n integer kl,ks,kt\n! extract the first word of text\n ks=1\n if(eolch(text,ks)) then\n! if empty line, just exit\n ok=.false.; goto 1000\n else\n! find the space after the first word\n kt=ks+index(text(ks:),' ')-1\n! the abbreviation of the keyword must be at least 3 character !!!\n if(kt-ks.lt.3 .or. kt-ks.ge.64) then\n ok=.false.; goto 1000\n endif\n endif\n word=text(ks:kt)\n kt=kt-ks\n key=keyword\n kl=len_trim(key)\n! check if word is an abbreviation of key\n if(word(1:kt).eq.key(1:kt)) then\n! found keyword at start of line, set nextc to be positioned at the final space\n nextc=ks+kt\n ok=.true.\n else\n ok=.false.\n endif\n! write(*,100)ok,text(1:15),word(1:15),key(1:15),nextc,ks,kt,kl\n!100 format('iskeyword: ',l1,' >',a,'<>',a,'<>',a,'<',5i3)\n1000 continue\n iskeyword=ok\n return\n end function iskeyword\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable integer function istdbkeyword\n!\\begin{verbatim} %-\n integer function istdbkeyword(text,nextc)\n! compare a text with a given keyword. Abbreviations allowed (not within _)\n! but the keyword and abbreviation must be surrounded by spaces\n! nextc set to space character in text after the (abbreviated) keyword\n implicit none\n character text*(*)\n integer nextc\n!\\end{verbatim} %+\n! only those currently implemented ... rest ignored\n integer, parameter :: kwl=20\n integer, parameter :: nkw=14\n character (len=kwl), dimension(nkw), parameter :: keyword=&\n ['ELEMENT ','SPECIES ',&\n 'PHASE ','CONSTITUENT ',&\n 'FUNCTION ','PARAMETER ',&\n 'TYPE_DEFINITION ','LIST_OF_REFERENCES ',&\n 'ADD_REFERENCES ','ASSESSED_SYSTEMS ',&\n 'DATABASE_INFORMATION','VERSION ',&\n 'DEFAULT_COMMAND ','DEFINE ']\n! \n character word*64\n integer j,ks,kt\n! extract the first word of text\n ks=1\n if(eolch(text,ks)) then\n! if empty line, just exit\n j=0; goto 1000\n else\n! find the space after the first word\n kt=ks+index(text(ks:),' ')-1\n! the abbreviation of the keyword must be at least 3 character, max kwl\n if(kt-ks.lt.3 .or. kt-ks.ge.kwl) then\n! write(*,*)'3E too long keyword: ',trim(text),kt-ks,kwl\n j=0; goto 1000\n endif\n endif\n word=text(ks:kt)\n kt=kt-ks\n call capson(word)\n! replace - by _\n90 continue\n j=index(word,'-')\n if(j.gt.0) then\n word(j:j)='_'\n goto 90\n endif\n! check if word is an abbreviation of a keyword\n! write(*,*)'abbreviation: ',kt,'>',word(1:kt),'<'\n! do j=1,10\n do j=1,nkw\n if(word(1:kt).eq.keyword(j)(1:kt)) goto 100\n enddo\n j=0\n! write(*,99)j,nextc,text(1:nextc),trim(text)\n99 format('3E Not a keyword: ',2i3,'>',a,'<'/1x,a)\n goto 1000\n! found keyword at start of line, set nextc to be positioned at the final space\n100 continue\n if(j.eq.11 .and. kt.lt.8) then\n! we found 'DATA' at the start of several lines that is not DATABASE_INFO\n! write(*,*)'3E why? ',trim(text),kt\n j=0\n goto 1000\n endif\n nextc=ks+kt\n! write(*,101)j,nextc,text(1:nextc),trim(text)\n101 format('3E Found keyword: ',2i3,'>',a,'<'/1x,a)\n1000 continue\n istdbkeyword=j\n return\n end function istdbkeyword\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine readtdb\n!\\begin{verbatim}\n subroutine readtdb(filename,nel,selel)\n! reading data from a TDB file with selection of elements, read_tdb\n!-------------------------------------------------------\n! Not all TYPE_DEFS implemented\n! MODIFIED FOR ENCRYPTED DATABASES\n!-------------------------------------------------------\n implicit none\n integer nel\n character filename*(*),selel(*)*2\n!\\end{verbatim} %+\n integer, parameter :: maxrejph=30,maxorddis=10,maxtypedefs=100,mtxp=100\n character line*128,elsym*2,name1*24,name2*24,elsyms(10)*2,stoiline*72\n! character longline*10000,reftext*512\n! to read references in MatCalc TDB files\n character longline*40000,reftext*512\n! to handle ternary_extrapolation lines\n character ternaryxpol(mtxp)*2000\n character phtype*1,ch1*1,const(maxsp)*24,name3*24,funname*60,name4*60,chd*1\n character refx*16,more*4\n character (len=1), dimension(maxtypedefs) :: typedefchar\n integer, dimension(maxtypedefs) :: typedefaction\n integer, dimension(5) :: addphasetypedef\n double precision mass,h298,s298\n integer, dimension(10) :: knr,endm\n! lint(1,*) is sublattice, lint(2,*) is species\n double precision stoik(10),xsl,xxx\n integer lint(2,3),TDthisphase,nytypedef,nextc,keyw,tdbv,rewindx,nend\n integer typty,fractyp,lp1,lp2,ix,jph,kkk,lcs,nint,noelx,idum,jdum\n logical onlyfun,nophase,ionliq,notent,mqmqa,ferroref\n integer norew,newfun,nfail,nooftypedefs,nl,ipp,jp,jss,lrot,ip,iq,jt,bmabbr\n integer nsl,ll,kp,nr,nrr,mode,lokph,lokcs,km,nrefs,ideg,iph,ics,ndisph\n integer ntxp,ctxp\n! disparttc and dispartph to handle phases with disordered parts\n integer nofunent,disparttc,dodis,jl,nd1,thisdis,cbug,nphrej,never,always\n character*24 dispartph(maxorddis),ordpartph(maxorddis),phreject(maxrejph)*24\n! character*24 disph(20)\n integer orddistyp(maxorddis),suck,notusedpar,totalpar,reason,zz,dismag\n integer enteredpar,loop,emodel,manylonglines,zp,noparref,pz1,pz2\n type(gtp_phase_add), pointer :: addrec\n logical tdbwarning,only_typedefs\n! this is used for reading encrypted FUNCTION and PARAMETER part of a TDB file\n! integer encrypted ---- replaced by globaldata%encrypted\n! character encryptline*128\n character encryptline*256\n! set to TRUE if element present in database\n logical, allocatable :: present(:)\n! to prevent any output\n logical silent,thisphaserejected,addternaryxpol\n! if tdbwarning is true at the end pause before listing bibliography\n#ifdef encrypopt\n write(*,*)'3E compiled with option to read encrypted files',&\n globaldata%encrypted\n#endif \n! write(*,*)'3E in readtdb 1:',allocated(seltdbph),nselph\n emodel=0\n nsl=0\n bmabbr=0\n noparref=0\n! for mqmqa we need to initiate nend to a negative value\n nend=-100\n! dbcheck made global\n! dbcheck=.FALSE.\n tdbwarning=.FALSE.\n silent=.FALSE.\n addternaryxpol=.FALSE.\n! grobaldata%encrypted=0\n! this was Ting request to have ferromanetic reference state for alloys\n ferroref=.FALSE.\n nphrej=0\n nytypedef=0\n totalpar=0\n notusedpar=0\n enteredpar=0\n manylonglines=0\n ntxp=0\n ctxp=0\n! this counts number of undefined/unused model-parameter-identifiers\n nundefmpi=0\n if(btest(globaldata%status,GSSILENT)) then\n silent=.TRUE.\n! write(*,*)'3E in readtdb reading database silent'\n endif\n! write(*,*)'3E in readtdb reading a TDB file: ',globaldata%encrypted\n if(ocv()) write(*,*)'3E reading a TDB file'\n if(.not.(index(filename,'.tdb').gt.0 &\n .or. index(filename,'.TDB').gt.0)) then\n! no extention provided\n filename(len_trim(filename)+1:)='.TDB'\n endif\n if(nel.gt.0) then\n allocate(present(nel))\n present=.FALSE.\n endif\n! disparttc counts the number of disordered phases to read, the\n! disordered phase names are in dispartph(1..disparttc)\n! dodis is nonzero only when reading the disordered part of phases.\n disparttc=0\n dodis=0\n!====================================================\n#ifdef encrypopt\n! compiled for reading encrypted files\n! write(*,*)'3E compiled for encrypted file: ',globaldata%encrypted\n! globaldata%encrypted nonzero if used given READ ENCRYPTED \n if(globaldata%encrypted.ne.0) then\n! the value of globaldata%encrypted is set in pmon6\n write(*,*)'3E trying to read an encrypted database',trim(filename)\n! stop\n!----------------------------------------------------------------\n! decrypt the file and provide the decrypted file line by line \n!\n! call decrypting software from thalesgroup <<<<<<<<<<<<<<<<<<< line 3987\n!\n!----------------------------------------------------------------\n! As the file is rewinded several times it may be clumsy?\n write(*,*)'3E reading encrypted database: ',trim(filename)\n open(21,file=filename,access='sequential',form='formatted',&\n err=1010,iostat=gx%bmperr,status='old')\n!\n! the decrypted line provided as unit 21\n else\n! allow reading non-encrypted files\n if(.not.silent) write(*,*)'3E nonencrypted database: ',trim(filename)\n open(21,file=filename,access='sequential',form='formatted',&\n err=1010,iostat=gx%bmperr,status='old')\n endif\n#else\n! ======================================================\n if(.not.silent) write(*,19)trim(filename)\n19 format('3E reading database file: ',a)\n!\n open(21,file=filename,access='sequential',form='formatted',&\n err=1010,iostat=gx%bmperr,status='old')\n#endif\n! read whole TDB file to extract TYPE_DEFS with DIS_PART so disordered parts\n! are not entered\n! call any_disordered_part(21,ndisph,disph)\n call any_disordered_part(21,ndisph,dispartph,ordpartph,orddistyp)\n if(ndisph.gt.0) then\n! write(*,*)'3E ndisph: ',ndisph\n! write(*,11)(trim(ordpartph(ip)),trim(dispartph(ip)),orddistyp(ip),&\n! ip=1,ndisph)\n11 format('3E ord/dis: \"',a,'\"+\"',a,'\" ',i2)\n endif\n onlyfun=.FALSE.\n tdbv=1\n norew=0\n newfun=0\n nfail=0\n nrefs=0\n! always is a dummy variable\n always=0\n nooftypedefs=0\n! nophase set false after reading a PHASE keyword, \n! expecting next keyword to be CONSTITUENT\n nophase=.TRUE.\n rewindx=0\n! read whole file FIRST to pick up TYPE_DEFs\n only_typedefs=.TRUE.\n! return here after rewind\n90 continue\n nl=0\n! return here to look for a new keyword, end-of-file OK here\n100 continue\n read(21,110,end=2000)line\n110 format(a)\n nl=nl+1\n! missing capson??\n! call capson(line)\n! REDUNDANT CODE when attempting to separate TDB files in 2 parts\n! if(nl.eq.1) then\n! if(line(1:10).eq.'ENCRYPTED ') then\n! encrypted files consists of a \"structure\" part with elements, phases etc\n! which are not encrypted and a file name with the encrypted FUNCTION and\n! PARAMETER keywords. After reading the structure part call readencrypt\n! onlyfun is set TRUE and that triggers read the encrypted part\n! encrypted=encrypted+1\n! encryptline=line\n! if(encrypted.eq.1) write(*,*)'3E this database has an encrypted part'\n! goto 100\n! endif\n! endif\n! if(len_trim(line).gt.80) then\n! lines longer than 200 characters give warning ... can mess up a lot\n if(len_trim(line).gt.120) then\n manylonglines=manylonglines+1\n if(.not.silent) then\n! if(manylonglines.lt.5) then\n write(*,121)nl\n121 format(' *** Warning: line ',i5,' has characters beyond position',&\n ' 120, some information may be lost')\n! elseif(manylonglines.eq.5) then\n! write(*,*)' Ignoring subsequent longline warnings'\n! endif\n endif\n endif\n! One should remove TAB characters !! ?? YES !!\n! if(line(1:1).eq.'$') goto 100\n ipp=1\n if(eolch(line,ipp)) goto 100\n if(line(ipp:ipp).eq.'$') goto 100\n! replace TAB by space\n call replacetab(line,nl)\n! goto 120\n!---------------------------------------------------------\n! handle all TDB keywords except function\n120 continue\n keyw=istdbkeyword(line,nextc)\n if(.not.(keyw.eq.11 .or. keyw.eq.9 .or. keyw.eq.8)) then\n! added 2023.10.22/BoS. kew=11 is database_information, =8,9 is bibliography\n call capson(line)\n endif\n if(.not.onlyfun) then\n! write(*,71)'3E back from istdbkeyword',keyw\n if(keyw.eq.0) then\n if(trim(line).eq.' DEFINE_SYSTEM_DEFAULT ELEMENT 2 !') then\n goto 100\n elseif(trim(line).eq.'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !') then\n goto 100\n! elseif(dodis.ne.1) then\n elseif(dodis.ne.1 .and. .not.only_typedefs) then\n! do not give this warning when reading disordered phases ...\n! This message came also during reading only_typedfs ...\n write(*,122)nl,trim(line)\n122 format('3E *** Warning, ignoring line ',i5,' with \"',a,'\"'/)\n endif\n endif\n endif\n if(keyw.eq.0) then\n ip=1\n if(.not.eolch(line,ip)) then\n! why error here??\n if(ocv()) write(*,1230)nl,ip,trim(line)\n1230 format('3E Ignoring line: ',i5,i7,' with \"',a,'\"'/)\n! write(*,1230)nl,ip,trim(line)\n! tdbwarning=.true.\n! write(*,*)'3E tdbwarning set true 1'\n endif\n goto 100\n elseif(onlyfun) then\n! keyw=5 is FUNCTION\n if(keyw.eq.5) goto 800\n goto 100\n elseif(only_typedefs) then\n! extract only_typdefs at first read\n if(keyw.ne.7) goto 100\n! write(*,*)'3E reading a TYPE_DEF'\n endif\n!\n if(.not.nophase .and. keyw.ne.4) then\n! after a PHASE keyword one should have a CONSTITUENT\n if(.not.silent) write(kou,*)'3E WARNING expeciting CONSTITUENT: ',&\n line(1:30)\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 2'\n endif\n! check there is a ! in line, otherwise read until we find an exclamation mark\n ip=1\n longline(ip:)=line\n ip=len_trim(longline)+1\n! write(*,71)'3E line 1 ',ip,trim(longline)\n! write(*,*)'3E new keyword ',ip,'>',longline(1:40)\n do while(index(longline,'!').le.0)\n read(21,110,err=2200,end=2200)line\n nl=nl+1\n if(line(1:1).ne.'$') then\n if(.not.(keyw.eq.11 .or. keyw.eq.9 .or. keyw.eq.8)) then\n! no capson for database info and bibliography\n call capson(line)\n else\n! write(*,67)trim(line)\n67 format('info or bib: ',a)\n endif\n call replacetab(line,nl)\n longline(ip:)=line\n ip=len_trim(longline)+1\n if(ip.ge.len(longline)-100) then\n if(.not.silent) write(kou,69)nl,ip,longline(1:72)\n69 format('Overflow in longline ',2i8,' for line starting:'/a)\n gx%bmperr=4304; goto 1000\n endif\n endif\n enddo\n! if(keyw.eq.8 .or. keyw.eq.9) then\n! no capson!!\n! write(*,67)trim(longline)\n! endif\n! Here we have read data for the keyword up to !\n! write(*,71)'3E line 2 ',ip,trim(longline)\n71 format(a,i4,1x,a)\n if(dodis.eq.1) then\n! if dodis=1 only read data for disordred phases\n! PHASE=3, CONSTITUENT=4, PARAMETER=6 ... BIBLIOGRAPHIC REFERENCES=8,9\n! if(keyw.lt.3 .or. keyw.eq.5 .or. keyw.gt.6) goto 100\n if(.not.(keyw.eq.3 .or. keyw.eq.4 .or. keyw.eq.6 &\n .or. keyw.eq.8 .or. keyw.eq.9)) goto 100\n endif\n!\n! we have 13 keywords\n! write(*,*)'3E Reading tdb: ',keyw\n select case(keyw)\n case default\n if(ocv()) write(*,*)'3E default case: ',keyw,line(1:30)\n!---------------------------------------------------------------------\n!101 format('readtdb 1: ',i3,'>',a,'<')\n! if(line(2:9).eq.'ELEMENT ') then\n case(1) !element ------------------------------------------------\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01!\n ip=nextc\n if(eolch(longline,ip)) then\n if(.not.silent) &\n write(kou,*)'No element name after ELEMENT keyword on line ',nl\n gx%bmperr=4305; goto 1000\n endif\n elsym=longline(ip:ip+1)\n if(elsym.eq.'/-' .or. elsym.eq.'VA') goto 100\n! allow lower case in TDB file ...\n call capson(elsym)\n if(nel.gt.0) then\n! check if element among selected, if nel=0 accept all\n do jt=1,nel\n if(elsym.eq.selel(jt)) goto 76\n enddo\n! ignore this element as not selected\n if(ocv()) write(*,*)'3E Skipping database element: ',elsym\n! write(*,*)'Skipping database element: ',elsym\n! write(*,*)'Select: ',nel,(selel(jt),jt=1,nel)\n goto 100\n endif\n! mark we found a selected element\n76 continue\n if(allocated(present)) then\n present(jt)=.TRUE.\n endif\n! we seem to miss the first letter of the reference state below ??\n ip=ip+len_trim(elsym)-1\n if(eolch(longline,ip)) then\n name1='DUMMY'\n mass=one\n h298=zero\n s298=zero\n else\n! extract the reference phase, third argument is 1 meaning until next space\n! ix is the length of the reference phase (irrelevant here)\n! ip is updated to character after the name extracted\n call getext(longline,ip,1,name1,' ',ix)\n! write(*,*)'3E longline: ',ip,longline(1:ip+10)\n! write(*,*)'3E element ref: ',name1\n! name1=longline(ip:)\n! ip=ip+len_trim(name1)\n! after the name should be mass, H298-H0 and S298, ignore errors\n call getrel(longline,ip,mass)\n if(buperr.ne.0) then\n mass=one; buperr=0\n endif\n call getrel(longline,ip,h298)\n if(buperr.ne.0) then\n h298=zero; buperr=0\n endif\n call getrel(longline,ip,s298)\n if(buperr.ne.0) then\n s298=zero; buperr=0\n endif\n name2=elsym\n endif\n call store_element(elsym,name2,name1,mass,h298,s298)\n if(gx%bmperr.ne.0) goto 1000\n case(2) !SPECIES -------------------------------------------------\n! elseif(line(2:9).eq.'SPECIES ') then\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! SPECIES O3PU2 O3PU2!\n ip=nextc\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'Line after SPECIES keyword empty'\n gx%bmperr=4306; goto 1000\n endif\n name1=longline(ip:)\n! find first space after non-space\n jp=index(name1,' ')\n! write(*,*)'3E longline:',trim(longline),ip,jp\n name1(jp:)=' '\n ip=ip+jp\n! handle MQMQA quads ... do I need capson? maybe ...\n! write(*,*)'3E species line 3863: ',trim(name1)\n call capson(name1)\n kp=index(name1,'/')\n if(kp.gt.0 .and. &\n name1(kp+1:kp+1).ge.'A' .and. name1(kp+1:kp+1).le.'Z') then\n! this is an MQMQA quad, an ion has /+ or /- or /digit \n kp=len_trim(longline)\n if(longline(kp:kp).eq.'!') longline(kp:kp)=':'\n! write(*,572)trim(name1),trim(longline(ip:))\n572 format('3E Call mqmqa_species: \"',a,'\" \"',a,'\" ')\n call mqmqa_species(name1,longline(ip:),nend)\n if(gx%bmperr.ne.0) write(*,*)'3E error creating MQMQA quad',gx%bmperr\n goto 573\n endif\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'WARNING No stoichiometry for species: ',&\n trim(name1)\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 3'\n goto 100\n endif\n stoiline=longline(ip:)\n! write(*,'(a,a,i3,a,a)')'3E stoi:',trim(longline),ip,':',trim(stoiline)\n jp=index(stoiline,' ')\n! write(*,'(4a,i4)')'3E >> species: ',trim(name1),' ',trim(stoiline),jp\n stoiline(jp:)=' '\n! write(*,'(4a,i4)')'3E >> species: ',trim(name1),' ',trim(stoiline),jp\n call decode_stoik(stoiline,noelx,elsyms,stoik)\n if(gx%bmperr.ne.0) goto 1000\n! check elements exist\n call enter_species(name1,noelx,elsyms,stoik)\n! write(*,*)'3E: entering species error: ',gx%bmperr\n573 continue\n if(gx%bmperr.ne.0) then\n! if element not selected just skip the species\n if(gx%bmperr.eq.4046) then\n gx%bmperr=0; goto 100\n else\n if(.not.silent) write(kou,*)'Error enter species: \"',&\n trim(name1),'\" with stoichometry: ',trim(stoiline)\n goto 1000\n endif\n endif\n!-----------------------------------------------------------------------\n case(5) ! function\n! see code at label 800 for functions\n! elseif(line(2:10).eq.'FUNCTION ') then\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T)\n! name1=line(11:18)\n! longline=' '\n! longline=line(20:)\n!300 continue\n! jp=len_trim(longline)\n! if(longline(jp:jp).eq.'!') then\n! write(*,*)'3E Skipping function: ',name1\n! all functions entered at the end, skip until !\n! do while(index(longline,'!').le.0)\n if(index(longline,'!').le.0) then\n if(.not.silent) &\n write(*,*)'3E Error, terminating ! not found for function!!',nl\n gx%bmperr=4307; goto 1000\n endif\n!-------------------------------------------------------------------------\n! elseif(line(2:7).eq.'PHASE ') then\n case(3) ! PHASE\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! PHASE LIQUID:L % 1 1.0 !\n if(nophase) then\n nophase=.false.\n! give a warning if any selected element is not present\n if(allocated(present)) then\n funname=' '\n kkk=1\n do jt=1,nel\n if(.not.present(jt)) then\n funname(kkk:)=selel(jt)\n kkk=len_trim(funname)+2\n endif\n enddo\n if(kkk.gt.1) then\n if(.not.silent) write(kou,68)funname(1:kkk)\n68 format(/' *** Warning, elements not present in database: ',a/)\n endif\n deallocate(present)\n endif\n else\n if(.not.silent) write(kou,*) &\n 'Error, a PHASE keyword must be followed by its CONSTIT'\n gx%bmperr=4308; goto 1000\n endif\n! problem finding phase when line before is too long, i.e. missing the \"!\"\n! write(*,*)'3E found PHASE ',trim(longline),' line: ',nl\n! number of TYP_DEFS for this phase\n TDthisphase=0\n ip=nextc\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'line after PHASE empty'\n goto 100\n endif\n name1=longline(ip:)\n! convert phase name to upp case\n call capson(name1)\n jp=index(name1,' ')\n ip=nextc+jp\n if(jp.gt.0) then\n name1(jp:)=' '\n endif\n jp=index(name1,':')\n! write(*,*)'3E readtdb 11: ',name1,ip,jp\n! phytype, a letter after the phase name separated by a :, for example GAS:G\n! I2SL is :Y, MQMQA is :Q or :X for new coding\n if(jp.gt.0) then\n phtype=name1(jp+1:jp+1)\n name1(jp:)=' '\n else\n phtype=' '\n endif\n! we must know if we have the mqmqa model before reading constituents!!\n! tested below also.\n! if(phtype.eq.'Q') then\n if(phtype.eq.'Q' .or. phtype.eq.'X') then\n! Q was the original MQMQA phtype, X means maybe some new code\n mqmqa=.TRUE.\n else\n mqmqa=.FALSE.\n endif\n! check if phase rejected\n! write(*,*)'3E number of phases rejected: ',nphrej\n do jt=1,nphrej\n if(name1.eq.phreject(jt)) then\n thisphaserejected=.TRUE.\n! write(*,*)'3E skipping rejected phase: ',name1\n! why is nophase set true? If I comment it away nothing read!!\n nophase=.true.\n goto 100\n endif\n enddo\n! SELECTED_PHASES\n! if seltdbph is allocated check if this phase selected when dodis=0\n if(dodis.eq.0 .and. allocated(seltdbph) .and. nselph.gt.0) then\n! write(*,*)'3E Calling isabbr: ',trim(name1),nselph\n jt=isabbr(name1,seltdbph,nselph)\n! write(*,*)'3E return from isabbr: ',jt\n if(jt.eq.0) then\n! write(*,*)'3E not selected phase: ',trim(name1)\n thisphaserejected=.TRUE.\n nophase=.true.\n goto 100\n else\n write(*,'(a,a,a,a)')'3E Phase ',trim(name1),' fits selection ',&\n trim(seltdbph(jt))\n endif\n endif\n! end elected phases\n thisphaserejected=.false.\n! write(*,*)'3E nophase set to false, phase: ',name1\n ip=ip+1\n! jp=ip\n! CCI\n jp=index(longline,'%')\n! if(jp.eq.0) then\n! evidently name2 is just the % sign ...\n! write(*,*)'3E missing % after phase name, continuing'\n! jp=ip+1\n! endif\n! I am no longer sure what name2 is used for ....\n name2=longline(ip:jp)\n! write(*,302)trim(name2),ip,jp,trim(longline)\n!302 format('3E Debug: name2: ',a,2i5/a)\n thisdis=0\n phdis: if(dodis.eq.1) then\n! special when reading disordered parts, check phase name equal\n! write(*,*)'3E Check if disordered part: ',dodis,name1\n do jt=1,disparttc\n if(name1.eq.dispartph(jt)) goto 307\n enddo\n! not a disordered part\n goto 100\n307 continue\n thisdis=jt\n! write(*,'(3a)')'3E ',trim(name1),' is a disordered part'\n! check if disordered phase is magnetic!, we have to step though type_defs\n dismag=0\n if(.not.eolch(longline,jp)) then\n ch1=longline(jp:jp)\n! write(*,312)trim(longline),jp,trim(longline(jp+1:))\n312 format('3E distypes: ',a,i3,' \"',a,'\"')\n dmag: do while(ch1.ne.' ')\n do jt=1,nooftypedefs\n if(ch1.eq.typedefchar(jt) .and. &\n ((typedefaction(jt).eq.-1 .or. &\n typedefaction(jt).eq.-3))) then\n dismag=typedefaction(jt)\n! write(*,*)'3E disordered part is magnetic',dismag\n exit dmag\n endif\n enddo\n jp=jp+1\n ch1=longline(jp:jp)\n enddo dmag\n endif\n! we skip the rest of the phase line ...\n goto 100\n elseif(dodis.eq.0 .and. ndisph.gt.0) then\n! make use of initial read of TDB file to skip phases that are disordered parts\n! write(*,*)'3E comparing \"',trim(name1),'\" with \"',trim(disph(1)),'\" etc'\n do jt=1,ndisph\n! if(name1.eq.disph(jt)) then\n if(name1.eq.dispartph(jt)) then\n! write(*,*)'3E Phase ',trim(name1),' is a disordered part of ',&\n! trim(ordpartph(jt)),jt,nphrej\n! if the phase ordpartph(jt) is rejected, enter the disordered phase!!\n do zz=1,nphrej\n! write(*,*)'3E check \"',trim(ordpartph(jt)),'\" and \"',&\n! trim(phreject(zz)),'\"'\n if(ordpartph(jt).eq.phreject(zz)) then\n write(*,'(a,a,a,a,a)')'3E Keeping ',trim(name1),&\n ' because phase ',trim(phreject(zz)),' is rejected'\n goto 310\n endif\n enddo\n! do not enter this phase as it is a disordered part\n! all these must be set ...\n thisdis=-1\n nophase=.true.\n thisphaserejected=.TRUE.\n goto 100\n endif\n enddo\n elseif(dodis.eq.0 .and. disparttc.gt.0) then\n! we must not enter phases that are disordered parts\n do jt=1,disparttc\n if(name1.eq.dispartph(jt)) then\n! write(*,*)'3E Skip phase that is a disordered part: ',name1\n thisdis=-1\n goto 100\n endif\n enddo\n endif phdis\n! write(*,*)'3E Entering phase: ',name1\n! write(*,*)'3E Checking phase types for phase: ',name1,jp\n! skip blanks, then read type code, finished by a blank\n if(eolch(longline,jp)) then\n if(.not.silent) &\n write(kou,*)'3E WARNING no phase typecode: ',trim(name1)\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 4'\n endif\n jp=jp-1\n! WE MUST CHECK IF TYPE_DEFS appear after phases have been entered!!\n! write(*,311)'3E TDs: ',nooftypedefs,&\n! (typedefchar(jt),jt=1,nooftypedefs)\n! return here to check for different TYPE_DEFS\n310 jp=jp+1\n! check which type_defs that has been entered\n! write(*,*)'3E typedefs: ',trim(name1),': ',trim(longline(jp:)),jp\n! NOTE and FIX: type code expected to be after a single space: be flexible ??\n typedefcheck: if(longline(jp:jp).ne.' ') then\n ch1=longline(jp:jp)\n if(always.eq.3) then\n! this code an attempt to fool -O2 compiler switch\n! write(*,*)'3E typedef for ',trim(name1),': ',ch1,TDthisphase\n! write(*,311)'3E TDs: ',nooftypedefs,&\n! (typedefchar(jt),jt=1,nooftypedefs)\n311 format(a,i3,': ',10('\"',a,'\", '))\n always=always+1\n endif\n do jt=1,nooftypedefs\n if(ch1.eq.typedefchar(jt)) goto 320\n enddo\n! ignore typedef % meaning sequential read ...\n if(ch1.eq.'%') goto 310\n! WARNING that unknown TYPE_DEF has been used!!\n write(kou,313)trim(name1),ch1\n313 format(' *** WARNING: phase ',a,' has unknown TYPE_DEF: ',a/&\n ' *** Move all TYPE_DEFS before used in any phase!')\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 5'\n goto 310\n320 continue\n if(typedefaction(jt).eq.99) then\n! ignore TYPE_DEF SEQ\n continue\n elseif(typedefaction(jt).eq.-1 .or. &\n typedefaction(jt).eq.-3) then\n! Inden magnetic addition, save for after phase created\n TDthisphase=TDthisphase+1\n addphasetypedef(TDthisphase)=typedefaction(jt)\n elseif(abs(typedefaction(jt)).ge.25 .and. &\n abs(typedefaction(jt)).le.37) then\n! ferroref replaced by negative typedefaction ...\n! Qing-Xiong magnetic addition\n TDthisphase=TDthisphase+1\n addphasetypedef(TDthisphase)=typedefaction(jt)\n elseif(typedefaction(jt).eq.1905) then\n! Einstein\n TDthisphase=TDthisphase+1\n addphasetypedef(TDthisphase)=typedefaction(jt)\n elseif(typedefaction(jt).eq.491) then\n! Liquid 2-state model\n TDthisphase=TDthisphase+1\n addphasetypedef(TDthisphase)=typedefaction(jt)\n elseif(typedefaction(jt).eq.777) then\n778 continue\n! ternary extrapolations, these should be executed at the end of reading\n! some of the elements involved may not be selected.\n TDthisphase=TDthisphase+1\n addphasetypedef(TDthisphase)=typedefaction(jt)\n ctxp=ctxp+1\n ternaryxpol(ctxp)=trim(name1)//' '//ternaryxpol(ctxp)\n! write(*,'(a,i4,\": \",a)')'3E ternary around line 4137: ',&\n! ctxp,trim(ternaryxpol(ctxp))\n! this ignores the type letter, just assignes in same order as phases entered\n! Or one must enforce that the TYPE_DEF for ternary is right after the phase?\n elseif(.not.(typedefaction(jt).eq.100.or.typedefaction(jt).eq.0)) then\n! give an alert if typedefaction is not 100\n write(*,*)'3E Unknown typedefaction: ',typedefaction(jt)\n endif\n goto 310\n endif typedefcheck\n! write(*,*)'3E typedefs for ',trim(name1),': ',TDthisphase,&\n! (addphasetypedef(ll),ll=1,TDthisphase)\n name2='TDB file model: '//name2\n! number of sublattices\n! write(*,*)'3E buperr: ',buperr ,jp\n call getrel(longline,jp,xsl)\n if(buperr.ne.0) then\n if(.not.silent) write(kou,*)'3E tdb: \"',longline(1:jp),'\"',buperr\n gx%bmperr=buperr; goto 1000\n endif\n! dummy statement to fool -O2 optimization (or parallelization?)\n if(nsl.lt.0) jt=1\n nsl=int(xsl)\n do ll=1,nsl\n call getrel(longline,jp,stoik(ll))\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n enddo\n! write(*,*)'3E readtdb 3A: ',nsl,(stoik(ll),ll=1,nsl)\n!---------------------------------------------------------------------\n! The constituent line must follow PHASE before any new phase\n case(4) ! CONSTITUENT LIQUID:L :CR,FE,MO : !\n! the phase must have been defined\n if(nophase) then\n if(thisphaserejected) then\n! write(*,*)'3E previous phase rejected '\n goto 100\n endif\n if(.not.silent) write(kou,327)nl,trim(longline)\n327 format('3E A CONSTITUENT keyword not directly preceeded by PHASE!',&\n ' line ',i7/a)\n gx%bmperr=4308; goto 1000\n endif\n nophase=.true.\n! write(*,*)'3E constituents: ',trim(longline)\n condis1: if(dodis.eq.1) then\n! searchin why sigma in TAFID does not have c disordered fraction set\n! write(*,*)'3E sigma 17:',trim(longline),thisdis\n! write(*,*)'3E sigma 17:',thisdis\n if(thisdis.eq.0) goto 100\n! we skip the constituent line and go directly to create disordered fractions\n goto 395\n elseif(disparttc.gt.0 .and. thisdis.lt.0) then\n! this is a disordered part, skip\n goto 100\n endif condis1\n!360 continue\n jp=len_trim(longline)\n! write(*,*)'3E readtdb gas1: ',nl,jp,longline(1:jp)\n! eliminate all after the exclamation mark\n! longline(jp+1:)=' '\n! \n ip=index(longline,' :')+2\n! in TDB files MQMQA quads entered as constituents\n! if(mqmqa) write(*,*)'3E skipping redundant? code for MQMQA in readtdb'\n goto 363\n!--------------------------- redundant code below\n if(mqmqa) then\n! this is a FactSage MQMQA model for liquids\n! entering constituents as quadrupoles\n write(*,'(a,a,a,2i5)')'3E mqmqa const: \"',trim(longline(ip:jp)),&\n '\"',ip,jp\n loop=0\n! clear any old content in const\n const=' '\n! MQMQA constituents created \"on the fly\" as quadrupols using existing species\n! and additional coordination numbers n1..n4. A / separate sublattices\n! a , separate species in same sublattice. If any A B X Y species not entered\n! the quadrupole is ignored (not an error)\n! 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 ...\n! The r3 is a FNN/SNN ratio for pairs, normally 2.4\n! nend is set to zero at first call, then incremented for each FNN endmember\n call mqmqa_constituents(longline(ip:jp),const,nend,loop)\n! write(*,*)'3E back from entering constituents',gx%bmperr\n if(gx%bmperr.ne.0) then\n write(*,*)'3E error entering quadrupoles'\n goto 1000\n endif\n call mqmqa_rearrange(const)\n! write(*,*)'3E back from rearranging constituents',gx%bmperr\n if(gx%bmperr.ne.0) then\n write(*,*)'3E error rearranging quadrupoles',gx%bmperr\n goto 1000\n endif\n! skip the rest below except entering the phase\n! stoik(1) is bonds/atom, just for output, never used explicitly\n stoik(1)=2.0D0\n knr(1)=mqmqa_data%nconst\n! write(*,*)'3E enter_p: ',trim(name1),' ',knr(1),stoik(1),' ',phtype\n name2='MQMQA '\n call enter_phase(name1,1,knr,const,stoik,name2,phtype,&\n tdbwarning,emodel)\n write(*,*)'3E back from entering phase 1',gx%bmperr\n! if(tdbwarning) write(*,*)'3E tdbwarning set true 6'\n if(gx%bmperr.ne.0) then\n write(*,*)'3E failed to enter the MQMQA phase',gx%bmperr\n endif\n goto 100\n endif\n!--------------- code above redundant when MQMQA quad added as species\n363 continue\n! write(*,*)'3E readtdb gas2: ',jp,longline(1:jp)\n ll=0\n nr=0\n nrr=0\n! write(*,*)'3E readtdb 3E: ',ll,nr,nsl,longline(ip:jp)\n! mode=1 indicates to getname that / + - are allowed in species names\n mode=1\n370 continue\n if(ll.ge.1) then\n knr(ll)=nr\n if(nr.le.0) then\n if(ocv()) then\n write(*,*)'3E Skipping phase due to missing constituents: ',name1\n! write(*,378)name1,ll\n378 format('Phase ',a,' has no constituents in sublattice ',i2)\n! Not a fatal error when elements have been selected but skip this phase\n endif\n goto 100\n endif\n endif\n ll=ll+1\n! write(*,*)'3E start sublat ',ll,nsl,nr,ip\n if(ll.gt.nsl) goto 390\n nr=0\n380 continue\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'Error extracting constituents 1'\n gx%bmperr=4309; goto 1000\n endif\n nr=nr+1\n nrr=nrr+1\n! write(*,379)'readtdb 3EA: ',ip,nr,mqmqa,longline(ip:ip+10)\n379 format(a,2i4,L2,' >',a,'< >',a,'< >',a,'<')\n call getname(longline,ip,name3,mode,ch1)\n! write(*,379)'readtdb 3EB: ',ip,nr,longline(ip:ip+10),name3,ch1\n if(buperr.ne.0) then\n write(*,381)'3E readtdb EC: ',ll,nr,longline(1:ip+5),ip,name3\n381 format(a,2i4,' \"',a,'\" ',i5,1x,a,'\"',a)\n gx%bmperr=buperr; goto 1000\n endif\n! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3,ch1\n const(nrr)=name3\n! bypass any \"major\" indicator %\n if(ch1.eq.'%') ip=ip+1\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'Error extracting constituents 2'\n gx%bmperr=4309; goto 1000\n endif\n! check that const(nrr) among the selected elements ...\n if(mqmqa) then\n iq=len_trim(name3)\n! if bot supplied in the database add -Q to quads ....\n if(name3(iq-1:iq).ne.'-Q') name3(iq+1:iq+2)='-Q'\n endif\n! write(*,*)'3E Testing constituent: \"',name3,'\" ',nr\n! call find_species_record_noabbr(name3,lp1)\n! the _exact variant ignores stuff after -Q for MQMQA quads\n call find_species_record_exact(name3,lp1)\n if(gx%bmperr.ne.0) then\n! this species is not present, not a fatal error, skip it and continue\n! write(*,*)'3E Skipping constituent: ',name3\n gx%bmperr=0; nrr=nrr-1; nr=nr-1\n endif\n! do not remove the -Q\n! if(mqmqa) name3(iq:)=' '\n ch1=longline(ip:ip)\n if(ch1.eq.',') then\n! separator (not needed) between constituents\n ip=ip+1; goto 380\n elseif(ch1.eq.':') then\n! end of constituents in a sublattice\n ip=ip+1; goto 370\n endif\n! write(*,*)'3E we are at line 4358',gx%bmperr\n if(ch1.ne.'!') goto 380\n! when an ! found the list of constutents is finished. But we\n! should have found a : before the !\n if(.not.silent) &\n write(kou,*)'3E Found \"!\" before terminating \":\" around line',nl\n gx%bmperr=4310; goto 1000\n! write(*,*)'Species terminator error: ',ch1,nl\n! gx%bmperr=4157; goto 1000\n390 continue\n! name2 is model, ignored on reading TDB\n ionliq=.FALSE.\n mqmqa=.FALSE.\n! write(*,*)'3E phtype: \"',phtype,'\"'\n if(phtype.eq.'Y') then\n! name2='IONIC_LIQUID '\n name2='I2SL '\n ionliq=.TRUE.\n elseif(phtype.eq.'Q') then\n name2='MQMQA '\n mqmqa=.TRUE.\n else\n name2='CEF-TDB-RKM? '\n endif\n if(ocv()) write(*,*)'3E readtdb 9: ',name1,nsl,knr(1),knr(2),phtype\n! write(*,*)'3E readtdb 9: ',name1,nsl,knr(1),knr(2),phtype\n395 continue\n!\n! THE CODE HERE IS A MESS\n!\n! write(*,*)'3E sigma4 label 395 add disordered fraction set: ',dodis,nphrej\n condis2: if(dodis.eq.1) then\n! if we have a disordered part do not enter the phase, add disordered fracs!\n! the ordered phase name is ordpart(thisdis)\n! write(*,*)'3E sigma19: ',trim(ordpartph(disparttc)),disparttc,&\n! trim(ordpartph(thisdis)),thisdis\n do jt=1,nphrej\n! if(ordpartph(disparttc).eq.phreject(jt)) then\n! why disparttc?\n if(ordpartph(thisdis).eq.phreject(jt)) then\n write(*,'(a,a,a)')'3E ordered part ',trim(phreject(jt)),&\n ' is rejected, keep disordered part '\n goto 100\n endif\n enddo\n! write(*,*)'3E sigma20: ',trim(ordpartph(thisdis))\n call find_phase_by_name(ordpartph(thisdis),iph,ics)\n if(gx%bmperr.ne.0) then\n! NOTE THE ORDERED PHASE MAY NOT BE ENTERED DUE TO COMPONENTS!!\n if(.not.silent) write(kou,396)trim(ordpartph(thisdis))\n396 format('3E and disordered part ',a,' has not been selected')\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 7'\n gx%bmperr=0\n goto 100\n else\n! if(.not.silent) write(kou,*) &\n write(kou,'(a,a,3i3)')'3E Adding disordered part to ',&\n trim(ordpartph(thisdis)),orddistyp(thisdis),thisdis,dismag\n if(dismag.ne.0) then\n! disordered phase magnetic, check if ordered is also ...\n lokph=phases(iph)\n nullify(addrec)\n addrec=>phlista(lokph)%additions\n write(*,1221)\n1221 format('3E checking if ordered phase has magnetic model')\n! type(gtp_phase_add), pointer :: addrec\n do while(associated(addrec))\n! write(*,*)'3E addrec: ',addrec%type,INDENMAGNETIC,XIONGMAGNETIC\n if(addrec%type.eq.INDENMAGNETIC) goto 798\n if(addrec%type.eq.XIONGMAGNETIC) goto 798\n addrec=>addrec%nextadd\n enddo\n! write(*,*)'3E adding magnetic model to ordered phase'\n! ordered not magnetic, set the same as disordered \n if(dismag.eq.-1) then\n! Inden magnetic for BCC\n call add_addrecord(lokph,'Y',indenmagnetic)\n elseif(dismag.eq.-3) then\n! Inden magnetic for FCC/HCP\n call add_addrecord(lokph,'N',indenmagnetic)\n endif\n endif\n endif\n798 continue\n! we are creating the phase, there is only one composition set, iph is ordered\n! write(*,*)'3E sigma18: get_phase_compset'\n call get_phase_compset(iph,1,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n! ch1 is suffix for disordered parameters, always D\n ch1='D'\n! jl=0 if NDM (sigma)\n! jl=1 if phase can be totally disordered (but can have interstitials)\n! nd1 is the number of sublattices to sum into disordered set\n if(orddistyp(thisdis).eq.1) then\n jl=1\n if(phlista(lokph)%noofsubl.le.5) nd1=4\n if(phlista(lokph)%noofsubl.le.3) nd1=2\n! if(.not.silent) write(kou,397) trim(ordpartph(thisdis)),nd1\n write(kou,397) trim(ordpartph(thisdis)),nd1,thisdis\n397 format('3E Phase ',a,' has order/disorder partition model',&\n ' adding first ',i2,'; thisdis: ',i2)\n else\n jl=0\n nd1=phlista(lokph)%noofsubl\n endif\n! goto 402\n402 continue\n if(jl.eq.0 .and. .not.silent) write(kou,398)trim(ordpartph(thisdis))\n398 format('3E The phase ',a,&\n ' cannot be completely disordered at equilibrium.')\n! add DIS_PART from TDB\n! write(*,*)'3E adding disordered fraction set',csfree,highcs\n call add_fraction_set(iph,ch1,nd1,jl)\n if(gx%bmperr.ne.0) then\n if(.not.silent) write(kou,*) &\n '3E Error entering disordered fraction set: ',gx%bmperr\n goto 1000\n endif\n! suck= newhighcs(.true.)\n! write(*,*)'3E added disordered fraction set 1: ',csfree,highcs,suck\n if(jl.eq.0) then\n! we must set the correct formula unit of the disordered phase, on the\n! TDB file it is unity. Sum up the sites for the ordered phase in lokcs\n xxx=zero\n do ll=1,nd1\n xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll)\n enddo\n firsteq%phase_varres(lokcs)%disfra%fsites=xxx\n else\n xxx=one\n endif\n! if(.not.silent) write(kou,601) &\n! dispartph(thisdis)(1:len_trim(dispartph(thisdis))),ch1,nd1,jl,xxx\n601 format('3E Add parameters from disordered part: ',a,5x,a,2x,2i3,F12.4)\n else\n! write(*,*)'3E enter phase: ',name1\n call enter_phase(name1,nsl,knr,const,stoik,name2,phtype,&\n tdbwarning,emodel)\n! if(tdbwarning) write(*,*)'3E tdbwarning set true 8'\n! no error entering an I2SL liuqid with empty first sublattice ... suck\n! It is just not entered ....\n! write(*,*)'3E back from enter_phase 2, error? ',gx%bmperr\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4121) then\n if(.not.silent) write(kou,*) &\n '3E Phase ',trim(name1),&\n ' is ambiguous or short for another phase'\n endif\n goto 1000\n endif\n! any typedefs? only magnetic handelled at present\n call find_phase_by_name(name1,iph,lcs)\n! write(*,*)'readtdb 9X: ',gx%bmperr\n if(gx%bmperr.ne.0) then\n if(.not.silent) write(kou,*)'Phase ',name1,' is ambiguous'\n goto 1000\n endif\n lokph=phases(iph)\n! write(*,*)'3E typedefs for ',trim(name1),lokph,TDthisphase\n phasetypes: do jt=1,TDthisphase\n! write(*,*)'3E manage typedef ',jt,addphasetypedef(jt)\n if(addphasetypedef(jt).eq.-1) then\n! Inden magnetic for BCC\n call add_addrecord(lokph,'Y',indenmagnetic)\n! call add_magrec_inden(lokph,1,-1)\n elseif(addphasetypedef(jt).eq.-3) then\n! Inden magnetic for FCC and other phases\n call add_addrecord(lokph,'N',indenmagnetic)\n! call add_magrec_inden(lokph,1,-3)\n elseif(addphasetypedef(jt).eq.1905) then\n! Einstein lowt model\n call add_addrecord(lokph,' ',einsteincp)\n elseif(addphasetypedef(jt).eq.491) then\n! Liquid 2-state model\n call add_addrecord(lokph,' ',TWOSTATEMODEL1)\n else\n! Assumed Xiong magnetic, the factor 0.37 (BCC) or 0.25 (FCC) needed\n! write(*,*)'3E Entering Qing-Xiongmagnetic ',addphasetypedef(jt)\n! in TDB files ALWAYS average bohr magenton numbers\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHBMAV)\n more=' '\n! This is a secret way to set ferromagnetic reference state for alloys\n if(addphasetypedef(jt).eq.-37 .or. addphasetypedef(jt).eq.-25) &\n more(3:3)='R'\n! if(ferroref) more(3:3)='R'\n! write(*,*)'3E more: \"',more,'\" and ',ferroref\n! write(*,*)'3E add typedef: ',lokph,jt,addphasetypedef(jt)\n if(abs(addphasetypedef(jt)).eq.37) then\n! BCC ...... very cryptic: 2nd letter space, \" \", means not idividual IBM\n more(1:1)='Y'\n! write(*,*)'3E more: \"',more,'\" and ',ferroref\n call add_addrecord(lokph,more,xiongmagnetic)\n! call add_addrecord(lokph,'Y ',xiongmagnetic)\n elseif(abs(addphasetypedef(jt)).eq.25) then\n! FCC and others\n more(1:1)='N'\n! write(*,*)'3E more: \"',more,'\" and ',ferroref\n call add_addrecord(lokph,more,xiongmagnetic)\n! call add_addrecord(lokph,'N ',xiongmagnetic)\n elseif(abs(addphasetypedef(jt)).eq.777) then\n! ternary extrapolations should be handled after all parameters entered\n! The phase name has to be added ... we just need to add the phase name here.\n! Can we have several phases with ternary extrapolation? YES!!\n! write(*,'(\"3E ternaryxpol phase \",a,2i5)')&\n! trim(phlista(lokph)%name),lokph,jt\n addternaryxpol=.true.\n! we are never here!!\n else\n write(*,13)lokph,addphasetypedef(jt)\n13 format(78('*')/'3E unknown addition: ',2i7/78('*'))\n endif\n endif\n if(gx%bmperr.ne.0) goto 1000\n enddo phasetypes\n! write(*,607)trim(name1),iph\n607 format('3E Entered phase ',a,i5)\n endif condis2\n! write(*,*)'3E readtdb 9B:',name1,nsl,phtype\n!-------------------------------------------------------------------\n case(6) ! PARAMETER --------------------------------------------\n! elseif(line(4:13).eq.'PARAMETER ') then\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T\n if(eolch(longline,nextc)) then\n if(.not.silent) write(kou,*)'Empty line after PARAMETER'\n gx%bmperr=4311; goto 1000\n endif\n! if(dodis.eq.1) write(*,*)'Reading disordered parameters'\n! write(*,*)'3E found parameter: ',totalpar,dodis,nl\n! count parameter only when dodis=0\n! if(dodis.eq.1) totalpar=totalpar+1\n if(dodis.eq.0) totalpar=totalpar+1\n ip=nextc\n funname=longline(ip:)\n! problem with default low T limit, can be ,, directly after parameter )\n kp=index(funname,' ')\n cbug=index(funname,'),')\n! save position after parameter name in nextc\n if(cbug.gt.0 .and. cbug.lt.kp) then\n nextc=ip+cbug+1\n kp=cbug+1\n! write(*,*)'3E ,,2: ',trim(longline),ip,kp\n else\n cbug=index(funname,')')\n if(cbug.lt.kp) then\n nextc=ip+kp\n else\n! We have spaces inside constituent arrays !!!\n kp=cbug+1\n nextc=ip+cbug\n! write(*,*)'3E spaces inside constituent array ',&\n! trim(funname(1:kp)),kp,nextc\n funname(kp:)=' '\n612 continue\n cbug=index(funname(1:kp),' ')\n if(cbug.gt.0) then\n funname(cbug:)=funname(cbug+1:)\n kp=kp-1\n goto 612\n endif\n! write(*,*)'3E spaces removed in constituent array? ',&\n! trim(funname(1:kp)),kp,nextc\n kp=kp+1\n endif\n endif\n funname(kp:)=' '\n! extract symbol, normally G or L but TC, BMAGN and others can occur\n lp1=index(funname,'(')\n name1=funname(1:lp1-1)\n! strange bug when V0 is interpreted as LPZ !!!\n! write(*,*)'3E mpi: ',name1\n typty=0\n! this \"L \" is kept for compatibility with old TDB files\n if(name1(1:2).eq.'G ' .or. name1(1:2).eq.'L ') then\n typty=1\n elseif(name1(1:3).eq.'TC ') then\n typty=2\n! NOTE this is actually too long only 4 letters mpi should be allowed\n elseif(name1(1:6).eq.'BMAGN ') then\n typty=3\n! elseif(name1(1:3).eq.'V0 ') then\n! Wow ... these not corrected when changing model_parameter_id !!!\n! typty=8\n! elseif(name1(1:3).eq.'VA ') then\n! typty=9\n endif\n! we should handle also other parameter types\n if(typty.eq.0) then\n! find the property associated with this symbol\n! write(*,*)'psym1: ',trim(name1)\n! HANDLE THE ABBREVIATION BM to be accepted as BMAG \n if(name1(1:3).eq.'BM ') then\n if(bmabbr.eq.0) then \n write(kou,1210)\n1210 format('3E *** Tdbwarning, the parameter identifier \"BM\"',&\n ' assumed to be \"BMAG\"'/)\n endif\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 9'\n bmabbr=bmabbr+1\n name1='BMAG'\n endif\n! call get_parameter_typty(name1,lokph,typty,fractyp)\n call get_parameter_typty(name1,lokph,typty)\n if(gx%bmperr.ne.0) then\n write(*,*)'Unknown MPID \"',trim(name1),'\" typty: ',typty \n lp2=len_trim(name1)\n do lp1=1,nundefmpi\n if(undefmpi(lp1)(1:lp2).eq.trim(name1)) goto 618\n enddo\n if(nundefmpi.lt.mundefmpi) then\n nundefmpi=nundefmpi+1\n undefmpi(nundefmpi)=trim(name1)\n else\n write(*,*)'3E too many model parameter identifier errors',&\n mundefmpi\n endif\n if(.not.silent) write(kou,*) &\n ' *** WARNING unknown parameter identifier, \"',&\n trim(name1),'\" on line: ',nl\n618 continue\n gx%bmperr=0; typty=0\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 10'\n endif\n! write(*,*)'psym2: ',typty,fractyp\n endif\n! fractyp 1 is normal or ordered part if there is a disordered part\n fractyp=1\n! write(*,*)'readtdb: PAR',name1,typty\n! extract phase name and constituent array\n lp1=index(funname,'(')\n lp2=index(funname,',')\n name2=funname(lp1+1:lp2-1)\n dispar: if(dodis.eq.1) then\n! first check if phase name is a disordered part, if not skip\n! then change phase name to ordered phase and set fractyp=2\n! and add a suffix D to parameter symbol\n do jl=1,disparttc\n if(name2.eq.dispartph(jl)) goto 710\n enddo\n! notusedpar=notusedpar+1\n! not disordered phase, skip this parameter\n! goto 100\n reason=1\n goto 888\n!-----------------------\n! This parameter was added to notusedpar at first run, correct that now\n710 continue\n notusedpar=notusedpar-1\n! write(*,*)'Entering disordered parameter to: ',thisdis,jl\n thisdis=jl\n if(dbcheck) write(*,887)notusedpar,longline(ip:ip+55)\n887 format('3E restored: ',i5,': ',a)\n! write(*,*)'Entering disordered parameter to: ',ordpartph(thisdis)\n! write(*,*)'3E ',longline(1:len_trim(longline))\n name2=ordpartph(jl)\n! fractyp is now detected inside enter_parameter\n! fractyp=2\n endif dispar\n!---------------------- check phase is entered,\n! the database may contain many phases that are not selected\n! if(name2(1:2).eq.'ZR') write(*,*)'3E parameter for phase: ',trim(name2)\n call find_phase_by_name_exact(name2,jph,kkk)\n! write(*,*)'readtdb 19: ',jph,gx%bmperr,name2\n if(gx%bmperr.ne.0) then\n! Why is ZRTE not accepted?? ... exact match with first phase was not OK! suck\n if(gx%bmperr.eq.4121) &\n write(*,*)'3E WARNING parameter with ambiguous phase name',&\n ' ignored: ',trim(name2)\n! this parameter is not entered as phase not entered\n! notusedpar=notusedpar+1\n! gx%bmperr=0; goto 100\n gx%bmperr=0; reason=2; goto 888\n! goto 1000\n endif\n! extract constituent array, remove final ) and decode\n! constituent names can be very long ....\n lokph=phases(jph)\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! check if ionic liquid for handling neutrals ... with or without *:\n ionliq=.TRUE.\n else\n ionliq=.FALSE.\n endif\n name4=funname(lp2+1:)\n! find terminating )\n lp1=index(name4,')')\n! if(name2(1:7).eq.'FCC_L12') then\n! write(*,*)'3E constituent array: ',trim(name4)\n! endif\n if(lp1.le.0) then\n if(.not.silent) then\n! problem with space in constituent array ...\n write(kou,*) &\n '3E WARNING missing \")\" in parameter constituent array \"',&\n trim(name2),',',trim(name4),'\", line:',nl\n write(*,*)'3E funname: ',trim(funname(lp2+1:))\n write(*,*)'3E longline: ',trim(longline)\n endif\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 11'\n! notusedpar=notusedpar+1\n! goto 100\n reason=3\n goto 888\n else\n name4(lp1:)=' '\n endif\n! Handling of ionic liquid parameters for neutrals\n if(ionliq) then\n nsl=index(name4,':')\n! write(*,*)'3E ionic liquid parameter: ',trim(name4),nsl\n if(nsl.le.0) then\n name4(3:)=name4\n name4(1:2)='*:'\n! write(*,*)'3E Added wildcard to parameter: ',trim(name4)\n endif\n endif\n297 continue\n!\n call decode_constarr(lokph,name4,nsl,endm,nint,lint,ideg)\n if(ocv()) write(*,303)'readtdb 303: ',name4(1:len_trim(name4)),&\n nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint)\n303 format(a,a,2i4,2x,2i3,' : ',3(2i3,2x))\n if(gx%bmperr.ne.0) then\n! error here can mean parameter with un-selected constituent, i.e. no error\n! write(*,*)'3E: decode',ionliq,tdbv,nsl,gx%bmperr\n if(ionliq .and. tdbv.eq.1 .and. nsl.eq.1) then\n! handle parameters in ionic liquids with only neutrals in second sublattice\n! in TC one can have no constituent there or an arbitrary constituent,\n! in OC the constituent in sublattice 1 must be a *\n nsl=2\n endm(2)=endm(1)\n endm(1)=-99\n! shift any interaction from sublattice 1 to 2\n do ip=1,nint\n! write(*,*)'3E lint: ',lint(1,ip),lint(2,ip)\n lint(2,ip)=2\n enddo\n if(ocv()) write(*,303)'modif endmem: ',name4(1:len_trim(name4)),&\n nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint)\n gx%bmperr=0\n else\n if(ocv()) write(*,*)'Skipping parameter: ',name4(1:len_trim(name4))\n! notusedpar=notusedpar+1\n! gx%bmperr=0; goto 100\n gx%bmperr=0; reason=4; goto 888\n endif\n endif\n! if(nint.gt.1) then\n! lint(1,1) is species of first, lint(1,2) in second interaction\n! write(*,305)'readtdb 305: ',endm(1),nint,lint(2,1),lint(2,2)\n! endif\n305 format(a,5i4)\n!---------------- encode function\n! if(dodis.eq.1) write(*,*)'We are here 1'\n! limit Model parameter id and phase name to 5 characters \n ip=index(funname,',')\n if(ip.gt.7) funname(7:)=funname(ip:)\n!------------------------\n ip=0\n jp=0\n400 continue\n ip=ip+1\n405 continue\n! write(*,*)'3E funname: ',trim(funname)\n ch1=funname(ip:ip)\n! accept the first 6 letters and numbers of phase name\n! accept the first 8 letters and numbers of phase name\n if((ch1.ge.'A' .and. ch1.le.'Z') .or. &\n (ch1.ge.'0' .and. ch1.le.'9')) goto 400\n if(ch1.ne.' ') then\n funname(ip:)=funname(ip+1:)\n jp=jp+1\n if(jp.lt.8) goto 405\n funname(ip+1:)=' '\n endif\n funname='_'//funname\n!-------------------------------------------------\n! now read the function, start from position nextc\n! write(*,398)'3E ,,: ',trim(longline),nextc\n longline=longline(nextc:)\n!410 continue\n jp=len_trim(longline)\n if(longline(jp:jp).ne.'!') then\n if(.not.silent) write(kou,410)nl,ip,longline(1:ip)\n410 format('Error, parameter line not ending with !',2i5/a)\n gx%bmperr=4312; goto 1000\n endif\n! extract bibliographic reference if any\n! NOTE: a legal ending is ;,,,!\n refx='none'\n kp=jp-1\n do while(longline(kp:kp).ne.';')\n kp=kp-1\n if(kp.lt.1) then\n! illegal termination of function in TDB file\n if(.not.silent) write(kou,417)nl\n417 format('No final ; of function in TDB file, around line: ',i5)\n gx%bmperr=4013; goto 1000\n endif\n enddo\n kp=kp+2\n! longline(kp:kp) is character after \"; \" or \";,\" \n! next is upper temperature limit or , meaning default. We have a \"!\" at end\n430 continue\n if(eolch(longline,kp)) continue\n if(longline(kp:kp).eq.',') then\n kp=kp+1\n elseif(longline(kp:kp).eq.'!') then\n goto 433\n else\n! ; 6000 N 91DIN !\n! kp=^ => index(...,' ')=5; kp=kp+4\n kp=kp+index(longline(kp:),' ')-1\n endif\n! next is N or ,\n if(eolch(longline,kp)) continue\n if(longline(kp:kp).ne.'!') then\n kp=kp+1\n endif\n if(eolch(longline,kp)) continue\n if(kp.lt.jp) then\n! NEW feature, comment after bibliographic reference, to be suppressed online!!\n refx=longline(kp:jp-1)\n zp=index(refx,' ')\n if(zp.gt.0) refx(zp:)=' '\n call capson(refx)\n else\n refx=' '\n endif\n! ------------------- we found the reference, continue with the expression\n433 continue\n! replace any # by ' '\n412 continue\n jss=index(longline(1:jp),'#')\n if(jss.gt.0) then\n longline(jss:jss)=' '\n goto 412\n endif\n! write(*,*)'3E Entering function 2: ',funname,trim(longline)\n lrot=0\n! write(*,*)'3E globaldata%encrypted 1: ',globaldata%encrypted\n! call store_tpfun(funname,longline,lrot,.TRUE.)\n call store_tpfun(funname,longline,lrot,rewindx)\n! write(*,17)lokph,typty,nsl,lrot,(endm(i),i=1,nsl)\n17 format('readtdb 17: ',4i3,5x,10i3)\n! write(*,404)'readtdb entpar: ',refx,fractyp,nint,ideg\n404 format(a,a,i3,2x,10i3)\n if(gx%bmperr.ne.0) then\n if(.not.silent) write(kou,406)gx%bmperr,lrot,trim(funname),nl\n406 format(/'Fatal error: ',2i7,': ',a,' around line: ',i7)\n goto 1000\n else\n! write(*,*)'3E calling enter_parameter from 3E line 4919'\n call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,&\n lrot,refx)\n if(ocv()) write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr\n! write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr\n if(gx%bmperr.ne.0) then\n! error entering parameter, not fatal\n! if(dodis.eq.1 .and. .not.silent) &\n! write(*,408)'3E parameter warning:',gx%bmperr,nl,&\n! funname(1:40)\n!408 format(a,i6,' line ',i5,': ',a)\n! if(.not.(gx%bmperr.ne.4096 .or. gx%bmperr.ne.4066)) then\n! goto 1000\n! Error 4096 means \"no such constituent\" and 4066 \"... in a sublattice\"\n! Error 4154 means no reference but the parameter has been entered\n if(gx%bmperr.eq.4096 .or. gx%bmperr.eq.4066 .or. &\n gx%bmperr.eq.4154) then\n! this means the user has not selected this component or forgot reference\n! write(*,*)'readtdb entparerr: ',gx%bmperr,' >',&\n! funname(1:len_trim(funname))\n! error 4154 means missing reference but the parameter is entered\n if(gx%bmperr.eq.4154 .and. .not.silent) then\n write(*,409)gx%bmperr,nl\n409 format('3E Warning: Parameter reference missing ',i6,&\n ', around line:',i7,' continuing')\n noparref=noparref+1\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 12'\n else\n write(*,4091)gx%bmperr,nl\n4091 format('3E Error ',i5,' occured around line ',i6)\n endif\n else\n! Other errors than 4096, 4066 and 4154 are fatal\n goto 1000\n endif\n gx%bmperr=0\n! else\n endif\n enteredpar=enteredpar+1\n! write(*,407)'3E Entered parameter: ',lokph,typty,gx%bmperr,enteredpar\n407 format(a,4i5)\n endif\n! there cannot be any error when we come here ...\n! if(gx%bmperr.ne.0 .and. .not.silent) &\n! write(*,*)'3E parameter function error: ',gx%bmperr\n goto 100\n!------------------------------------------------------------------\n! this is end of PARAMETER keyword\n888 continue\n! TAFID with 9000 parameters have about 100 unused when all selected\n! reason 1= parameter not part of disordered fraction set after rewind\n! reason 2= phase not entered\n! reason 3= constituent array error\n! reason 4= constituent array not selected\n if(reason.ne.1) then\n notusedpar=notusedpar+1\n if(dbcheck) write(*,889)reason,notusedpar,longline(ip:ip+55)\n889 format('3E unused: ',i2,i5,': ',a)\n! else\n! parameters in disordered part read after rewinding\n! notusedpar=notusedpar-1\n endif\n goto 100\n!------------------------------------------------------------------\n! elseif(line(2:17).eq.'TYPE_DEFINITION ') then\n case(7) !TYPE_DEFINITION \n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 !\n if(.not.only_typedefs) then\n! skip TYPE_DEFS unless only_typdefs is TRUE\n! write(*,*)'3E skipping TYPE_DEFS at later rewind',rewindx\n goto 100\n endif\n nytypedef=nytypedef+1\n typedefchar(nytypedef)=longline(nextc+1:nextc+1)\n! in TC the same typedef \"letter\" can be used several times\n do ip=1,nooftypedefs\n if(typedefchar(nytypedef).eq.typedefchar(ip)) then\n write(*,*)'3E Same typedef again, \"',&\n typedefchar(nytypedef),'\", ignoring second or later occurance'\n nytypedef=nytypedef-1\n goto 88\n endif\n enddo\n nooftypedefs=nytypedef\n if(nooftypedefs.gt.maxtypedefs) then\n write(*,*)'3E Too many TYPE_DEFINITION, modify readtdb in gtp3E.F90'\n gx%bmperr=4399; goto 1000\n endif\n ip=nextc+3\n! newtypedef: if(index(longline(ip:),' SEQ').gt.0) then\n newtypedef: if(index(longline,' SEQ').gt.0) then\n typedefaction(nytypedef)=100\n else\n!---------------------------------------------- TYPE_DEF phase einstein\n km=index(longline,' EINSTEIN ')\n einstein: if(km.gt.0) then\n typedefaction(nytypedef)=1905\n exit newtypedef\n endif einstein\n!---------------------------------------------- TYPE_DEF magnetic\n km=index(longline,' MAGNETIC ')\n! write(*,*)'3E typedef: ',trim(longline),km\n magnetic: if(km.gt.0) then\n ip=km+9\n!73 format(a,i3,' \"',a,'\"')\n call getrel(longline,ip,xxx)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n if(xxx.eq.zero) then\n! this is Qing-Xiong magnetic model, next number is 0.37 for BCC or 0.25\n call getrel(longline,ip,xxx)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 1000\n endif\n typedefaction(nytypedef)=int(1.0D2*xxx)\n! write(*,*)'3E Qing-Xiong magnetic model',nytypedef,&\n! typedefaction(nytypedef)\n! Special for Ting, check and set if ferromagnetic reference state\n! write(*,*)'3E magnetic: \"',trim(longline(ip:)),'\"'\n if(.not.eolch(longline,ip)) then\n! If there is a final F on the TYPE_DEF line set ferromagnetic reference state\n if(longline(ip:ip).eq.'F') then\n! in this way all magnetic phases will have T=0 as refernce state ...\n! ferroref=.TRUE.\n! Use a negative value to indicate T=0 is ferroref\n typedefaction(nytypedef)=-typedefaction(nytypedef)\n endif\n endif\n else\n! this is Inden model, xxx can be -1 for BCC or -3 for FCC, HCP and other phases\n typedefaction(nytypedef)=int(xxx)\n endif\n else\n!------------------------------------------ TYPE_DEF disordered-part and others\n km=index(longline,' DIS_PART ')\n never=1\n! write(*,*)'3E sigma1: ',trim(longline),km,never\n addnever: if(km.eq.0) then\n! Allow for NEVER_DIS ...\n km=index(longline,' NEVER')\n! this is for disordered SIGMA etc.\n if(never.gt.0) then\n never=-1\n endif\n endif addnever\n! write(*,*)'3E sigma2: ',trim(longline),km,never\n dispart: if(km.gt.0) then\n! disordered part, either DIS_PART or NEVER_DIS several checks\n disparttc=disparttc+1\n! find the ordered phase name, we have to go backwards from km\n ip=km-1\n81 continue\n if(longline(ip:ip).eq.' ') then\n ordpartph(disparttc)=' '\n! The ordpartph is not correct\n ordpartph(disparttc)=longline(ip+1:km)\n! if the ordered part rejected skip this TYPE_DEF\n else\n ip=ip-1\n goto 81\n endif\n orddistyp(disparttc)=never\n! extract the disordered part phase name\n ip=index(longline(km+2:),' ')\n dispartph(disparttc)=longline(km+2+ip:)\n! find the end of phase name, a space or a , there is always a space after ,\n ip=index(dispartph(disparttc),' ')\n km=index(dispartph(disparttc),',')\n if(km.gt.0 .and. km.lt.ip) ip=km\n! if(ip.le.0) ip=1\n dispartph(disparttc)(ip:)=' '\n! if ordered part rejected all OK\n do jt=1,nphrej\n if(ordpartph(disparttc).eq.phreject(jt)) then\n write(*,*)'3E ordered part rejected, keep disordered'\n goto 84\n endif\n enddo\n if(.not.silent) write(kou,82)disparttc, &\n trim(ordpartph(disparttc)),&\n trim(dispartph(disparttc)),orddistyp(disparttc)\n82 format('3E Found a type_def DIS_PART:',i2,&\n ' with ',a,' and ',a,' type:',i2)\n! THIS CODE REDUNDANT BECAUSE ALL TYPE_DEFS READ BEFORE PHASES ARE ENTERED\n! if the disordered part phase already entered give warning and advice\n! call find_phase_by_name(dispartph(disparttc),iph,ics)\n! if(gx%bmperr.ne.0) then\n! gx%bmperr=0\n! else\n! if(.not.silent) write(kou,83)dispartph(disparttc)\n!83 format('3E *** Warning, the disordered phase is already',&\n! ' entered ***'/' Please rearrange the TDB file so',&\n! ' this TYPE_DEF comes before'/&\n! ' the PHASE keyword for the disordered phase: ',a/&\n! ' *** The disordered part ignored ***')\n! disparttc=disparttc-1\n! warning=.TRUE.\n! endif\n84 continue\n else\n km=index(longline,' LIQUID 2-STATE ')\n liq2state: if(km.gt.0) then\n!------------------------------------------- TYPE_DEF liquid 2-state model\n typedefaction(nytypedef)=491\n else\n!---------------------------------------------- TYPE-DEF TERNARY_EXTRAPOL\n! write(*,*)'3E typedef: ',trim(longline)\n km=index(longline,' TERNARY')\n! do we know which phase we have here? The command should be\n! type_def z A-P-D phase TERNARY\n! extract the phase name before TERNARY !!! done at label 778, line 4148!!!\n! step backward to extract phase name, bypass spaces\n! pz2=km-1\n! do while(longline(pz2:pz2).eq.' ')\n! pz2=pz2-1\n! enddo\n! pz1=pz2\n! do while(longline(pz1:pz1).ne.' ')\n! pz1=pz1-1\n! enddo\n! write(*,'(\"3E phase name: \",a)')longline(pz1+1:pz2)\n! code above redundant\n ternaryxp: if(km.gt.0) then\n typedefaction(nytypedef)=777\n ntxp=ntxp+1\n! write(*,86)nytypedef,ntxp,trim(longline)\n86 format('3E Found ternary extrapolation',2i4/a)\n! we need to save the line!!\n if(ntxp.gt.mtxp) then\n write(*,*)'3E Error, ternary_extrapolations max',mtxp\n gx%bmperr=4399; goto 1000\n endif\n! write(*,'(\"3E line1: \",i3,a)')km,trim(longline)\n! skip from km to first space and compress multiple spaces to a single one\n zp=index(longline(km+1:),' ')\n! write(*,'(\"3E line2: \",i3,a)')zp,trim(longline(km+zp:))\n! we must add the phase name first!!\n! NO, that is done at label 778, line 4148 !!! double \n! ternaryxpol(ntxp)=longline(pz1+1:pz2+1)//longline(km+zp:)\n ternaryxpol(ntxp)=longline(km+zp:)\n! write(*,'(\"3E line3: \",a,i3)')trim(ternaryxpol(ntxp)),ntxp\n! call merge_spaces(longline(km+zp:))\n! Indicate we should execute ternaryxpol\n addternaryxpol=.true.\n else\n!---------------------------------------------- unknown TYPE-DEF\n typedefaction(nytypedef)=99\n if(.not.silent) &\n write(kou,87)nl,longline(1:min(78,len_trim(longline)))\n87 format('3E WARNING ignoring TYPE_DEF on line ',i5,':'/a)\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 13'\n! write(*,*)' WARNING SET TRUE <<<<<<<<<<<<<<<<<<<<<<<<<<<'\n endif ternaryxp\n endif liq2state\n endif dispart\n endif magnetic\n endif newtypedef\n88 continue\n!---------------------------------------------------------------------\n! elseif(line(2:20).eq.'LIST_OF_REFERENCES ' .or. &\n! line(2:16).eq.'ADD_REFERENCES ') then\n case(8,9) ! LIST_OF_REFERENCES and ADD_REFERENCES bibliography\n!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678\n! LIST_OF_REFERENCES\n! NUMBER SOURCE\n! REF283 'Alan Dinsdale, SGTE Data for Pure Elements,\n! Calphad Vol 15(1991) p 317-425,\n! also in NPL Report DMA(A)195 Rev. August 1990'\n! write(kou,*)'Does not handle REFERENCES'\n! skip the line with \"NUMBER SOURCE\"\n! position ip after \"NUMBER SOURCE\"\n ip=index(longline,'NUMBER SOURCE')+14\n if(eolch(longline,ip)) then\n if(.not.silent) write(kou,*)'Empty reference line',nl\n gx%bmperr=4313; goto 1000\n endif\n if(longline(ip:ip).eq.'!') then\n! write(*,*)'No references at all'\n goto 100\n endif\n! write(*,*)'list_of_references text length: ',len_trim(longline),ip\n! some reference lists like those from SSUB has no single quotes\n kp=index(longline(ip:),\"'\")\n citationmarks: if(kp.gt.0) then\n775 continue\n! reference symbol is refx; reference text in reftext\n refx=longline(ip:ip+kp-2)\n if(longline(ip+kp:ip+kp).eq.\"'\") then\n! two ' after each other, a dummy reference\n reftext=' '\n ip=ip+kp+1\n kkk=1\n! write(*,*)'dummy: ',refx,' next >',longline(ip:ip+20),'<'\n else\n jp=ip+kp+1+index(longline(ip+kp+1:),\"'\")\n reftext=longline(ip+kp:jp-2)\n ip=jp\n! when all works replace multiple spaces by a single one in reftext\n kkk=len_trim(reftext)\n kp=index(reftext(1:kkk),' ')\n do while(kp.gt.0)\n reftext(kp:)=reftext(kp+1:)\n kkk=kkk-1\n kp=index(reftext(1:kkk),' ')\n enddo\n endif\n! write(*,776)refx,nrefs,ip,jp,reftext(1:kkk)\n776 format('Reference: ',a,3i5/a)\n! this will not create bibliographic references that has not been referenced\n call tdbrefs(refx,reftext(1:kkk),1,ix)\n nrefs=nrefs+1\n! write(*,*)'added biblio ',refx,'>',longline(ip-5:ip+5),'<'\n if(eolch(longline,ip)) then\n gx%bmperr=4313; goto 1000\n endif\n if(longline(ip:ip).ne.'!') then\n kp=index(longline(ip:),\"'\")\n goto 775\n endif\n else\n! references without citation marks no capson\n! ip is at the start of the reference id, look for space\n if(.not.silent) write(kou,*) &\n 'Cannot handle references without citation marks',nl\n gx%bmperr=4314; goto 1000\n endif citationmarks\n777 continue\n! write(*,*)'Read ',nrefs,' references, ending at',nl\n!----------------------------------------------------------------\n case(10) ! ASSESSED_SYSTEMS\n if(.not.silent) write(kou,*) &\n '3E cannot handle ASSESSED_SYSTEMS ending at ',nl\n! warning=.TRUE.\n! skip lines until !\n do while(index(line,'!').le.0)\n read(21,110)line\n nl=nl+1\n! call replacetab(line,nl)\n enddo\n!------------------------------------------------------------------\n case(11) ! DATABASE_INFORMATION\n! skip this as checktdb2 has already presented the information\n! if(.not.silent) write(kou,*)'3E Cannot handle DATABASE_INFORMATION at ',nl\n! warning=.TRUE.\n! skip lines until !\n! write(*,*)'3E reading database information'\n! write(*,*)'3E ',trim(line)\n! ll=index(line,'!')\n! write(*,*)'3E value of ll: ',ll\n! this loop probably meaningless as we have read up to ! already ...\n! write(*,*)'3E found this line: ',nl\n do while(index(line,'!').le.0)\n read(21,110)line\n nl=nl+1\n! ll=index(line,'!')\n! write(*,*)'3E value of ll: ',ll\n! call replacetab(line,nl)\n enddo\n!------------------------------------------------------------------\n case(12) ! VERSION, recognize OC1\n780 continue\n if(eolch(line,ip)) then\n read(21,110)line\n nl=nl+1\n call replacetab(line,nl)\n goto 780\n else\n if(line(ip:ip).eq.'!' .and. .not.silent) then\n write(kou,*)'Found VERSION keyword but no specification'\n else\n if(line(ip:ip+3).eq.'OC1 ') tdbv=2\n endif\n endif\n! skip lines until !\n do while(index(line,'!').le.0)\n read(21,110)line\n nl=nl+1\n call replacetab(line,nl)\n enddo\n!------------------------------------------------------------------\n case(13) ! DEFAULT_COMMAND, handle REJECT only\n! skip lines until !\n do while(index(line,'!').le.0)\n read(21,110)line\n nl=nl+1\n call replacetab(line,nl)\n enddo\n! replace - by _ ... can be dangerous for electrons /-\n790 continue\n ip=index(line,'-')\n if(ip.gt.0) then\n line(ip:ip)='_'\n goto 790\n endif\n! here I handle only reject phase\n791 continue\n call getext(line,nextc,1,name1,' ',ix)\n if(name1(1:ix).eq.'REJECT_PHASE') then\n793 continue\n! save phase names to be rejected in a structure \n call getext(line,nextc,1,name1,' ',ix)\n if(name1(1:1).eq.' ' .or. name1(1:1).eq.'!') then\n goto 794\n else\n nphrej=nphrej+1\n if(nphrej.gt.maxrejph) then\n write(*,*)'3E Too many phases to reject, increase maxrejph'\n else\n write(*,*)'3E rejected phase: ',name1\n phreject(nphrej)=name1\n endif\n endif\n goto 793\n elseif(name1(1:7).eq.'DEF_SYS' .or. &\n name1(1:13).eq.'DEFINE_SYSTEM') then\n! ignore default define_system... as, Va and /- are always entered by default\n continue\n else\n write(*,*)'3E WARNING: ignoring default command: ',trim(name1)\n endif\n794 continue\n! rejected phases OK\n! do zz=1,nphrej\n! write(*,*)'3E rejected phase: ',phreject(zz)\n! enddo\n!--------------------------------- DEFINE\n case(14) !ignore without warning\n write(*,*)'3E ignoring DEFINE keyword'\n continue\n end select\n!-------------------------------------------------------- end select\n if(gx%bmperr.ne.0 .and. .not.silent) then\n write(kou,711)gx%bmperr,nl,trim(line)\n711 format('3E error: ',i5,' around line ',i7,': '/a)\n! this error means reference error\n if(gx%bmperr.eq.4154) gx%bmperr=0\n endif\n! look for next KEYWORD\n goto 100\n!--------------------------------------------------------\n!----- reading FUNCTIONS at the end from a TDB file, we read just functions\n800 continue\n if(eolch(line,nextc)) then\n if(.not.silent) write(kou,*) &\n 'Function name must be on same line as FUNCTION'\n gx%bmperr=4315; goto 1000\n endif\n ipp=nextc+index(line(nextc:),' ')\n name1=line(nextc:ipp-1)\n! write(*,18)'function >',name1,'< ',nextc,ipp\n!18 format(a,a,a,2i4)\n! old code\n longline=' '\n longline=line(ipp:)\n810 continue\n jp=max(len_trim(longline),1)\n! write(*,811)jp,longline(jp:jp),longline(1:jp)\n811 format('3E ll: ',i3,' \"',a1,'\" ',a)\n! if(longline(jp:jp).eq.'!') then\n! This is to allow comments between ! and EndOfLine\n if(index(longline(1:jp),'!').gt.0) then\n! replace # by ' '\n820 continue\n jss=index(longline(1:jp),'#')\n if(jss.gt.0) then\n longline(jss:jss)=' '\n goto 820\n endif\n! file is not encrypted\n call find_tpfun_by_name_exact(name1,nr,notent)\n if(gx%bmperr.eq.0) then\n if(notent) then\n! write(*,*)'Entering function: ',name1\n! entering a function may add new unentered functions ... last argument TRUE\n! write(*,*)'3E Entering function 3: ',name1,len_trim(longline)\n! lrot=0\n! call store_tpfun(name1,longline,lrot,.TRUE.)\n! we are using the version which can read encrypted files\n call store_tpfun(name1,longline,lrot,rewindx)\n if(gx%bmperr.ne.0) then\n! one may have error here\n if(.not.silent) write(kou,*)'Failed entering function: ',name1\n goto 1000\n endif\n if(ocv()) write(*,*)'Entered function: ',name1\n nofunent=nofunent+1\n else\n! write(*,*)'3E referenced: ',trim(name1),nr,&\n! tpfuns(nr)%rewind,rewindx\n if(tpfuns(nr)%rewind.eq.rewindx) then\n! Function entered and referenced, check if duplicate!\n write(*,828)trim(name1),nl,rewindx\n828 format('3E WARNING duplicate function ',a,' at line: ',2i5)\n tdbwarning=.TRUE.\n! write(*,*)'3E tdbwarning set true 14'\n endif\n endif\n else\n! ignore the function as it is not referenced. Reset error code\n gx%bmperr=0\n endif\n else\n830 continue\n nl=nl+1\n read(21,110)line\n! write(kou,101)'readtdb 2: ',nl,line(1:40)\n! skip lines with a $ in first position\n if(line(1:1).eq.'$')goto 830\n call replacetab(line,nl)\n call capson(line)\n longline=longline(1:jp)//line\n goto 810\n endif\n goto 100\n! endif barafun\n!---------------------------------------------------------\n! We have now read all\n!--------------------------------------------------------\n1000 continue\n! write(*,1111)totalpar,totalpar-notusedpar\n! write(*,1111)totalpar,enteredpar,notusedpar\n if(manylonglines.gt.0) &\n write(*,*)'3E Number of lines exceeding 80 characters: ',manylonglines\n if(noparref.gt.0) write(*,1117)noparref\n1117 format('There are ',i7,' parameters with no reference')\n write(*,1111)totalpar,enteredpar\n1111 format(/'Out of ',i5,' model parameters ',i5,' have been entered'/)\n if(tdbwarning) then\n1001 continue\n write(*,*)\n! if silent set ignore warnings\n if(.not.silent) then\n do jss=1,nundefmpi\n write(*,1008)undefmpi(jss)\n1008 format('3E *** WARNING unused model parameter identifier ',a,&\n ' in some phases')\n enddo\n write(kou,1003)\n1003 format(/'There were warnings, check them carefully'/&\n 'and press RETURN if you wish to continue.')\n read(kiu,1004)ch1\n1004 format(a)\n! if(ch1.eq.'N') stop 'warnings reading database'\n! if(ch1.ne.'Y') then\n! write(kou,*)'Please answer Y or N'\n! goto 1001\n! endif\n endif\n \n endif\n! write(*,*)'3E At label 1000'\n if(buperr.ne.0 .or. gx%bmperr.ne.0) then\n if(gx%bmperr.eq.0) gx%bmperr=buperr\n if(.not.silent) write(kou,1002)gx%bmperr,nl\n1002 format('Error ',i5,', occured at TDB file line ',i7)\n! write(*,*)'Do you want to continue at your own risk anyway?'\n! read(*,1008)ch1\n!1008 format(a)\n! if(ch1.eq.'Y') then\n! write(*,*)'Now any kind of error may occur .... '\n! buperr=0\n! gx%bmperr=0\n! goto 100\n! endif\n endif\n!000000000000000000000000000000000000000000000000000000\n! After entering all parameters we should take care of ternary_extrapolations \n if(addternaryxpol) then\n! write(*,'(a)')'3E Adding extrapolation methods',ntxp\n do zp=1,ntxp\n! write(*,*)'3E call set_database_ternary: ',trim(ternaryxpol(zp))\n! this subroutine is in gtp3H.F90 is obsolete\n! call set_database_ternary(ternaryxpol(zp))\n! this subroutine is in gtp3XQ.F90\n call set_ternary_asymmetry(ternaryxpol(zp))\n enddo\n! else\n! write(*,*)'3E No ternary extrapolations'\n endif\n!000000000000000000000000000000000000000000000000000000\n! no more read(21 ...\n close(21)\n! read numbers, value after / is maximum\n! endmember, interactions, property,\n! tpfuns, composition sets, equilibria\n! state variable functions, references, additions\n if(ocv()) write(*,1007)noofel,maxel,noofsp,maxsp,noofph,maxph,&\n noofem,100000,noofint,100000,noofprop,100000,&\n notpf(),maxtpf,highcs,2*maxph,eqfree-1,maxeq,&\n nsvfun,maxsvfun,reffree-1,maxrefs,addrecs,csfree-1\n1007 format('Created records for elements, species, phases: ',2x,&\n 3(i4,'/',i4,1x)/&\n 'end members, interactions, properties: ',10x,&\n 3(i4,'/',i4,1x)/&\n 'TP-funs, max and free composition sets, equilibria: ',10x,&\n 3(i4,'/',i4,1x)/&\n 'state variable functions, references, additions: ',&\n 3(i4,'/',i4,1x)/)\n! a special warning message as it may be scrolled away by all references\n! write(*,*)'Any warnings?',tdbwarning\n! nonzero multiuse will prompt a warning in the monitor\n firsteq%multiuse=0\n if(gx%bmperr.eq.0 .and. tdbwarning) firsteq%multiuse=-1\n return\n!--------------------------------------------------------------------------\n! errors and rewinds\n1010 continue\n if(.not.silent) write(kou,*)'I/O error opening file: ',gx%bmperr\n return\n!-----------------------------------------------------\n! end of file found, act differently if reading functions\n2000 continue\n rewindx=rewindx+1\n if(only_typedefs) then\n! new feature, read only_typdes at first run, then set it false\n only_typedefs=.FALSE.\n! write(*,*)'3E Finished reading all TYPE_DEFS, now the rest of the file'\n gx%bmperr=0\n rewind(21)\n nl=0\n goto 100\n endif\n rewindfile: if(dodis.eq.0 .and. disparttc.gt.0) then\n! rewind to read disordred parts\n if(.not.silent) write(kou,1220)\n1220 format('3E Rewinding to read disordered part of phases')\n rewind(21)\n dodis=1\n nl=0\n goto 100\n elseif(.not.onlyfun) then\n! rewind to read referenced functions and references !!\n dodis=2\n rewind(21)\n onlyfun=.TRUE.\n nofunent=0\n! write(*,2002)gx%bmperr\n2002 format('Found end-of-file, rewind to find functions',i5)\n nl=0\n goto 100\n! elseif(encrypted.gt.0) then\n! REDUNDANT CODE when testing using 2 files for encrypted TDB files\n! on encrypted TDB files the FUNCTION and PARAMETER keywords are\n! in a separate file. When onlyfun is TRUE then we swich to this file\n! close(21)\n! write(*,*)'3E closing TDB file to read encrypted part'\n! call readencrypt(encryptline,nr)\n! nr is missing functions ...\n! if(gx%bmperr.eq.0) then\n! if(nr.gt.0) then\n! write(*,*)'3E read encrypted part, missing functions: ',nr\n! endif\n! else\n! write(*,*)'3E error reading encrypted part',gx%bmperr\n! endif\n! return\n elseif(nofunent.gt.0) then\n! rewind if there were functions entered last time\n rewind(21)\n norew=norew+1\n! write(*,*)'Found functions: ',nofunent,' rewinding again',norew,gx%bmperr\n! if(newfun.gt.0) then\n! write(*,*)'Read ',newfun+nfail,' functions, entered ',newfun,&\n! ' rewinding ',norew\n! newfun=0\n nofunent=0\n nl=0\n goto 100\n else\n! check if there are any unentered functions\n call list_unentered_funs(kou,nr)\n if(nr.gt.0) then\n if(.not.silent) write(kou,*)'3E Number of missing function: ',nr\n gx%bmperr=4186\n endif\n! check if any function not entered\n onlyfun=.FALSE.\n endif rewindfile\n goto 1000\n! end of file while looking for ! terminating a keyword\n2200 continue\n if(.not.silent) write(kou,2210)nl,longline(1:72)\n2210 format('End of file at ',i5,' looking for end of keyword:'/a)\n gx%bmperr=4316\n goto 1000\n end subroutine readtdb\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine readtdbsilent\n!\\begin{verbatim}\n subroutine readtdbsilent\n!\\end{verbatim} %+\n globaldata%status=ibset(globaldata%status,GSSILENT)\n return\n end subroutine readtdbsilent\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine any_disordered_part\n!\\begin{verbatim}\n subroutine any_disordered_part(lin,ndisph,dispartph,ordpartph,orddistyp)\n! reading data from a TDB/PDB file with selection of elements\n! extract only TYPE_DEFS for order/disorder\n!-------------------------------------------------------\n! Not all TYPE_DEFS implemented\n!-------------------------------------------------------\n implicit none\n integer lin,ndisph\n character dispartph(*)*(*),ordpartph(*)*(*)\n integer orddistyp(*)\n!\\end{verbatim}\n character line*128,longline*1024,phase*24\n integer ip,jp,zp\n ndisph=0\n loop1: do while(.true.)\n read(lin,100,end=900)line\n100 format(a)\n ip=1\n if(eolch(line,ip)) cycle loop1\n if(line(ip:ip).eq.'$') cycle loop1\n typedef: if(line(ip:ip+7).eq.'TYPE_DEF') then\n! search for ! meaning end of keyword\n longline=line(ip:)\n ip=len_trim(longline)\n loop2: do while(longline(ip:ip).ne.'!')\n read(lin,100,end=900)line\n longline(ip+1:)=line\n ip=len_trim(longline)\n enddo loop2\n! write(*,*)'3E type_def 1: ',longline(1:ip)\n! the important part is \"GES\" followed by \"A_P_D\" (or AMEND_PHASE_DEFINITION)\n! followed by phase name and followed by \"DIS_PART\" or \"NEVer\" and a phase name\n jp=index(longline,' GES ')\n if(jp.le.0) exit typedef\n! below is a clumsy way to extract phase names for ordered/disordered parts\n! skip the first item after \"GES\" (should be AMEND_PHASE_DESCRIPTION or abbrev\n zp=jp+4\n if(eolch(longline,zp)) then\n exit typedef\n endif\n! skip to next item, if none loop, else extract next item\n jp=index(longline(zp:),' ')\n if(zp.le.0) exit typedef\n zp=zp+jp\n! write(*,*)'3E zp1: ',trim(longline),zp\n if(eolch(longline,zp)) then\n exit typedef\n endif\n phase=longline(zp:)\n jp=index(phase,' ')\n phase(jp:)=' '\n! this should be a phase name, maybe the ordered part\n! write(*,*)'3E phase name? ',trim(phase)\n! check what comes after phase name, \n! the important is \"DISORDERED_PART\" or \"NEVER_DISORDERED\" or abbreviations\n ip=zp+jp\n! write(*,*)'3E after phase: \"',trim(longline(ip:)),'\"'\n if(eolch(longline,ip)) exit typedef\n if(longline(ip:ip+2).eq.'NEV') then\n ndisph=ndisph+1\n orddistyp(ndisph)=1\n elseif(longline(ip:ip+2).eq.'DIS') then\n ndisph=ndisph+1\n orddistyp(ndisph)=-1\n else\n exit typedef\n endif\n! write(*,'(a,a,2i3)')'3E zp2: ',trim(longline),orddistyp(ndisph),ip\n! find space after NEVER or DIS_PART\n jp=ip+index(longline(ip:),' ')\n! disordered phase name should be now\n! write(*,*)'3E after dis/nev: \"',trim(longline(ip:)),'\"',jp\n if(eolch(longline,jp)) then\n write(*,'(a/a)')'3E no disordered phase! ',trim(longline)\n exit typedef\n endif\n dispartph(ndisph)=longline(jp:)\n! name terminated by space, comma or !\n ip=index(dispartph(ndisph),',')\n if(ip.gt.0) dispartph(ndisph)(ip:)=' '\n ip=index(dispartph(ndisph),'!')\n if(ip.gt.0) dispartph(ndisph)(ip:)=' '\n! ip=index(dispartph,' ')\n! dispartph(ndisph)(ip:)=' '\n ordpartph(ndisph)=phase\n! write(*,'(a,i2,5a,i3)')'3E ord/dis: ',ndisph,' \"',&\n! trim(ordpartph(ndisph)),'\" + \"',trim(dispartph(ndisph)),'\"',&\n! orddistyp(ndisph)\n endif typedef\n enddo loop1\n! eof\n900 continue\n rewind(lin)\n1000 continue\n return\n end subroutine any_disordered_part\n\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\n\n!\\addtotable subroutine checkdb2\n!\\begin{verbatim}\n subroutine checkdb2(filename,ext,nel,selel)\n! checking a TDB and XTDB file exists and return the elements\n! It also writes 15 lines from any \"DATABASE_INFO\" in the file\n implicit none\n integer nel\n character filename*(*),ext*(*),selel(*)*2\n!\\end{verbatim}\n character line*256,ext2*4\n integer ipp,nl,kk,dbinfo\n logical cl\n!\n ext2=ext\n dbinfo=0\n call capson(ext2)\n! write(*,*)'3E extract elements: \"',trim(filename),'\" and \"',ext\n if(.not.(index(filename,ext).gt.0 &\n .or. index(filename,ext2).gt.0)) then\n! no extention provided\n filename(len_trim(filename)+1:)=ext2\n endif\n nel=0\n#ifdef entrypopt\n write(*,*)'PM: no listing of elements in encrypted databases'\n nel=-1\n goto 1000\n#endif\n! there is a need to extract elements also from encrypted files\n open(21,file=filename,access='sequential',form='formatted',&\n err=1010,iostat=gx%bmperr,status='old')\n! if first line of file is \"$OCVERSION ...\" the text is displayed once\n read(21,110)line\n if(line(1:11).eq.'$OCVERSION ') then\n write(kou,117)trim(line(12:))\n117 format(/'TDB file id: ',a/)\n endif\n rewind(21)\n nl=0\n write(*,*)'3E Database file extention is: \"',ext,'\"'\n if(ext.eq.'.xtdb' .or. ext.eq.'.XTDB') then\n write(*,*)'3E *** WOW *** Reading elements from XTDB file'\n! extracting elements from XTDB file \n cl=.FALSE.\n200 continue\n read(21,110,end=2000)line\n nl=nl+1\n if(cl) then\n! if cl is TRUE then skip all lines until !>\n if(index(line,'-->').gt.0) then\n cl=.FALSE.\n endif\n goto 200\n elseif(index(line,'').gt.0) cl=.FALSE.\n goto 200\n endif\n if(index(line,'ceq%phase_varres(lokcs)\n! this is to check how the ordered phase constituents\n! ip=0\n! do i2=1,phlista(lokph)%noofsubl\n! write(*,*)'3EA: ',lokph,(phlista(lokph)%constitlist(ip+nn),&\n! nn=1,phlista(lokph)%nooffr(i2))\n! ip=ip+phlista(lokph)%nooffr(i2)\n! i3=i3*phlista(lokph)%nooffr(i2)\n! enddo\n! write(*,*)'3E number of endmembers 1: ',lokph,i3\n disvarres=>ceq%phase_varres(varres%disfra%varreslink)\n! write(*,*)'3ZZ: ',disvarres%sites(1),disvarres%sites(2)\n! there must be a disfra record, \n! the number of sublattices and constituents in each sublattice found there\n ip=0\n i3=1\n nsubl=varres%disfra%ndd\n do i2=1,varres%disfra%ndd\n! write(*,*)'3ZB: ',varres%disfra%nooffr(2),&\n! (varres%disfra%splink(nn+ip),&\n! nn=1,varres%disfra%nooffr(i2))\n! ip=ip+varres%disfra%nooffr(i2)\n i3=i3*varres%disfra%nooffr(i2)\n enddo\n! write(*,*)'3E number of endmembers 2: ',lokph,i3\n disfactor=varres%disfra%fsites\n! write(*,*)'3ZC factor: ',disfactor,varres%disfra%latd\n else\n nsubl=phlista(lokph)%noofsubl\n do i2=1,phlista(lokph)%noofsubl\n i3=i3*phlista(lokph)%nooffr(i2)\n enddo\n disfactor=one\n endif\n! write(*,*)'3E nonsuspended phase constituents: ',i1,i3\n ncon(i1)=i3\n! for check at the end\n endx(i1)=ncon(i1)\n endif\n enddo phloop1\n! now can we write the line with overall phase information ... suck\n ip=1\n noelel=noofel+nelectrons\n write(text(ip:),110)noelel\n ip=len_trim(text)+1\n! number of mixture phases and for each mixture the number of endmembers\n! if nogas is TRUE add a phase with zero endmembers first\n if(nogas) then\n write(text(ip:),109)nphmix+1,0\n ip=len_trim(text)+1\n109 format(2i4)\n else\n write(text(ip:),110)nphmix\n ip=len_trim(text)+1\n110 format(i4)\n112 format(i5)\n endif\n ph1: do i1=1,noofph\n lokph=phasetuple(i1)%lokph\n if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then\n! write(*,*)'3E skipping phase loop 2: ',phlista(lokph)%name\n cycle ph1\n endif\n! Write the number of constituents in mixures (including gas if present) \n! write(*,*)'3E mixture constituents: ',i1,ncon(i1)\n if(ncon(i1).gt.0) then\n write(text(ip:),112)ncon(i1)\n ip=len_trim(text)+1\n if(ip.gt.72) then\n! write(lut,100)trim(text)\n! According to Ted\n write(lut,99)trim(text)\n ip=1\n endif\n endif\n enddo ph1\n! finally the number of stoichiometric phases using i5\n write(text(ip:),112)nphstoi\n! NOTE format 100 adds an initial space on the line\n! write(lut,100)trim(text)\n! According to Ted\n write(lut,99)trim(text)\n! write(*,*)'3E elements mm: ',trim(text)\n!------------------ system components including electrons for charged phases\n ip=1\n text=' '\n lcase=ichar('a')-ichar('A')\n do i1=1,noofel\n! second letter lower case\n elsym=ellista(elements(i1))%symbol\n if(elsym(2:2).ne.' ') then\n elsym(2:2)=char(ichar(elsym(2:2))+lcase)\n endif\n text(ip:)=elsym\n ip=ip+25\n if(ip.gt.51) then\n write(lut,100)trim(text)\n ip=1\n text=' '\n endif\n enddo\n! electrons\n nnn=1\n do i1=1,noofph\n if(estoi(i1).lt.0) then\n if(phchargedx(nnn).eq.i1) then\n text(ip:)='e('//trim(phcharged(nnn))//')'\n nnn=nnn+1\n else\n lokph=phasetuple(i1)%lokph\n text(ip:)='e('//trim(phlista(lokph)%name)//')'\n endif\n ip=ip+25\n if(ip.gt.51) then\n write(lut,100)trim(text)\n ip=1\n text=' '\n endif\n endif\n enddo\n if(ip.gt.1) then\n write(lut,100)trim(text)\n endif\n! allocate an array for constituent stoichiometry\n! if(noofel+nelectrons.gt.50) &\n if(noelel.gt.50) &\n write(*,*)'Allocating large constituent array: ',noelel\n allocate(constcomp(noelel))\n!----------------------------- system component mass, electrons 0.00054858???\n ip=1\n text=' '\n do i1=1,noofel\n write(text(ip:),130)ellista(elements(i1))%mass\n130 format(F25.8)\n ip=ip+25\n if(ip.gt.51) then\n write(lut,100)trim(text)\n ip=1\n text=' '\n endif\n enddo\n! electrons\n do i1=1,nelectrons\n write(text(ip:),130)5.4858D-4\n ip=ip+25\n if(ip.gt.51) then\n write(lut,100)trim(text)\n ip=1\n text=' '\n endif\n enddo\n if(ip.gt.1) then\n write(lut,100)trim(text)\n endif\n!---------------------------------T powers, always the same line \n! if(npows.eq.9) then\n! 10 here are the allowed powers: 0 1 100 2 3 -1 ; 7 -9 -2 any any\n! 1 2 3 4 5 6 7 8 9 10 11\n! Those after the ; are special. 100 means T*ln(T)\n if(npows.le.15) then\n! the first 7 digits should be 9 1..6\n! write(lut,140)trim(powers(36:))\n! write(lut,140)trim(powers(36:))\n!140 format(' 9 1 2 3 4 5 6',a)\n! it does not seem to matter what is on these lines ...\n write(lut,140)\n write(lut,140)\n!140 format(' 6 1 2 3 4 5 6')\n! According to Ted\n140 format('6 1 2 3 4 5 6 ')\n else\n write(*,*)'3E too many different T powers: ',npows\n stop\n endif\n!-------------------------------------- end of header section\n! SOLGASMIX phase names must start with 4 unique letters, when TDB files\n! has phases with same first 4 characters add a prefix\n phunique='P000'\n! data for mixtures\n! First the endmembers\n mphstoi=1\n phases1: do i1=1,noofph\n lokph=phasetuple(i1)%lokph\n skipfc=.false.\n if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then\n! skip phases with suspended default composition set\n! write(*,*)'3E skipping phase loop 3: ',phlista(lokph)%name\n cycle phases1\n endif\n! havemag nonzero if there are magnetic parameters\n! magloop set to TRUE to list magnetic excess parameters\n havemag=0\n magloop=.FALSE.\n if(phlista(lokph)%nooffs.gt.1) then\n! skip first ordered fraction set\n skipfc=.true.\n endif\n if(i1.eq.phstoi(mphstoi)) then\n! write(*,*)'3E skipping stoichiometric ',trim(phlista(lokph)%name)\n mphstoi=mphstoi+1\n cycle phases1\n! else\n! write(*,*)'3E parameters for mixture ',trim(phlista(lokph)%name)\n endif\n lokcs=phlista(lokph)%linktocs(1)\n varres=>ceq%phase_varres(lokcs)\n! if disordered fraction set, set varres to point to disordered phase_varres\n if(skipfc) then\n varres=>ceq%phase_varres(lokcs)\n fedup=>varres\n! write(*,*)'3E disordered part: ',varres%disfra%ndd\n varres=>ceq%phase_varres(varres%disfra%varreslink)\n endif\n nsubl=1\n ionliq=.false.\n! phase model ane expected endmembers\n! we calculate the number of endmembers, end1mem is needed for DAT file\n! end2mem is actual. Error is not the same\n end1mem=0\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n model='SUBI'\n nsubl=2\n ionliq=.true.\n! there can just be one ionic liquid ... ??\n allocate(constcompiliq(noelel))\n elseif(btest(phlista(lokph)%status1,PHID)) then\n model='IDMX' \n else\n! there are phases with other bits which will not work but they are rarely set\n! now for sublattices ...\n nsubl=phlista(lokph)%noofsubl\n offset=nsubl\n if(btest(phlista(lokph)%status1,PHFORD)) then\n! NOTE varres is the disordered fraction set\n nsubl=size(varres%sites)\n! write(*,141)trim(phlista(lokph)%name),nsubl\n141 format('Phase ',a,' has FCC permutated parameters, ignore ordered',&\n i3)\n elseif(btest(phlista(lokph)%status1,PHBORD)) then\n nsubl=size(varres%sites)\n! write(*,142)trim(phlista(lokph)%name),nsubl\n142 format('Phase ',a,' has BCC permutated parameters, ignore ordered',&\n i3)\n elseif(btest(phlista(lokph)%status1,PHMFS)) then\n nsubl=size(varres%sites)\n! write(*,143)trim(phlista(lokph)%name),nsubl\n143 format('Phase ',a,' has disorded fraction sets, ignore ordered',i3)\n endif\n if(nsubl.gt.1) then\n model='SUBL'\n else\n model='RKMP'\n endif\n! fill values in xnooffr\n if(skipfc) then\n xnooffr=0\n do i2=1,nsubl\n xnooffr(i2)=xnooffr(i2-1)+fedup%disfra%nooffr(i2)\n enddo\n xnooffr(0)=1\n else\n xnooffr=0\n do i2=1,nsubl\n xnooffr(i2)=xnooffr(i2-1)+phlista(lokph)%nooffr(i2)\n enddo\n xnooffr(0)=1\n endif\n! write(*,*)'3E xnooffr: ',(xnooffr(i2),i2=0,nsubl)\n! magnetism?\n addrec=>phlista(lokph)%additions\n lastadd: do while(associated(addrec))\n! no need to increment CHTD except for magnetism\n! write(*,*)'3E additions?: ',phlista(lokph)%name,addrec%type\n if(addrec%type.eq.1) then\n aff=addrec%aff\n havemag=3\n model(5:5)='M'\n write(*,*)'3E magnetic phase 2: ',phlista(lokph)%name\n elseif(addrec%type.ne.7) then\n! ignore addrec%type=7 which is volume model \n write(*,*)'3E WARNING addition type: ',addrec%type,' ignored'\n endif\n addrec=>addrec%nextadd\n enddo lastadd\n endif\n! prepare a dummy prefix\n phdummy=phlista(lokph)%name(1:4)\n jp=0\n name2: do i3=1,noofph\n if(i3.ne.lokph .and. phdummy.eq.phlista(i3)%name(1:4)) then\n! write(*,*)'Duplicate name',i3,lokph,phdummy,' ? ',&\n! phlista(i3)%name(1:4)\n jp=1; exit name2\n endif\n enddo name2\n if(jp.gt.0) then\n call incunique(phunique)\n phdummy=phunique\n! write(*,*)'3E prefixing TDB phase name ',&\n! phdummy//'_'//trim(phlista(lokph)%name),i1,lokph\n else\n phdummy=' '\n endif\n! According to Ted\n if(phdummy(1:1).eq.' ') then\n write(*,180)trim(phlista(lokph)%name),trim(model),&\n nsubl,ncon(i1),disfactor\n180 format('3E mixture: ',a,' with model ',a,2i4,F12.4,a)\n write(lut,201)phlista(lokph)%name,nsubl,trim(model)\n else\n warnings=warnings+1\n write(*,180)phdummy//'_'//trim(phlista(lokph)%name),trim(model),&\n nsubl,ncon(i1),disfactor,' with name change'\n write(lut,201)phdummy//'_'//phlista(lokph)%name,nsubl,trim(model)\n endif\n201 format(a,5x,'= MIXTURE PHASE =',i3/a)\n if(havemag.ne.0) then\n if(aff.eq.one) then\n! Inden BCC magnetism\n write(lut,202)-aff,0.4\n else\n! Inden FCC, HCP and other structures\n write(lut,202)-one/aff,0.28\n endif\n202 format(F8.6,2x,F10.6)\n endif\n!-------------------- we must repeat the endmember loop below for interactions\n205 continue\n missend(1)=1\n do ip=2,nsubl\n missend(ip)=missend(ip-1)+phlista(lokph)%nooffr(ip-1)\n enddo\n endmember=>phlista(lokph)%ordered\n if(associated(phlista(lokph)%disordered)) then\n! skip writing ordered part, nsubl set above!!\n! if(.not.skipfc) then\n! write(*,*)'3E We have disorderd fraction set but skipfc not set!'\n! else\n! write(*,*)'3E Skipfc set correctly',nsubl\n! endif\n write(*,*)'BEWARE skipping ordered part of :',&\n trim(phlista(lokph)%name),nsubl,offset\n endmember=>phlista(lokph)%disordered\n endif\n! write(*,*)'3E first the endmembers',nsubl\n! endmember parameters, when they are done loop for excess parameters\n excessparam=.FALSE.\n!===========================================================================\n!================================== big loop for endmembers and interactions\n! when all endmembers written then set excesspara=.true. and jump back here\n207 continue\n if(ionliq) then\n nextcation=>endmember%nextem\n cation=endmember%fraclinks(1,1)\n if(.not.excessparam) then\n! check if there is a missing endmember, skip wildcard parameters\n if(cation.ne.-99 .and. anion.ne.-99) then\n if(cation.ne.missend(1) .or. &\n endmember%fraclinks(2,1).ne.missend(2)) then\n write(*,*)'3E first endmember missing for liquid: ',&\n missend(1),missend(2)\n stop 'Check if inonic liquid has all endmember parameters'\n endif\n endif\n endif\n! NOTE there can be missing endmembers!!\n! write(*,*)'3E firstcation: ',cation\n firstcation=cation\n iliqwild=.false.\n if(firstcation.eq.-99) then\n iliqwild=.true.\n else\n ccc=one\n endif\n endif\n lokcs=phlista(lokph)%linktocs(1)\n varres=>ceq%phase_varres(lokcs)\n!--------------------------------------------------------------------\n! here starts the loop for all parameters\n! i1 is the index of this phase in the SOLGASMIX order\n allend: do while(associated(endmember))\n! we have to generate two lines by extracting the endmember and constituents\n! we may have to do this loop several times for the same phase to list\n! the endmembers in correct order, at least for the ionic liquid phase\n! For the ionic liquid all endmembers with the same cation must come together\n constcomp=zero\n if(ionliq) constcompiliq=zero\n constext=' '\n text=' '\n ip=1\n valency=zero\n wildcard=.false.\n if(.not.ionliq) then\n!-----------------------------------------------\n! for all other mixtures except ionic liquid ... note there are some tests\n! of ionliq here as this loop originally was also for ionic liquids ...\n sloop1: do isubl=1,nsubl\n! this is the loop for the constituents in sublattices\n if(skipfc) then\n! We should skip the ordered sublattices\n! for isubl=2 we should use the constituents in the last sublattce\n isp=endmember%fraclinks(isubl,1)\n! write(*,*)'3E constituent 1: ',isp,offset\n else\n isp=endmember%fraclinks(isubl,1)\n endif\n intconst(isubl)=isp\n if(isp.eq.-99) then\n! this means wildcard in this sublattice\n wildcard=.true.\n constext(ip:)='*:'\n ip=ip+2\n! if(ionliq .and. wildcard .and. isubl.eq.1) then\n! iliqwild=.true.\n! wildcard=.false.\n! endif\n! Hm we should add stoichiometric factors for all constituents in this subl\n! For ionliq this means neutrals on sublattice 2\n!>> QUESTION >> the DAT format repeats all neutrals for all cations\n!>>>>>>>>>>>>>> with the stoichiometry of the cation !!!\n! if(ionliq) valency(1)=one\n cycle sloop1\n endif\n if(skipfc) then\n! which index should be used to find the constituent in last sublattice\n! write(*,*)'3E disordered species: ',isp\n! nn=phlista(lokph)%constitlist(isp)\n i3=firsteq%phase_varres(lokcs)%disfra%splink(isp)\n! write(*,*)'3E disordered species: ',isp,nn,i3\n isp=i3\n! write(*,*)'3E species: ',splista(isp)%symbol\n else\n isp=phlista(lokph)%constitlist(isp)\n endif\n if(btest(splista(isp)%status,SPVA)) then\n valency(isubl)=zero\n! according to the example I have the stoichiometry should be 1 for (cation:VA)\n if(ionliq) valency(2)=-one\n else\n valency(isubl)=splista(isp)%charge\n if(abs(valency(isubl)).lt.1.0D-6) valency(isubl)=zero\n endif\n! here we cannot have ionic liquid here!\n! if(ionliq .and. isubl.eq.2) then\n! write(*,*)'3E we cannot have an ionic liquid here!'\n! do i3=1,noofel\n! constcomp(i3)=-constcomp(i3)*valency(2)\n! enddo\n! elseif(estoi(i1).lt.0) then\n if(estoi(i1).lt.0) then\n! charged sublattice phase. Electronic stoichiometry should be positive!\n! constcomp(-estoi(i1))=constcomp(-estoi(i1))+&\n constcomp(-estoi(i1))=constcomp(-estoi(i1))-&\n valency(isubl)*varres%sites(isubl)\n! write(*,901)'3E e-stoik:',isubl,-estoi(i1),&\n! valency(isubl),varres%sites(isubl),constcomp(-estoi(i1))\n901 format(a,2i3,3F10.2)\n endif\n call lower_case_species_name(constext,ip,isp)\n constext(ip:ip+1)=':'\n ip=ip+1\n do i2=1,splista(isp)%noofel\n! this is a loop for the components of the endmember constituents\n i3=ellista(splista(isp)%ellinks(i2))%alphaindex\n if(i3.eq.0) then\n! skip vacancies\n continue\n elseif(ionliq) then\n write(*,*)'#C we should never be here if ionic liquid 2'\n if(isubl.eq.1) then\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)\n else\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)*valency(1)\n endif\n else\n!\n! here the stoichiometry of the endmember is added together\n!\n if(skipfc) then\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)*&\n varres%disfra%dsites(isubl)\n else\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)*varres%sites(isubl)\n endif\n endif\n enddo\n enddo sloop1\n! for endmembers check that there is no missing endmember\n missend1: if(.not.excessparam) then\n www=0\n donotincrement=0\n miss7: do i2=1,nsubl\n if(intconst(i2).eq.-99) then\n! if we find a wildcard endmember do not increment missend !!!\n www=0; goto 1814\n endif\n thisend(i2)=missend(i2)\n if(intconst(i2).ne.missend(i2)) then\n www=77\n! this endmember is not the expected one. There can be several missing\n! but we should expect the one following. That means we should reset\n! constituents expected in higher sublattices .... \n missend(i2)=intconst(i2)+1\n if(donotincrement.eq.0) donotincrement=i2\n endif\n enddo miss7\n if(www.ne.0) then\n write(*,48)'3E *** Phase ',trim(phlista(lokph)%name),&\n ' missing endmember: ',(thisend(i2),i2=1,nsubl)\n! write(*,49)'3E found endmember: ',(intconst(i2),i2=1,nsubl)\n warnings=warnings+1\n48 format(a,a,a,9(1x,i3,':'))\n49 format(a,19x,9(1x,i3,':'))\n endif\n! increment constituents from the end for next test\n! To handle also disordered fraction sets use varres pointer\n! xnooffr(0) initially 1, xnooffr(j) is sum of constituents to and including j\n if(donotincrement.ne.nsubl) missend(nsubl)=missend(nsubl)+1\n do i2=nsubl,2,-1\n if(missend(i2).gt.xnooffr(i2)) then\n missend(i2)=xnooffr(i2-1)+1\n missend(i2-1)=missend(i2-1)+1\n endif\n enddo\n1814 continue\n! write(*,49)'3E expecting: ',(missend(i2),i2=1,nsubl)\n endif missend1\n else\n!--------------------------------------------------------------------\n! This is exclusivly for inonic liquids, loop second sublattice first ...\n! this is the loop for the constituents in sublattices\n! Hm we should add stoichiometric factors for all constituents in this subl\n! write(*,*)'3E we are here 1 ',excessparam,firstcation\n if(.not.iliqwild) then\n isp=phlista(lokph)%constitlist(cation)\n intconst(1)=cation\n valency(1)=splista(isp)%charge\n cationval=valency(1)\n do i2=1,splista(isp)%noofel\n! this is a loop for the components of the endmember constituents\n i3=ellista(splista(isp)%ellinks(i2))%alphaindex\n if(i3.eq.0) then\n! skip vacancies\n continue\n else\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)\n endif\n enddo\n call lower_case_species_name(constext,ip,isp)\n constext(ip:ip+1)=':'\n ip=ip+1\n else\n valency(1)=one\n endif\n! what about neutrals?\n anion=endmember%fraclinks(2,1)\n intconst(2)=anion\n isp=phlista(lokph)%constitlist(anion)\n missend2: if(.not.excessparam) then\n if(cation.ne.missend(1) .or. anion.ne.missend(2)) then\n write(*,47)'3E **** liquid missing endmember: ',&\n missend(1),missend(2)\n47 format(a,2i5,5x,2i5)\n stop 'Missing endmember in ionic liquid'\n warnings=warnings+1\n! avoid having several errors due to a missing cation:anion pair\n missend(1)=cation\n endif\n! Hm, cation should not be incremented here ...\n! missend(1)=cation+1\n missend(2)=anion+1\n if(anion.eq.phlista(lokph)%tnooffr) then\n missend(1)=missend(1)+1\n missend(2)=phlista(lokph)%nooffr(1)+1\n endif\n endif missend2\n if(btest(splista(isp)%status,SPVA)) then\n! according to the example I have the stoichiometry should be 1 for (cation:VA)\n valency(2)=-one\n else\n valency(2)=splista(isp)%charge\n if(abs(valency(2)).lt.1.0D-6) valency(2)=zero\n endif\n! This is values in the stoichiometry line ....\n do i3=1,noofel\n constcomp(i3)=-constcomp(i3)*valency(2)\n enddo\n call lower_case_species_name(constext,ip,isp)\n constext(ip:ip+1)=':'\n ip=ip+1\n do i2=1,splista(isp)%noofel\n! this is a loop for the components of the endmember constituents\n i3=ellista(splista(isp)%ellinks(i2))%alphaindex\n if(i3.eq.0) then\n! skip vacancies\n continue\n elseif(ionliq .and. iliqwild) then\n! For neutrals in ionic liquid we must multiply with ccc (the cation valency)\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)*valency(1)*ccc\n else\n constcomp(i3)=constcomp(i3)+&\n splista(isp)%stoichiometry(i2)*valency(1)\n endif\n enddo\n! write(*,917)'3E Ionliq endmember: ',constext(1:ip-2),iliqwild,ccc,&\n! valency(2),(constcomp(i3),i3=1,noofel)\n917 format(a,a,L3,2F10.2/10F7.3)\n!------------------ end special ionic liquid\n endif\n! write(*,*)'3E we are here 2 '\n endorexcess: if(excessparam) then\n! we can have several excess parameters for each endmember\n intparam=>endmember%intpointer\n ilevel=0\n! write(*,*)'3E we are here 3 '\n intree: do while(associated(intparam))\n! we must save intparam%nextlink to be able to follow the parameter tree\n ilevel=ilevel+1\n saveint(ilevel)%intlink=>intparam%nextlink\n isp=intparam%fraclink(1)\n intconst(nsubl+ilevel)=isp\n isp=phlista(lokph)%constitlist(isp)\n property=>intparam%propointer\n! Check if endmember contains wildcard\n if(wildcard .and. associated(property)) then\n write(*,903)'3E Expanding wildcard interaction: ',&\n trim(phlista(lokph)%name),trim(constext),&\n (intconst(k1),k1=1,nsubl+ilevel)\n903 format(a,a,',',a,2x,6i4)\n! we should make a loop fof all constituents in sublattice with wildcard\n! and write the same parameter for all. There can be several wildcards!!\n! like G(C1_MO2,Zr+2:*:*), where *=(O-2,Va) in both cases\n! wildloop expanded constituent sets returned in iset, allocated inside\n call expand_wildcards(intconst,nsubl+ilevel,&\n wildloop,iset,lokph)\n! wildloop=1\n! replace current intconst with values in iset and loop below back to 310\n do k1=1,nsubl+ilevel\n intconsty(k1)=intconst(k1)\n intconst(k1)=iset(k1,wildloop)\n enddo\n! write(*,324)'3E wildloop1: ',wildloop,&\n! (intconst(k1),k1=1,nsubl+ilevel)\n savedproperty=>property\n else\n wildloop=0\n endif\n! return here with new set of constituents in intconst if wildloop not zero\n310 continue\n maxideg=-1\n extcpar=zero; exbmpar=zero\n intproploop: do while(associated(property))\n! Check type of excess parameter and what kind to be listed ....\n if(magloop) then\n if(property%proptype.eq.2) then\n! this is Curie/Neel temperature\n do ideg=0,property%degree\n f1=property%degreelink(ideg)\n if(f1.gt.0) then\n extcpar(ideg)=tpfc(f1)%cfun%coefs(1,1)\n else\n write(*,315)' 3E zero excess TC parameter: ',&\n trim(tpfuns(property%degreelink(property%degree))%symbol)\n! trim(phlista(lokph)%name),ideg,ilevel\n315 format(a,a,5i5)\n extcpar(ideg)=zero\n endif\n enddo\n! write(*,*)'3E excess TC: ',f1,partc\n paratyp=17\n if(ideg.gt.maxideg) maxideg=ideg\n elseif(property%proptype.eq.3) then\n! This is BMAGN\n do ideg=0,property%degree\n f1=property%degreelink(ideg)\n if(f1.gt.0) then\n exbmpar(ideg)=tpfc(f1)%cfun%coefs(1,1)\n else\n write(*,315)' 3E zero excess BM parameter: ',&\n trim(tpfuns(property%degreelink(property%degree))%symbol)\n exbmpar(ideg)=zero\n endif\n enddo\n paratyp=17\n if(ideg.gt.maxideg) maxideg=ideg\n endif\n property=>property%nextpr\n cycle intproploop\n elseif(property%proptype.ne.1) then\n! we should have a loop here also as G not always first parameter\n continue\n endif\n! write the identification of the excess parameter ....\n! The list of constituents (in intconst) arranged in ascending order\n call intsort(intconst,nsubl+ilevel,intconstx)\n! write interaction level (2=binary, 3=ternary ...)\n! Then constituent indices in acending order (maybe rearrange intconst)\n! finally the degree (number of Redlich-Kister parameters)\n! write(*,907)'3E solgasorder: ',nsubl+ilevel,&\n! (intconstx(k1),k1=1,nsubl+ilevel),property%degree+1\n! write an excess parameter\n write(lut,208)nsubl+ilevel,&\n (intconstx(k1),k1=1,nsubl+ilevel),property%degree+1\n907 format(a,10i5)\n208 format(i5/10i5)\n! write the expression of the excess parameter .... (Redlich-Kister ??)\n alldegs: do ideg=0,property%degree\n f1=property%degreelink(ideg)\n! excess parameters has just the coefficients\n! call list_tpascoef(lut,text,f1,npows,tpfc)\n if(f1.lt.1) then\n! This means one RK parameter is zero!! L(FCC,NB:C,Va,1) is zero !!1\n! write(*,*)'3E No function?: ',f1,ideg,property%degree\n write(*,*)'3E zero RK paramameter: ',&\n tpfuns(property%degreelink(property%degree))%symbol\n write(lut,307)0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0\n307 format(6(1x,G15.8))\n cycle alldegs\n endif\n if(tpfc(f1)%nranges.gt.1) then\n write(*,*)'3E excess parameter with T-ranges!'\n stop\n endif\n! This gave compiler error on MacOS 10.13 ??? GNU Fortran 5.2 ...\n! write(lut,311)(tpfc(f1)%cfun%coefs(jj,1),jj=1,6)\n! write another excess parameter. What about magnetism and paratype???\n write(lut,311)tpfc(f1)%cfun%coefs(1,1),&\n tpfc(f1)%cfun%coefs(2,1),tpfc(f1)%cfun%coefs(3,1),&\n tpfc(f1)%cfun%coefs(4,1),tpfc(f1)%cfun%coefs(5,1),&\n tpfc(f1)%cfun%coefs(6,1)\n311 format(6(1x,G15.8))\n enddo alldegs\n property=>property%nextpr\n enddo intproploop\n! if(wildloop.gt.0) write(*,*)'3E wildloop2: ',wildloop\n! magnetic excess parameter not written above but here\n! write(*,*)'3E exit intproploop',magloop,paratyp,&\n! associated(property)\n if(magloop .and. paratyp.eq.17) then\n paratyp=4\n call intsort(intconst,nsubl+ilevel,intconstx)\n! write(*,907)'3E solgasorder: ',nsubl+ilevel,&\n! (intconstx(k1),k1=1,nsubl+ilevel),1\n write(lut,208)nsubl+ilevel,&\n (intconstx(k1),k1=1,nsubl+ilevel),maxideg\n write(lut,323)(extcpar(ideg),exbmpar(ideg),ideg=0,maxideg-1)\n323 format(2F12.3)\n! end of output of magnetic excess parameter\n endif\n! If this is a wildcard parameter maybe it should be written several times\n if(wildcard) then\n if(wildloop.gt.1) then\n wildloop=wildloop-1\n do k1=1,nsubl+ilevel\n intconst(k1)=iset(k1,wildloop)\n enddo\n! write(*,324)'3E next expanded: ',wildloop,&\n! (intconst(k1),k1=1,nsubl+ilevel)\n324 format(a,i3,2x,10i4)\n property=>savedproperty\n goto 310\n else\n! deallocate iset and restore intconst as we may have higher interactions ...\n deallocate(iset)\n do k1=1,nsubl+ilevel\n intconst(k1)=intconsty(k1)\n enddo\n endif\n endif\n! Take link to higher\n intparam=>intparam%highlink\n do while(ilevel.gt.0 .and. .not.associated(intparam))\n! go down the saved links\n intparam=>saveint(ilevel)%intlink\n ilevel=ilevel-1\n enddo\n enddo intree\n else\n! here we are writing endmembers, we have generated the endmember symbol,\n! for the parameters follow the property link\n! write(*,*)'3E We are here 4'\n property=>endmember%propointer\n if(wildcard .and. associated(property)) then\n write(*,*)'3E ERROR! Endmember parameter with wildcard: ',&\n trim(phlista(lokph)%name),',',trim(constext)\n endif\n paratyp=4\n partc=zero; parbm=zero\n! return here if we find a magnetic property first\n333 continue\n propem: if(associated(property)) then\n! some endmembers may not have a property record!!\n if(property%proptype.ne.1) then\n! for magnetism we can have proptype 1 and 2 (TC and BMAGN)\n! They can be before the G parameter in the TDB file.\n! write(*,*)'3E magnetic 1: ',trim(phlista(lokph)%name),&\n! havemag,property%proptype,paratyp\n if(havemag.ne.0) then\n if(property%proptype.eq.2) then\n! this is Curie/Neel temperature\n f1=property%degreelink(0)\n partc=tpfc(f1)%cfun%coefs(1,1)\n! write(*,*)'3E endmember TC: ',f1,partc\n paratyp=16\n elseif(property%proptype.eq.3) then\n! This is BMAGN\n f1=property%degreelink(0)\n parbm=tpfc(f1)%cfun%coefs(1,1)\n! write(*,*)'3E endmember BMAGN: ',f1,parbm\n paratyp=16\n else\n write(*,*)'3E skipping magnetic endmember property: ',&\n property%proptype\n exit propem\n endif\n else\n write(*,*)'3E unknown endmember property: ',&\n property%proptype\n exit propem\n endif\n if(associated(property%nextpr)) then\n property=>property%nextpr\n goto 333\n endif\n! else\n! paratyp=4\n endif\n! this line with the stoichiometry of the endmember should be written\n! together with the type of coefficients and number of ranges\n! it may require several lines\n write(text,210)constcomp\n! THIS IS THE STOICHIMETRY OF THE ENDMEMBER, with 6 decimal digits\n! If this format is changed the output routine list_tpascoef must be changed!\n!210 format(60(1x,F11.6))\n! ERNESTO GEIGER complained it did not work ... this is stoichiometry format\n210 format(60(1x,F7.2))\n! Check if any value in contcomp is greated than 1000, could give overflow\n! Check also if two decimals not enough\n do i3=1,noofel\n if(constcomp(i3).gt.maxcc) then\n warnings=warnings+1\n write(*,206)trim(phlista(lokph)%name),i3,constcomp(i3)\n206 format('3E *** Warning stoichiometry factor >100: ',&\n a,i4,F10.2)\n endif\n decimals=int(1.0D5*constcomp(i3))\n xxx=1.0D-5*dble(decimals)\n if(abs(xxx-constcomp(i3)).gt.1.0D-6) then\n warnings=warnings+1\n write(*,203)trim(constext),i3,constcomp(i3)\n203 format('3E *** Warning stoichiometry with >5 decimals: ',&\n a,i4,2F10.6)\n endif\n enddo\n! property record has property=1 it is G; take care of magnetic properties\n! write(*,*)'3E havemag: ',trim(phlista(lokph)%name),havemag\n magprop: if(havemag.gt.0) then\n nextprop=>property%nextpr\n334 continue\n! write(*,*)'3E magnetic 2: ',trim(phlista(lokph)%name),&\n! property%proptype,associated(nextprop)\n if(associated(nextprop)) then\n if(nextprop%proptype.eq.2) then\n! this is Curie/Neel temperature\n f1=nextprop%degreelink(0)\n partc=tpfc(f1)%cfun%coefs(1,1)\n! write(*,*)'3E endmember TC2: ',f1,partc\n paratyp=16\n elseif(nextprop%proptype.eq.3) then\n! This is BMAGN\n f1=nextprop%degreelink(0)\n parbm=tpfc(f1)%cfun%coefs(1,1)\n! write(*,*)'3E endmember BMAGN2: ',f1,parbm\n paratyp=16\n else\n write(*,*)'3E ignoring endmember property: ',&\n nextprop%proptype\n endif\n else\n exit magprop\n endif\n nextprop=>nextprop%nextpr\n goto 334\n endif magprop\n! property record has still property=1 it is G\n f1=property%degreelink(0)\n if(f1.gt.0) then\n factor=one\n if(ionliq .and. iliqwild) then\n write(lut,211)constext(1:ip-2),ccc\n! According to Ted\n211 format(a,40x,' * ',F12.2)\n! We must multiply tpfc(f1) with ccc, store in tpfc(jp) coefficient function!\n jp=ntpf+1\n call tpmult(f1,jp,ccc,tpfc)\n call list_tpascoef(lut,text,paratyp,jp,npows,factor,tpfc)\n if(paratyp.eq.16) write(lut,222)partc,parbm\n222 format(2G15.8)\n else\n! according to Ted: endmember symbol \n! write(*,99)constext(1:ip-2)\n write(lut,99)constext(1:ip-2)\n call list_tpascoef(lut,text,paratyp,f1,npows,factor,tpfc)\n if(paratyp.eq.16) write(lut,222)partc,parbm\n endif\n else\n write(*,*)'3 C missing function for endmember property',&\n constext(3:ip-2)\n endif\n endy(i1)=endy(i1)+1\n endif propem\n endif endorexcess\n! take next endmember\n! write(*,*)'3E We are here 5'\n if(.not.ionliq) then\n endmember=>endmember%nextem\n else\n! find next endmember with the same cation, liquids without cations? !!\n! if none set endmember=>nextcation\n! if nextcation has same cation as firstcation we have finished!\n240 continue\n iliqwild=.false.\n! write(*,241)'ionliq done: ',firstcation,cation,&\n! endmember%fraclinks(1,1),endmember%fraclinks(2,1)\n endmember=>endmember%nextem\n if(associated(endmember)) then\n! write(*,241)'ionliq ass: ',firstcation,cation,&\n! endmember%fraclinks(1,1),endmember%fraclinks(2,1)\n241 format(a,2i3,2x,2i3)\n if(endmember%fraclinks(1,1).eq.-99) then\n iliqwild=.true.\n! ccc is the valency of the cation used to multiply the neutral parameter\n ccc=cationval\n elseif(endmember%fraclinks(1,1).ne.cation) then\n goto 240\n endif\n else\n! write(*,*)'3E we are here 6: ',associated(nextcation)\n endmember=>nextcation\n if(associated(endmember)) then\n nextcation=>nextcation%nextem\n cation=endmember%fraclinks(1,1)\n! write(*,241)'ionliq notaass: ',firstcation,cation,&\n! endmember%fraclinks(1,1),endmember%fraclinks(2,1)\n! we have looped through all cations\n if(cation.eq.firstcation) exit allend\n! there were just one cation but some neutrals (already listed)\n if(endmember%fraclinks(1,1).eq.-99) exit allend\n! else\n! no more cations, finished!\n! write(*,*)'3E no nextcation!'\n endif\n endif\n endif\n enddo allend\n! ------------------- end of endmembers, constituents and excess parameters ??\n if(model(1:4).eq.'IDMX') cycle phases1\n if(excessparam) goto 297\n! After endmembers for sublattice phases write number of sublattices and sites\n if(model(1:4).eq.'SUBL') then\n write(lut,250)nsubl\n if(skipfc) then\n write(lut,260)(varres%disfra%dsites(isubl),isubl=1,nsubl)\n else\n write(lut,260)(ceq%phase_varres(lokcs)%sites(isubl),isubl=1,nsubl)\n250 format(1x,i4)\n260 format(1x,8F9.5)\n endif\n endif\n! write(*,*)'3E here 8: ',phlista(lokph)%name,model\n if(model(1:4).eq.'SUBL' .or. model(1:4).eq.'SUBI') then\n! number of constituents in each sublattice\n if(skipfc) then\n write(lut,270)(varres%disfra%nooffr(isubl),isubl=1,nsubl)\n else\n write(lut,270)(phlista(lokph)%nooffr(isubl),isubl=1,nsubl)\n270 format(9i5)\n endif\n endif\n! For all phases with sublattices we should write the constituents of each\n! problem here for UC2_C11A, constituent in first sublattice ignored\n if(nsubl.eq.1) goto 280\n i3=0\n! do isubl=1,phlista(lokph)%noofsubl\n do isubl=1,nsubl\n constext=' '\n ip=1\n if(skipfc) then\n nn=varres%disfra%nooffr(isubl)\n else\n nn=phlista(lokph)%nooffr(isubl)\n endif\n do i2=1,nn\n i3=i3+1\n if(skipfc) then\n isp=firsteq%phase_varres(lokcs)%disfra%splink(i3)\n else\n isp=phlista(lokph)%constitlist(i3)\n endif\n jp=ip\n call lower_case_species_name(constext,ip,isp)\n ip=jp+25\n if(ip.ge.75) then\n write(lut,100)trim(constext)\n constext=' '\n ip=1\n endif\n enddo\n! write(*,271)'3E constext: ',trim(constext),isubl,i2,i3,ip\n!271 format(a,a,4i4)\n ip=len_trim(constext)\n! for a single component names ip=1 here ...\n if(ip.gt.1 .or. constext(1:1).ne.' ') then\n write(lut,100)trim(constext)\n endif\n enddo\n280 continue\n if(model(1:4).eq.'SUBI') then\n! There should be a line with just a \"2\" ???\n write(lut,272)\n272 format(' 2')\n! for ionic liquid list abs(valencies) of constituents, one line per sublattice\n ip=1\n isp=1\n constext=' '\n do i2=1,phlista(lokph)%nooffr(1)\n ccc=splista(phlista(lokph)%constitlist(isp))%charge\n write(constext(ip:),274)ccc\n274 format(F10.5)\n ip=len_trim(constext)\n if(ip.gt.69) then\n write(lut,99)trim(constext)\n ip=1\n constext=' '\n endif\n isp=isp+1\n enddo\n if(ip.gt.1) then\n write(lut,99)trim(constext)\n endif\n ip=1\n constext=' '\n do i2=1,phlista(lokph)%nooffr(2)\n! Benjamin problem 1, he wants negative anion change ....\n! For anions the charge as a positive value, for Va unity, for neutrals zero\n if(btest(splista(phlista(lokph)%constitlist(isp))%status,SPVA)) then\n ccc=-one\n else\n! Benjamin correction: changed sign of ccc \n! ccc=abs(splista(phlista(lokph)%constitlist(isp))%charge)\n ccc=splista(phlista(lokph)%constitlist(isp))%charge\n endif\n write(constext(ip:),274)ccc\n ip=len_trim(constext)\n if(ip.gt.69) then\n write(lut,99)trim(constext)\n ip=1\n constext=' '\n endif\n isp=isp+1\n enddo\n if(ip.gt.1) then\n write(lut,99)trim(constext)\n endif\n endif\n! if(phlista(lokph)%noofsubl.gt.1) then\n! lastix=0\n if(nsubl.gt.1) then\n! A very strange output of integers representing endmembers\n jp=1\n mult=1\n! do isubl=phlista(lokph)%noofsubl,1,-1\n do isubl=nsubl,1,-1\n mult(isubl)=jp\n if(skipfc) then\n jp=jp*varres%disfra%nooffr(isubl)\n else\n jp=jp*phlista(lokph)%nooffr(isubl)\n endif\n enddo\n! write(*,278)'3E mult2: ',jp,(mult(ip),ip=1,phlista(lokph)%noofsubl)\n278 format(a,10i4)\n do isubl=1,nsubl\n lastix=0\n text=' '\n ip=3\n k1=0\n i2=0\n290 continue\n k1=k1+1\n i3=0\n292 continue\n lastix=lastix+1\n exix(lastix)=k1\n! the use of text here will be made redundant\n call wriint(text,ip,k1)\n ip=ip+3\n i2=i2+1\n i3=i3+1\n if(i3.lt.mult(isubl)) goto 292\n if(skipfc) then\n if(k1.gt.varres%disfra%nooffr(isubl)) k1=0\n if(k1.eq.varres%disfra%nooffr(isubl) .and. isubl.gt.1) k1=0\n else\n if(k1.gt.phlista(lokph)%nooffr(isubl)) k1=0\n if(k1.eq.phlista(lokph)%nooffr(isubl) .and. isubl.gt.1) k1=0\n endif\n if(i2.lt.jp) goto 290\n! According to Markus Piro one should have 19 values per line, 18*4+3=75\n! New code using i4 format\n lineb=1\n firstix=1\n do while(lastix.gt.lineb)\n lineb=min(firstix+18,lastix)\n! write(*,*)'3E firstix: ',firstix,lineb\n write(lut,'(19i4)')(exix(isp),isp=firstix,lineb)\n firstix=lineb+1\n enddo\n! output below is wrong and removed redunant\n! isp=1\n! do while(len_trim(text(isp:))-76.gt.0)\n! Corrected 2020-11-12 with the help from Max Poschmann and Markus Piro\n! do while(len_trim(text(isp:))-76.gt.0)\n! write(lut,99)trim(text(isp:isp+74))\n! isp=isp+75\n! lineb=75\n! do while(text(isp+lineb:isp+lineb).ne.' ')\n! increment lineb until we find a space\n! lineb=lineb+1\n! enddo\n! write(*,*)'3E linebreak: \"',text(isp+lineb-1:isp+lineb-1),&\n! '\" and \"',text(isp+lineb:isp+lineb),'\"',lineb\n! write(lut,99)trim(text(isp:isp+lineb-1))\n! isp=isp+lineb\n! enddo\n! if(len_trim(text(isp:)).gt.0) write(lut,99)trim(text(isp:))\n enddo\n endif\n!...................... repeat loop for excess parameters\n297 continue\n if(.not.excessparam) then\n! repeat the endmember loop again for interaction parameters (and magnetism??)\n! write(*,*)'3E Now the excess parameters',nsubl\n excessparam=.true.\n! if magnetic we have FIRST loop all excess parameters for magnetic parameters\n if(havemag.ne.0) magloop=.TRUE.\n! and then again for the G parameters .... SUCK\n endmember=>phlista(lokph)%ordered\n if(associated(phlista(lokph)%disordered)) then\n endmember=>phlista(lokph)%disordered\n endif\n! if(magloop) write(*,*)'3E First magnetic excess parameters'\n goto 207\n elseif(magloop) then\n! First finish the magetic excess parameter parameters with a zero\n write(lut,555)\n555 format(' 0',30x,' = end of magnetic excess parameters')\n! here we write the Gibbs energy excess parameters\n magloop=.FALSE.\n endmember=>phlista(lokph)%ordered\n if(associated(phlista(lokph)%disordered)) then\n endmember=>phlista(lokph)%disordered\n endif\n! write(*,*)'3E Gibbs energy excess parameters after magnetic'\n goto 207\n endif\n! terminate the excess parameters for this phase with a line starting with 0\n write(lut,300)\n300 format(' 0')\n enddo phases1\n!-------------------------------------------------------\n! now data for stoichiometric phases\n mphstoi=1\n! write(*,*)\n! write(*,*)'3E loop for compounds ',nphstoi\n!\n phases2: do i1=1,noofph\n lokph=phasetuple(i1)%lokph\n if(ceq%phase_varres(phlista(lokph)%linktocs(1))%phstate.eq.PHSUS) then\n! skip phases with suspended default composition set\n! write(*,*)'3E skipping phase loop 4: ',phlista(lokph)%name\n cycle phases2\n endif\n if(i1.ne.phstoi(mphstoi)) then\n! write(*,*)'3E skipping mixture ',trim(phlista(lokph)%name),&\n! i1,mphstoi,phstoi(mphstoi)\n cycle phases2\n endif\n mphstoi=mphstoi+1\n skipfc=.FALSE.\n factor=one\n if(phlista(lokph)%nooffs.gt.1) then\n! skip first composition set\n skipfc=.true.\n endif\n! magnetism?\n havemag=0\n addrec=>phlista(lokph)%additions\n lastadd2: do while(associated(addrec))\n! no need to increment CHTD except for magnetism\n! write(*,*)'3E additions?: ',phlista(lokph)%name,addrec%type\n if(addrec%type.eq.1) then\n havemag=3\n write(*,*)'3E magnetic phase 1: ',phlista(lokph)%name\n aff=addrec%aff\n elseif(addrec%type.ne.7) then\n! type 7 is volume\n write(*,*)'3E WARNING addition type: ',addrec%type,' ignored'\n endif\n addrec=>addrec%nextadd\n enddo lastadd2\n lokcs=phlista(lokph)%linktocs(1)\n varres=>ceq%phase_varres(lokcs)\n nsubl=1\n ionliq=.false.\n nsubl=phlista(lokph)%noofsubl\n if(skipfc) then\n factor=varres%disfra%fsites\n varres=>ceq%phase_varres(varres%disfra%varreslink)\n if(btest(phlista(lokph)%status1,PHMFS)) then\n nsubl=size(varres%sites)\n endif\n endmember=>phlista(lokph)%disordered\n else\n! there is just one endmember!!\n endmember=>phlista(lokph)%ordered\n endif\n! prepare a dummy prefix for compounds ... NOT NECESSARY\n! phdummy=phlista(lokph)%name(1:4)\n! jp=0\n! do i3=1,noofph\n! if(i3.ne.lokph .and. phdummy.eq.phlista(i3)%name(1:4)) jp=1\n! enddo\n! if(jp.gt.0) then\n! warnings=warnings+1\n! call incunique(phunique)\n! phdummy=phunique\n! write(*,*)'3E prefixing TDB phase name ',&\n! phdummy//'_'//trim(phlista(lokph)%name),i1\n! else\n! phdummy=' '\n! endif\n phdummy=' '\n if(phdummy(1:1).eq.' ') then\n write(*,477)trim(phlista(lokph)%name),nsubl,factor\n477 format('3E Compound: ',a,i3,F12.3,a)\n! write on file\n write(lut,500)phlista(lokph)%name,factor\n500 format(1x,a,5x,'= COMPOUND PHASE = ',F12.4)\n else\n write(*,477)phdummy//'_'//trim(phlista(lokph)%name),nsubl,factor,&\n ' with name change'\n write(lut,500)phdummy//'_'//phlista(lokph)%name,factor\n endif\n if(havemag.ne.0) then\n if(aff.eq.one) then\n write(lut,202)-aff,0.4\n else\n write(lut,202)-one/aff,0.28\n endif\n endif\n constext=' '\n ip=1\n constcomp=zero\n sloop2: do isubl=1,nsubl\n! this is the loop for the constituents in sublattices\n if(.not.associated(endmember)) then\n write(*,*)'3E no parameter!! ',phlista(lokph)%name\n cycle sloop2\n endif\n isp=endmember%fraclinks(isubl,1)\n if(isp.eq.-99) then\n! this means wildcard in this sublattice\n write(*,*)'3E *** ERROR! Wildcard in a stoichiometric compound!!!'\n constext(ip:)='*:'\n ip=ip+2\n cycle sloop2\n endif\n! Hm we should add stoichiometric factors for all constituents in this subl\n isp=phlista(lokph)%constitlist(isp)\n if(btest(splista(isp)%status,SPVA)) then\n write(*,*)'3E Warning: vacancy in stoichiometric compound!!'\n endif\n write(constext(ip:),99)trim(splista(isp)%symbol)//':'\n ip=len_trim(constext)+1\n do i2=1,splista(isp)%noofel\n! this is a loop for the components of the endmember constituents\n i3=ellista(splista(isp)%ellinks(i2))%alphaindex\n if(i3.eq.0) then\n! skip vacancies\n continue\n else\n constcomp(i3)=constcomp(i3)+splista(isp)%stoichiometry(i2)*&\n varres%sites(isubl)\n endif\n enddo\n enddo sloop2\n! we may come here if there are no endmembers!\n if(.not.associated(endmember)) then\n write(*,*)'3E skipping this phase'\n cycle phases2\n endif\n! for the parameters follow the property link\n property=>endmember%propointer\n if(associated(property)) then\n! For a compound do not write any constituent array\n! write(lut,100)constext(1:ip-2)\n! this line should be written together with the type of coefficients and ranges\n! it may require several lines\n write(text,210)constcomp\n! Check if any value in contcomp is greated than 1000, could give overflow\n do i3=1,noofel\n if(constcomp(i3).gt.maxcc) then\n warnings=warnings+1\n write(*,206)trim(phlista(lokph)%name)\n endif\n enddo\n paratyp=4\n partc=zero; parbm=zero\n if(havemag.ne.0) paratyp=16\n! what about several properties?? YES\n575 continue\n if(property%proptype.eq.1) then\n f1=property%degreelink(0)\n if(f1.gt.0) then\n call list_tpascoef(lut,text,paratyp,f1,npows,factor,tpfc)\n else\n write(*,*)'missing endmember parameter'\n endif\n elseif(property%proptype.eq.2) then\n f1=property%degreelink(0)\n partc=tpfc(f1)%cfun%coefs(1,1)\n elseif(property%proptype.eq.3) then\n f1=property%degreelink(0)\n parbm=tpfc(f1)%cfun%coefs(1,1)\n else\n write(*,*)'3E ignoring compound property ',property%proptype\n endif\n property=>property%nextpr\n if(associated(property)) goto 575\n endif\n if(paratyp.eq.16) write(lut,222)partc,parbm\n enddo phases2\n! At the end some dummy line for the pure elements??\n write(lut,602)\n602 format('###################################################')\n goto 900\n!----------------------- ???\n! At the end some dummy line for the pure elements??\n do i1=1,noofel\n write(lut,605)ellista(elements(i1))%symbol\n605 format(1x,a2,22x,'#')\n constcomp=zero\n constcomp(i1)=one\n write(lut,610)constcomp\n610 format(' 4 1',12F7.1)\n write(lut,620)\n620 format(' 6001.0000 0.00000000 0.00000000 0.00000000',&\n ' 0.00000000 '/' 0.00000000 0.00000000 '/&\n ' 1 0.00000000 0.00')\n enddo\n!\n900 continue\n do i1=1,noofph\n if(endx(i1).ne.endy(i1)) then\n lokph=phases(i1)\n write(*,911)trim(phlista(lokph)%name),endx(i1),endy(i1)\n911 format('3E Endmembers missing for ',a,&\n ', should have ',i3,' endmembers, has ',i3)\n endif\n enddo\n write(*,700)noofph,nphmix,nphstoi\n700 format('3E written data for ',i4,' phases: ',i3,' mixtures and ',&\n i4,' compounds')\n if(warnings.gt.0) write(*,701)warnings\n701 format(' *** Attention: there were ',i3,' warnings!')\n! \n1000 continue\n! Finished SOLGASMIX outpur\n if(allocated(tpfc)) deallocate(tpfc)\n if(gx%bmperr.ne.0) then\n write(*,1009)trim(filename),gx%bmperr\n1009 format(/' *** Output terminated on ',a,' due to error ',i5/)\n elseif(date(1:4).ne.' ') then\n write(*,1010)trim(filename)\n1010 format('3E Output finished on ',a/)\n else\n write(*,1020)trim(filename)\n1020 format('3E no output on ',a/)\n endif\n close(lut)\n return\n end subroutine save_datformat\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine incunique\n!\\begin{verbatim}\n subroutine incunique(text)\n character text*(*)\n!\\end{verbatim} %+\n integer j1,j2,j3\n j1=len(text)\n! write(*,*)'3E phunique 1: ',text\n loop: do while(j1.ge.1)\n j2=ichar(text(j1:j1))-ichar('0')\n! this position is not a number, exit\n if(j2.lt.0) exit loop\n if(j2.lt.9) then\n! increment the number and exit\n text(j1:j1)=char(j2+1+ichar('0'))\n exit loop\n elseif(j2.eq.9) then\n text(j1:j1)='0'\n j1=j1-1\n else\n! this position is not a number, exit\n exit loop\n endif\n enddo loop\n! write(*,*)'3E phunique 2: ',text\n return\n end subroutine incunique\n\n !/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine expand_wildcards\n!\\begin{verbatim}\n subroutine expand_wildcards(intconst,nconst,wildloop,iset,lokph)\n! Expand a wildcard constituent with all constituents it replaces\n! There can be several wildcards\n! intconst is the original set of constuents including the wildcards (-99)\n! nconst is the number of constituents\n! wildloop is set to the number of times the interaction is repeated\n! iset is a matrix with the expanded constituents\n! phrecord is the phase record where one can find the phase structure\n implicit none\n integer intconst(*)\n integer, allocatable, dimension(:,:) :: iset\n integer nconst,wildloop,lokph\n!\\end{verbatim} %+\n integer la,lb,lc,lz,ja,jb,jc,jz,ka,kb,nexp\n integer, allocatable, dimension(:) :: multi\n! write(*,10)'3E in expand_wildcard: ',nconst,(intconst(la),la=1,nconst)\n10 format(a,i3,2x,10i4)\n nexp=1\n allocate(multi(phlista(lokph)%noofsubl))\n multi=1\n do la=1,phlista(lokph)%noofsubl\n if(intconst(la).eq.-99) then\n multi(la)=nexp\n nexp=nexp*phlista(lokph)%nooffr(la)\n endif\n enddo\n! write(*,*)'3E expand: ',nconst,nexp\n allocate(iset(nconst,nexp))\n! initiate iset to original constituents (with wildcards)\n do la=1,nexp\n do ja=1,nconst\n iset(ja,la)=intconst(ja)\n enddo\n enddo\n! do ja=1,nexp\n! write(*,10)'3E before expanded: ',ja,(iset(la,ja),la=1,nconst)\n! enddo\n! loop several times expanding one sublattice with wildcard each time\n ja=1\n lat1: do la=1,phlista(lokph)%noofsubl\n if(iset(la,1).eq.-99) then\n ka=1\n do while(ka.lt.nexp)\n jc=ja\n do jb=1,phlista(lokph)%nooffr(la)\n do jz=1,multi(la)\n iset(la,ka)=jc\n ka=ka+1\n enddo\n jc=jc+1\n enddo\n enddo\n endif\n ja=ja+phlista(lokph)%nooffr(la)\n enddo lat1\n wildloop=nexp\n! do ja=1,wildloop\n! write(*,10)'3E after expanded: ',ja,(iset(la,ja),la=1,nconst)\n! enddo\n1000 continue\n return\n end subroutine expand_wildcards\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine intsort\n!\\begin{verbatim}\n subroutine intsort(intc,nint,intx)\n! This is just another stupid sorting subroutine \n! intc is not changed\n implicit none\n integer intc(*),intx(*),nint\n!\\end{verbatim} %+\n integer byte,jj\n if(nint.lt.2) then\n write(*,*)'*** ERROR: intsort called with too few constituents',nint\n stop\n endif\n do byte=1,nint\n intx(byte)=intc(byte)\n enddo\n do while(byte.gt.0)\n! values in intx are never zero\n byte=0\n do jj=2,nint\n if(intx(jj-1).gt.intx(jj)) then\n byte=intx(jj)\n intx(jj)=intx(jj-1)\n intx(jj-1)=byte\n endif\n enddo\n enddo\n1000 continue\n return\n end subroutine intsort\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine lower_case_species_name\n!\\begin{verbatim}\n subroutine lower_case_species_name(constext,ip,isp)\n! writes a species name using lower case for second letter of element\n implicit none\n character constext*(*)\n integer ip,isp\n!\\end{verbatim}\n integer iel,jp,lcase,kp\n character elsym*2,name*24\n jp=1\n name=' '\n lcase=ichar('a')-ichar('A')\n do iel=1,splista(isp)%noofel\n elsym=ellista(splista(isp)%ellinks(iel))%symbol\n kp=0\n if(elsym(2:2).ne.' ') then\n elsym(2:2)=char(ichar(elsym(2:2))+lcase)\n name(jp:)=elsym\n jp=jp+2\n else\n name(jp:)=elsym\n jp=jp+1\n kp=1\n endif\n! 3rd argument 0 means no sign\n if(abs(splista(isp)%stoichiometry(iel)-one).gt.1.0D-6 .or. &\n (iel.lt.splista(isp)%noofel .and. kp.eq.1)) then\n call wrinum(name,jp,6,0,splista(isp)%stoichiometry(iel))\n if(buperr.ne.0) then\n write(*,*)'3E buperr 2: ',trim(name),buperr\n buperr=0\n endif\n endif\n enddo\n! species may have a charge\n if(splista(isp)%charge.eq.one) then\n name(jp:jp)='+'\n jp=jp+1\n elseif(splista(isp)%charge.eq.-one) then\n name(jp:jp)='-'\n jp=jp+1\n elseif(abs(splista(isp)%charge).gt.1-0D-6) then\n call wrinum(name,jp,6,1,splista(isp)%charge)\n endif\n! write(*,*)'3E suck: lower case name: ',trim(name)\n constext(ip:)=name\n ip=len_trim(constext)+1\n1000 continue\n return\n end subroutine lower_case_species_name\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function notallowlisting\n!\\begin{verbatim}\n logical function notallowlisting(privil)\n! check if user is allowed to list data\n double precision privil\n!\\end{verbatim}\n logical ok\n! false means listing allowed\n ok=.FALSE.\n notallowlisting=ok\n return\n end function notallowlisting\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine get_parameter_typty\n!\\begin{verbatim}\n! subroutine get_parameter_typty(name1,lokph,typty,fractyp)\n subroutine get_parameter_typty(name1,lokph,typty)\n! interpret parameter identifiers like MQ&C#2 in MQ&C#2(FCC_A1,FE:C) ...\n! find the property associated with this symbol\n implicit none\n integer typty,fractyp,lokph\n character name1*(*)\n!\\end{verbatim}\n integer nr,typty1,iel,isp,kel,loksp,lk3,kq,k4,kk,ll\n character elnam*24\n! It can be a mobility with a & inside\n kel=index(name1,'&')\n if(kel.gt.0) then\n! note that elnam may contain sublattice specification like Fe+2#2\n elnam=name1(kel+1:)\n name1=name1(1:kel-1)\n endif\n kq=len_trim(name1)\n! write(*,*)'3D: fractyp: ',kq,name1(1:kq)\n! if(name1(kq:kq).eq.'D') then\n! No longer user suffix D for fractyp 2\n! A final \"D\" on the paramer symbol indicates fractyp=2\n! name1(kq:kq)=' '\n! fractyp=2\n! else\n! fractyp=1\n! endif\n!----------------------\n! write(*,*)'Property symbol: \"',propid(nr)%symbol,'\" >',name1(1:4),'<'\n do nr=1,ndefprop\n if(name1(1:4).eq.propid(nr)%symbol) then\n goto 70\n endif\n enddo\n! no matching property identifier\n gx%bmperr=4292; goto 1000\n!\n70 continue\n typty=nr\n typty1=nr\n iel=0; isp=0\n if(kel.gt.0) then\n! there is a specifier, check if correct element or species\n kel=index(elnam,'#')\n if(kel.gt.0) then\n! extract sublattice number 1-9 specification\n lk3=ichar(elnam(kel+1:kel+1))-ichar('0')\n! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3\n!73 format('3D sublattice: \"',a,'\" position: ',i3,' in ',a,' : ',i3)\n elnam(kel:)=' '\n else\n lk3=0\n endif\n if(btest(propid(typty)%status,IDELSUFFIX)) then\n! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam\n call find_element_by_name(elnam,iel)\n if(gx%bmperr.ne.0) then\n write(kou,*)'3D Unknown element ',elnam,&\n ' in parameter type MQ, please reenter'\n gx%bmperr=0; goto 1000\n endif\n typty=100*typty+iel\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\n! to know the constituents we must know the phase but as we do not know \n! the phase name yet but check the species exists !!!\n call find_species_by_name(elnam,isp)\n if(gx%bmperr.ne.0) then\n! This is not an error, the species may not be selected!!!\n! write(kou,*)'Unknown species ',elnam,&\n! ' in parameter type MQ, please reenter',gx%bmperr\n gx%bmperr=0; goto 1000\n endif\n! convert from index to location, loksp\n loksp=species(isp)\n! write(*,69)'3D: conname: ',kel,lk3,typty,isp,loksp,elnam\n69 format(a,5i4,a)\n! extract sublattice after #\n else\n! write(kou,*)'This property has no specifier'\n gx%bmperr=4168; goto 1000\n endif\n! this is the property type stored in property record\n else\n! check if there should be a specifier !!\n if(btest(propid(typty)%status,IDELSUFFIX) .or. &\n btest(propid(typty)%status,IDCONSUFFIX)) then\n write(*,77)propid(typty)%symbol\n77 format('3D Missing specifier for model parameter idenifier ',a)\n gx%bmperr=4169; goto 1000\n endif\n endif\n! if the parameter symbol has a constituent specification check that now\n if(isp.gt.0) then\n k4=0\n do ll=1,phlista(lokph)%noofsubl\n if(lk3.eq.0 .or. lk3.eq.ll) then\n do kk=1,phlista(lokph)%nooffr(ll)\n k4=k4+1\n if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80\n enddo\n elseif(ll.lt.lk3) then\n k4=k4+phlista(lokph)%nooffr(ll)\n endif\n enddo\n! constituent not found\n write(kou,*)'No such constituent'\n gx%bmperr=4066; goto 1000\n! constituent found in right sublattice\n80 continue\n typty=100*typty+k4\n! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp\n81 format(a,10i4)\n endif\n1000 continue\n return\n end subroutine get_parameter_typty\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine merge_spaces\n!\\begin{verbatim}\n! subroutine merge_spaces(text)\n subroutine merge_spaces(text)\n! merge multiple spaces to a single one in text\n implicit none\n character text(*)\n!\\end{verbatim}\n1000 continue\n return\n end subroutine merge_spaces\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\n" }, { "path": "src/models/gtp3EX.F90", "content": "!\r\n! gtp3EX included in gtp3.F90\r\n!\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n!> 9B. Section: read and save on files using XML bases XTDB\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine read_xtdb_dummy\r\n!\\begin{verbatim}\r\n subroutine read_xtdb_dummy(filename,nel,selel)\r\n! reading data from an XTFB file and list data on screen\r\n! if nel<=0 then only extract elements and retutn in selel (-nel dimension)\r\n! if nel>0 extract data for the the nel elements in selel\r\n!\r\n implicit none\r\n integer nel\r\n character filename*(*),selel(*)*2\r\n!\\end{verbatim}\r\n! for extracting elements, phases and data from database\r\n integer warnings,ip,jp,kp,tagno,lastp,tag,fl,taglevel\r\n! character (len=2) :: present(78)\r\n character line*512,lline*2048\r\n! when reading a tag with nested tag this is the end of the tad\r\n! up to \"nestedtags\" levels of nested tags allowed\r\n integer, parameter :: nestedtags=10\r\n character(len=24), dimension(nestedtags) :: tagend\r\n character tagname*18\r\n type(gtp_xtdbcompatibility) :: pmpid\r\n logical onlyfun,comment\r\n\r\n! write(*,*)'3EX read_xtdb not implemented yet'\r\n! goto 1000\r\n if(len(xtdbtags(1)).gt.18) then\r\n write(*,*)'3EX xtdbtags longer than 18 characters, extend tagend!',&\r\n len(xtdbtags)\r\n endif\r\n! initiating xtdbmpid\r\n call xtdbinitmpid(nxtdbmpids)\r\n!\r\n!\r\n if(index(filename,'.').eq.0) then\r\n! no extention provided\r\n filename(len_trim(filename)+1:)='.XTDB'\r\n endif\r\n!\r\n write(*,*)'Reading XTDB files not implemented'\r\n gx%bmperr=9999; goto 1000\r\n!\r\n open(21,file=filename,access='sequential',form='formatted',&\r\n err=2010,iostat=gx%bmperr,status='old')\r\n onlyfun=.FALSE.\r\n!\r\n warnings=0\r\n! This is the current level of nexted tags \r\n taglevel=0\r\n comment=.FALSE.\r\n! if the tag and its attributes continue on next line lastp end of previous line\r\n lastp=0\r\n! this is current number of lines read from file\r\n fl=1\r\n!-------------------------\r\n! Reading the XTDB file:\r\n! 1. If no elements provided just extract all the elements\r\n! 2. If elements provides read first the Models tag and possibly modify the MPID\r\n! 2.1 if an unknown model give a warning but no error unless used by a phase\r\n! 3. If elements then read all species and phases that can form\r\n! 3.1 There can be phases rejected or selected\r\n! 3.2 If a phase have an unknown model skip it with a warning\r\n! 4. Read the parameters for the phases and species entered\r\n! 5. Maybe perform some conditional action (extra composition sets,\r\n! default constituents)\r\n!-------------------------\r\n readfile: do while(.true.)\r\n! return here to read next line from file\r\n read(21,110,end=900,err=2010)line\r\n110 format(a)\r\n fl=fl+1\r\n ip=1\r\n if(taglevel.eq.0) then\r\n! No current tag\r\n! or \r\n! (on several lines) with on a later line\r\n! max nestedtags (=10) tags possible\r\n! we expect to read the beginning of a tag or comment\r\n!\r\n! call gettag(line,ip,tagname)\r\n!\r\n! extract tag and all its attributes (can be on several lines)\r\n jp=ip\r\n! call xtdbkey_old(line,jp,tagname)\r\n select case(tag)\r\n! case default means keyw not understood\r\n case default\r\n write(*,*)'3EX no such XTDB tag: ',line(ip:jp)\r\n! handle all tags here\r\n case(1)\r\n\r\n end select\r\n else\r\n! we are reading a continuation line of a tag, can be a new tag\r\n continue\r\n end if\r\n!\r\n!\r\n!\r\n end do readfile\r\n! we have finished reading from the fil, we may need to read it agaon\r\n900 continue\r\n close(21)\r\n!\r\n if(warnings.ne.0) then\r\n write(*,*)'3EX warning ',warnings\r\n endif\r\n!\r\n1000 continue\r\n return\r\n! error opening file\r\n2000 continue\r\n write(*,'(\"3EX error opening file \",i7)')gx%bmperr\r\n goto 1000\r\n2010 continue\r\n write(*,'(\"3EX error reading file \",i7,\", line \",i7)')gx%bmperr,fl\r\n goto 1000\r\n end subroutine read_xtdb_dummy\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine xtdbinitmpid(ns)\r\n integer ns\r\n! initiating xtdbmpid\r\n! use the xtdbmodel records\r\n allocate(xtdbmodel(ns))\r\n!\r\n! maybe one should reconsider the indexing in the result data arrays ...\r\n! In the new models all will have a GEIN model, some a magnetic model\r\n! Note the liquid may be magnetic ...\r\n! these are 9 models allowed in the AmendPhase tag\r\n! for the ocix values: 1=G, 2=LNTH, 3=BMAGN, 4=TC, 5=NT, 6=G2\r\n! Magnetic model 1, previously AFF=-1\r\n! write(*,*)'Initating xtdbmodel'\r\n xtdbmodel(1)%modelid='IHJBCC'\r\n xtdbmodel(1)%nmpid=2\r\n allocate(xtdbmodel(1)%mpid(2))\r\n allocate(xtdbmodel(1)%ocmpid(2))\r\n allocate(xtdbmodel(1)%ocix(2))\r\n xtdbmodel(1)%mpid(1)='TC'\r\n xtdbmodel(1)%mpid(2)='BMAG'\r\n xtdbmodel(1)%ocmpid(1)='TC'\r\n xtdbmodel(1)%ocmpid(2)='BMAG'\r\n! The ocix is the location for the parameter in the result array in GTP ????\r\n xtdbmodel(1)%ocix(1)=4\r\n xtdbmodel(1)%ocix(2)=3\r\n! Magnetic model 2, previously AFF=-3\r\n xtdbmodel(2)%modelid='IHJREST'\r\n xtdbmodel(2)%nmpid=2\r\n allocate(xtdbmodel(2)%mpid(2))\r\n allocate(xtdbmodel(2)%ocmpid(2))\r\n allocate(xtdbmodel(2)%ocix(2))\r\n xtdbmodel(2)%mpid(1)='TC'\r\n xtdbmodel(2)%mpid(2)='BMAG'\r\n xtdbmodel(2)%ocmpid(1)='TC'\r\n xtdbmodel(2)%ocmpid(2)='BMAG'\r\n xtdbmodel(2)%ocix(1)=4\r\n xtdbmodel(2)%ocix(2)=3\r\n! Magnetic model 3, previously AFF=0\r\n xtdbmodel(3)%modelid='IHJQX'\r\n xtdbmodel(3)%nmpid=3\r\n allocate(xtdbmodel(3)%mpid(3))\r\n allocate(xtdbmodel(3)%ocmpid(3))\r\n allocate(xtdbmodel(3)%ocix(3))\r\n xtdbmodel(3)%mpid(1)='TC'\r\n xtdbmodel(3)%mpid(2)='NT'\r\n xtdbmodel(3)%mpid(3)='BMAG'\r\n xtdbmodel(3)%ocmpid(1)='TC'\r\n xtdbmodel(3)%ocmpid(2)='NT'\r\n xtdbmodel(3)%ocmpid(3)='BMAG'\r\n xtdbmodel(3)%ocix(1)=4\r\n xtdbmodel(3)%ocix(2)=5\r\n xtdbmodel(3)%ocix(3)=3\r\n! Einstein\r\n xtdbmodel(4)%modelid='GEIN'\r\n xtdbmodel(4)%nmpid=1\r\n allocate(xtdbmodel(4)%mpid(1))\r\n allocate(xtdbmodel(4)%ocmpid(1))\r\n allocate(xtdbmodel(4)%ocix(1))\r\n xtdbmodel(4)%mpid(1)='LNTH'\r\n xtdbmodel(4)%ocmpid(1)='LNTH'\r\n xtdbmodel(4)%ocix(1)=2\r\n! Liq2State\r\n xtdbmodel(5)%modelid='LIQ2STATE'\r\n xtdbmodel(5)%nmpid=2\r\n allocate(xtdbmodel(5)%mpid(2))\r\n allocate(xtdbmodel(5)%ocmpid(2))\r\n allocate(xtdbmodel(5)%ocix(2))\r\n xtdbmodel(5)%mpid(1)='LNTH'\r\n xtdbmodel(5)%mpid(2)='G2'\r\n xtdbmodel(5)%ocmpid(1)='LNTH'\r\n xtdbmodel(5)%ocmpid(2)='G2'\r\n xtdbmodel(5)%ocix(1)=2\r\n xtdbmodel(5)%ocix(2)=6\r\n!\r\n! These models have no model parameters\r\n xtdbmodel(6)%modelid='FCC4PERM'\r\n xtdbmodel(6)%nmpid=0\r\n xtdbmodel(7)%modelid='BCC4PERM'\r\n xtdbmodel(7)%nmpid=0\r\n xtdbmodel(8)%modelid='EEC'\r\n xtdbmodel(8)%nmpid=0\r\n xtdbmodel(9)%modelid='EBEF'\r\n xtdbmodel(9)%nmpid=0\r\n!\r\n! The DisorderedPart is a separate tag\r\n!\r\n return\r\n end subroutine xtdbinitmpid\r\n \r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine write_xtdbformat\r\n!\\begin{verbatim}\r\n subroutine write_xtdbformat(filename,ext)\r\n! write an XTDB database\r\n!--------------------------------------------------\r\n! NOTE writing TDB files is in gtp3C.F90 by subroutine list_phase_data2\r\n! The XTDB format is defined in gtp3_xml.F90\r\n!--------------------------------------------------\r\n implicit none\r\n character*(*) filename,ext\r\n!\\end{verbatim}\r\n integer ip,jp,kp,lut,nl,ia,ib,ic,id,nk,isp\r\n integer lokph,ics,lokcs,proptyp,lokxx\r\n! integer, parameter :: maxint=20\r\n integer :: freemodels=0\r\n character date*20,tlim8*8,ch1*1,configmodel*32\r\n! character line*2000,text16*16,text80*80,text256*256,text512*512\r\n! there was a TPfun in TAFID with more than 700 characters .... BAGAS?\r\n character line*2000,text16*16,text80*80,text256*256,text512*1024\r\n! eventually list a short description of models used in this database\r\n character, dimension(50) :: usedmodels*24\r\n logical lrange\r\n TYPE(gtp_phase_varres), pointer :: phvarres\r\n TYPE(gtp_phase_add), pointer :: addrec\r\n!\r\n10 format(a)\r\n!\r\n! write(*,*)'3E: in write_xtbformat: XTDB format output not yet finished\r\n! write(*,*)'3E: filename: \"',trim(filename),'\" \"',ext,'\"'\r\n! make sure extention is .XTDB\r\n if(index(filename,ext).le.0) then\r\n ip=index(filename,' ')\r\n filename(ip:)='.'//ext\r\n endif\r\n write(*,*)'Output on: ',trim(filename)\r\n! open the file\r\n lut=27\r\n open(lut,file=filename,access='sequential',form='formatted',&\r\n err=1100,iostat=gx%bmperr,status='unknown')\r\n nl=0\r\n! write heading\r\n! xtdbversion is in gtp3_xml.F90?\r\n call date_and_time(date)\r\n write(lut,80)trim(xtdbversion),version(2:7),date(1:4),date(5:6),date(7:8)\r\n! There should probably be some intial XML stuff\r\n80 format('')\r\n nl=nl+1\r\n! values of lowtdef,hightdef,bibrefdef and eldef are set in gtp3_xml.F90\r\n! but can be changed by user or when reading an XTDB database\r\n if(eldef(1:1).eq.' ') then\r\n write(lut,90)trim(lowtdef),trim(hightdef),trim(bibrefdef)\r\n90 format(' ')\r\n else\r\n write(lut,91)trim(lowtdef),trim(hightdef),trim(bibrefdef),trim(eldef)\r\n91 format(' ')\r\n endif\r\n nl=nl+1\r\n write(lut,95)ModelAppendXTDB\r\n95 format(' '/&\r\n ' ')\r\n nl=nl+2\r\n! Writing in this order (option writing parameters by phase?)\r\n! 1: Elements and species\r\n! 2: Phases\r\n! 3: Parameters\r\n! 4: TPfuns\r\n! 5: Bibliography\r\n!-----------------------------\r\n! 1: Elements and species\r\n do ia=1,noofel\r\n! skip /- and VA\r\n write(lut,100)trim(ellista(ia)%symbol),trim(ellista(ia)%ref_state),&\r\n ellista(ia)%mass,ellista(ia)%h298_h0,ellista(ia)%s298\r\n100 format(2x,'')\r\n nl=nl+1\r\n enddo\r\n! list alse elements as species\r\n do ia=1,noofsp\r\n text80=' '\r\n! ip is set to 1 inside encode_stoik, text is the stoichiometry with 8 digits\r\n call encode_stoik(text80,ip,8,ia)\r\n! if MQMQA or UNIQUAC ???????\r\n write(lut,110)trim(splista(ia)%symbol),text80(1:ip)\r\n110 format(2x,'')\r\n nl=nl+1\r\n enddo\r\n write(*,*)'No check for MQMQA or UNIQUAC species'\r\n!----------------------------------------------------------------------\r\n! in gtp3C.F90 there is a subroutine list_phase_data2 for TDB files\r\n! 2: Phases\r\n phaseloop: do ia=1,noofph\r\n lokph=phases(ia)\r\n ics=1\r\n! write(lut,*)''\r\n! write(*,*)'3E phase ',trim(phlista(lokph)%name),ia,lokph\r\n! Default is CEF and solid phase, test some status bits\r\n!-Bits in PHASE record STATUS1 there are also bits in each phase_varres record!\r\n! 0 HID phase is hidden (not implemented)\r\n! 1 IMHID phase is implictly hidden (not implemented)\r\n! 2 ID phase is ideal, substitutional and no interaction\r\n! 3 NOCV phase has no concentration variation\r\n! 4 HASP phase has at least one parameter entered\r\n! 5 FORD phase has 4 sublattice FCC ordering with parameter permutations\r\n! 6 BORD phase has 4 sublattice BCC ordering with parameter permutations\r\n! 7 SORD phase has TCP type ordering (not subract ordered as disordered, NEVER)\r\n! 8 MFS phase has a disordered fraction set (DisorderedPart)\r\n! 9 GAS this is the gas phase (first in phase list) \r\n! 10 LIQ phase is liquid (can be several but listed directly after gas)\r\n! 11 IONLIQ phase has ionic liquid model (I2SL)\r\n! 12 AQ1 phase has aqueous model (not implemented)\r\n! 13 2STATE elemental liquid twostate model parameters (not same as I2SL!)\r\n! 14 QCE phase has corrected quasichemical entropy (Hillerst-Selleby-Sundman)\r\n! 15 CVMCE phase has some CVM ordering entropy (not implemented, SEE CVMTFL)\r\n! 16 EXCB phase need explicit charge balance (has ions)\r\n! 17 XGRID use extra dense grid in gridminimizer for this phase (not used ?)\r\n! 18 MQMQA phase has FACT quasichem SRO model - implementation pending\r\n! 19 NOCS not allowed to create composition sets for this phase\r\n! 20 HELM parameters are for a Helmholz energy model (not implemented),\r\n! 21 PHNODGDY2 phase model with no analytical 2nd derivatives (not implemented)\r\n! 22 not used\r\n! 23 EECLIQ this is the condensed phase (liquid) for highest entropy\r\n! 24 PHSUBO special use testing models DO NOT USE\r\n! 25 PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!!\r\n! 26 MULTI may be used with care\r\n! 27 BMAV Xiong magnetic model with average Bohr magneton number\r\n! 28 UNIQUAC The UNIQUAC fluid model\r\n! 29 TISR phase has the TSIR entropy model (E Kremer)\r\n! 30 PHSSRO phase has the tetrahedral FCC model for SRO (without LRO)\r\n! 31 SROT phase has a tetrahedron quasichemical model -- NOT USED\r\n! 32 CVMTFL phase has the tetrahedral FCC for LRO and SRO (not impl)\r\n! some bits tested later for AmendPhase and DisorderedPart\r\n configmodel='CEF'; ch1='S'\r\n if(btest(phlista(lokph)%status1,PHGAS)) then\r\n configmodel='IDEAL'\r\n ch1='G'\r\n elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then\r\n configmodel='I2SL'\r\n ch1='L'\r\n elseif(btest(phlista(lokph)%status1,PHMQMQA)) then\r\n configmodel='MQMQA'\r\n ch1='L'\r\n elseif(btest(phlista(lokph)%status1,PHUNIQUAC)) then\r\n configmodel='UNIQUAC'\r\n ch1='L'\r\n elseif(btest(phlista(lokph)%status1,PHLIQ)) then\r\n ch1='L'\r\n endif\r\n line=' '\r\n write(lut,10)trim(line)\r\n nl=nl+1\r\n! sublattices/sublattices\r\n line=' firsteq%phase_varres(lokcs)\r\n do ic=1,ib\r\n! ip postion (updates) 10 is max digits, 0 means no + sign (>0 means sign)\r\n call wrinum(line,ip,10,0,phvarres%sites(ic))\r\n ip=ip+1\r\n enddo\r\n line(ip-1:)='\" >'\r\n write(lut,10)trim(line)\r\n nl=nl+1\r\n! how are constiuents stored\r\n! write(*,70)phlista(lokph)%constitlist\r\n70 format('3E constituents: ',20i3)\r\n! constituents\r\n! loop for all sublattices\r\n nk=0\r\n do ic=1,ib\r\n line=' ')\r\n nl=nl+1\r\n! DisorderedPart, in OC the ordered and disordered parameters in same phase\r\n if(btest(phlista(lokph)%status1,PHMFS)) then\r\n write(*,*)'3EX The phase '//trim(phlista(lokph)%name)//&\r\n ' has a DisorderedPart'\r\n! in gtp_fraction_set the data for disordered phase can be found\r\n! write(*,*)'3E Disordere:',phvarres%disfra%latd,phvarres%disfra%totdis\r\n line=' phlista(lokph)%additions\r\n do while(associated(addrec))\r\n proptyp=addrec%type\r\n! write(*,*)'3E addrec%propval: ',proptyp\r\n select case(proptyp)\r\n case default\r\n write(*,*)'3E Unknown property: ',proptyp\r\n case(1) ! INDENMAGNETIC=1, BCC and other phases\r\n if(addrec%aff.eq.-1) then\r\n text512(ip:)='IHJBCC'; ip=ip+7\r\n elseif(addrec%aff.eq.-3) then\r\n text512(ip:)='IHJREST'; ip=ip+8\r\n endif\r\n case(2) ! XIONGMAGNETIC=2 same for all\r\n text512(ip:)='IHJQX'; ip=ip+6\r\n case(3)! DEBYECP=3, not implemented\r\n continue\r\n case(4) ! EINSTEINCP=4 \r\n text512(ip:)='GEIN'; ip=ip+9\r\n case(5) ! TWOSTATEMODEL1=5\r\n text512(ip:)='LIQ2STATE'; ip=ip+10\r\n case(6) ! ELASTICMODEL1=6\r\n case(7) ! VOLMOD1=7\r\n! OC by default set VOLMOL\r\n continue\r\n case(8) ! UNUSED_CRYSTBREAKDOWNMOD=8\r\n case(9) ! SECONDEINSTEIN=9\r\n case(10) ! SCHOTTKYANOMALY=10\r\n case(11) ! DIFFCOEFS=11\r\n end select\r\n addrec=>addrec%nextadd\r\n enddo\r\n! these amendments/amendments are set by other bits\r\n if(btest(phlista(lokph)%status1,PHFORD)) then\r\n text512(ip:)='FCC4PERM'; ip=ip+9\r\n elseif(btest(phlista(lokph)%status1,PHBORD)) then\r\n text512(ip:)='BCC4PERM'; ip=ip+9\r\n endif\r\n if(ip.gt.1) then\r\n! write(*,*)'3E additions: ',trim(text512),ip\r\n if(len_trim(text512).gt.1) write(lut,270)trim(text512)\r\n270 format(' ')\r\n nl=nl+1\r\n endif\r\n!------------------------------------------ suck ....\r\n! CrystalStructure ?\r\n write(lut,290)\r\n290 format(' ')\r\n nl=nl+1\r\n!\r\n! write(*,*)'3E Finished this phase'\r\n enddo phaseloop\r\n! goto 900\r\n write(lut,*)' '\r\n!-----------------------------\r\n! 3: Parameters, phase by phase\r\n! code here copied from gtp3C.F90 subroutine list_phase_data\r\n do ia=1,noph()\r\n! write(*,*)'3E calling write_parametrar',lut\r\n lokph=phases(ia)\r\n call write_parameters(lokph,lut,2,nl)\r\n if(gx%bmperr.ne.0) goto 1100\r\n! write(*,*)'3E Finished listing parameters for this phase'\r\n enddo\r\n!----------------------------- CHANGE HERE if gtp3_xml.F90 changes\r\n! 4: TPfuns this is the tag xmlel(26) \r\n write(lut,*)' '\r\n write(lut,*)' '\r\n nl=nl+2\r\n! write(*,*)'3E tpfuns: ',notpf(),freetpfun\r\n tpfuns: do ia=3,notpf()\r\n text512=' '\r\n tlim8=' '\r\n lrange=.FALSE.\r\n! A TPfun can be very long\r\n call list_tpfun(ia,0,text512)\r\n if(text512(1:1).eq.'_') cycle tpfuns\r\n! check that there is a \" N \" in text512 to indicate end of expression\r\n if(index(text512,' N ').le.0) then\r\n ip=index(text512,'= ')-1\r\n write(*,*)text512(1:ip)\r\n130 format('3E no end of TPfun ',a,' in text512')\r\n stop\r\n endif\r\n! we have to format this using TPfun anda Trange tags\r\n! we should use lowtdef and hightdef which are 8 characters\r\n ip=index(text512,'= ')+2\r\n tlim8=text512(ip:)\r\n jp=index(tlim8,' ')\r\n tlim8(jp:)=' '\r\n if(tlim8.ne.lowtdef) then\r\n line=' '\r\n else\r\n line(kp:)='\" HighT=\"'//text512(ip:ip+jp-2)//'\" >'\r\n endif\r\n else\r\n if(lrange) then\r\n line(kp:)='\" />'\r\n else\r\n line(kp:)='\" >'\r\n endif\r\n endif\r\n lrange=.TRUE.\r\n write(lut,10)trim(line)\r\n nl=nl+1\r\n ip=ip+jp+2\r\n! This is the tag xmlel(26)\r\n line=' '\r\n else\r\n! at the highT limit\r\n line(kp:)='\" />'\r\n endif\r\n ip=ip+jp+1\r\n kp=len_trim(line)+1\r\n write(lut,10)line(1:kp)\r\n nl=nl+1\r\n! if there has been Trange tags then end the TPfun, tag xmlel(26)\r\n if(lrange) write(lut,10)' '\r\n cycle tpfuns\r\n endif\r\n! there are more tranges\r\n! write(*,*)'3E next range: ',trim(text512(ip:))\r\n enddo tranges\r\n enddo tpfuns\r\n!-----------------------------\r\n! 5: Bibliography\r\n! write(*,*)'3EX reffree: ',reffree\r\n if(reffree.gt.1) then\r\n write(lut,400)\r\n400 format(' ')\r\n nl=nl+1\r\n do ia=1,reffree-1\r\n! Wow, reference texts are stored using storec/loadc ... max 1024 chars\r\n ip=bibrefs(ia)%wprefspec(1)\r\n line=' '\r\n call loadc(2,bibrefs(ia)%wprefspec,line(1:ip))\r\n! check to < > and &\r\n! call check_illegal_xml(line,ip)\r\n! write(*,*)'Bibitem: ',trim(line),ip\r\n write(lut,410)trim(bibrefs(ia)%reference),trim(line)\r\n410 format(' ')\r\n nl=nl+1\r\n enddo\r\n write(lut,420)trim(bibrefdef)\r\n420 format(4x,' '/' ')\r\n nl=nl+1\r\n else\r\n endif\r\n!-----------------------------\r\n! Models in AppendXTDB\r\n! Finished !!\r\n900 continue\r\n write(lut,990)\r\n990 format('')\r\n nl=nl+1\r\n!----------------------------\r\n1000 continue\r\n close(lut)\r\n write(*,1010)nl,trim(filename)\r\n!\r\n1010 format('Written: ',i7,' lines on ',a)\r\n return\r\n! error open or writing\r\n1100 continue\r\n write(*,*)'Error during writing XTDB file',gx%bmperr\r\n goto 1000\r\n! \r\n end subroutine write_xtdbformat\r\n \r\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\r\n\r\n! \\addtotable subroutine check_illegal_xml\r\n subroutine replace_illegal_xml(line,ip)\r\n! replace < > & and \" in references by\r\n! [ ] | and #\r\n character*(*) line\r\n integer ip\r\n!\r\n integer jp\r\n lt: do while(.true.)\r\n jp=index(line(1:ip),'<')\r\n if(jp.eq.0) exit lt\r\n line(jp:jp)='['\r\n enddo lt\r\n gt: do while(.true.)\r\n jp=index(line(1:ip),'>')\r\n if(jp.eq.0) exit gt\r\n line(jp:jp)=']'\r\n enddo gt\r\n amp: do while(.true.)\r\n jp=index(line(1:ip),'&')\r\n if(jp.eq.0) exit amp\r\n line(jp:jp)='|'\r\n enddo amp\r\n quote: do while(.true.)\r\n! this means \" is replaced by a single '\r\n jp=index(line(1:ip),'''')\r\n if(jp.eq.0) exit quote\r\n line(jp:jp)='#'\r\n enddo quote\r\n return\r\n end subroutine replace_illegal_xml\r\n\r\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\r\n\r\n! \\addtotable subroutine exp2xml\r\n subroutine exp2xml(lut,expr,tag,nl)\r\n! convert expr to TPfun/Parameter and Trange and write lines on unit lut\r\n! tag is TPfun or Parameter and the first part of expr is the Id followd\r\n! by the expression\r\n integer lut,nl\r\n character expr*(*),tag*(*)\r\n!\r\n integer ip,jp,kp\r\n character tlim8*8,line*1000,bibref*16\r\n logical lrange\r\n! \r\n! make sure there is a final ' N '\r\n ip=index(expr,' N ')\r\n if(ip.le.0) then\r\n write(*,*)'3E expression has no terminating N'\r\n stop\r\n elseif(tag(1:1).eq.'P') then\r\n! extract reference if tag is Parameter\r\n bibref=trim(expr(ip+3:))\r\n else\r\n bibref=' '\r\n endif\r\n! missing default bibref?? fixed\r\n! write(*,*)'3E exp2xml: \"',trim(expr),'\" \"',trim(bibref)\r\n! in tlow is after \"= \"\r\n! write(*,*)'3E exp2xml: ',len_trim(expr)\r\n! write(*,*)'3E exp2xml: ',trim(expr)\r\n lrange=.FALSE.\r\n ip=index(expr,'= ')+2\r\n tlim8=expr(ip:)\r\n jp=index(tlim8,' ')\r\n tlim8(jp:)=' '\r\n line=' <'//trim(tag)//' Id=\"'//expr(1:ip-3)//'\"'\r\n kp=len_trim(line)\r\n! write(*,*)'3E line 1A: ',line(1:kp)\r\n if(tlim8.ne.lowtdef) then\r\n line(kp+2:)=' LowT=\"'//trim(tlim8)//'\" Expr=\"'\r\n else\r\n! Default LowT\r\n line(kp+2:)=' Expr=\"'\r\n endif\r\n kp=len_trim(line)+2\r\n! write(*,*)'3E line 1B: >',line(1:kp),'<'\r\n! find space after lowT limit ...\r\n! write(*,*)'3E space1: ',expr(1:ip),ip\r\n! ip=ip+index(expr(ip:),' ')-1\r\n ip=ip+index(expr(ip:),' ')\r\n! write(*,*)'3E after space: ',expr(ip:ip+20)\r\n! ip is after lowT in expr and kp is after Expr=\"\r\n! there can be breakpoints in T\r\n tranges: do while(.TRUE.)\r\n jp=index(expr(ip:),';')\r\n if(jp.le.0) then\r\n write(*,*)'Missing ; at end of expression',ip,jp\r\n write(*,*)'3E expr :',trim(expr(ip:)),':'\r\n stop\r\n endif\r\n! write(*,*)'3E line 1C: >',line(1:kp),'<'\r\n! write(*,*)'3E exp 2: ',expr(ip:ip+20),ip\r\n! line(kp:)=expr(ip+1:ip+jp+1)\r\n! problem here because initial sign disappeared!!!\r\n line(kp:)=expr(ip:ip+jp-1)\r\n! write(*,*)'3E line 2: >',trim(line),'<'\r\n kp=kp+jp\r\n ip=ip+jp+1\r\n! HighT limit or more ranges?\r\n jp=index(expr(ip:),' Y ')\r\n if(jp.gt.0) then\r\n! more ranges, save end of this range do not check highT limit\r\n tlim8=expr(ip:ip+jp-2)\r\n if(tlim8.ne.hightdef) then\r\n if(lrange) then\r\n line(kp:)='\" HighT=\"'//expr(ip:ip+jp-2)//'\" />'\r\n else\r\n! there is a seconed or more ranges, the bibref should be part of TPfun tag\r\n line(kp:)='\" HighT=\"'//expr(ip:ip+jp-2)//'\" >'\r\n if(bibref(1:1).ne.' ') then\r\n kp=len_trim(line)\r\n line(kp:)=' Bibref=\"'//trim(bibref)//'\" >'\r\n bibref=' '\r\n endif\r\n endif\r\n else\r\n line(kp:)='\" />'\r\n endif\r\n lrange=.TRUE.\r\n! write(*,*)'3E line: ',trim(line)\r\n write(lut,10)trim(line)\r\n10 format(a)\r\n nl=nl+1\r\n nl=nl+1\r\n ip=ip+jp+2\r\n line=' '\r\n else\r\n! at the highT limit\r\n line(kp:)='\" />'\r\n endif\r\n! add the Bibref if there has not been any Tranges\r\n if(bibref(1:1).ne.' ') then\r\n kp=len_trim(line)-1\r\n line(kp:)=' Bibref=\"'//trim(bibref)//'\" />'\r\n endif\r\n! ip=ip+jp+1\r\n kp=len_trim(line)\r\n! write(*,*)'3E line 7: ',trim(line)\r\n write(lut,10)line(1:kp)\r\n nl=nl+1\r\n! if there has been Trange tags then end the Parameter/Tpfun tag\r\n! write(*,*)trim(line)\r\n if(lrange) then\r\n write(lut,10)' '\r\n nl=nl+1\r\n endif\r\n exit tranges\r\n endif\r\n! loop if there are more tranges\r\n enddo tranges\r\n1000 continue\r\n return\r\n end subroutine exp2xml\r\n\r\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\r\n\r\n!\\addtotable subroutine write_parameters\r\n!\\begin{verbatim}\r\n subroutine write_parameters(lokph,lut,typ,nl)\r\n! code below same as in list_all_data ... maybe make it a subroutine ...\r\n! lokph is phlista index, lut is output unit\r\n! typ 1 for screen, 2 for XML, nl counts number of lines written\r\n implicit none\r\n integer lokph,lut,typ,nl\r\n!\\end{verbatim}\r\n integer parlist,ll,nsl,ij,ideg,typty,typspec,kk,kkx,iel,linkcon,nz,ics\r\n integer ncsum,ip,intpq,prplink,nint,lokcs,ik,jdeg,kkk,iqhigh,iqnext,lqq\r\n!\r\n integer ilist(9), endm(15), lint(2,3)\r\n character text*2000,prop*32,funexpr*1000,phname*24,ch1*1,toopsp(3)*24\r\n logical mqmqa,noelin1,subref\r\n! This is the index of PARAMETER in xtdbtags\r\n integer, parameter :: xmlpartag=17\r\n!\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_endmember), pointer :: endmemrec\r\n TYPE(gtp_interaction), pointer :: intrec\r\n! a smart way to have an array of pointers\r\n TYPE intrecarray \r\n type(gtp_interaction), pointer :: p1\r\n end TYPE intrecarray\r\n integer, parameter :: maxstack=20\r\n TYPE(intrecarray), dimension(maxstack) :: intrecstack\r\n TYPE(gtp_fraction_set), pointer :: disfrap\r\n type(gtp_tooprec), pointer :: tooprec\r\n!\r\n!--------------------------------------------------\r\n! return here to list disordered parameters\r\n! write(lut,*)''\r\n! write(*,*)'3E In write_parameters',lokph,lut,typ\r\n phname=phlista(lokph)%name\r\n parlist=1\r\n ics=1\r\n! tooptop=0\r\n mqmqa=.FALSE.\r\n100 continue\r\n! parlist changed below for disordered fraction set\r\n if(parlist.eq.1) then\r\n endmemrec=>phlista(lokph)%ordered\r\n nsl=phlista(lokph)%noofsubl\r\n else\r\n! write(*,*)'3E Listing disordred parameters 1',nsl\r\n endmemrec=>phlista(lokph)%disordered\r\n disfrap=>firsteq%phase_varres(lokcs)%disfra\r\n nsl=disfrap%ndd\r\n endif\r\n! write(*,*)'3E Listing parameters 2, nsl=',nsl\r\n endmemberlist: do while(associated(endmemrec))\r\n do ll=1,nsl\r\n! ilist(ll)=emlista(lokem)%fraclinks(ll,1)\r\n ilist(ll)=endmemrec%fraclinks(ll,1)\r\n if(ilist(ll).gt.0) then\r\n if(parlist.eq.2) then\r\n! what is disfra here??!!\r\n! write(*,*)'3E disfra?: ',disfra%splink(ilist(ll)),&\r\n! disfrap%splink(ilist(ll))\r\n! endm(ll)=disfra%splink(ilist(ll))\r\n endm(ll)=disfrap%splink(ilist(ll))\r\n else\r\n endm(ll)=phlista(lokph)%constitlist(ilist(ll))\r\n endif\r\n else\r\n! wildcard, write '*'\r\n endm(ll)=-99\r\n endif\r\n enddo\r\n nint=0\r\n ideg=0\r\n text=' '\r\n call encode_constarr(text,nsl,endm,nint,lint,ideg)\r\n if(gx%bmperr.ne.0) goto 1000\r\n proprec=>endmemrec%propointer\r\n ptyloop: do while(associated(proprec))\r\n ij=proprec%proptype\r\n if(ij.ge.100) then\r\n typty=ij/100\r\n typspec=mod(ij,100)\r\n else\r\n typty=ij\r\n endif\r\n if(typty.gt.0 .and. typty.le.ndefprop) then\r\n prop=propid(typty)%symbol\r\n! if(parlist.eq.2) then\r\n! disordered endmember parameter\r\n! DO NOT ADD D on disordered parameter identifiers\r\n! kk=len_trim(prop)+1\r\n! prop(kk:kk)='D'\r\n! endif\r\n if(btest(propid(typty)%status,IDELSUFFIX)) then\r\n! property like ZZ&(phase,constituent array)\r\n! the element index should be in typsepc\r\n iel=typspec\r\n if(iel.ge.0 .and. iel.le.noofel) then\r\n! prop=propid(typty)%symbol\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //ellista(elements(iel))%symbol\r\n else\r\n gx%bmperr=4082; goto 1000\r\n endif\r\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\r\n! property like mobility, MQ&(phase,constituent array)\r\n! the suffix is a constituent\r\n iel=typspec\r\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\r\n if(parlist.eq.2) then\r\n! we must consider parlist, take disordered constituent list\r\n! we have no current equilibrium record but can use firsteq!!\r\n! lokcs=phlista(lokph)%linktocs(1)\r\n! write(*,*)'3E: endmember typspec 1: ',iel\r\n! write(*,*)'3E splink: ',disfrap%splink\r\n linkcon=disfrap%splink(iel)\r\n! write(*,*)'3E: endmember typspec 2: ',linkcon\r\n ll=0\r\n! ll=1\r\n! linkcon has nothing to do with which sublattice, ignore ll\r\n! if(linkcon.gt.disfrap%nooffr(1)) ll=2\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //splista(linkcon)%symbol\r\n! write(*,*)'3E We are here',linkcon,disfrap%nooffr(1),ll\r\n prop=prop(1:len_trim(prop))\r\n! goto 120\r\n goto 121\r\n else\r\n linkcon=phlista(lokph)%constitlist(iel)\r\n if(linkcon.le.0) then\r\n write(*,*)'Illegal use of wildcard 1'\r\n gx%bmperr=4286; goto 1000\r\n endif\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //splista(linkcon)%symbol\r\n! also add the sublattice number ...\r\n ncsum=0\r\n do ll=1,phlista(lokph)%noofsubl\r\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\r\n if(iel.le.ncsum) goto 120\r\n enddo\r\n endif\r\n! error if sublattice not found\r\n write(*,*)'Error in constituent depended parameter id'\r\n gx%bmperr=4287; goto 1000\r\n! jump here to append sublattice\r\n120 continue\r\n! write(*,*)'property 1: ',prop(1:10),ll\r\n if(ll.gt.1) then\r\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\r\n! else\r\n! prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\r\n endif\r\n121 continue\r\n else\r\n write(*,*)'lpd 7B: ',iel,typty\r\n gx%bmperr=4082; goto 1000\r\n endif\r\n endif\r\n else\r\n! unknown property ...\r\n write(*,*)'unknown property type xx: ',ij,typty,typspec\r\n prop='ZZ'\r\n endif\r\n! note changes here must be repeated for interaction parameters below\r\n write(funexpr,200)prop(1:len_trim(prop)),&\r\n phname(1:len_trim(phname)),text(1:len_trim(text))\r\n200 format(A,'(',A,',',A,') ')\r\n ip=len_trim(funexpr)+1\r\n! check if FNN MQMQA parameter ...\r\n if(mqmqa) then\r\n! ilist is index in fraction list, same as index in mqmqa_data%contyp\r\n! intpq=ilist(1)\r\n! write(*,*)'3E check if SNN parameter',intpq,&\r\n! mqmqa_data%contyp(5,intpq)\r\n if(mqmqa_data%contyp(5,ilist(1)).le.0) goto 203\r\n endif\r\n if(typ.eq.1) then\r\n! subtract reference states\r\n if(subref .and. typty.eq.1) then\r\n call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1)\r\n if(noelin1) then\r\n! this can happen for ionic liquids with just neutrals in sublattice 2\r\n! replace the constituent in sublattice 1 with \"*\" !!!\r\n! write(*,*)'before: ',funexpr(1:ip)\r\n kk=index(funexpr,',')\r\n ik=index(funexpr,':')\r\n funexpr(kk+1:)='*'//funexpr(ik:)\r\n ip=len_trim(funexpr)+2\r\n! write(*,*)'after: ',funexpr(1:ip)\r\n endif\r\n endif\r\n endif\r\n203 continue\r\n! this writes the expression as for a TDB file\r\n call list_tpfun(proprec%degreelink(0),1,funexpr(ip:))\r\n! write(*,*)' >>>> fun? ',trim(funexpr(ip:)),lut\r\n ip=len_trim(funexpr)\r\n if(len_trim(proprec%reference).le.0) then\r\n funexpr(ip+1:)=' Default '\r\n else\r\n funexpr(ip+1:)=' '//proprec%reference\r\n endif\r\n ip=len_trim(funexpr)\r\n if(typ.eq.1) then\r\n! nice output over several lines if needed with indentation 12 spaces\r\n call wrice2(lun,2,12,78,1,funexpr(1:ip))\r\n else\r\n! write(*,10)funexpr(1:ip)\r\n! write(lut,10)funexpr(1:ip)\r\n! this convert TDB expression to XTDB format, this is the Parameter tag\r\n! call exp2xml(lut,funexpr,xmlel(xmlpartag),nl)\r\n call exp2xml(lut,funexpr,xtdbtags(xmlpartag),nl)\r\n endif\r\n proprec=>proprec%nextpr\r\n enddo ptyloop\r\n if(typ.eq.1) then\r\n if(btest(phlista(lokph)%status1,PHFORD).or. &\r\n btest(phlista(lokph)%status1,PHBORD)) then\r\n! if(endmemrec%noofpermut.gt.1) then\r\n intpq=0\r\n if(associated(endmemrec%intpointer)) then\r\n intpq=endmemrec%intpointer%antalint\r\n endif\r\n prplink=0\r\n if(associated(endmemrec%propointer)) prplink=1\r\n! keep this output for the moment\r\n if(parlist.eq.1) write(*,207)endmemrec%antalem,&\r\n endmemrec%noofpermut,intpq,prplink\r\n207 format('3E Endmember check: permut, interaction, pty: ',4i5)\r\n endif\r\n endif\r\n endmemrec=>endmemrec%nextem\r\n enddo endmemberlist\r\n! write(*,*)'3E Finished listing endmember parameters',parlist,nsl\r\n!-----------------------------------------------------------------------\r\n! parameters for interactions using site fractions\r\n if(parlist.eq.1) then\r\n endmemrec=>phlista(lokph)%ordered\r\n else\r\n if(.not.associated(phlista(lokph)%disordered)) &\r\n write(*,*)'3E Problems with disordered fraction set'\r\n endmemrec=>phlista(lokph)%disordered\r\n if(.not.associated(disfrap)) write(*,*)'3E disfrap problems!'\r\n nsl=disfrap%ndd\r\n! write(*,*)'new nsl',nsl\r\n endif\r\n intlist1: do while(associated(endmemrec))\r\n intrec=>endmemrec%intpointer\r\n if(associated(intrec)) then\r\n! write(*,*)'intlist 1B: ',intrec%status\r\n do ll=1,nsl\r\n kkx=endmemrec%fraclinks(ll,1)\r\n if(kkx.eq.-99) then\r\n! wildcard\r\n endm(ll)=-99\r\n elseif(parlist.eq.2) then\r\n endm(ll)=disfrap%splink(kkx)\r\n else\r\n endm(ll)=phlista(lokph)%constitlist(kkx)\r\n endif\r\n enddo\r\n endif\r\n nint=0\r\n intlist2: do while(associated(intrec))\r\n nint=nint+1\r\n if(nint.gt.maxstack) then\r\n write(*,*)'3E overflow in intrecstack 1'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n intrecstack(nint)%p1=>intrec\r\n!--------------------------------------------------\r\n lint(1,nint)=intrec%sublattice(1)\r\n kkk=intrec%fraclink(1)\r\n if(parlist.eq.2) then\r\n lint(2,nint)=disfrap%splink(kkk)\r\n else\r\n lint(2,nint)=phlista(lokph)%constitlist(kkk)\r\n endif\r\n proprec=>intrec%propointer\r\n ptyloop2: do while(associated(proprec))\r\n! typty=proprec%proptype\r\n ij=proprec%proptype\r\n if(ij.ge.100) then\r\n typty=ij/100\r\n typspec=mod(ij,100)\r\n else\r\n typty=ij\r\n endif\r\n if(typty.gt.0 .and. typty.le.ndefprop) then\r\n prop=propid(typty)%symbol\r\n if(btest(propid(typty)%status,IDELSUFFIX)) then\r\n! property like ZZ&(phase,constituent array)\r\n! the element index should be in typsepc\r\n iel=typspec\r\n if(iel.ge.0 .and. iel.le.noofel) then\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //ellista(elements(iel))%symbol\r\n else\r\n! write(*,*)'lpd 7: ',iel,typty\r\n gx%bmperr=4082; goto 1000\r\n endif\r\n elseif(btest(propid(typty)%status,IDCONSUFFIX)) then\r\n! property like mobility MQ&(phase,constituent array)\r\n! the suffix is a constituent\r\n iel=typspec\r\n if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then\r\n if(parlist.eq.2) then\r\n! we must consider parlist, take disordered constituent list\r\n! we have no current equilibrium record but can use firsteq!!\r\n! write(*,*)'3E: typspec: 3 ',typty,iel,prop(1:10)\r\n linkcon=disfrap%splink(iel)\r\n! write(*,*)'3E: typspec: 4 ',typty,linkcon,prop(1:10)\r\n ll=1\r\n if(iel.gt.disfrap%nooffr(1)) ll=2\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //splista(linkcon)%symbol\r\n goto 220\r\n else\r\n linkcon=phlista(lokph)%constitlist(iel)\r\n if(linkcon.le.0) then\r\n! write(*,*)'Illegal use of wildcard 2'\r\n gx%bmperr=4286; goto 1000\r\n endif\r\n prop=prop(1:len_trim(prop))//'&'&\r\n //splista(linkcon)%symbol\r\n! also add the sublattice number ...\r\n ncsum=0\r\n do ll=1,phlista(lokph)%noofsubl\r\n ncsum=ncsum+phlista(lokph)%nooffr(ll)\r\n if(iel.le.ncsum) goto 220\r\n enddo\r\n endif\r\n! there cannot be any errors here ....\r\n! write(*,*)'Never never error 2'\r\n gx%bmperr=4288; goto 1000\r\n220 continue\r\n! write(*,*)'property 2: ',prop(1:10),ll\r\n! add sublattice index only if not unity\r\n if(ll.gt.1) then\r\n prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0'))\r\n endif\r\n else\r\n! write(*,*)'lpd 7: ',iel,typty\r\n gx%bmperr=4082; goto 1000\r\n endif\r\n endif\r\n else\r\n! unknown property ...\r\n write(*,*)'unknown property type yy: ',typty\r\n prop='ZZ'\r\n endif\r\n! note changes here must be repeated for endmember parameters above\r\n degree: do jdeg=0,proprec%degree\r\n if(proprec%degreelink(jdeg).eq.0) then\r\n! write(*,*)'Ignoring function link'\r\n cycle degree\r\n endif\r\n call encode_constarr(text,nsl,endm,nint,lint,jdeg)\r\n write(funexpr,300)trim(prop),trim(phname),trim(text)\r\n300 format(A,'(',A,',',A,') ')\r\n ip=len_trim(funexpr)+1\r\n call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:))\r\n ip=len_trim(funexpr)\r\n! default reference missing for excess parameters\r\n if(len_trim(proprec%reference).le.0) then\r\n funexpr(ip+1:)=' Default '\r\n else\r\n funexpr(ip+1:)=' '//proprec%reference\r\n endif\r\n! funexpr(ip+1:)=' '//proprec%reference\r\n ip=len_trim(funexpr)\r\n if(typ.eq.1) then\r\n call wrice2(lun,4,12,78,1,funexpr(1:ip))\r\n else\r\n! write(*,10)funexpr(1:ip)\r\n! write(lut,10)funexpr(1:ip)\r\n! This is the Parameter xml tag\r\n! call exp2xml(lut,funexpr,xmlel(xmlpartag),nl)\r\n call exp2xml(lut,funexpr,xtdbtags(xmlpartag),nl)\r\n10 format(a)\r\n endif\r\n enddo degree\r\n proprec=>proprec%nextpr\r\n enddo ptyloop2\r\n! list temporarily the number of permutations for FCC and BCC ordering\r\n pdebug: if(typ.eq.1) then\r\n if(btest(phlista(lokph)%status1,PHFORD).or. &\r\n btest(phlista(lokph)%status1,PHBORD)) then\r\n if(nint.eq.1) then\r\n nz=intrec%noofip(2)\r\n else\r\n nz=size(intrec%sublattice)\r\n lqq=intrec%noofip(size(intrec%noofip))\r\n if(lqq.ne.nz) then\r\n write(*,*)'3E Not same 1: ',intrec%antalint,nz,lqq\r\n endif\r\n! write(*,301)nz,intrec%noofip\r\n301 format('noofip: ',10i3)\r\n! nz=intrec%noofip(intrec%noofip(1)+2)\r\n endif\r\n iqnext=0\r\n iqhigh=0\r\n if(associated(intrec%highlink)) then\r\n iqhigh=intrec%highlink%antalint\r\n endif\r\n if(associated(intrec%nextlink)) then\r\n iqnext=intrec%nextlink%antalint\r\n endif\r\n prplink=0\r\n if(associated(intrec%propointer)) prplink=1\r\n! keep this output for the moment\r\n if(parlist.eq.1) write(*,302)intrec%antalint,&\r\n nz,nint,iqhigh,iqnext,prplink\r\n302 format('3E Inter check 1: id, permut, level, high, next, pty: ',&\r\n i5,i3,i3,i4,i4,i2)\r\n endif\r\n endif pdebug\r\n intrec=>intrec%highlink\r\n empty: do while(.not.associated(intrec))\r\n if(nint.gt.0) then\r\n! restore pointers in same clumsy way\r\n intrec=>intrecstack(nint)%p1\r\n intrec=>intrec%nextlink\r\n! write(*,*)'poping a pointer from intrecstack',ninit\r\n nint=nint-1\r\n else\r\n exit intlist2\r\n endif\r\n enddo empty\r\n enddo intlist2\r\n endmemrec=>endmemrec%nextem\r\n enddo intlist1\r\n! write(*,*)'3E Finished listing interactions',parlist,nsl\r\n! check if there are other fraction lists\r\n! parlist=parlist+1, hm parlist can only be 1 or 2\r\n! write(*,*)'checking for disordered parameters'\r\n if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then\r\n subref=.TRUE.\r\n! lokcs=phlista(lokph)%cslink\r\n lokcs=phlista(lokph)%linktocs(ics)\r\n! does this make a copy? Maybe it should be a pointer. IT IS A POINTER!\r\n disfrap=>firsteq%phase_varres(lokcs)%disfra\r\n if(.not.associated(disfrap)) then\r\n! write(*,*)'disfrap OK'\r\n! else\r\n write(*,*)'3E disfrap not set, expect segmentation fault?'\r\n endif\r\n nsl=disfrap%ndd\r\n! write(*,810)disfrap%fsites,nsl\r\n write(lut,810)disfrap%fsites,nsl\r\n810 format('')\r\n parlist=2\r\n! write(*,*)'3E Jump back to list disordered parameters',nsl,parlist\r\n goto 100\r\n endif\r\n! Check if there are toop/kohler ternaries\r\n tooprec=>phlista(lokph)%tooplast\r\n if(associated(tooprec)) then\r\n write(*,*)'3EX there are Toop/Kohler extrapolations'\r\n write(*,*)'There is some code in gtp3C.F90 to handle this'\r\n endif\r\n! write(lut,*)''\r\n! write(*,*)'3E listing by write_parameters\r\n1000 continue\r\n return\r\n end subroutine write_parameters\r\n\r\n!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!!/!\\!\r\n\r\n!\\addtotable subroutine debug_phaseparameters\r\n!\\begin{verbatim}\r\n subroutine debug_phaseparameters(lokph,lut,ceq)\r\n! code to debug a phase structure of parameters\r\n! It follows the data structure as in calcg_internal in gtp3X.F90\r\n! lokph is phlista index, lut is output unit\r\n implicit none\r\n integer lokph,lut\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer lokres\r\n! use composition set 1, phlista is protected inside GTP\r\n lokres=phlista(lokph)%linktocs(1)\r\n! this call will eventually be replaced by call calcg_internal\r\n! after setting a global debugpar variable. The subroutines\r\n! debug_endmember and debug_intrec may be integrated in calcg_internal\r\n! to ensure that any new data structures are followed\r\n write(*,*)'3EX In debug_phaseparameters',lut\r\n call list_phaseparameters(lokph,lut,ceq%phase_varres(lokres),ceq)\r\n return\r\n end subroutine debug_phaseparameters\r\n \r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine list_phaseparameters\r\n!\\begin{verbatim}\r\n subroutine list_phaseparameters(lokph,lut,cps,ceq)\r\n! code to debug a phase structure of parameters\r\n! It follows the data structure as in calcg_internal in gtp3X.F90\r\n! lokph is phlista index, lut is output unit\r\n implicit none\r\n integer lokph,lut\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n type(gtp_phase_varres), target :: cps\r\n!\\end{verbatim}\r\n! Most declaration copied, some may not be needed\r\n integer fractype,epermut,maxprec,sameint,nprop,lokres,lokdiseq\r\n integer moded,nofc2,nsl,msl,qz,incffr(0:maxsubl),spmod,intlevel,ipermut\r\n!\r\n TYPE(gtp_parcalc) :: gz\r\n TYPE(gtp_fraction_set), pointer :: fracset,dislink\r\n TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_endmember), pointer :: endmemrec\r\n TYPE(gtp_interaction), pointer :: intrec\r\n! array with intrec pointers\r\n type intstackarray\r\n TYPE(gtp_interaction), pointer :: save\r\n end type intstackarray\r\n type(intstackarray), dimension(5) :: intstack\r\n! TYPE(gtp_pystack), pointer :: pystack\r\n! TYPE(gtp_phase_add), pointer :: addrec\r\n! to handle parameters with wildcard constituent and other things\r\n logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva,iliqneut\r\n integer, parameter :: permstacklimit=150\r\n integer, dimension(permstacklimit) :: lastpmq,maxpmq\r\n integer pmq,nz\r\n!\r\n write(*,*)'3EX in list_phaseparameters',lokph\r\n if(btest(phlista(lokph)%status1,PHMQMQA)) then\r\n write(*,*)'3EX phase has MQMQA model, no listing'\r\n goto 1000\r\n endif\r\n spmod=0\r\n if(btest(phlista(lokph)%status1,PHFORD) .or. &\r\n btest(phlista(lokph)%status1,PHBORD)) then\r\n! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP\r\n chkperm=.true.\r\n! spmod tries to keep track of disordered/permutation of parameters? >10 permut\r\n spmod=10\r\n if(.not.btest(phlista(lokph)%status1,PHPALM)) then\r\n! write(*,*)'3X calling palmtree ',lokph,cps%phtupx\r\n! This is needed only once unless parameters are changed. It numbers the\r\n! interaction records sequ+entially for the permutations\r\n! the subroutine palmtree is in gtp3Y.F90 for some unknown reason ...\r\n call palmtree(lokph)\r\n if(gx%bmperr.ne.0) goto 1100\r\n write(lut,300)'Phase has parameter permutations'\r\n300 format(a)\r\n! this must be zeroed if a new interaction parameter is added\r\n! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHPALM)\r\n endif\r\n endif\r\n!-----------------------------------------------------------------\r\n50 continue\r\n! local work arrays for products of Y and calculated parameters are allocated\r\n gz%nofc=phlista(lokph)%tnooffr\r\n!\r\n! dimension for number of parameter properties\r\n nprop=cps%nprop\r\n! phres will point either to ordered or disordered results\r\n! phmain will always point to record for ordered phase_varres\r\n phmain=>cps\r\n phres=>cps\r\n!\r\n nsl=phlista(lokph)%noofsubl\r\n write(lut,10)trim(phlista(lokph)%name),phlista(lokph)%nooffs\r\n10 format(a,' parameter structure with ',i3,' fraction sets')\r\n write(*,*)'3EX Inside list_phaseparameters ',phlista(lokph)%nooffs,nsl\r\n! \r\n fractype=0\r\n! chkperm true if FCC/HCP or BCC permutation of ordered phases\r\n chkperm=.false.\r\n if(btest(phlista(lokph)%status1,PHFORD) .or. &\r\n btest(phlista(lokph)%status1,PHBORD)) then\r\n! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP\r\n chkperm=.true.\r\n if(.not.btest(phlista(lokph)%status1,PHPALM)) then\r\n! write(*,*)'3X calling palmtree ',lokph,cps%phtupx\r\n! This is needed only once unless parameters are changed.\r\n! interaction records sequentially for the permutations\r\n write(*,*)'3EX parameter permutations initiated'\r\n call palmtree(lokph)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n endif\r\n!\r\n! loop for different types of fractions: site fractions, mole fractions ...\r\n fractyp: do while(fractype.lt.phlista(lokph)%nooffs)\r\n!\r\n105 continue\r\n fractype=fractype+1\r\n write(*,*)'3EX fraction type: ',fractype\r\n! Jump back here for parameters in disordered fraction set (fractype>1)\r\n110 continue\r\n fracset=>phmain%disfra\r\n! code to handle phases with two fraction sets (Disordered_2Part and _3Part)\r\n ftype: if(fractype.eq.1) then\r\n odtest: if(btest(phlista(lokph)%status1,PHMFS)) then\r\n! there is a disordered fraction set \r\n if(fracset%totdis.ne.0) then\r\n if(btest(phlista(lokph)%status1,PHSUBO)) then\r\n write(lut,300)'Phase has Disordered_2Part model'\r\n write(*,*)'Disordered_2Part model'\r\n goto 106\r\n endif\r\n write(lut,300)'Phase has Disordered_3Part model'\r\n if(btest(phmain%status2,CSORDER)) then\r\n! this is a Disordered_3Part model, the ordered part is calculated twice\r\n nevertwice=.false.\r\n! else\r\n! Disordered_3Part model and phase is disordered, skip ordered part (fractype=1)\r\n! goto 105\r\n! When listing include the listing of ordered parameters ...\r\n endif\r\n endif\r\n endif odtest\r\n106 continue\r\n! initiate variables for disordered part\r\n gz%nofc=phlista(lokph)%tnooffr\r\n msl=nsl\r\n incffr(0)=0\r\n do qz=1,nsl\r\n incffr(qz)=incffr(qz-1)+phlista(lokph)%nooffr(qz)\r\n enddo\r\n else\r\n! parameters in disordered fraction set \r\n msl=fracset%ndd\r\n! write(*,*)'3EX disordered fraction set',msl,associated(fracset)\r\n gz%nofc=fracset%tnoofxfr\r\n incffr(0)=0\r\n do qz=1,msl\r\n incffr(qz)=incffr(qz-1)+fracset%nooffr(qz)\r\n enddo\r\n! no need to handle fractions and derivatives \r\n dislink=>cps%disfra\r\n lokdiseq=dislink%varreslink\r\n phres=>ceq%phase_varres(lokdiseq)\r\n! UNFINISHED: moded has no value here ....\r\n if(moded.gt.1) then\r\n nofc2=gz%nofc*(gz%nofc+1)/2\r\n! if(.not.allocated(phres%d2gval)) then\r\n! allocate(phres%d2gval(nofc2,nprop))\r\n! endif\r\n! phres%d2gval=zero\r\n endif\r\n endif ftype\r\n first=.true.\r\n!\r\n! HERE WE START FOLLOWING THE LINKS BETWEEN ENDMEMBERS\r\n! ordered fraction set listed first\r\n if(fractype.eq.1) then\r\n endmemrec=>phlista(lokph)%ordered\r\n else\r\n endmemrec=>phlista(lokph)%disordered\r\n endif\r\n! write(*,70)'3EX debug endmemberloop',nsl,msl,associated(endmemrec)\r\n!70 format(a,2i3,l3)\r\n! write(*,*)'3EX we are here 1'\r\n! write(*,*)'3EX number of permutations: ',endmemrec%noofpermut\r\n! write(*,*)'3EX we are here 2'\r\n endmemloop: do while(associated(endmemrec))\r\n! Note all interaction are calculated inside this loop!!!!\r\n! The array maxpmq is used for interaction permutations. It must be\r\n! initialized to zero at the first endmember permutation. It is set to\r\n! limits for the interacton permutations for all interaction records.\r\n maxpmq=0\r\n maxprec=0\r\n epermut=0\r\n sameint=0\r\n! not implemented for MQMQA\r\n empermut: do while(epermut.lt.endmemrec%noofpermut)\r\n epermut=epermut+1\r\n!----------------------------------------------------------\r\n! list endmembers\r\n call debug_endmemberpar(endmemrec,lut,lokph,msl,epermut,&\r\n fractype,ceq)\r\n!----------------------------------------------------------\r\n if(gx%bmperr.ne.0) goto 1100\r\n! write(*,*)'Listed excess parameters ',&\r\n! epermut,endmemrec%noofpermut\r\n! Excess parameters based on this endmember, also permutations ...\r\n pmq=1\r\n intlevel=0\r\n intrec=>endmemrec%intpointer\r\n interloop: do while(associated(intrec))\r\n! return here if the interaction ?? maybe use cycle ? in gtp3X\r\n200 continue\r\n! each interaction has two pointer, to higher and to same level\r\n! push link to same level on intstack and follow highlink\r\n intlevel=intlevel+1\r\n intstack(intlevel)%save=>intrec%nextlink\r\n pmq=intrec%order\r\n! write(*,*)'3EX interaction level ',intlevel\r\n! this is label 220 also in gtp3X.F90\r\n220 continue\r\n bford: if(chkperm) then\r\n! complicated handling of permuted interaction parameter, see gtp3X,F90\r\n! copied from gtp3X.F90\r\n setipermut: if(maxpmq(pmq).eq.0) then\r\n ipermut=1; lastpmq(pmq)=ipermut\r\n! should I use gz%intlevel ??\r\n maxpmq=intrec%noofip(intlevel)\r\n plimit: if(ipermut.gt.maxpmq(pmq)) then\r\n level: if(intlevel.eq.1) then\r\n maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(1)\r\n elseif(intlevel.gt.2) then\r\n write(*,*)'3EX permutation max intlevel 2'\r\n gx%bmperr=4340; goto 1000\r\n else\r\n varying: if(intrec%noofip(1).eq.1) then\r\n maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2)\r\n if(ipermut.le.maxpmq(pmq)) goto 230\r\n else\r\n! complicated, see gtp3X at same place ....\r\n nz=intrec%noofip(1)\r\n if(maxpmq(pmq).gt.0) then\r\n if(intrec%noofip(1).eq.2) then\r\n maxpmq(pmq)=-maxpmq(pmq)\r\n else\r\n nz=mod(ipermut-1,intrec%noofip(1))\r\n if(nz.eq.0) then\r\n maxpmq(pmq)=maxpmq(pmq)\r\n else\r\n maxpmq(pmq)=maxpmq(pmq)+&\r\n intrec%noofip(nz+1)\r\n endif\r\n endif\r\n if(ipermut.le.maxpmq(pmq)) goto 230\r\n else\r\n maxpmq(pmq)=intrec%noofip(2)-&\r\n maxpmq(pmq)\r\n if(ipermut.le.maxpmq(pmq)) goto 230\r\n endif\r\n endif varying\r\n endif level\r\n if(associated(intrec%highlink)) then\r\n if(intlevel.eq.2) then\r\n write(*,*)'3EX too high interaction'\r\n gx%bmperr=4340; goto 1000\r\n endif\r\n goto 290\r\n endif\r\n if(intlevel.eq.0) exit interloop\r\n pmq=intrec%order\r\n nullify(intrec)\r\n goto 295\r\n endif plimit\r\n230 continue\r\n endif setipermut\r\n! this value of ipermut should vary with permutations \r\n write(*,*)'3EX ipermut: ',ipermut\r\n lastpmq(pmq)=ipermut\r\n else\r\n ipermut=1\r\n endif bford\r\n!----------------------------------------------------------\r\n! list excess parameters with permutationer\r\n! subroutine debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq)\r\n call debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n!----------------------------------------------------------\r\n! jump to 290 take higher excess several times for same lower order permutation\r\n290 continue\r\n! jump to 295 take higher excess ??\r\n295 continue\r\n! take highlink, if empty (not associated) pop intstack(level)\r\n intrec=>intrec%highlink\r\n nextint: do while(.not.associated(intrec))\r\n! write(*,*)'3EX no higher link',intlevel\r\n if(intlevel.le.0) then\r\n exit nextint\r\n endif\r\n! intrec is set to the next interaction on same level, if empty decend furter\r\n intrec=>intstack(intlevel)%save\r\n intlevel=intlevel-1\r\n enddo nextint\r\n enddo interloop\r\n! loop the whole data structure for each permutation of this endmember!!!\r\n enddo empermut\r\n!-----------------------------------------\r\n! Done all permutations and interaction of this endmember record\r\n endmemrec=>endmemrec%nextem\r\n! write(*,*)'Next endmember',associated(endmemrec)\r\n enddo endmemloop\r\n! ?? check how this is used in calcg_internal in gtp3X.F90 ??\r\n write(*,*)'3EX Finished listing parameters for this phase'\r\n disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) &\r\n .and. btest(phmain%status2,csorder)) then\r\n! we have traversing some of the parameter tree.\r\n returnoradd: if(first) then\r\n! list (calculate) parameters in second (disordered) fraction set\r\n first=.false.\r\n! in gtp3X we calculate for the first fraction set twice, now as disordered\r\n! not needed for listing\r\n! goto 110\r\n! else\r\n! here gtp3X returns to sums the disordered and ordered results and \r\n! maybe subtracs ordered as ordered. Not needed when listing\r\n endif returnoradd\r\n else\r\n! Here adding the two fraction sets, skip when listing \r\n endif disord\r\n! loop if more fraction types, fractype incremented when loop starts\r\n enddo fractyp\r\n!----------------------------------------------\r\n! original label ...\r\n410 continue\r\n! fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then\r\n! both ordered and disordered listed above\r\n! write(*,*)'3EX Can be ignored?'\r\n! endif fractionsets\r\n! finished this phase\r\n1000 continue\r\n write(lut,1010)trim(phlista(lokph)%name)\r\n1010 format(/'End of listing for phase ',a/60('-')/)\r\n return\r\n! if error\r\n1100 write(*,*)'Some error: ',gx%bmperr\r\n goto 1000\r\n end subroutine list_phaseparameters\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine debug_endmemberpar\r\n!\\begin{verbatim}\r\n subroutine debug_endmemberpar(endmemrec,lut,lokph,msl,epm,fractype,ceq)\r\n! code to write a debug list of endmembers\r\n! lokph is phlista index, lut is output unit\r\n! cps is phase_varres record, ceq is equilibrium record\r\n implicit none\r\n integer lut,lokph,msl,epm,fractype\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_endmember), pointer :: endmemrec\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n! type(gtp_phase_varres), target :: cps\r\n!\\end{verbatim}\r\n integer ll,idlist(9),id,ip,nsl\r\n character endmemconst*80\r\n character props*60\r\n TYPE(gtp_interaction), pointer :: intrec\r\n TYPE(gtp_pystack), pointer :: pystack\r\n TYPE(gtp_phase_add), pointer :: addrec\r\n! to remember for fractset 2\r\n save nsl\r\n!\r\n! write(*,*)'In debug_endmemberpar',msl\r\n endmemconst=':'\r\n ip=2\r\n if(fractype.eq.1) then\r\n! >>>>>>>>> to be added: special for I2SL \r\n! save value of msl for use for fractype 2\r\n nsl=msl\r\n pyqloop: do ll=1,msl\r\n! id is sequatial index of constituent over all sublattices ...\r\n id=endmemrec%fraclinks(ll,epm)\r\n idlist(ll)=id\r\n if(id.lt.0) then\r\n endmemconst(ip:)=\"*:\"\r\n ip=ip+2\r\n else\r\n! orderd or only fraction set has same constituents in sublattice 1 as ordered\r\n endmemconst(ip:)=&\r\n trim(splista(phlista(lokph)%constitlist(id))%symbol)//':'\r\n ip=len_trim(endmemconst)+1\r\n endif\r\n enddo pyqloop\r\n else\r\n! fractype 2, \r\n! If msl=2 then constituents in first and last sublattice, else just in first\r\n! this is SPECIES index, alphabetical order. Index in SPLISTA is SPECIES(..)\r\n idlist(1)=species(endmemrec%fraclinks(1,epm))\r\n endmemconst=':'//trim(splista(idlist(1))%symbol)//':'\r\n if(msl.eq.2) then\r\n ip=len_trim(endmemconst)+1\r\n! write(*,*)'3EX 2nd disordered sublattice: ',idlist(2),species(idlist(2))\r\n idlist(2)=species(endmemrec%fraclinks(2,epm))\r\n endmemconst(ip:)=trim(splista(idlist(2))%symbol)//':'\r\n endif\r\n! write(*,*)'Constituent: :',trim(endmemconst),idlist(1),idlist(2)\r\n endif\r\n!\r\n proprec=>endmemrec%propointer\r\n write(*,*)'3EX Endmember: ',trim(endmemconst)\r\n write(lut,300,advance='no')trim(endmemconst)\r\n300 format(5x,'Endmember ',a,i3)\r\n! >>>>>>>> to be added: special for liquid2state \r\n if(associated(proprec)) then\r\n props=' '\r\n id=1\r\n do while(associated(proprec))\r\n props(id:)=proprec%modelparamid\r\n id=len_trim(props)+2\r\n proprec=>proprec%nextpr\r\n enddo\r\n! this is added to the line with the constituents\r\n write(lut,310)epm,trim(props)\r\n310 format(i3,', MPIDs: ',a)\r\n else\r\n write(lut,320)epm\r\n320 format(i3,', none')\r\n endif\r\n1000 continue\r\n return\r\n end subroutine debug_endmemberpar\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable debug_excesspar\r\n!\\begin{verbatim}\r\n subroutine debug_excesspar(intrec,lut,lokph,ipermut,intlevel,ceq)\r\n! code to debug list and endmember\r\n! lokph is phlista index, lut is output unit\r\n! cps is phase_varres record, ceq is equilibrium record\r\n implicit none\r\n integer lut,lokph,msl,epm,intlevel\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_interaction), pointer :: intrec\r\n! TYPE(gtp_endmember), pointer :: endmemrec\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n! type(gtp_phase_varres), target :: cps\r\n!\\end{verbatim}\r\n integer nn,ll,isp,id\r\n character props*60\r\n! from gtp3X:\r\n integer ipermut,intlat,ic,pmq\r\n!\r\n! write(*,*)'3EX In debug_excesspar',intlevel,chkperm,ipermut\r\n intlat=intrec%sublattice(ipermut)\r\n ic=intrec%fraclink(ipermut)\r\n if(intlat.le.0 .or. ic.le.0) then\r\n write(*,*)'3EX illegal interaction constituent'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! ic is a sequential index to constituent fractions ... not species index\r\n! extract the species number from phmain ...\r\n! iliqsave and iliqva used in gtp3X but not here as we do not calculate anything\r\n! but we can have wildcards ... maybe??\r\n isp=phlista(lokph)%constitlist(ic)\r\n! write(*,10)'3EX excess constituent/sublattice ',isp,ic,&\r\n! trim(splista(isp)%symbol),trim(splista(species(isp))%symbol)\r\n!10 format(a,2i4,' symbol: ',a,' or ',a)\r\n!\r\n proprec=>intrec%propointer\r\n props='MPIDs: '\r\n if(associated(proprec)) then\r\n id=8\r\n do while(associated(proprec))\r\n props(id:)=proprec%modelparamid\r\n id=len_trim(props)+2\r\n proprec=>proprec%nextpr\r\n enddo\r\n endif\r\n if(len_trim(props).eq.6) props='none'\r\n write(*,100)intlevel,trim(splista(isp)%symbol),intlat,trim(props)\r\n write(lut,100)intlevel,trim(splista(isp)%symbol),intlat,trim(props)\r\n100 format(10x,'Excess level ',i3,' ',a,'@',i1,', ',a)\r\n! bford: if(chkperm) then\r\n! internal loop for for permutations for FCC/HCP and BCC with this endmember\r\n! write(*,*)'3EX this excess has permutations'\r\n! endif bford\r\n1000 continue\r\n return\r\n end subroutine debug_excesspar\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n" }, { "path": "src/models/gtp3EY.F90", "content": "!----------------------------\r\n! Reading the XTDB file with AppendXTDB: Models, parameters, TPfun and Biblio\r\n! 1. All data on original file. It may have to be rewinded for missing TPfuns\r\n! 2. One can select a subset of elements. All species which can form from\r\n! this subset are entered.\r\n! 3. An external Model file, this is read initially and never again\r\n! 4. The original file is then read to the end and phases, parameters entered\r\n! If TPfun missing the file may be rewinded and reread severel times\r\n! until the number of missing TPfuns/bibitems are zero or constant.\r\n! 5. One can have an external parameter file which will be read once.\r\n! Needed parameters are entered and file closed. Preferably no TPfuns\r\n! 6. One can have an external TPfuns file which is read and rewinded\r\n! to extract missing TPfuns until no TPfun entered from this file.\r\n! Warning of duplicates of same TPfuns.\r\n! 7. One can have a file with biblitems which is opende if there are\r\n! missing bibitems at the end.\r\n! 8. If there ate missing TPfun or bibitem at the end that is reported.\r\n!----------------------------\r\n!\r\n! The values for modelappy, parappy, tpfunappy, biblioappy initiates to 0\r\n! if there are no associated file:\r\n! modelappy=1 if there is an AppendXTB Model file. Read once and set to zero\r\n! parappy=1 if there is an AppendXTB parameter file. Read once and set to zero\r\n! tpfunappy=1 if there is an AppendXTB TPfun file. Read once and \r\n! incremented by one for each rewind. Stop rewinding and set to 0\r\n! when number of missing TPfuns is zero or do not decrease.\r\n! biblioappy=1 if the is a biblogapy file. Read once and set to zero.\r\n! allappy is 0 initially. It is set to 1 while reading parappy and tpfunappy\r\n! files. If the masterfile is rewinded allappy is set to 2 o 3\r\n! to prevent reading anythng except TPfun/Trange and bibitem tags.\r\n!\r\n!----------------------------\r\n! To do:\r\n! 1. Clean up a bit, remove duplicate variables\r\n! 2. Reread masterfile for TPfuns if no AppendXDB file\r\n! 3. Store complete attribute for each tag in selxx temporary storage\r\n\r\n!------------------------------\r\n!\r\n! Module xtdblib\r\n! program to read an xml file, in particular XTDB\r\n! implicit none\r\n! this contais tags, attributes and some global variables\r\n! #include \"gtp3_xml.F90\"\r\n!\r\n! integer nselph\r\n!\r\n!==================================================================\r\n! contains\r\n!==================================================================\r\n! \r\n! subroutines and functions\r\n!\r\n! xtdbread(masterfile) \r\n! read a whole database. This may open and read other AppendXTDB files\r\n!\r\n! xtdbtag(unit,fline,tagname,matt,pretag,attributes)\r\n! extract all attributes of tag from the file in sequential order.\r\n! fline is the line number. The tag can depend om other nested tags.\r\n!\r\n! logical function getatt(line,ip,attname,value)\r\n! extract sequentially the attributes and their values within \"\" from line\r\n! The value should be all spaces and for the first attribute ip should be 1\r\n!\r\n! - The important tags on a single XTDB file are:\r\n! Model, Element, Species, Phase (and nested tags), Parameter, Tpfun, Trange \r\n! but as a TPfun may use other TPfun the file may be rewinded to find all\r\n! - A first sequential read will pick up all phases parameters selected but\r\n! as TPfuns may call other TPfuns and it may be necessary to rewind the file.\r\n! - The program keeps track of all needed TPfuns and may rewind to find them.\r\n! - All bibliographic references are stored until reading the bibliography.\r\n! - An AppendXTDB file for models is recommended if the database may be\r\n! used by different software.\r\n!\r\n! For large databases the the primary XTDB file should contain all\r\n! AppendXTDB, Element, Species, Phase (and nested tags)\r\n! On separate AppendXTDB file one can have:\r\n! a file sith model information \r\n! a file with Parameter and Trange tags (which is read only once)\r\n! a file with TPfun and Trange tags which is rewinded until all TPfuns extracted\r\n! a file with bibliograpgic refenences (read once at the end)\r\n! The Parameter file can contain TPfuns but it will not be rewinded\r\n! The TPfun file may contain Parameters but it should be as short as possible\r\n! as it may be rewinded several times.\r\n! An AppendXTDB file should start with and end with \r\n!\r\n! The XTDB tags, attributes and some global data and variables \r\n! are in gtp3_xml.F90\r\n!\r\n! Some routines in this file:\r\n! subroutine xtdbread(filename,nel,elnames)\r\n! open filename and read an XTDB file including ApendXTDB files and\r\n! extracts tag and data for nel elemsnte for storing in thermodynamic softaware\r\n! if nel=0 the elements in the satabase is returned\r\n!\r\n! subroutine xtdbtag(unit,fline,tagname,matt,pretag,attributes)\r\n! reads lines from unit until the end of attributes of a tag\r\n! If matt=1 a nested tag found with tagname and attributes\r\n! matt=0 a complete tag found with tagname and attributes\r\n! matt=-1 the end of a nested tag found and some action needed\r\n! Maybe pretag in not needed inside xtdbtag?\r\n!\r\n! logical function getatt(attributes,ip,attname,values)\r\n! extracts sequentially from attributes the attname and its values using ip\r\n! True if it finds and attribute\r\n!\r\n! logical function xeolch(line,ip)\r\n! Skipping spaces and TAB characters in \"line\" from \"ip\". True if no data\r\n!\r\n!* logical function check_mpid(mpid,phase)\r\n! Check that phase has a model corresponding to the MPID of a parameter\r\n!\r\n!--------------------------------------------------------\r\n \r\n subroutine xtdbread(masterfile,nel,el)\r\n! To read xtdb files and extract tags and attributes including nesting\r\n implicit none\r\n character*(*) masterfile\r\n character*2 el(*)\r\n integer nel\r\n! if nel=0 extract all elements from database\r\n!----------------------------\r\n! Reading the XTDB file with AppendXTDB: Models, Parameters, TPfun and Biblio\r\n! 1. All data on original file. It may be rewinded for missing TPfuns\r\n! 2. If there is an external Model file it is read and closed before any data.\r\n! 3. The original file is then read to EOF and phases, parameters and \r\n! missing TPfuns and bibliographic refs are read. File will not be closed!\r\n! DUPLICATE TPfuns will always be reported as errors, keeping first case.\r\n! 4. If there is an external parameter file (WITHOUT ANY TPFUNS) this is\r\n! opened and parameters needed are entered and the file closed at EOF.\r\n! Any TPfuns found will be create a warning but entered if needed.\r\n! This file will not be rewound. \r\n! 5. If there is an external TPfuns file this is opened and read to extract\r\n! missing TPfuns, it may be rewinded several times until no \r\n! missing TPfun found and then it will be closed.\r\n! 6. If there are TPfuns or biblitems missing the original XTDB file will\r\n! be rewinded and read again until no missing TPfuns or bibitems found\r\n! and the file closed\r\n! 7. If TPfun or bibitem missing now that will be reported.\r\n!----------------------------\r\n! line is line read from file\r\n character line*256,tagname*64\r\n! tag attributes\r\n! character(len=:), allocatable :: attributes ! this does not work\r\n! character attributes*(1024)\r\n character(len=:), allocatable :: attributes\r\n! the global character wholexpr is concatinated Expr for TPfun or Parameter\r\n! The different files used for reading the XTDB files\r\n! The database can be a single (primary) file or split on several files.\r\n! All elements and phases and extra files must be in the primary file\r\n! The extra files can define models, parameters, tpfuns and bibliography\r\n! The model file is not needed but defines the MPIDs\r\n! The parameter file should only have Parameter and Trange tags\r\n! The tpfun file should only have TPfun and Trange tags\r\n! The bibliography file should only have bibliograpgy and bibitem tags\r\n integer unit ! the current file used by xtdbget, any of those below\r\n integer, parameter :: unit1=21 ! main XTDB file, \r\n ! with everyting or just element and phases\r\n ! open the whole time, may be rewinded at the end\r\n integer, parameter :: unit2=22 ! parameter file read once and then closed\r\n integer, parameter :: unit3=23 ! tpfun file may be rewinded several times\r\n!\r\n! for nested tags level is current level, matt=0 if tagend missing (nesting)\r\n character pretag*24,values*256,attname*18\r\n integer tagno,matt\r\n! for storing data during nested tags, each at a higher level ?? needed\r\n integer, parameter :: maxatt=5\r\n character*256, dimension(maxatt) :: saveatt\r\n! tags with nested tagas are TPfun 1: Trange\r\n! character phaseid*24\r\n! Phase sublattices, 10xconstituents, crystalstructure, amendphase, disord ...)\r\n character phid*24,phconfig*24,phmodels*128,phstate*1\r\n! check of missing tpfun and missingbib\r\n integer prevmisstp,prevmissbib\r\n! extending an allocated variable ??\r\n!\r\n! extending an allocatable and already allocated array (data(m))\r\n! data = [ data, ( 0, kk=1,n ) ] see ternary extrapolation!\r\n! \r\n\r\n! curent line in a database file (mater or AppendXTDB\r\n integer fline\r\n! for tempraty storage of phase data\r\n integer phnsub,phisub\r\n character (len=:), allocatable :: lowt, default_lowt,tpfun\r\n character (len=:), allocatable :: hight,default_hight,expr\r\n character (len=:), allocatable :: parid,bibref\r\n character*16 usedtpfun ! is tpfun found in Expr of Parameter or TPfun\r\n\r\n logical listphases,add,ternaryxwarning\r\n\r\n! handling of AppendXTDB\r\n! The Models must be read first and only once\r\n! The Parameters after reading the phases and only once\r\n! The TPfun after all paramaters and maybe several times\r\n! The Bibiliography read last and and only once\r\n! Bibilographic references\r\n character(len=:), allocatable :: currentfile\r\n character ch1*1,spel*24,spname*24,stoichiometry*80,mqmqa*40,uniquac*12\r\n character stoisp*40,refstate*40,phname*24\r\n character(len=:), allocatable :: addon\r\n character(len=:), allocatable :: xpoldata\r\n! for disorderedpart\r\n character (len=:), allocatable :: sum,disph,sub\r\n character*2 element\r\n!\r\n! for various purposes\r\n double precision mass, h298, s298\r\n integer ip,iq,ir,is,it,level,prevlev,lk,kk,semicolon,lph,jp\r\n integer missbib,unknowntp,jel,skip,rewinds\r\n type(octerxpol), allocatable, target :: terxpol\r\n!\r\n! initiate position in arrays for storing selected information\r\n! We automatically introdce Va\r\n! We may have to order elements and species alphabetically!!\r\n nselel=0; nselsp=1; nselph=0; nselpar=0; nseltp=0; nselbib=0\r\n\r\n! software defaults\r\n default_lowt='298.15'\r\n default_hight='6000'\r\n debug=.false.\r\n rewinds=0\r\n ternaryxwarning=.true.\r\n!\r\n! write(*,*)'3EY xtdbread: ',trim(masterfile),nel\r\n! data for missing and found AppendXTDB, initiated to 0 below\r\n! when specified set -1, while reading +1, when read 0\r\n! allappy initially set to 0, set to 1 when any other AppendXTDB file read\r\n if(nel.eq.0) then\r\n! write(*,*)'Just to know which elements are in the database'\r\n ignorEOT=.true.\r\n else\r\n ignorEOT=.false.\r\n do jel=1,nel\r\n call capson(el(jel))\r\n enddo\r\n write(*,8)(el(jel),jel=1,nel)\r\n8 format(/'Extract data for: ',20(a,x))\r\n! array for bibliographic references, selbib, for selected parameter below\r\n! allocate arrays for storing data, related to number of elements\r\n listphases=.true.\r\n maxtdbel=nel+2; maxtdbsp=10*nel*(nel-1); maxtdbph=5*nel*(nel+1); \r\n maxpar=20*nel*(nel+1)*(nel+2)\r\n maxtp=30*nel*(nel+1); maxbib=5*nel*(nel+1)*(nel+2)\r\n if(allocated(selel)) then\r\n! deallocate all\r\n deallocate(selel)\r\n deallocate(selsp)\r\n deallocate(selph)\r\n deallocate(selpar)\r\n deallocate(seltpfun)\r\n deallocate(selbib)\r\n endif\r\n allocate(selel(-1:maxtdbel))\r\n if(debug) write(*,9)'Dimensioning:',&\r\n maxtdbel,maxtdbsp,maxtdbph,maxpar,maxtp,maxbib\r\n9 format(a,6i7)\r\n! Always include Va and /- as element -1 and 0\r\n selel(-1)%elname='/-'; selel(-1)%data=' '\r\n selel(0)%elname='VA'; selel(0)%data=' '\r\n allocate(selsp(maxtdbsp))\r\n! allocate(selspord(maxtdbsp)) allocated later\r\n selsp(1)%species='VA'; selsp(1)%data='VA'; selsp(1)%charge=0.0D0\r\n! needed for Va as species\r\n allocate(selsp(1)%elnames(1));\r\n allocate(selsp(1)%stoicc(1));\r\n selsp(1)%elnames='Va'; selsp(1)%stoicc(1)=1.0D0\r\n!\r\n allocate(selph(maxtdbph))\r\n allocate(selpar(maxpar))\r\n allocate(seltpfun(maxtp))\r\n allocate(selbib(maxbib))\r\n endif\r\n! When just returning all elements\r\n jel=0\r\n! AppendXTB files\r\n allappy=0\r\n modelappy=0; parappy=0; tpfunappy=0; biblioappy=0\r\n prevmisstp=0; missingtp=0; prevmissbib=0; missingbib=0\r\n!\r\n nselbib=0\r\n!\r\n! write(*,*)'Opening XTDB file: ',trim(masterfile)\r\n unit=unit1\r\n fline=0\r\n open(unit,file=masterfile,&\r\n access='sequential',form='formatted',status='old')\r\n! zero main file line number\r\n currentfile=masterfile\r\n! zero position in characters containing attributes\r\n attpos=0\r\n attributes=' '\r\n tpfun=' '\r\n! initiate tag nesting\r\n level=0\r\n matt=0\r\n pretag=' '\r\n xtdberr=0\r\n nomorelements=.FALSE.\r\n!\r\n! big loop for reading everything\r\n!==============================================================\r\n readall: do while(.true.)\r\n! only one tag per line, attributes can be on following lines\r\n if(line(1:2).eq.''\r\n!========================= handling end of nested tags\r\n elseif(matt.eq.-1) then\r\n!========================= nested TPfun =========\r\n! if matt=-1 the line is end of nested pretag, decrease level !!??\r\n! write(*,*)' >>>Nested tag end: \"',&\r\n! trim(tagname),'\" pretag: \"',trim(pretag),'\" ',level,fline\r\n if(trim(pretag).eq.'' .or. trim(pretag).eq.'') then\r\n!================== end of file: or \r\n! Here we are at the end of the primary file or an AppendXTDB file\r\n! The ModelXTDB is read when found, the other will be opened for read here\r\n if(debug) write(*,*)'End of file for: ',trim(currentfile)\r\n prevmisstp=missingtp\r\n missingtp=0\r\n do ntp=1,nseltp\r\n if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1\r\n enddo\r\n prevmissbib=missingbib\r\n missingbib=0\r\n do ntp=1,nselbib\r\n if(selbib(ntp)%status.lt.0) missingbib=missingbib+1\r\n enddo\r\n if(debug) then\r\n write(*,*)'Number of TPfuns found and missing:',nseltp,missingtp\r\n write(*,*)'Number of bibitem found and missing:',&\r\n nselbib,missingbib\r\n! The principal XTDB file is not closed, it may be rewinded in the end\r\n write(*,47)parappy,tpfunappy,biblioappy,allappy\r\n47 format('Any AppendXTDB files to read?',4i3)\r\n write(*,*)'Press return to continue 1',tpfunappy\r\n read(*,'(a)')ch1\r\n endif\r\n! if there is an AppendXTDB for Parameters read that now!\r\n! The Parameter file is done first (well actually the ModelAPpendXTDB)\r\n if(parappy.eq.1) then\r\n if(debug) write(*,*)'Appending Parameter file: ',trim(parappx)\r\n!----------------------------------------------------------\r\n! allappy set to unity indicate only parameter, tpfun and trange tags allowed\r\n allappy=1\r\n! parappy set to 0 as it it read only once\r\n parappy=0\r\n unit=unit2\r\n fline=0\r\n open(unit,file=parappx,access='sequential',&\r\n status='old',form='formatted')\r\n if(debug) write(*,*)' *** Opened ',trim(parappx),' line',fline\r\n currentfile=parappx\r\n! Now read parameters from appendixfile\r\n cycle readall\r\n elseif(tpfunappy.eq.1) then\r\n!----------------------------------------------- tpfuns\r\n! if there is an AppendXTDB for Tpfuns read that, maybe including rewinds\r\n! This file may have to be rewinded if there are unknown TPfuns\r\n! missingtp and missingbib set to zero initially\r\n ignorEOT=.true.\r\n allappy=2\r\n tpfunappy=tpfunappy+1\r\n if(unit.eq.unit2) then\r\n! We may not have opend any parameterappendix but of so, close it\r\n if(debug) write(*,*)'Closing append file: ',trim(parappx)\r\n close(unit2)\r\n endif\r\n if(debug) write(*,*)'Appending TPfun file: ',trim(tpfunappx)\r\n unit=unit3\r\n fline=0\r\n open(unit,file=tpfunappx,access='sequential',&\r\n status='old',form='formatted')\r\n if(debug) write(*,*)' *** Opened ',trim(tpfunappx)\r\n currentfile=tpfunappx\r\n! Now read TPfuns from appendixfile\r\n cycle readall\r\n elseif(tpfunappy.ge.2) then\r\n!----------------------------------------- maybe rewind the TPfun file?\r\n! we may have to rewind the TPfunappx file if there are unknown TPfuns\r\n if(debug) write(*,401)nseltp,prevmisstp,missingtp\r\n401 format('Of ',i4,' TPfun missing changed from ',i4,' to ',i4)\r\n if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then\r\n prevmisstp=missingtp\r\n if(debug) then\r\n write(*,*)'Press return to Rewind ',trim(tpfunappx)\r\n read(*,'(a)')ch1\r\n endif\r\n! Rewind appendixfile and read again (maybe several times)\r\n! as TPfuns may use other TPfuns\r\n fline=0\r\n rewind(unit)\r\n cycle readall\r\n else\r\n! The number of missing TPfuns does not decrease after rewinding\r\n! Either all TPfuns found or the missing are not on tpfunappx\r\n if(debug) write(*,*)'Closing tpfunfile: ',trim(tpfunappx)\r\n tpfunappy=0\r\n close(unit)\r\n endif\r\n! if there is a biblioappy read this here \r\n! It is also read in the following elseif but that is outside this scope\r\n if(biblioappy.gt.0) then\r\n fline=0\r\n if(debug) write(*,410)trim(biblioappx)\r\n410 format(/'Appending bibliography 1: ',a)\r\n! the file is opended and read separatelym only bibitems allowed\r\n biblioappy=0\r\n call xtdbbiblio(biblioappx)\r\n if(debug) write(*,*)'Back from reading bibliography'\r\n missingbib=0\r\n do ntp=1,nselbib\r\n if(selbib(ntp)%status.lt.0) missingbib=missingbib+1\r\n enddo\r\n! if there are missing tpfuns and/or biblographics rewind and read the main file\r\n if(missingtp.gt.0 .or. missingbib.gt.0) then\r\n if(debug) write(*,491)missingtp,missingbib,masterfile\r\n491 format('Missing data, ',2i4,' rewinding: ',a)\r\n! allappy=3 means only Bibitem and TPfun tags read\r\n ignorEOT=.true.\r\n allappy=3\r\n fline=0\r\n unit=unit1 \r\n currentfile=masterfile\r\n rewind(unit)\r\n cycle readall\r\n endif\r\n elseif(missingtp.gt.0 .or. missingbib.gt.0) then\r\n! a final try rewinding and rewind and read again from primary file\r\n rewinds=rewinds+1\r\n! write(*,*)'Rewinding masterfile A',rewinds\r\n unit=unit1\r\n currentfile=masterfile\r\n rewind(unit)\r\n cycle readall\r\n endif\r\n elseif(biblioappy.eq.1) then\r\n! We can be here if there is no AppendXTDB for TPfuns\r\n! if there is an AppendXTDB for bibliography read that now!\r\n! There may also be a tag in the main file? \r\n if(debug) write(*,*)'Appending bibliography: ',trim(biblioappx)\r\n biblioappy=0\r\n call xtdbbiblio(biblioappx)\r\n if(debug) write(*,*)'Back from reading bibliography'\r\n prevmisstp=missingtp\r\n missingtp=0\r\n do ntp=1,nseltp\r\n if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1\r\n enddo\r\n prevmissbib=missingbib\r\n missingbib=0\r\n do ntp=1,nselbib\r\n if(selbib(ntp)%status.lt.0) missingbib=missingbib+1\r\n enddo\r\n if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then\r\n! to avoid rewind masterfile forever\r\n prevmisstp=0\r\n fline=0\r\n if(debug) write(*,*)'Found missing data, rewinding: ',&\r\n masterfile,fline\r\n! we must ignore all tags except TPfun/Trange and Bibitem\r\n allappy=3\r\n rewinds=rewinds+1\r\n! write(*,*)'Rewinding masterfile B',rewinds\r\n unit=unit1\r\n currentfile=masterfile\r\n rewind(unit)\r\n cycle readall\r\n else\r\n! time to close when TPfuns as well as masterfile rewinded\r\n fline=0\r\n if(debug) write(*,321)trim(masterfile)\r\n321 format('3EY Finished reading XTDB file: ',a)\r\n unit=unit1\r\n goto 990\r\n endif\r\n else\r\n! reading bibliography AppendXTB if there is no AppendXTDB for TPfuns\r\n if(debug) write(*,*)'Applied all AppendXTDB (or none)'\r\n missingtp=0\r\n do ntp=1,nseltp\r\n if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1\r\n enddo\r\n prevmissbib=missingbib\r\n missingbib=0\r\n do ntp=1,nselbib\r\n if(selbib(ntp)%status.lt.0) missingbib=missingbib+1\r\n enddo\r\n if(rewinds.gt.0.and.missingtp.eq.0) write(*,324)trim(masterfile)\r\n324 format('All TPfuns found, closing ',a)\r\n! if(missingtp.gt.0 .and. missingtp-prevmisstp.gt.0) then\r\n if(missingtp.gt.0 .and. rewinds.lt.3) then\r\n allappy=3\r\n fline=0\r\n rewinds=rewinds+1\r\n write(*,322)missingtp-prevmisstp,trim(masterfile),rewinds\r\n322 format('3EY Missing ',i3,' TPfuns, rewinding: ',a,i3)\r\n! try reading the masterfile once again, \r\n! write(*,*)'Rewinding masterfile C',rewinds\r\n currentfile=masterfile\r\n unit=unit1\r\n rewind(unit)\r\n cycle readall\r\n else\r\n! time to close when there is no TPfuns file and masterfile has been rewinded\r\n if(debug) then\r\n write(*,*)'Finished 2, closing: ',trim(masterfile)\r\n write(*,491)missingtp,missingbib,masterfile\r\n write(*,321)trim(masterfile)\r\n endif\r\n unit=unit1\r\n write(*,*)'Closing file 1'\r\n goto 990\r\n endif\r\n endif\r\n!========================= Below handling end of nested tags\r\n elseif(trim(pretag).eq.'') then\r\n! a nested tag has the end of tag on a single line\r\n!======================== end of nested and Trange\r\n! simple TPfun without Trange are entered below\r\n! check if the TPfun should be add(ed) (used in a Parameter or other TPfun\r\n call xtdbentertpfun(tpfun,add)\r\n if(add) then\r\n call OCentertpfun(tpfun)\r\n! the expression is stored in the global wholexpr\r\n endif\r\n elseif(trim(pretag).eq.'') then\r\n!======================== end of Phase, always nested\r\n! The end of Phase tag (always nested) \r\n wholexpr=phrec%confent//' '//phrec%state//' '//phrec%clist(1)%list\r\n! inside OCenterphase the phase may be added to selph if constituents entered\r\n call OCenterphase(phrec)\r\n! write(*,201)fline,phrec%id,phrec%confent,phrec%state,&\r\n! phnsub,phrec%mult\r\n201 format(/'Collected all phase data: ',i7/&\r\n 'Phase name: ',a,5x,a,5x,a,5x,i2,5x,a)\r\n! do ip=1,phnsub\r\n! write(*,202)phrec%clist(ip)%subx,phrec%clist(ip)%list\r\n202 format('Sublattice: ',a,' Constituents: ',a)\r\n! enddo\r\n!>>>>>>> create record for phase and store data in OC <<<<<<<<<<<<<\r\n! clear for next phase by deallocate the whole phrec\r\n deallocate(phrec)\r\n elseif(trim(pretag).eq.'') then\r\n!======================== end of Sublattices tag, part pf Phase\r\n! Update level here for next tag, done separately here as code is messy\r\n! Note that the ') then\r\n!========================= end of nested Parameter, may include Trange\r\n! The end of a nested Parameter tag, non-nested parameters treated below \r\n! A nested parameter contains Trange records\r\n! write(*,*)'Found end of nested add ',bibref\r\n! the ' N ' to be compatible with TDB files ... add bibref inside xtdbOCfun\r\n! NOTE wholexpr is an allocated character\r\n wholexpr=wholexpr//' N'\r\n if(.not.allocated(bibref)) bibref=' '\r\n call OCenterpar(parid,skip,bibref)\r\n! if skip negative the parameter is not entered\r\n elseif(trim(pretag).eq.'') then\r\n!========================= end of nested Bibliography, nothing to do\r\n continue\r\n! write(*,*)' End of Bibliography'\r\n else\r\n! still with matt=-1, nested tags without special action ...\r\n! write(*,667)trim(tagname),trim(pretag),matt,level,allappy, fline\r\n! Probably end of file ...\r\n if(debug) write(*,*)'End of file at ',fline\r\n continue\r\n667 format(' Unknown end of nested tag: \"',a,'\" \"',a,'\"',5i7)\r\n endif\r\n!============================ prepare to read next tag, matt=-1\r\n! We have to decrease the nesting level and prepare for reading a new tag\r\n level=level-1\r\n if(level.gt.0) then\r\n! it must be wrong to set pretag same as tagname ??\r\n pretag=''\r\n else\r\n! Level 0 means we have read the whole xtdb file, we should never be here\r\n! write(*,*)'We have read past end of '\r\n continue\r\n endif\r\n cycle readall\r\n! Done all for end of nested tag, matt=-1\r\n!============================ end of actions for all nested tags, matt=-1\r\n endif\r\n! Here matt=0 or 1, maybe we need to save attributes\r\n! write(*,660)trim(tagname),trim(pretag),matt,fline\r\n660 format('660 Tag: \"',a,'\" pretag \"',a,'\" ',i3,i7)\r\n!\r\n if(matt.ge.0) then\r\n if(tagname(1:1).eq.' ') then\r\n! This should not appear\r\n! for rewind of masterfile it is OK\r\n if(allappy.eq.0) write(*,*)'xtdbtag found no tag on line ',&\r\n fline,matt,allappy\r\n cycle readall\r\n endif\r\n else\r\n! we have found the end of a nested tag\r\n write(*,*)'Handle end of nested tag: ',trim(tagname),matt,level,fline\r\n endif\r\n! check if we have reached endoffile, maybe rewind and read again?\r\n if(fline.lt.0) then\r\n! unless there are errors one should never come here\r\n write(*,*)'Closing file 3'\r\n goto 990\r\n endif\r\n!======================================= select case for a new tag\r\n! The tags and attribues are defined in gtp3_xml.F90\r\n lk=len_trim(tagname)+1\r\n tagno=0\r\n findtag: do kk=1,nxtdbtags\r\n! compare ignoring trailing spaces\r\n if(tagname(1:lk).eq.xtdbtags(kk)(1:lk)) then\r\n tagno=kk;\r\n! Abbreviated tags not allowed\r\n if(xtdbtags(kk).eq.' ') exit findtag\r\n endif\r\n enddo findtag\r\n! write(*,99)tagname(1:lk),tagno,fline,level,matt\r\n99 format('99 Tag: ',a,', number',i3,', line: ',i7,', level: ',2i3)\r\n!\r\n!\r\n! detect tag\r\n!------------------------------------------\r\n select case(tagno)\r\n!------------------------------------------\r\n case default\r\n! process the XTD tag, sometimes nested tags depend on previous attributes\r\n write(*,*)' *** Unknown tag ignored: <',trim(tagname),'>'\r\n!------------------------------------------\r\n case(1) ! XTDB\r\n ip=1; values=' '\r\n! write(*,*)'XTDB: '\r\n! the getatt function extracts attribute name and value sequentially from ip\r\n do while(getatt(attributes,ip,attname,values))\r\n if(debug) write(*,38)trim(attname),trim(values)\r\n38 format(3x,'Att: ',a,' = ',a,i5)\r\n enddo\r\n!------------------------------------------\r\n case(2) ! Defaults\r\n ip=1; values=' '\r\n! write(*,*)'Defaults: '\r\n do while(getatt(attributes,ip,attname,values))\r\n! these should replace the software defaults such as LowT and HighT\r\n! write(*,38)trim(attname),trim(values)\r\n if(attname(1:8).eq.'Bibref') defaultbib=values\r\n enddo\r\n! lowT and highT should be used for parameters and TPfuns\r\n!------------------------------------------\r\n case(3) ! DatabaseInfo\r\n ip=1; values=' '\r\n! write(*,*)'DatabaseInfo: '\r\n! do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n! enddo\r\n!------------------------------------------\r\n case(4) ! AppendXTDB\r\n ip=1; values=' '\r\n! write(*,*)'AppendTDB files: '\r\n do while(getatt(attributes,ip,attname,values))\r\n! this will extract the attributes in any order\r\n! write(*,38)trim(attname),trim(values)\r\n! save appfiles in appropriate variables (declared in gtp3_xml\r\n! negative *appy means it is has to be done\r\n if(attname(1:6).eq.'Models') then\r\n modelappx=trim(values)\r\n modelappy=1\r\n endif\r\n if(attname(1:10).eq.'Parameters') then\r\n parappx=trim(values)\r\n parappy=1\r\n endif\r\n if(attname(1:6).eq.'TPfuns') then\r\n tpfunappx=trim(values)\r\n tpfunappy=1\r\n endif\r\n if(attname(1:12).eq.'Bibliography') then\r\n biblioappx=trim(values)\r\n biblioappy=1\r\n endif\r\n! Not implemented. Maybe useful for non-thermodynamic data?\r\n! if(attname(1:13).eq.'Miscellaneous') then\r\n! miscappx=trim(values)\r\n! miscappy=-1\r\n! endif\r\n enddo\r\n! list AppendXTDB file set\r\n! write(*,*)'AppendXTDB: ',modelappy,parappy,tpfunappy,biblioappy\r\n! if there is a Models appendix read that now!\r\n if(modelappy.eq.1) then\r\n call xtdbmodels(modelappx)\r\n! setting modelappy=0 means we have read it\r\n! The other AppendXTDB files opened after reading the primary file once\r\n modelappy=0\r\n endif\r\n!------------------------------------------\r\n case(5) ! Element, 5 attributes. some may be missing ...\r\n! ip=1; values=' '; mass=1.0D0; h298=0.0D0; s298=0.0D0\r\n! do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n! if(attname(1:2).eq.'Id') tpfun=trim(values)\r\n!------------------------------------------\r\n case(6) ! Species\r\n ip=1; values=' '\r\n! we need to know the elements of the species\r\n mqmqa=' '; uniquac=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n if(attname(1:2).eq.'Id') spname=trim(values)\r\n if(attname(1:13).eq.'Stoichiometry') stoisp=trim(values)\r\n if(attname(1:5).eq.'MQMQA') mqmqa=trim(values)\r\n if(attname(1:7).eq.'UNIQUAC') uniquac=trim(values)\r\n enddo\r\n! write(*,*)'Calling OCenterspecies: ',trim(spname),'\" \"',&\r\n! trim(stoisp),'\"'\r\n! in OCenterspecies there is a check if species can be formed from elements\r\n call OCenterspecies(spname,stoisp,mqmqa,uniquac)\r\n!------------------------------------------\r\n case(7) ! TPfun\r\n ip=1; values=' '\r\n if(matt.eq.0) then\r\n! matt=0 means no nested tags, matt=-1 is taken care of earler\r\n! We may have to read all TPfuns several times until all used has been found\r\n! matt=0 means there are no nested tranges\r\n lowt=default_lowt\r\n hight=default_hight\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n if(attname(1:2).eq.'Id') tpfun=trim(values)\r\n if(attname(1:4).eq.'LowT') lowt=trim(values)\r\n if(attname(1:4).eq.'Expr') expr=trim(values)\r\n if(attname(1:5).eq.'HighT') hight=trim(values)\r\n enddo\r\n! semicolon is accepted and added if not present\r\n semicolon=len_trim(expr)\r\n if(expr(semicolon:semicolon).eq.';') then\r\n expr(semicolon:semicolon)=' '\r\n semicolon=semicolon-1\r\n endif\r\n! terminate with N as in TDB files\r\n wholexpr=lowt//' '//expr(1:semicolon)//'; '//hight//' N'\r\n! check if the TPfun is needed, tpfun is Id of selph(lph)%terxpol\r\n allocate(selph(lph)%terxpol)\r\n selph(lph)%terxpol%next=>xpol\r\n xpol=>selph(lph)%terxpol\r\n else\r\n allocate(selph(lph)%terxpol)\r\n nullify(selph(lph)%terxpol%next)\r\n xpol=>selph(lph)%terxpol\r\n endif\r\n! no need to save the phase name, the data is linked from the phase\r\n xpol%phase=phname\r\n xpol%sps=addon(3:)\r\n xpol%xpol=xpoldata\r\n elseif(allocated(phrec)) then\r\n! the phase is not (yet) selected (maybe the xpol tag is inside the phase tag)\r\n if(.not.associated(firstxpol)) then\r\n! this is the first TernaryXpol without a selected phase\r\n allocate(firstxpol)\r\n nullify(firstxpol%next)\r\n xpol=>firstxpol\r\n else\r\n! add the new Xpol record first\r\n allocate(xpol)\r\n xpol%next=>firstxpol\r\n firstxpol=>xpol\r\n endif\r\n! enter data in xpol, we must use the phase name from current phase tag\r\n xpol%phase=trim(phrec%id)\r\n! write(*,*)'TernaryXpol inside phasetag: \"',&\r\n! xpol%phase,'\" \"',addon(3:),'\" \"',xpoldata,'\"'\r\n xpol%sps=addon(3:)\r\n xpol%xpol=xpoldata\r\n else\r\n write(*,*)'TernaryXpol for ',trim(phname),' ignored, line',fline\r\n cycle readall\r\n endif\r\n! if we arrive here the constituents are OK but we may not have a phase (lph=0)\r\n! write(*,*)'3EY TernaryXpol \"',xpol%phase,'\" ',lph\r\n!------------------------------------------\r\n case(28) ! UnarySystem has no interest for the software\r\n write(*,*)'Found UnarySystems 28'\r\n!------------------------------------------\r\n case(29) ! BinarySystem has no interest for the software\r\n write(*,*)'Found BinarySystem 29'\r\n!------------------------------------------\r\n case(30) ! TernarySystem has no interest for the software\r\n write(*,*)'Found TernarySystem 30' \r\n end select\r\n!------------------------------------------\r\n! end of file but maybe rewind and read for some special tag? such as TPfun\r\n900 continue\r\n! write(*,*)'At label 900, select case: ',tagno\r\n cycle readall\r\n!\r\n enddo readall\r\n! errors and end of file- ignoreEOT is true if just extracting elements\r\n990 continue\r\n! write(*,*)'At label 990'\r\n if(.not. ignorEOT) then\r\n! There can be TernaryXpol records not linked to a phase\r\n xpol=>firstxpol\r\n! nullify(lastxpol)\r\n fixpol: do while(associated(xpol))\r\n! Either xpol will be linked to a selph(lph)%terxpol or igored\r\n! write(*,*)'3EY There is an unlinked TernaryXpol for: ',xpol%phase\r\n! write(*,*)'Calling findabbrphname 2: \"',xpol%phase,'\"'\r\n call findabbrphname(xpol%phase,lph)\r\n if(lph.le.0) then\r\n write(*,*)'Ignore TernaryXpol as ',xpol%phase,' not selected'\r\n if(.not.associated(lastxpol)) then\r\n xpol=>xpol%next\r\n endif\r\n else\r\n! link the ternaryxpol to the phase\r\n write(*,*)'TernaryXpol included in phase ',&\r\n trim(selph(lph)%phasename)\r\n lastxpol=>xpol%next\r\n if(associated(selph(lph)%terxpol)) then\r\n xpol%next=>selph(lph)%terxpol\r\n else\r\n nullify(xpol%next)\r\n endif\r\n selph(lph)%terxpol=>xpol\r\n xpol=>lastxpol\r\n endif\r\n enddo fixpol\r\n! if(debug) then\r\n! write(*,*)'3Y End of file',unit\r\n write(*,993)nselel,nselsp,nselph,nselpar,nseltp,nselbib\r\n993 format(/'3EY nselel ',i4,' nselsp ',i4,' nselph ',i4,&\r\n ' nselpar ',i4,' nseltp ',i5,' nselbib ',i4/)\r\n! endif\r\n missingtp=0\r\n do ntp=1,nseltp\r\n if(seltpfun(ntp)%status.lt.0) missingtp=missingtp+1\r\n enddo\r\n prevmissbib=missingbib\r\n missingbib=0\r\n do ntp=1,nselbib\r\n if(selbib(ntp)%status.lt.0) missingbib=missingbib+1\r\n enddo\r\n endif\r\n if(debug .or. missingtp.gt.0 .or. missingbib.gt.0) then\r\n write(*,*)'Number of TPfuns and missing ones:',nseltp,missingtp\r\n write(*,*)'Number of bibref and missing ones:',nselbib,missingbib\r\n endif\r\n!\r\n999 continue\r\n close(unit)\r\n1000 continue\r\n! list or save all data in OC data structures\r\n if(.not.ignorEOT) then\r\n write(*,312)trim(masterfile),xtdberr\r\n312 format(/'Listing of selected data from XTDB file: ',a,', error: ',i5)\r\n call list_selected_xtdbdata\r\n endif\r\n return\r\n1100 continue\r\n write(*,*)'Error reading xtdbfile ',xtdberr\r\n goto 990\r\n!\r\n end subroutine xtdbread\r\n\r\n! \\/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\r\n\r\n subroutine list_selected_xtdbdata\r\n! temporary listing from xtdb local arrays\r\n!\r\n implicit none\r\n character line*128, charge*24, spline*24,ch1*1\r\n integer jj,kk,ip,lk,nn\r\n type(octerxpol), pointer :: terxpol\r\n! \r\n! if(missingtp.gt.0) then\r\n! write(*,491)missingtp,missingbib\r\n491 format('Missing TPfuns, bibitems: ',2i4)\r\n! endif\r\n!\r\n write(*,12)\r\n12 format(//'Finished reading the XTDB file, temporary listing')\r\n! list all elements, species, phases with constit, parameters, tpfuns and biblio\r\n! list all elements -------------------------------------------------\r\n write(*,311)\r\n311 format(//'Elements:')\r\n write(*,10)(selel(nn)%elname,nn=1,nselel)\r\n10 format('Elements entered: ',20(a,1x))\r\n!\r\n! list all species --------------------------------------------------\r\n write(*,299)\r\n299 format(/'Species:')\r\n if(allocated(selsp)) then\r\n do ntp=1,nselsp\r\n jj=selspord(ntp)\r\n charge=' '\r\n if(jj.le.0) write(*,*)'3EY selspord: ',ntp,jj,selsp(ntp)%species\r\n if(selsp(jj)%charge.ne.0.0d0) &\r\n write(charge,'(F10.6)')selsp(jj)%charge\r\n spline=selsp(jj)%species\r\n if(allocated(selsp(jj)%elnames)) then\r\n nn=size(selsp(jj)%elnames)\r\n lk=27\r\n do kk=1,nn\r\n write(line(lk:),23)selsp(jj)%elnames(kk),selsp(jj)%stoicc(kk)\r\n23 format(a,2x,F10.7)\r\n lk=lk+15\r\n enddo\r\n if(selsp(jj)%charge.ne.0.0D0)spline=trim(spline)//' charge '//charge\r\n else\r\n lk=len_trim(line)\r\n line(lk+3:)='MQMQA quad'\r\n endif\r\n write(*,24)ntp,trim(spline)\r\n24 format('Species: ',i3,2x,a)\r\n enddo\r\n endif\r\n!\r\n! list all selected phases --------------------------------------------\r\n write(*,*)'Press return to list selected phases'\r\n read(*,'(a)')ch1\r\n write(*,298)\r\n298 format(/'Phases:')\r\n do ip=1,nselph\r\n write(*,69)trim(selph(ip)%phasename),selph(ip)%confent,&\r\n selph(ip)%nsublat,trim(selph(ip)%mult),&\r\n trim(selph(ip)%const)\r\n69 format('Phase: ',a,' cfg: ',a,' Subl: ',i2,' Mult: ',a/&\r\n ' Constituents: \"',a,'\"')\r\n if(allocated(selph(ip)%amendph)) write(*,76)selph(ip)%amendph\r\n76 format(' AmendPhase: ',a)\r\n if(allocated(selph(ip)%dispar)) &\r\n write(*,'(\" DisPart \",a)')selph(ip)%dispar\r\n terxpol=>selph(ip)%terxpol\r\n! if(.not.associated(terxpol)) write(*,*)'No ternary methods'\r\n do while(associated(terxpol))\r\n write(*,78)trim(selph(ip)%phasename),terxpol%sps,terxpol%xpol\r\n78 format(' TernaryXpol Phase=\"',a,&\r\n '\" Constituents=\"',a,'\" Xpol=\"',a,'\"')\r\n terxpol=>terxpol%next\r\n enddo\r\n enddo\r\n!\r\n! list all parameters selected ---------------------------------------\r\n write(*,*)'Press return to list selected parameters'\r\n read(*,'(a)')ch1\r\n if(nselpar.gt.0) then\r\n write(*,63)nselpar\r\n63 format(/'All ',i5,' parameters entered')\r\n do ip=1,nselpar\r\n if(len_trim(selpar(ip)%parname)+len_trim(selpar(ip)%data).gt.60) then\r\n write(*,72)ip,trim(selpar(ip)%parname),trim(selpar(ip)%data)\r\n72 format(i4,2x,a,' ='/10x,a)\r\n else\r\n write(*,73)ip,trim(selpar(ip)%parname),trim(selpar(ip)%data)\r\n73 format(i4,2x,a,' = ',a)\r\n endif\r\n enddo\r\n endif\r\n!\r\n! list asll TPfuns ---------------------------------------------------\r\n write(*,*)'Press return to list selected TPfuns'\r\n read(*,'(a)')ch1\r\n if(nseltp.gt.0) then\r\n write(*,82)nseltp\r\n82 format(/'All ',i5,' TPfun entered or missing (-1)')\r\n do ip=1,nseltp\r\n if(len_trim(seltpfun(ip)%data).le.50) then\r\n write(*,77)ip,seltpfun(ip)%tpfunname,seltpfun(ip)%status,&\r\n trim(seltpfun(ip)%data)\r\n77 format(i3,2x,a,2x,i2,3x,a)\r\n else\r\n write(*,87)ip,seltpfun(ip)%tpfunname,seltpfun(ip)%status,&\r\n trim(seltpfun(ip)%data)\r\n87 format(i3,2x,a,2x,i2/5x,a)\r\n endif\r\n enddo\r\n endif\r\n!\r\n! list all biteams ---------------------------------------------------\r\n write(*,*)'Press return to list selected bibilography'\r\n read(*,'(a)')ch1\r\n if(nselbib.gt.0) then\r\n write(*,772)nselbib\r\n772 format(/'All ',i4,' bibitems entered or missing (-1)')\r\n do ip=1,nselbib\r\n write(*,79)ip,selbib(ip)%bibitem,selbib(ip)%status,selbib(ip)%data\r\n79 format('Bibitem ',i4,' \"',a,'\" ',i3/5x,a)\r\n enddo\r\n endif\r\n!\r\n return\r\n end subroutine list_selected_xtdbdata\r\n \r\n! \\/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\\/!\\/!\\/!\\/!/!\r\n\r\n subroutine xtdbtag(unit,fline,tagname,matt,pretag,attributes)\r\n! this subroutine extract a tag and its attributes from lines read from file. \r\n! Tag begins with \"\" if no attributes, otherwise \"\" or \"/>\", the latter also means end of tag\r\n! End of tag may be on a separate line as \"/>\" or if nested \r\n! USING XEOLCH\r\n \r\n! Attributes are one or more identifier=\"values\" decoded in calling routine\r\n!-------------------\r\n! character tagname*(*),pretag*(*),attributes*(*)\r\n character(len=:), allocatable :: attributes\r\n! character attributes*(1024)\r\n character tagname*(*),pretag*(*)\r\n integer unit,fline,matt\r\n!-------------\r\n character line*512\r\n integer ep,ip,jp,kp,tp,taglen,tagend,lines,lentagname\r\n logical comment,rewindtp\r\n! problem initiating rewindtp? It should be false unless rewinding\r\n! and the toggle rewind within TPfun tags\r\n save rewindtp\r\n!-------\r\n ! matt tagend meaning\r\n! 0 -2 looking for ') then\r\n write(*,*)' *** Error, use of -- inside comment, line',fline\r\n xtdberr=4518\r\n exit readtag\r\n endif\r\n! we found end of multiline comment -->\r\n! write(*,*)'End of multiline comment',fline\r\n attributes=' '\r\n attpos=-1\r\n comment=.false.\r\n! skip rest of line\r\n if(len_trim(line).gt.ip+3) then\r\n write(*,103)fline\r\n103 format('Skipping text trailing comment on line ',i7)\r\n endif\r\n! reset line count for next tag\r\n tagend=-2\r\n lines=0\r\n endif\r\n cycle readtag !------- skip rest of line and cycle\r\n endif\r\n!================================================\r\n! use xeolch to find first character on line\r\n ip=1\r\n if(xeolch(line,ip)) then\r\n! if line empty read next line\r\n cycle readtag\r\n endif\r\n! first character of a tag must be <\r\n if(line(ip:ip).eq.'<') then\r\n if(tagend.ne.-2) then\r\n write(*,*)' *** ERROR XTDB has only one tag per line,',fline\r\n xtdberr=4515; exit readtag\r\n endif\r\n if(line(ip:ip+3).eq.'').gt.0) comment=.TRUE.\r\n cycle readtag\r\n endif\r\n if(line(ip:ip+1).eq.', negative matt\r\n! write(*,666)line(ip:ip+jp-1),trim(pretag),fline\r\n666 format('PRETAG: \"',a,'\" \"',a,'\" ',i7)\r\n matt=-1\r\n if(allappy.gt.1 .and. line(ip:ip+7).eq.'') then\r\n! A TPfun with nested Trange, return as normal after clearing rewindtp\r\n rewindtp=.FALSE.\r\n endif\r\n elseif(allappy.gt.1) then\r\n! we are rewinding file loocking only for \r\n! write(*,*)'Ignore all endoftags except TPfun'\r\n if(line(ip:ip+7).ne.'') then\r\n cycle readtag\r\n endif\r\n elseif(allappy.le.1) then\r\n write(*,*)' *** Error, illegal end of tag, line',fline\r\n xtdberr=4514\r\n endif\r\n! just end of reading, maybe indicate an error?\r\n if(.not.(ignorEOT .or. (trim(line(ip:)).eq.trim(pretag)))) then\r\n if(allappy.eq.0) write(*,345)trim(line(ip:)),trim(pretag),fline\r\n345 format('Found unexpected end of tag: \"',a,'\" \"',a,'\" ',i3,i7)\r\n endif\r\n exit readtag\r\n endif\r\n! We have found a new tag.\r\n! we can be after rewinding the master file. If so allappy=3\r\n! and only TPfuns or bibitem are accepted, ignore all other tags \r\n! write(*,*)'Check rewinding: 1: ',allappy,rewindtp,trim(line)\r\n if(allappy.gt.1) then\r\n! write(*,777)allappy,rewindtp,line(ip:ip+25),ip,matt,fline\r\n777 format('Allappy ',i3,l3,' line \"',a,'\" ',3i5)\r\n if(line(ip:ip+7).eq.'') then\r\n! Tag name end with > this is a tag without attributes but with nested tags\r\n! skip any trailing text\r\n tagname=line(ip+1:ip+jp-3)\r\n! write(*,*)'TAGNAME1: \"',trim(tagname),'\"'\r\n matt=1\r\n exit readtag\r\n else\r\n tagname=line(ip+1:ip+jp-2)\r\n! write(*,*)'TAGNAME2: \"',trim(tagname),'\"'\r\n endif\r\n! we have found the tagname, tagend=-1 indicate attributes can be on next linws\r\n lentagname=len_trim(tagname)\r\n tagend=-1\r\n ip=ip+jp\r\n endif\r\n! we are looking for attributes in line after ip\r\n if(xeolch(line,ip)) then\r\n! line empty and we have not found end of attributes\r\n cycle readtag\r\n else\r\n jp=index(line(ip:),'>')\r\n! this indicate end of attributes\r\n if(jp.le.0) then\r\n! no end of attributes, copy all to attributes and read next line\r\n if(ip.gt.0) then\r\n! attributes(attpos+2:)=trim(line(ip:))\r\n attributes=attributes//' '//trim(line(ip:))\r\n attpos=len_trim(attributes)\r\n endif\r\n else\r\n! Found > as end of attributes. maybe end of tag, matt=0 means no nested tags\r\n if(line(ip+jp-2:ip+jp-1).eq.'/>') then\r\n! attributes(attpos+2:)=line(ip:ip+jp-3)\r\n attributes=attributes//' '//line(ip:ip+jp-3)\r\n matt=0\r\n else\r\n! If no end of tag nested tags may follow on next lines\r\n! attributes(attpos+2:)=line(ip:ip+jp-2)\r\n attributes=attributes//' '//line(ip:ip+jp-2)\r\n tp=ip+jp+1\r\n matt=1\r\n! check for rubbish and maybe full endoftag after rubbish\r\n if(.not.xeolch(line,tp)) then\r\n jp=index(line(tp:),'<')\r\n if(jp.gt.0) then\r\n! The text has a <, if part of means end of tag\r\n write(*,69)line(tp+jp+1:tp+jp+lentagname),trim(tagname),tp\r\n69 format('3EY Are \"',a,'\" and \"',a,'\" equal?',i7)\r\n if(line(tp+jp:tp+jp).eq.'/' .and. &\r\n line(tp+jp+1:tp+jp+lentagname).eq.trim(tagname)) then\r\n! end of tag found after >, no nesting for this tag\r\n write(*,*)'3EY Trash found between > and tagend on line ',fline\r\n matt=0\r\n else\r\n write(*,*)'3EY *** Error, new tag after > on line ',fline\r\n xtdberr=4766\r\n exit readtag\r\n endif\r\n else\r\n! ignore rubbish after >\r\n write(*,88)fline,trim(line)\r\n88 format('3EY *** Rubbish after > line ',i7,&\r\n '. Quit reading.'/a/)\r\n xtdberr=4766\r\n exit readtag\r\n endif\r\n endif\r\n endif\r\n! we have found > or /> or \r\n exit readtag\r\n endif\r\n endif\r\n! maybe add\r\n if(lines.gt.2) then\r\n! check for tags with multiple lines\r\n if(tagname(1:1).eq.' ') write(*,104)fline-1\r\n104 format('3EY *** Warning, line without tag, line ',i7)\r\n if(lines.gt.3 .and. matt.lt.0) write(*,106)fline-3\r\n106 format('3EY *** Warning, very long list of attributes, line ',i7)\r\n endif\r\n enddo readtag\r\n! puh.................\r\n1000 continue\r\n! write(*,1002)matt,fline,trim(tagname)\r\n1002 format('Exiting xtdbtag: ',i2,i7,' ',a)\r\n return\r\n1100 continue\r\n! write(*,*)'End of file in xtdbtag'\r\n xtdberr=4700\r\n fline=-1\r\n goto 1000\r\n end subroutine xtdbtag\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n logical function xeolch(line,ip)\r\n! identical to eolch in METLIB, except it can handle endofline\r\n!...End Of Line CHeck, TO SKIP SPACES/TAB FROM IP. RETURNS .TRUE. IF another\r\n character line*(*)\r\n integer ip\r\n!\r\n integer, parameter :: itab=9\r\n xeolch=.true.\r\n if(ip.le.0) ip=1\r\n loop: do while(ip.le.len(line))\r\n if(line(ip:ip).eq.' ' .or. ichar(line(ip:ip)).eq.itab) then\r\n ip=ip+1\r\n else\r\n exit loop\r\n endif\r\n enddo loop\r\n! with allocated characters there is maybe no space before EOL\r\n! only when ip is larger than len(line) it returns true\r\n if(ip.le.len(line)) xeolch=.false.\r\n900 RETURN\r\n END function xeolch\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n logical function getatt(text,ip,attname,value)\r\n! extract \"values\" of any XML \"attname\" in text from position ip\r\n character*(*) text,attname,value\r\n integer ip\r\n!\r\n integer jp,kp,attlen\r\n!\r\n getatt=.false.\r\n! write(*,*)'3EY getatt 1',len(text)\r\n find: if(.not.xeolch(text,ip)) then\r\n if(text(ip:ip).eq.'=') exit find\r\n jp=index(text(ip+1:),'=')\r\n if(jp.gt.0) then\r\n! the attname is terminated by a = (possibly preceeded by spaces)\r\n attname=text(ip:ip+jp-1)\r\n! write(*,*)'3EY getatt 2 ',trim(attname)\r\n ip=ip+jp+1\r\n if(.not.xeolch(text,ip)) then\r\n! the values are preceeded by a \" (possibly prceeded by spaces)\r\n if(text(ip:ip).eq.'\"') then\r\n jp=index(text(ip+1:),'\"')\r\n if(jp.gt.0) then\r\n value=text(ip+1:ip+jp-1)\r\n ip=ip+jp+1\r\n getatt=.true.\r\n else\r\n xtdberr=4601\r\n endif\r\n else\r\n xtdberr=4602\r\n endif\r\n else\r\n xtdberr=4603\r\n endif\r\n else\r\n xtdberr=4607\r\n endif\r\n! no error if line empty\r\n endif find\r\n return\r\n end function getatt\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n logical function check_mpid(mpid,phase)\r\n! check that phase has a model corresponding to the mpid of a parameter\r\n character*(*) mpid,phase\r\n!\r\n integer np,ip\r\n! 1. loop to find the phase\r\n! 2. loop models for the phase to find one with the MPID\r\n! 3. return TRUE if found, FALSE if not \r\n check_mpid=.FALSE.\r\n1000 continue\r\n return\r\n end function check_mpid\r\n\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine getxtdbatt(attname,text,ip,values)\r\n! extract \"values\" of attribute \"att\" of \"tag\" from text at position ip\r\n character*(*) text,attname,values\r\n integer att,ip\r\n!\r\n integer jp,kp,attlen\r\n! seach for attribute att is the array with attributes\r\n attlen=len_trim(attname)\r\n! write(*,*)'3EY getxtdbatt 1 >',text(ip:ip+25),'<',ip,attlen\r\n jp=index(text(ip:),attname(1:attlen))\r\n if(jp.le.0) goto 1100\r\n! set jp to position after attname, the attribute must finish with =\"\r\n jp=ip+jp+attlen-1\r\n! write(*,*)'3EY getxtdbatt 2 >',text(jp:jp+5),'<',jp\r\n if(text(jp:jp+1).ne.'=\"') goto 1110\r\n kp=index(text(jp+2:),'\"')\r\n! write(*,*)'3EY getxtdbatt 3 >',text(jp:kp+5),'<',jp,kp\r\n if(kp.le.0) goto 1120\r\n values=text(jp+2:jp+kp)\r\n! update ip to position after \"\r\n ip=jp+kp+1\r\n!\r\n 1000 continue\r\n! write(*,*)'3EY exit getxtdbatt ',text(ip:ip+5),ip,xtdberr\r\n return\r\n! cannot find attribute\r\n1100 xtdberr=4501\r\n goto 1000\r\n! attribute has no trailing =\"\r\n1110 xtdberr=4502\r\n goto 1000\r\n! attribute value has no final \"\r\n1120 xtdberr=4503\r\n goto 1000\r\n end subroutine getxtdbatt\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n! xtdbinitmpid removed\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine xtdbmodels(appfile)\r\n! reads an AppendXTDB file with models and MPID\r\n! may change a default MPID\r\n character*(*) appfile\r\n!\r\n! character(len=:), allocatable :: attributes\r\n! character attributes*(1024)\r\n character(len=:), allocatable :: attributes\r\n character tagname*18,pretag*24,values*24,attname*24\r\n integer unit,matt,lc,lt,ip,sm,mpid,level\r\n logical modeltag\r\n! \r\n unit=26\r\n write(*,5)trim(appfile)\r\n5 format('In xtdbmodels reading: ',a)\r\n!\r\n! xtdbmpid is allocated in gtp3EX with 9 models\r\n!\r\n fline=0\r\n pretag=' '\r\n open(unit,file=appfile,access='sequential',form='formatted',&\r\n err=1200,status='old')\r\n!\r\n! initiating xtdbmpid\r\n if(.not.allocated(xtdbmodel)) then\r\n! maybe deallocate and allocate new?\r\n write(*,*)'Allocating model MPID'\r\n call xtdbinitmpid(nxtdbmpids)\r\n else\r\n write(*,*)'3EY using current model MPID'\r\n endif\r\n!\r\n! write(*,*)'Model file opened'\r\n level=0\r\n modeltag=.false.\r\n pretag=''\r\n!\r\n models: do while(.true.)\r\n if(fline.lt.0) exit models\r\n! write(*,*)'Call with pretag \"',trim(pretag),'\"'\r\n call xtdbtag(unit,fline,tagname,matt,pretag,attributes)\r\n if(xtdberr.ne.0) goto 1100\r\n! write(*,10)trim(tagname),trim(attributes),fline,matt,modeltag\r\n10 format('Model tag: \"',a,'\" att \"',a,'\"',i7,i3,l2)\r\n lt=len_trim(tagname)+1\r\n! make sure we prepare an endoftag\r\n! This should use levels but here we have only Models and Bibliography\r\n if(matt.eq.1) then\r\n pretag=''\r\n level=level+1\r\n elseif(matt.eq.-1) then\r\n level=level-1\r\n! write(*,*)'Leveling down: ',trim(tagname),' ',trim(pretag),level\r\n pretag=''\r\n! at level 0 we close the file\r\n if(level.eq.0) goto 1000\r\n endif\r\n if(.not.modeltag) then\r\n if(tagname(1:lt).eq.'Models ') then\r\n modeltag=.true.\r\n else\r\n! write(*,*)'Expecting only nested modeltags'\r\n xtdberr=4700; goto 1100\r\n endif\r\n cycle models\r\n endif\r\n if(matt.lt.0) then\r\n! just skip the end of a model tag\r\n cycle models\r\n endif\r\n!\r\n! write(*,*)'Model tag \"',tagname(1:lt),'\" pretag \"',trim(pretag),'\"'\r\n! tags expected are\r\n if(tagname(1:lt).eq.'Magnetic ') then\r\n!------------------------------------------! case(22) ! Magnetism\r\n! write(*,40)trim(tagname),trim(attributes)\r\n40 format('*** Addition: ',a,' \"',a,'\"')\r\n ip=1; values=' '; sm=0; mpid=0\r\n do while(getatt(attributes,ip,attname,values))\r\n lc=len_trim(values)\r\n! write(*,38)trim(attname),trim(values),lc,ip\r\n38 format(3x,'Att: \"',a,'\" = \"',a,'\" ',i3,i7)\r\n if(sm.eq.0) then\r\n! first attribute must be modelid\r\n if(attname(1:2).eq.'Id') then\r\n do sm=1,3\r\n if(values(1:lc).eq.xtdbmodel(sm)%modelid) exit\r\n enddo\r\n endif\r\n if(sm.le.0 .or. sm.gt.3) then\r\n! write(*,*)'3EY Unknown magnetic model \"',trim(values),'\"'\r\n xtdberr=7777; goto 1000\r\n endif\r\n elseif(sm.eq.1) then\r\n! Hmmmm in this way the database can use different symbols for each phase ???\r\n! IHJBCC: second and third attribiures are MPD1 and MPD2\r\n mpid=mpid+1\r\n! write(*,*)'Storing MPID in xtdbmodel',sm,mpid\r\n! accept the name of the mpid in the XTDB file\r\n xtdbmodel(sm)%mpid(mpid)=trim(values)\r\n! write(*,63)sm,mpid,xtdbmodel(sm)%mpid(mpid)\r\n63 format('Model ',i1,', mpid',i1,' in xtdb file is: \"',a,'\"')\r\n elseif(sm.eq.2) then\r\n! IHJREST: second and third attribiures are MPD1 and MPD2\r\n mpid=mpid+1\r\n xtdbmodel(sm)%mpid(mpid)=trim(values)\r\n! write(*,63)sm,mpid,xtdbmodel(sm)%mpid(mpid)\r\n elseif(sm.eq.3) then\r\n! IHJQX: second, third and forth attribiure, MPD1, MPD2 and MPD3\r\n mpid=mpid+1\r\n xtdbmodel(sm)%mpid(mpid)=trim(values)\r\n! write(*,63)sm,mpid,trim(xtdbmodel(sm)%mpid(mpid))\r\n endif\r\n! skip bibitem\r\n if((mpid.eq.2 .and. sm.lt.3) .or. mpid.eq.3) exit\r\n enddo\r\n if(sm.eq.3) then\r\n! write(*,67)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),&\r\n! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2)),&\r\n! trim(xtdbmodel(sm)%mpid(3))\r\n67 format('Model tag: ',a,i3,' Id: \"',a,'\" MPIDs: ',3('\"',a,'\" '))\r\n else\r\n! write(*,66)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),&\r\n! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2))\r\n66 format('Model tag: ',a,i3,' Id: \"',a,'\" MPIDs: \"',a,'\" \"',a,'\"')\r\n endif\r\n elseif(tagname(1:lt).eq.'Einstein ') then\r\n!------------------------------------------\r\n! case(23) ! Einstein \r\n! write(*,*)'Modelinfo Einstein 23'\r\n ip=1; values=' '; sm=4\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n if(attname(1:4).eq.'MPID') xtdbmodel(sm)%mpid(1)=trim(values)\r\n enddo\r\n! write(*,65)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),&\r\n! trim(xtdbmodel(sm)%mpid(1))\r\n65 format('Model tag: ',a,i3,' Id: \"',a,'\" MPIDs: \"',a,'\"')\r\n elseif(tagname(1:lt).eq.'Liq2State ') then\r\n!------------------------------------------\r\n! case(24) ! Liq2state\r\n! write(*,*)'Modelinfo Liq2State 24'\r\n ip=1; values=' '; sm=5\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n if(attname(1:5).eq.'MPID1') xtdbmodel(sm)%mpid(1)=trim(values)\r\n if(attname(1:5).eq.'MPID2') xtdbmodel(sm)%mpid(2)=trim(values)\r\n enddo\r\n! write(*,66)tagname(1:lt),sm,trim(xtdbmodel(sm)%modelid),&\r\n! trim(xtdbmodel(sm)%mpid(1)),trim(xtdbmodel(sm)%mpid(2))\r\n elseif(tagname(1:lt).eq.'Volume ') then\r\n!------------------------------------------\r\n! case(25) ! Volume, not implemented\r\n! write(*,*)'Modelinfo Volume 25'\r\n ip=1; values=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n enddo\r\n elseif(tagname(1:lt).eq.'EEC ') then\r\n!------------------------------------------\r\n! case(26) ! EEC\r\n! write(*,*)'Modelinfo EEC 26'\r\n ip=1; values=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n enddo\r\n elseif(tagname(1:lt-1).eq.'Bibliography') then\r\n!------------------------------------------\r\n! write(*,*)' Ignoring bibliography of models, closing file'\r\n goto 1000\r\n else\r\n!------------------------------------------\r\n! Models which has no MPID or is otherwise without model tag\r\n if(tagname(1:lt).eq.'DisorderedPart ') then\r\n ip=1; values=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n enddo\r\n! write(*,*)' The DisorderedPart tag is used in the Phase tag'\r\n elseif(tagname(1:lt).eq.'Permutations ') then\r\n ip=1; values=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n enddo\r\n! write(*,*)' The permutations Id is in AppendPhase Model attribute'\r\n elseif(tagname(1:lt).eq.'TernaryXpol ') then\r\n ip=1; values=' '\r\n do while(getatt(attributes,ip,attname,values))\r\n! write(*,38)trim(attname),trim(values)\r\n enddo\r\n! write(*,*)' TernaryXpol tags are specified for each ternary'\r\n elseif(tagname(1:lt).eq.'EBEF ') then\r\n! write(*,*)' EBEF is indicated by the parameters of the phase'\r\n continue\r\n else\r\n! write(*,*)'Model \"',trim(tagname),'\" not kown by software'\r\n continue\r\n endif\r\n endif\r\n!\r\n enddo models\r\n!-----------------\r\n1000 continue\r\n write(*,1005)trim(appfile),fline\r\n1005 format('Closing model file: ',a,i7/)\r\n close(unit)\r\n1010 continue\r\n return\r\n1100 continue\r\n write(*,*)'Error ',xtdberr,' reset after reading ',trim(appfile)\r\n xtdberr=0\r\n goto 1000\r\n1200 continue\r\n write(*,*)'Error opening ',trim(appfile),' default MPID used'\r\n goto 1010\r\n!\r\n end subroutine xtdbmodels\r\n\r\n !\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine xtdbbiblio(appfile)\r\n! Listing bibitems from appfile with bibitems inside a bibliography tag\r\n! integer nselbib,maxbib\r\n character*(*) appfile\r\n character tagname*18,pretag*24\r\n character(len=:), allocatable :: attributes\r\n! character*1024 attributes\r\n character attname*24,values*128\r\n! character(len=:), allocatable :: attname,values\r\n integer unit,lc,ip,matt,nbib,lbib,found\r\n! integer, dimension(:), allocatable :: notfound\r\n logical bibtag\r\n! \r\n unit=25\r\n fline=0\r\n ignorEOT=.true.\r\n if(debug) write(*,5)nselbib,trim(appfile)\r\n5 format(/'Trying to extract ',i5,' bibliographic references from: ',a,i7)\r\n open(unit,file=appfile,access='sequential',form='formatted',status='old')\r\n!\r\n! bibtag=.false.\r\n bibtag=.true.\r\n matt=0\r\n found=0\r\n bibitems: do while(.true.)\r\n call xtdbtag(unit,fline,tagname,matt,pretag,attributes)\r\n if(xtdberr.ne.0) goto 1100\r\n!* write(*,10)trim(tagname),fline,matt,bibtag\r\n10 format('Tag: \"',a,'\" ',i7,i3,l2)\r\n lc=len_trim(tagname)+1\r\n if(.not.bibtag) then\r\n! with allappy.gt.1 the bibliography will never be returned from xtdbtag!!\r\n if(tagname(1:lc).eq.'Bibliography ') then\r\n pretag=''\r\n bibtag=.true.\r\n else\r\n cycle bibitems\r\n endif\r\n else\r\n if(matt.eq.0) then\r\n ip=1; values=' '\r\n if(getatt(attributes,ip,attname,values)) then\r\n! extract the bibitem Id, no trailing spaces allowed\r\n!* write(*,544)trim(attname),trim(values)\r\n544 format('Read from file: \"',a,'\" \"',a,'\"')\r\n! Assume first attribute is \"Id\"\r\n! if(attname(1:2).eq.'Id') then\r\n! write(*,*)' *** bibitem: ',trim(values)\r\n find: do nbib=1,nselbib\r\n! lbib=len_trim(selbib(nbib)%bibitem)\r\n! write(*,555)values(1:lbib),trim(selbib(nbib)%bibitem),nbib\r\n555 format('Compare \"',a,'\" \"',a,'\"',i7)\r\n! if(values(1:lbib).eq.selbib(nbib)%bibitem) then\r\n if(values.eq.selbib(nbib)%bibitem) then\r\n! This Id is used, extract the reference \r\n! write(*,556)values(1:lbib),trim(selbib(nbib)%bibitem)\r\n556 format('Found: \"',a,'\" \"',a,'\"')\r\n selbib(nbib)%status=1\r\n found=found+1\r\n! We found the bibitem, extract the reference as next value, ignore attname\r\n if(getatt(attributes,ip,attname,values)) then\r\n! write(*,50)selbib(nbib)%bibitem,values\r\n50 format('Reference: ',a,' is ',a) \r\n selbib(nbib)%data=trim(values)\r\n exit find\r\n else\r\n write(*,60)trim(appfile),fline\r\n60 format('3EY Formatting error file: \"',a,'\" line ',i7)\r\n endif\r\n endif\r\n enddo find\r\n endif\r\n endif\r\n endif\r\n! make sure we prepare an endoftag\r\n enddo bibitems\r\n1000 continue\r\n if(debug) write(*,*)'Found ',found,' relevant bibliographic references'\r\n close(unit)\r\n return\r\n! errors model\r\n1100 continue\r\n goto 1000\r\n end subroutine xtdbbiblio\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine addmissingtp(origin)\r\n! extract TPfuns called inside wholexpr and add those missing to seltpfun\r\n! with seltpfun(*)%status -1\r\n character*(*) origin\r\n! all variables global\r\n!\r\n integer ip,jp,kp,ntp\r\n character symbol*16\r\n ip=1\r\n! write(*,*)'Checking for new tpfuns'\r\n big: do while(ip.lt.len_trim(wholexpr))\r\n! istpfun extracts symbols inside wholexpr ip is updated inside istpfun\r\n call istpfun(wholexpr,ip,symbol)\r\n if(symbol(1:1).ne.' ') then\r\n do ntp=1,nseltp\r\n! if(symbol.eq.alltpfun(ntp)) then\r\n if(symbol.eq.seltpfun(ntp)%tpfunname) then\r\n symbol=' ';cycle big\r\n endif\r\n! write(*,55)ntp,ip,symbol,seltpfun(ntp)%tpfunname\r\n55 format('seltpfun ',2i5,' \"',a,'\" and \"',a,'\"')\r\n enddo\r\n! this symbol is missing\r\n! write(*,*)' >>> addmissingtp tpfun: ',trim(symbol)\r\n nseltp=nseltp+1\r\n! write(*,60)trim(origin),trim(symbol),nseltp\r\n60 format(' >>> TPfun used by \"',a,'\" added \"',a,'\" ',i4)\r\n seltpfun(nseltp)%tpfunname=symbol\r\n seltpfun(nseltp)%status=-1\r\n endif\r\n enddo big\r\n1000 continue\r\n return\r\n end subroutine addmissingtp\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine istpfun(line,ip,symbol)\r\n! extract unknown symbols (TPfuns) from an expression after position ip\r\n character line*(*),symbol*(*)\r\n integer ip\r\n!------\r\n! Strange error here when everyting was accepted as TPfuns ....\r\n integer jp,kp,mp\r\n character ch1*1\r\n call capson(line)\r\n kp=0\r\n! write(*,*)'3EY Looking for tpfun in: \"',trim(line),'\"',ip,kp\r\n symbol=' '\r\n! write(*,*)'In istpfun',ip,trim(line),len(line)\r\n issymbol: do while(ip.lt.len_trim(line))\r\n! symbols must start with letter A-Z and can contain letters, digits and \"_\"\r\n ch1=line(ip:ip)\r\n ip=ip+1\r\n! write(*,*)'Testing \"',ch1,'\": symbol: \"',trim(symbol),'\" ',ip,kp\r\n if(ch1.ge.'A' .and. ch1.le.'Z') then\r\n! first character must be a letter\r\n kp=kp+1\r\n symbol(kp:kp)=ch1\r\n! write(*,*)'Acceping \"',ch1,'\": symbol: \"',trim(symbol),'\" ',ip,kp\r\n cycle issymbol\r\n elseif(kp.ge.1 .and. &\r\n ((ch1.ge.'0' .and. ch1.le.'9') .or. ch1.eq.'_')) then\r\n! 2nd and later character can be number or \"_\"\r\n kp=kp+1\r\n if(kp.gt.len(symbol)) then\r\n write(*,77)symbol,ip,kp,trim(line)\r\n77 format('In istpfun: Too long symbol: \"',a,'\" ',2i4,' on line '/a)\r\n stop\r\n endif\r\n! write(*,*)'Accept \"',ch1,'\": symbol: \"',trim(symbol),'\" ',ip,kp\r\n symbol(kp:kp)=ch1\r\n! write(*,*)'istpfun symbol: ',trim(symbol),kp,ip\r\n cycle issymbol\r\n elseif(kp.ge.2) then\r\n! We found a character illegal in a symbols, check if in nottpfun\r\n if(kp.ge.2 .and. kp.le.4) then\r\n do mp=1,5\r\n! Skip symbols: LN LOG EXP ERF GEIN\r\n if(symbol(1:4).eq.nottpfun(mp)) goto 300\r\n enddo\r\n! symbol is not predefined function: LN LOG EXP ERF GEIN\r\n! write(*,*)'reference to tpfun: ',trim(symbol),ip\r\n endif\r\n exit issymbol\r\n endif\r\n! \r\n300 continue\r\n symbol=' '; kp=0\r\n enddo issymbol\r\n! write(*,*)'istpfun found tpfun: \"',trim(symbol),'\" ',ip\r\n1000 continue\r\n return\r\n end subroutine istpfun\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n!\\addtotable subroutine capson & Convert character to UPPER case\r\n!\\begin{verbatim}\r\n! SUBROUTINE capson(text)\r\n! converts lower case ASCII a-z to upper case A-Z, no other changes\r\n! implicit none\r\n! character text*(*)\r\n!\\end{verbatim}\r\n! integer, parameter :: lowa=ichar('a'),lowz=ichar('z'),&\r\n! iup=ICHAR('A')-ICHAR('a')\r\n! integer i,ich1\r\n! DO i=1,len(text)\r\n! ich1=ichar(text(i:i))\r\n! IF(ich1.ge.lowa .and. ich1.le.lowz) THEN\r\n! text(i:i)=char(ich1+iup)\r\n! ENDIF\r\n! ENDDO\r\n! END SUBROUTINE capson\r\n!\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine xtdbentertpfun(tpfun,add)\r\n! check if TPfun is needed and of so enter it in seltpfun\r\n character*(*) tpfun\r\n logical add\r\n!\r\n integer lentp,jj\r\n lentp=len_trim(tpfun)\r\n add=.false.\r\n do ntp=1,nseltp\r\n! write(*,*)'3EY in xtdbentertpfun: ',&\r\n! tpfun(1:lentp),' ? ',seltpfun(ntp)%tpfunname(1:lentp),' ',ntp\r\n if(tpfun.eq.seltpfun(ntp)%tpfunname(1:lentp)) then\r\n if(seltpfun(ntp)%status.eq.-1) then\r\n add=.true.\r\n seltpfun(ntp)%status=1\r\n! sometimes a final N has to be added ....\r\n! write(*,10)1,trim(wholexpr)\r\n10 format('In xtdbentertpfun: ',i2,' \"',a,'\"')\r\n jj=len_trim(wholexpr)\r\n if(wholexpr(jj:jj).ne.'N') then\r\n! Wow, wholexpr is allocated an it must ne extended like this ...\r\n wholexpr=wholexpr(1:jj)//' N'\r\n! write(*,10)2,trim(wholexpr)\r\n endif\r\n seltpfun(ntp)%data=trim(wholexpr)\r\n! check if this TPfun need other TPfuns wholexpr is a global variable\r\n call addmissingtp(tpfun)\r\n goto 1000\r\n endif\r\n endif\r\n enddo\r\n1000 continue\r\n! write(*,*)'exit xtdbentertpfun: ',add\r\n return\r\n end subroutine xtdbentertpfun\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine xtdbaddbibref(bibref,selbib,nselbib,maxbib)\r\n! adding new bibrefs to selbib if not already there\r\n integer nselbib,maxbib\r\n type(ocbib) :: selbib(*)\r\n character*(*) bibref\r\n integer nbib,lbib,kk,same\r\n lbib=len_trim(bibref)\r\n do nbib=1,nselbib\r\n if(bibref.eq.selbib(nbib)%bibitem(1:lbib)) goto 1000\r\n enddo\r\n! it is a new reference\r\n! if(nselbib.gt.0) write(*,*)'Adding bibref: \"',bibref,'\" \"',&\r\n! trim(selbib(nselbib)),'\"'\r\n if(nselbib.lt.maxbib) then\r\n nselbib=nselbib+1\r\n selbib(nselbib)%bibitem=bibref\r\n selbib(nselbib)%status=-1\r\n! this is never written?\r\n write(*,*)' >>> xtdbaddbibref added: \"',bibref,'\"',nselbib\r\n else\r\n! check if the same appears several times ...\r\n write(*,*)'Too many bibliographic references',nselbib\r\n same=0\r\n do nbib=1,nselbib\r\n write(*,*)'Bibref: ',selbib(nbib)%bibitem\r\n do kk=1,nselbib\r\n if(kk.ne.nbib) then\r\n if(selbib(nbib)%bibitem.eq.selbib(kk)%bibitem) then\r\n write(*,*)'Duplicate reference',kk,nbib,selbib(kk)%bibitem\r\n same=same+1\r\n endif\r\n endif\r\n enddo\r\n enddo\r\n write(*,*)'Duplicate references: ',same\r\n endif\r\n1000 continue\r\n return\r\n end subroutine xtdbaddbibref\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n! Application (OC) dependent subroutines called by xtdbread\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCenterel(spel,name,refstate,mass,h298,s298)\r\n! subroutine OCenterel(spel,data)\r\n! enter Element/species from the xtdb file. Name is full name in OC, ignored\r\n character spel*2,name*(*),refstate*(*)\r\n double precision mass,h298,s298\r\n! data is a text: Mass=\"5.199600E+01\" H298=\"4.050000E+03\" S298=\"2.354290E+01\"\r\n! /- and Va introduced automatically\r\n if(spel.eq.'/-' .or. spel.eq.'VA') goto 1000\r\n if(nomorelements) then\r\n write(*,*)'No more elements allowed'; goto 1000\r\n endif\r\n nselel=nselel+1\r\n selel(nselel)%elname=spel\r\n selel(nselel)%data=' '\r\n! Hm alphabetical order!! later ....\r\n! write(*,10)nselel,spel\r\n10 format('Selected element; ',i2,2x,a)\r\n! elements are also entered as species, except /-\r\n if(spel.ne.'/-') then\r\n nselsp=nselsp+1\r\n selsp(nselsp)%species=spel\r\n selsp(nselsp)%data=spel\r\n allocate(selsp(nselsp)%elnames(1))\r\n allocate(selsp(nselsp)%stoicc(1))\r\n selsp(nselsp)%elnames(1)=spel\r\n selsp(nselsp)%stoicc(1)=1.0D0\r\n selsp(nselsp)%charge=0.0D0\r\n! write(*,*)'Entering species ',spel,nselsp\r\n selsp(nselsp)%extra=' '\r\n endif\r\n! enter element also in OC, needed to check species and mqmqa quads\r\n! element symbol, name, reference state, mass, h298, s298\r\n call store_element(spel,name,refstate,mass,h298,s298)\r\n1000 continue\r\n return\r\n end subroutine OCenterel\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCenterspecies(spname,stoi,mqmqa,uniquac)\r\n! enter Element/species in xtdb file\r\n implicit none\r\n character*(*) spname,stoi,mqmqa,uniquac\r\n! this requires extracting the stoichiometry ... \r\n integer ia,ib,nel,kk,mel,kp\r\n character*2 el(10)\r\n double precision coef(10),qq\r\n! this nend should be reinitiated when the NEW command\r\n integer, save :: nend=-1\r\n!\r\n qq=0.0D0\r\n if(nomorelements) then\r\n write(*,*)'No more elements or species allowed'; goto 1000\r\n endif\r\n if(mqmqa(1:1).eq.' ') then\r\n! This is NOT MQMQA quad\r\n! write(*,10)trim(spname),trim(stoi),nselsp\r\n10 format('In OCenterspecies: \"',a,'\" stoi: \"',a,'\"',i4)\r\n! check species is not a duplicate\r\n do ia=1,nselsp\r\n if(spname.eq.selsp(ia)%species) then\r\n! write(*,*)'Species \"',trim(spname),'\" already entered'\r\n goto 1000\r\n endif\r\n enddo\r\n! extract the elements, the electron is included as /+/- here but removed below\r\n call extractstoi(stoi,nel,el,coef)\r\n if(xtdberr.ne.0) goto 1000\r\n! xtdberr=5000 means element not entered, this species should be ignored\r\n mel=nel\r\n! The elements must already be entered!\r\n thissp: do ia=1,nel\r\n entered: do ib=1,nselel\r\n if(el(ia).eq.selel(ib)%elname) cycle thissp\r\n enddo entered\r\n if(el(ia).eq.'/+') then\r\n qq=coef(ia)\r\n mel=nel-1\r\n elseif(el(ia).eq.'/-') then\r\n qq=-coef(ia)\r\n mel=nel-1\r\n else\r\n! this species has an unknown element, ignore it\r\n goto 1000\r\n endif\r\n enddo thissp\r\n! enter the species in OC\r\n call enter_species(spname, nel, el, coef)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! enter the species in temporary here\r\n nselsp=nselsp+1\r\n selsp(nselsp)%species=spname\r\n write(*,*)'3EY New species \"',trim(selsp(nselsp)%species),'\" ',nselsp\r\n! Hm here I allocate a place for the electon, maybe use mel?\r\n allocate(selsp(nselsp)%elnames(mel))\r\n allocate(selsp(nselsp)%stoicc(mel))\r\n do ia=1,mel\r\n selsp(nselsp)%elnames(ia)=el(ia)\r\n selsp(nselsp)%stoicc(ia)=coef(ia)\r\n enddo\r\n! charge\r\n if(qq.ne.0.0d0) then\r\n selsp(nselsp)%charge=qq\r\n! Here I add charge as last constituent\r\n! selsp(nselsp)%elnames(nel)='/-'\r\n! selsp(nselsp)%stoicc(nel)=qq\r\n else\r\n selsp(nselsp)%charge=0.0D0\r\n endif\r\n else\r\n!----------------------------------------------------\r\n! this IS AN MQMQA QUAD, code copied from gtp3E (for TDB) lines 3868-3888 \r\n call capson(spname)\r\n kp=index(spname,'/')\r\n if(kp.gt.0 .and. &\r\n spname(kp+1:kp+1).ge.'A' .and. spname(kp+1:kp+1).le.'Z') then\r\n! this is an MQMQA quad, an ion has /+ or /- or /digit \r\n! write(*,572)trim(spname),trim(mqmqa)\r\n572 format('3EY Call mqmqa_species: \"',a,'\" \"',a,'\" ')\r\n! mqmqa_species in gtp3B. It will check everything and enter the species in OC\r\n! provided the elements are entered!!!\r\n call mqmqa_species(spname,mqmqa,nend)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3E error creating MQMQA quad',gx%bmperr\r\n goto 1000\r\n endif\r\n endif\r\n! write(*,*)'3EY spname modified? ',spname,nselsp\r\n! modify the name\r\n nselsp=nselsp+1\r\n selsp(nselsp)%species=spname\r\n! if(eolch(longline,ip)) then\r\n! if(.not.silent) write(kou,*)'WARNING No stoichiometry for species: ',&\r\n! trim(name1)\r\n! tdbwarning=.TRUE.\r\n! write(*,*)'3E tdbwarning set true 3'\r\n selsp(nend)%extra=mqmqa\r\n endif\r\n! if(uniquac(1:1).ne.' ') selsp(nselsp)%extra=mqmqa\r\n1000 continue\r\n return\r\n end subroutine OCenterspecies\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine extractstoi(spstoi,nel,el,coef)\r\n! decode a species stoiciometry as element/number/ without spaces\r\n! The element can be one or two letters and the number an integer, real\r\n! or a quotent such as a/b: AL2O3 or ALO1.5 or ALO3/2 are the same species\r\n! No parenthesis are allowed Al2(SO4)3 must be written Al2S2O12\r\n! The element names are case insensitve\r\n! A single letter element must have a followng number (or a final space)\r\n! A two letter element without a following number is assumbed to have unity\r\n! A charge is /+ or /- followed by a digit\r\n!\r\n character*(*) spstoi\r\n character*2 el(*)\r\n integer nel\r\n double precision coef(*)\r\n!\r\n double precision stf,nom,kvot\r\n double precision, parameter :: one=1.0D0, zero=0.0D0\r\n integer lens,kk\r\n logical ddot,slash,ion\r\n!\r\n integer ip\r\n character ch1*1\r\n! \r\n debug=.false.\r\n! debug=.true.\r\n call capson(spstoi)\r\n lens=len_trim(spstoi)\r\n! if(lens.le.1) then\r\n! write(*,*)'The stoichiometry must be at least 1 character!'\r\n! xtdberr=5000; goto 1000\r\n! This can be a single element species with default stochiometry 1 \r\n! coef(1)=one\r\n! endif\r\n kvot=zero\r\n nom=one\r\n ion=.false.\r\n! nel is incremeneter for each element, ip for each position in spstoi\r\n nel=0\r\n ip=1\r\n ch1=spstoi(ip:ip)\r\n! lge and lle use ASCII character set\r\n if(.not.(LGE(CH1,'A') .AND. LLE(CH1,'Z'))) then\r\n write(*,10)trim(spstoi),ip,ch1\r\n10 format(' *** Error in \"',a,'\" expected element at ',i3,' found \"',a,'\"')\r\n xtdberr=5001; goto 1000\r\n endif\r\n!======================================= big extract loop\r\n extract: do while(.true.)\r\n! The first letter of an element is in ch1\r\n! It can be first letter of a second element or ion /\r\n nel=nel+1\r\n! second character of element a space\r\n el(nel)=ch1\r\n! Set default stoichiometric factor to 1.0\r\n stf=one\r\n! default stochiometric factor\r\n coef(nel)=stf\r\n ip=ip+1\r\n if(ip.gt.lens) exit extract\r\n! this ch1 is the first character of el(nel), ch1 is updated below\r\n! for ip=1 ch1 is always a letter but\r\n if(ch1.eq.'/') then\r\n if(ion) then\r\n write(*,14)trim(spstoi),ip\r\n14 format('*** Error in \"',a,'\" species already charged.',i3)\r\n xtdberr=5017; goto 1000\r\n endif\r\n! This cannot be the first slement or a / in a factor as 1/3 \r\n! But it can be the first letter of second element or ion \"/\"\r\n! An ion, \"/\" must be followed by a + or - to represent an ion\r\n! ip already incremented above\r\n if(ip.gt.lens) then\r\n write(*,11)trim(spstoi),ip\r\n11 format('*** Error ending \"',a,'\" with /',i3)\r\n xtdberr=5011; goto 1000\r\n elseif(spstoi(ip:ip).eq.'+' .or. spstoi(ip:ip).eq.'-') then\r\n ion=.true.; ddot=.true.\r\n! This is an ion, set a default charge 1\r\n! write(*,300)trim(spstoi),ip,nel,(coef(kk),kk=1,nel)\r\n300 format('Ion 1: \"',a,'\" ',2i3,10F8.3)\r\n el(nel)=spstoi(ip-1:ip)\r\n coef(nel)=one\r\n! jump to extract a digit, the valence must be the end of an ion\r\n ip=ip+1\r\n if(ip.gt.lens) exit extract\r\n ch1=spstoi(ip:ip)\r\n! there cannot be any new elements after a /+ or /-\r\n goto 500\r\n else\r\n write(*,13)trim(spstoi),ip\r\n13 format('*** Error charge of \"',a,'\" must be \"/+\" or \"/-\" ',i3)\r\n xtdberr=5009; goto 1000\r\n endif\r\n endif\r\n! ip was incremented above, second letter of an element, a factor or charge\r\n ch1=spstoi(ip:ip)\r\n if(debug) write(*,*)'second letter 1: ',ch1,ip\r\n! If second letter indicate an ion jump back to extract the whole symbol\r\n if(ch1.eq.'/') cycle extract\r\n if(lge(ch1,'A') .and. lle(ch1,'Z')) then\r\n! this must be the second letter of the element\r\n! Save full name, the charge taken care of above\r\n el(nel)(2:2)=ch1\r\n ip=ip+1\r\n if(ip.gt.lens) exit extract\r\n ch1=spstoi(ip:ip)\r\n! if the next character is a letter cycle, otherwise coefficient\r\n if((lge(ch1,'A') .and. lle(ch1,'Z')) .or. ch1.eq.'/') cycle extract\r\n endif\r\n!-------------------------------------\r\n! We arrive here to extract the stoichiometry or valency\r\n! It can start with a digit or a decimal point\r\n! reset the default stochiometry\r\n if(debug) write(*,*)'third letter 2: ',ch1,ip\r\n stf=zero; nom=1.0D0\r\n ddot=.false.; slash=.false.\r\n! jump here if ion\r\n500 continue\r\n stf=zero\r\n coefficient: do while(.true.)\r\n if(debug) write(*,*)'third letter 3: ',ch1,ip\r\n if(ch1.eq.'.') then\r\n! Handle a decimal point inside a real number\r\n if(ddot) then\r\n! not allowed for ions either\r\n if(debug) write(*,20)trim(spstoi),ip\r\n20 format('*** Error in \"',a,'\" two decimal dots ',i3)\r\n xtdberr=5002; goto 1000\r\n! the following numbers will be decimals\r\n endif\r\n ddot=.true.\r\n nom=1.0D-1\r\n ip=ip+1\r\n if(ip.gt.lens .and. stf.eq.zero) then\r\n! stoichiometry ends with a ., if stf=0.0 no previous digit\r\n if(debug) write(*,30)trim(spstoi),ip\r\n30 format('*** Error in \"',a,'\" missing stoichiometry ',i3)\r\n xtdberr=5003; goto 1000\r\n endif\r\n ch1=spstoi(ip:ip)\r\n endif\r\n! now there must be a number!!!\r\n if(debug) write(*,*)'third character 4: ',ch1,ip\r\n stoik: do while(lge(ch1,'0') .and. lle(ch1,'9'))\r\n! extract stoiciometic factor digit by digit\r\n! stf is the previous numbers in the stochiometric factor, initially 0.0\r\n if(debug) write(*,*)'third character 5: ',ch1,ip\r\n if(ddot) then\r\n stf=stf+nom*(ichar(ch1)-ichar('0'))\r\n nom=1.0D-1*nom\r\n else\r\n stf=stf*nom+ichar(ch1)-ichar('0')\r\n nom=1.0D1*nom\r\n endif\r\n if(debug) write(*,35)'third character 6: ',ch1,ip,nel,stf,nom,kvot\r\n35 format(1x,a,a,2i3,5F10.4)\r\n ip=ip+1\r\n! we have an element with a stochiometric factor, OK if no more\r\n! the stoichometry of last element set after extract\r\n if(ip.gt.lens) exit extract\r\n ch1=spstoi(ip:ip)\r\n if(debug) write(*,36)1,ch1,ip,nel,stf,nom,kvot\r\n36 format('fourth character ',i2,': \"',a,'\"',2i3,5F10.4)\r\n! there can be a / in stoichiometry, for example in AlO3/2, This is not an ion\r\n if(ch1.eq.'/') then\r\n if(spstoi(ip+1:ip+1).eq.'+' .or. &\r\n spstoi(ip+1:ip+1).eq.'-') then\r\n! this is not a division, it is the electone!\r\n goto 600\r\n endif\r\n if(slash) then\r\n write(*,40)trim(spstoi),ip\r\n40 format('**** Error in \"',a,'\" two slashes',i3)\r\n xtdberr=5004; goto 1000\r\n endif\r\n slash=.true.\r\n if(ddot) then\r\n write(*,50)trim(spstoi),ip\r\n50 format('**** Error in \"',a,'\" both slash and dot!',i3)\r\n xtdberr=5005; goto 1000\r\n endif\r\n if(stf.eq.zero) then\r\n write(*,60)trim(spstoi),ip\r\n60 format('**** Error in \"',a,'\" no digits before slash!',i3)\r\n xtdberr=5006; goto 1000\r\n endif\r\n! kvot is set to current value of stf, stf will be value to divide with\r\n kvot=stf\r\n stf=zero\r\n ip=ip+1\r\n if(ip.gt.lens) then\r\n write(*,70)trim(spstoi),ip\r\n70 format('**** Error in \"',a,'\" no digits after slash',i3)\r\n endif\r\n if(debug) write(*,16)2,ch1,ip,nel,stf,nom,kvot\r\n16 format('Position ',i2,' letter \"',a,'\" ',2i3,10F8.4)\r\n ch1=spstoi(ip:ip)\r\n! after a / there must be a digit, a \".\" or letter not allowed\r\n if(debug) write(*,16)3,ch1,ip,nel,stf,nom,kvot\r\n cycle stoik\r\n endif ! we have taken care of a /\r\n if(debug) write(*,16)4,ch1,ip,nel,stf,nom,kvot\r\n! if ch1 is not a digit exit here.\r\n if(stf.eq.zero) then\r\n write(*,80)trim(spstoi),ip,ch1\r\n80 format('*** Error in \"',a,'\" digit error at',i3,' \"',a,'\"')\r\n xtdberr=5009; goto 1000\r\n endif\r\n enddo stoik\r\n if(debug) write(*,16)5,ch1,ip,nel,stf,nom,kvot\r\n! there can be a . inside a stoichiometric factor followed by digits\r\n if(ch1.eq.'.') then\r\n if(slash) then\r\n write(*,50)trim(spstoi),ip\r\n xtdberr=5007; goto 1000\r\n endif\r\n cycle coefficient\r\n endif\r\n600 continue\r\n if(debug) write(*,16)6,ch1,ip,nel,stf,nom,kvot\r\n! we have to calculate the stoichiometric factor\r\n! If kvot=0.0 then coef is stf\r\n if(kvot.eq.zero) then\r\n coef(nel)=stf\r\n else\r\n coef(nel)=kvot/stf\r\n endif\r\n if(debug) write(*,16)7,ch1,ip,nel,stf,nom,kvot,coef(nel)\r\n stf=zero\r\n kvot=zero\r\n nom=one\r\n if(debug) write(*,16)8,ch1,ip,nel,stf,nom,kvot,coef(nel)\r\n cycle extract\r\n enddo coefficient\r\n! We come here if ch1 is not a digit, it can be a letter or / or ???\r\n if(debug) write(*,16)9,ch1,ip,nel,stf,nom,kvot,coef(nel)\r\n if(ch1.eq.\"/\" .or. (ch1.ge.'A' .and. ch1.le.'Z')) cycle extract\r\n!\r\n write(*,90)trim(spstoi),ip\r\n90 format('*** Error in \"',a,'\" illegal character at ',i3)\r\n xtdberr=5023; goto 1000\r\n enddo extract\r\n if(ip.gt.lens) then\r\n! we have to calculate the stoichiometric factor\r\n! If kvot=0.0 then coef is stf\r\n if(kvot.eq.zero) then\r\n coef(nel)=stf\r\n else\r\n coef(nel)=kvot/stf\r\n endif\r\n if(debug) write(*,16)8,ch1,ip,nel,stf,nom,kvot,coef(nel)\r\n endif\r\n!\r\n! write(*,*)'Leaving extractstoi: ',trim(spstoi),nel\r\n! do ip=1,nel\r\n! write(*,100)el(ip),coef(ip)\r\n100 format('Element: \"',a,'\" Stochiomentry ',1pe16.6)\r\n! enddo\r\n1000 continue\r\n return\r\n end subroutine extractstoi\r\n \r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCenterphase(phrec)\r\n! listing phase data to be entered in OC\r\n! type(phnest), pointer :: phrec\r\n type(phnest) :: phrec\r\n integer ms,ns,ip,jp,js,lk\r\n character*24 constituent,ch1*1\r\n character*1024 ccxx\r\n logical none,giveup\r\n!\r\n if(.not.nomorelements) then\r\n! when first phase enetered we cannot entoer more elements/species\r\n! we should arrange elements and species in alphanetical order!\r\n nomorelements=.TRUE.\r\n call alphabetical_order\r\n endif\r\n!\r\n ms=size(phrec%clist)\r\n! write(*,7)trim(phrec%Id),ms,(phrec%clist(ns)%list,ns=1,ms)\r\n7 format(/' in OCenterphase: ',a,'\" ',i3/20(' \"',a,'\"'))\r\n! we must check if the phase can exist, i.e. is there at least one\r\n! entered species in each sublattice\r\n nselph=nselph+1\r\n! maybe not needed?\r\n! allocate(cc(10))\r\n! write(*,*)'Try assigning ccxx'\r\n ccxx=' : '\r\n! write(*,*)'Success assigning ccxx'\r\n selph(nselph)%nsublat=ms\r\n selph(nselph)%mult=phrec%mult\r\n! not any ternary extrapolation methods yet\r\n nullify(selph(nselph)%terxpol)\r\n sublatt: do ns=1,ms\r\n! loop for all constituent in the phase in the database\r\n giveup=.false.\r\n none=.true.\r\n! selph(nselph)%const(ns)=' '\r\n ip=1\r\n! extract database constituents in sublattice ns from first position\r\n! with allocated characters there are not always a space at the end!!\r\n lk=len_trim(phrec%clist(ns)%list)\r\n any: do while(.not.xeolch(phrec%clist(ns)%list,ip))\r\n jp=index(phrec%clist(ns)%list(ip:),' ')\r\n! write(*,*)'Loop sublattice ',ns,ip,lk,jp\r\n! ip is start of constituent, find terminating space, if endofline\r\n!\r\n! big problem here because %list does not terminate with spaces\r\n! one has to be careful with jp=0 as there are no trailing spaces ....\r\n if(jp.eq.0 .and. ip.le.lk) then\r\n constituent=phrec%clist(ns)%list(ip:lk)\r\n! write(*,*)'Constituent ip:lk :',constituent,ip,lk\r\n! giveup set to true here as jp=0 means it is tha last species on the line\r\n! it would probably be safer to add a trailing space to %list\r\n giveup=.TRUE.\r\n jp=lk-ip+1\r\n! infinite number of problems here with C and V and character strings\r\n! that does not terminate with spaces !!! SUCK\r\n else\r\n constituent=phrec%clist(ns)%list(ip:ip+jp-1)\r\n endif\r\n! write(*,71)'Constituent: \"',trim(constituent),'\"',ip,jp,ip+jp,lk\r\n71 format(a,a,a,5i3)\r\n ip=min(ip+jp,lk)\r\n do js=1,nselsp\r\n! if the constituent is entered phase can exitst\r\n if(jp.gt.0) then\r\n! write(*,*)ns,'compare: \"',constituent(1:jp),&\r\n! '\" \"',selsp(js)%species(1:jp),'\"',ip,js\r\n! wow V was accepted twice as it matched VA also ....\r\n if(constituent(1:jp).eq.trim(selsp(js)%species)) then\r\n! this constituent is entered, append it to selph(nselph)%const\r\n ccxx=trim(ccxx)//' '//trim(constituent)\r\n! write(*,*)'Saving constituent in ccxx',trim(ccxx)\r\n none=.false.\r\n endif\r\n else\r\n exit any\r\n endif\r\n enddo\r\n! write(*,*)'Loop index ',ip,giveup\r\n if(giveup) exit any\r\n enddo any\r\n if(none) goto 1100\r\n ccxx=trim(ccxx)//' : '\r\n! write(*,*)'Next sublattice: \"',trim(ccxx),'\" ',ns\r\n enddo sublatt\r\n! there is at least one entered constituent in each sublattice in selph%const\r\n selph(nselph)%phasename=phrec%Id\r\n! write(*,10)selph(nselph)%phasename,ms,trim(ccxx)\r\n10 format('OK enter phase: ',a,i3,a)\r\n! write(*,*)'The remaining problem is to transfer cc(1:mn) to selph%const!'\r\n selph(nselph)%const=trim(ccxx)\r\n selph(nselph)%confent=trim(phrec%confent)\r\n if(allocated(phrec%amendph)) then\r\n! write(*,*)'Phase ',trim(phrec%id),' has models ',trim(phrec%amendph)\r\n selph(nselph)%amendph=phrec%amendph\r\n! else\r\n! write(*,*)'No amend phase allocated for: ',trim(phrec%Id)\r\n endif\r\n if(allocated(phrec%dispar)) then\r\n! write(*,*)'Phase ',trim(phrec%id),' has dispart ',trim(phrec%dispar)\r\n selph(nselph)%dispar=phrec%dispar\r\n endif\r\n! this is not needed, at the end the records in firstxpol will be searched\r\n! xpol=>firstxpol\r\n! nullify(lastxpol)\r\n! look for any ternary extrapolations for this selph(nselph)\r\n! if(associated(xpol)) then\r\n! write(*,*)'3EY xpol: \"',xpol%phase,'\" and \"',selph(nselph)%phasename.'\"'\r\n! if(xpol%phase.eq.selph(nselph)%phasename) then\r\n! write(*,*)'3EY adding ternary method',xpol\r\n! if(xpol.eq.firstxpol) then\r\n! firstxpol=>xpol%next\r\n! else\r\n! xpol2=>xpol\r\n! xpol2%next=>selph(nselph)%terxpol\r\n! selph(nselph)%terxpol=>xpol2\r\n! endif\r\n! xpol=xpol%next\r\n! endif\r\n1000 continue\r\n! write(*,*)'Press return to continue'\r\n! read(*,'(a)')ch1\r\n!\r\n return\r\n1100 continue\r\n! We arrive here there is a sublattice with no constituents entered in a subl\r\n! The phase cannot be entered\r\n! write(*,5)phrec%Id\r\n! deallocate(selph(nselph)%const)\r\n5 format('The phase ',a,' cannot exist in this system?')\r\n nselph=nselph-1\r\n goto 1000\r\n end subroutine OCenterphase\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine alphabetical_order\r\n! this should arrange elements and species in alphabetical order as in TDB\r\n integer nn,ia,ib,ic,mel,kk,jj\r\n character bytel*2,ch1*1,byt2*24\r\n character*24, dimension(:), allocatable :: ss\r\n logical, save :: notdone=.true.\r\n integer, dimension(:), allocatable :: orig\r\n! write(*,*)'In alphabetical order',notdone\r\n if(notdone) then\r\n! write(*,*)'In alphabetical order to arrange elements and species'&\r\n! ' in alphabetical order'\r\n notdone=.false.\r\n ic=1\r\n\r\n ord1: do while(ic.gt.0)\r\n ic=0\r\n! element /- is -1 and Va is 0\r\n do ia=1,nselel-1\r\n if(selel(ia)%elname.gt.selel(ia+1)%elname) then\r\n ic=1\r\n! shift data in ia and ia+1, very clumsy\r\n selel(maxtdbel)%elname=selel(ia)%elname\r\n selel(maxtdbel)%data=selel(ia)%data\r\n selel(ia)%elname=selel(ia+1)%elname\r\n selel(ia)%data=selel(ia+1)%data\r\n selel(ia+1)%elname=selel(maxtdbel)%elname\r\n selel(ia+1)%data=selel(maxtdbel)%data\r\n endif\r\n enddo\r\n if(ic.eq.0) exit ord1\r\n enddo ord1\r\n! write(*,10)(selel(nn)%elname,nn=1,nselel)\r\n10 format('Elements entered: ',20(a,1x))\r\n! this is very clumsy\r\n! write(*,*)'Order species alphabetically in selspord'\r\n! allocate(selspord(nselsp+1))\r\n! allocate(ss(nselsp+1))\r\n! allocate(orig(nselsp+1))\r\n allocate(selspord(maxtdbsp))\r\n allocate(ss(maxtdbsp))\r\n allocate(orig(maxtdbsp))\r\n do ia=1,nselsp\r\n selspord(ia)=ia\r\n orig(ia)=ia\r\n ss(ia)=selsp(ia)%species\r\n enddo\r\n!\r\n kk=0\r\n ord2: do while(.true.)\r\n! there is no /- species and Va is in alphabetical order\r\n ic=0\r\n! kk=kk+1\r\n do ia=1,nselsp-1\r\n! write(*,*)'Comparing ',ia,' \"',trim(ss(ia)),&\r\n! '\" and \"',trim(ss(ia+1)),'\"'\r\n if(ss(ia).gt.ss(ia+1)) then\r\n ic=1\r\n byt2=ss(ia)\r\n ss(ia)=ss(ia+1)\r\n ss(ia+1)=byt2\r\n jj=orig(ia)\r\n orig(ia)=orig(ia+1)\r\n orig(ia+1)=jj\r\n selspord(ia+1)=jj\r\n endif\r\n enddo\r\n if(ic.eq.0) exit ord2\r\n enddo ord2\r\n do ia=1,nselsp\r\n! write(*,90)ia,trim(ss(ia)),orig(ia)\r\n! selspord is in alphabetical order and has index to species\r\n selspord(ia)=orig(ia)\r\n enddo\r\n endif\r\n return\r\n end subroutine alphabetical_order\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCenterpar(parname,skip,bibref)\r\n! enter Parameter in OC if phase and constituents entered, FUNCTION IN wholexpr\r\n character*(*) parname,bibref\r\n! bibfref can be just a space if not used\r\n integer skip\r\n! return skip -1 or -2 if not needed\r\n!\r\n character*24 phase, constituent\r\n character MPID*8\r\n! the call to addmissingtp should only be used if the parameter is entered\r\n character*24 phasename\r\n integer nn,lk,lm,ip,lph,kk\r\n\r\n! Check that the parameter needed, i.e. phase and constituents entered\r\n! write(*,7)trim(parname)\r\n7 format(/'In OCenterpar: ',a)\r\n call checkifparisneeded(parname,lph)\r\n \r\n if(lph.lt.0) then\r\n! lph=-1 means phase not entered\r\n! if(lph.eq.-1) write(*,*)'Parameter not entered as phase not present'\r\n! if(lph.eq.-2) write(*,*)'Parameter not entered as constituent missing'\r\n skip=lph\r\n goto 1000\r\n endif\r\n!-----------------------\r\n! Enter this parameter, the parameter may need new TPfuns, check wholexpr\r\n call addmissingtp(parname)\r\n!\r\n! enter expr with bibref and add bibref to be added\r\n wholexpr=wholexpr//' '//bibref\r\n nselpar=nselpar+1\r\n if(nselpar.gt.maxpar) then\r\n write(*,*)'Too many parameters ',maxpar\r\n else\r\n selpar(nselpar)%parname=trim(parname)\r\n selpar(nselpar)%data=trim(wholexpr)\r\n endif\r\n! if entered in OC then add bibref to selbibref\r\n lk=len_trim(bibref)\r\n if(lk.gt.0) then\r\n do nn=1,nselbib\r\n! exit if already in selbib\r\n if(bibref.eq.selbib(nn)%bibitem(1:lk)) goto 300\r\n enddo\r\n if(nselbib.ge.maxbib) then\r\n write(*,*)'Too many bibliographic references 2 ',maxbib\r\n! check if the same appears several times ...\r\n do nn=1,nselbib\r\n write(*,*)'Bibref: ',selbib(nn)%bibitem\r\n do kk=1,nselbib\r\n if(kk.ne.nn) then\r\n if(selbib(nn)%bibitem.eq.selbib(kk)%bibitem) then\r\n write(*,*)'Duplicate reference',kk,nn,selbib(kk)%bibitem\r\n endif\r\n endif\r\n enddo\r\n enddo\r\n else\r\n nselbib=nselbib+1\r\n selbib(nselbib)%bibitem=bibref\r\n! mark this as missing\r\n selbib(nselbib)%status=-1\r\n endif\r\n endif\r\n300 continue\r\n! exit here if parameter not needed\r\n1000 continue\r\n return\r\n end subroutine OCenterpar\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine checkifparisneeded(parname,lph)\r\n! check if phase and constituents present in this parameter\r\n! The phase name may be abbreviated between \"_\" characters\r\n implicit none\r\n character*(*) parname\r\n character*24 phasename,constituent\r\n character(len=:), allocatable :: mpid\r\n integer lk,lm,ln,lph,lcomma,lcolon,lsemic,lright,lend\r\n integer js,jmod,jmpid\r\n!\r\n lph=0\r\n lk=index(parname,'(')\r\n if(lk.le.0) then\r\n write(*,*)'3EY Missing ( in parameter: ',trim(parname)\r\n xtdberr=4544; goto 1000\r\n endif\r\n mpid=parname(1:lk-1)\r\n! write(*,*)'MPID: \"',mpid,'\"',lk\r\n! check MPID is OK (must not be abbreviated)\r\n! do ln=1,noofmpid\r\n! if(mpid.eq.mpidok(ln)) goto 110\r\n! enddo\r\n!---------------------------------------------------------\r\n! VERY SPECIAL, always accept a single L as G. Even for endmembers ...\r\n if(mpid.eq.'L') mpid='G'\r\n if(mpid.eq.'G') goto 110\r\n! otherwise we have to find which model it belongs to ...\r\n!---------------------------------------------------------\r\n\r\n! There are 5 models with MPID, 3 magnetic, Einstein, liq2state\r\n do jmod=1,5\r\n! write(*,*)'Testing ',mpid,'. number of MPIDs for jmod ',&\r\n! jmod,xtdbmodel(jmod)%nmpid\r\n do jmpid=1,xtdbmodel(jmod)%nmpid\r\n if(mpid.eq.xtdbmodel(jmod)%mpid(jmpid)(1:lk-1)) then\r\n! write(*,*)'3EY Found model of MPID: \"',mpid,'\" is ',jmod,jmpid\r\n goto 110\r\n endif\r\n! write(*,108)mpid,xtdbmodel(jmod)%mpid(jmpid)(1:lk-1),jmod,jmpid\r\n108 format('3EY MPIDs: \"',a,'\" and \"',a,'\" indices: ',2i4) \r\n enddo\r\n enddo\r\n! now we use gtp_xtdbcompatibility: xtdbmodel\r\n! we have an unknown MPID\r\n write(*,*)'3EY Unknown Model Parameter IDentification (MPID): \"',mpid,'\"'\r\n write(*,*)'Parameter: \"',trim(parname),'\"'\r\n xtdberr=4546\r\n goto 1000\r\n!---------------------------------------------------------\r\n110 continue\r\n! there must be a , after the phase name lk+1 is the first letter\r\n lm=index(parname(lk+1:),',')\r\n if(lm.le.0) then\r\n write(*,*)'3EY Missing \",\" after phase name in parameter: ',trim(parname)\r\n write(*,*)'Parameter: \"',trim(parname),'\"'\r\n xtdberr=4545; goto 1000\r\n endif\r\n!\r\n phasename=parname(lk+1:lk+lm-1)\r\n lk=lk+lm+1\r\n! check this is a selected phase, allowing abbreviations\r\n! write(*,*)'Calling findabbrphname 1: \"',phasename,'\"'\r\n call findabbrphname(phasename,lph)\r\n if(lph.le.0) then\r\n write(*,*)'Phase not selected \"',phasename,'\" parameter ignored'\r\n goto 1000\r\n endif\r\n! if lph>0 check also that the constituents are present in correct sublattices\r\n! a comma deparates constituents in a sublattice, a colon in different\r\n! the semicolon and ) is the end of constituents\r\n lcomma=index(parname(lk:),',')\r\n lcolon=index(parname(lk:),':')\r\n lsemic=index(parname(lk:),';')\r\n lright=index(parname(lk:),')')\r\n! write(*,195)trim(parname(lk:)),lcolon,lcomma,lsemic,lright,lk\r\n195 format('Constituent array \"',a,'\" ',5i5)\r\n if(lcomma.eq.0 .and. lcolon.eq.0) then\r\n! the single constituent is terminated by ; or )\r\n if(lsemic.eq.0) then\r\n! there is always )\r\n constituent=parname(lk:lk+lright-2)\r\n else\r\n! if there is a ; that comes before )\r\n constituent=parname(lk:lk+lsemic-2)\r\n endif\r\n! write(*,*)'Constituent 1: ',trim(constituent)\r\n! A wildcard * in a single sublattice phase (rare!) is accepted\r\n if(constituent(1:1).eq.'*') goto 500\r\n do js=1,nselsp\r\n if(constituent.eq.selsp(js)%species) goto 500\r\n enddo\r\n goto 1100\r\n else\r\n! we have to handle several sublattices and interacting constituents\r\n! I do not understand the -4, I thought -2 would be correct\r\n if(lsemic.eq.0) then\r\n lend=lk+lsemic-4\r\n else\r\n lend=lk+lright-4\r\n endif\r\n! write(*,*)'More: \"',trim(parname(lk:)),'\"',lcolon,lcomma,lend\r\n! loop to extract all constituents terminated by , or : before lend\r\n more: do while(.true.)\r\n if(lcolon.gt.0 .and. lcomma.gt.0) then\r\n if(lcolon.lt.lcomma) then\r\n constituent=parname(lk:lk+lcolon-2)\r\n! write(*,*)'Constituent 2: ',trim(constituent)\r\n lk=lk+lcolon\r\n lcomma=lcomma-lcolon\r\n! lk is updated to position after the constutent found\r\n lcolon=index(parname(lk:),':')\r\n! if(lcolon.gt.0) lcolon=lk+lcolon\r\n! write(*,*)'Remaining: \"',trim(parname(lk:)),'\"',lk,lcolon,lcomma\r\n else\r\n constituent=parname(lk:lk+lcomma-2)\r\n! write(*,*)'Constituent 3: ',trim(constituent)\r\n lk=lk+lcomma\r\n lcolon=lcolon-lcomma\r\n lcomma=index(parname(lk:),',')\r\n! if(lcomma.gt.0) lcomma=lk+lcomma\r\n! write(*,*)'Remaining: \"',trim(parname(lk:)),'\"',lk,lcolon,lcomma\r\n endif\r\n! accept a wildcard \"*\" only if all other constituents selected\r\n if(constituent(1:1).ne.'*') then\r\n do js=1,nselsp\r\n if(constituent.eq.selsp(js)%species) cycle more\r\n enddo\r\n endif\r\n! constituent is not not selected\r\n goto 1100\r\n endif\r\n! write(*,*)'Only comma or colon',lcolon,lcomma,lend\r\n if(lcolon.gt.0) then\r\n constituent=parname(lk:lk+lcolon-2)\r\n! write(*,*)'Constituent 4: ',trim(constituent)\r\n lk=lk+lcolon\r\n lcolon=index(parname(lk:),':')\r\n! if(lcolon.gt.0) lcolon=lk+lcolon\r\n! write(*,*)'Remaining: \"',trim(parname(lk:)),'\"',lk,lcolon,lcomma\r\n elseif(lcomma.gt.0) then\r\n constituent=parname(lk:lk+lcomma-2)\r\n! write(*,*)'Constituent 5: ',trim(constituent)\r\n lk=lk+lcomma\r\n lcomma=index(parname(lk:),',')\r\n! if(lcomma.gt.0) lcomma=lk+lcomma\r\n! write(*,*)'Remaining: \"',trim(parname(lk:)),'\"',lk,lcolon,lcomma\r\n else\r\n constituent=parname(lk:lend)\r\n! write(*,*)'Constituent 6: ',trim(constituent),lk,lend,lsemic\r\n lk=lend\r\n endif\r\n! always accept wildcard *\r\n if(constituent(1:1).eq.'*') goto 500\r\n do js=1,nselsp\r\n if(constituent.eq.selsp(js)%species) then\r\n if(lk.eq.lend) then\r\n goto 500\r\n else\r\n cycle more\r\n endif\r\n endif\r\n enddo\r\n! constituent is not entered\r\n goto 1100\r\n! maybe there are more constituents, unless lk is lk is ge lend\r\n200 continue\r\n if(lk.ge.lend) exit more\r\n cycle more\r\n enddo more\r\n endif\r\n! we have the phase and species, enter parameter\r\n500 continue\r\n! write(*,*)'Phase and constituents OK'\r\n1000 continue\r\n return\r\n! parameter contain species not selected\r\n1100 continue\r\n! write(*,*)' *** Parameter skipped as constituent not selected ***'\r\n lph=-2\r\n goto 1000\r\n return\r\n end subroutine checkifparisneeded\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine findabbrphname(phasename,lp)\r\n character phasename*(*)\r\n integer lp ! is position after phase name ?? or phase index??\r\n!----------------\r\n integer lpp,lpx,ok1,lenph\r\n logical debug\r\n character*1 chp,chx\r\n! write(*,9)phasename\r\n9 format('In findabbrphname: \"',a,'\"')\r\n debug=.false.\r\n lenph=len(phasename)\r\n ok1=0 ! index of any previous matching phase\r\n!\r\n! phase names may be abbreviated between each \"_\". ! It must start with A-Z\r\n! An array with selcted phases in selph(array)%phasename\r\n! It can be a bit complicated, the phase names are in arbitrary order\r\n lpp=0 ! position in phasename\r\n lp=1 ! array index in selph(array)\r\n lpx=0 ! position in selph(array)%phasename(lpx:lpx)\r\n bigloop: do while(.true.)\r\n lpp=lpp+1\r\n if(lpp.gt.lenph) then\r\n! this is lenght of provide phase and we have match up to this position, accept\r\n! normally a phase name ends with a space but with allocated characters ...\r\n! write(*,*)'Is \"',phasename,'\" same as \"',selph(lp)%phasename,'\"?'\r\n lph=lp; goto 1000\r\n endif\r\n chp=phasename(lpp:lpp)\r\n lpx=lpx+1\r\n chx=selph(lp)%phasename(lpx:lpx)\r\n! if same character, compare next characters in lpp and lpx\r\n! write(*,*)'Letters \"',chx,'\" \"',chp,'\" position ',lpp,lpx\r\n if(chp.eq.chx .and. chp.ne.' ') cycle bigloop\r\n! The first character MUST be the same\r\n if(lpp.gt.1) then\r\n if(chp.eq.' ') then\r\n! trailing characters in selph(lp)%phasename irrelevant but check ambiguous\r\n! up to now we have found the same characters but it can be ambigous ...\r\n if(ok1.gt.0) then\r\n write(*,30)phasename,selph(ok1)%phasename,selph(lp)%phasename\r\n30 format('Ambiguous phase name: \"',a,'\"'/'\"',a,'\" and \"',a,'\"')\r\n else\r\n! save this then check the remaining phases\r\n ok1=lp;\r\n lp=lp+1; lpp=0; lpx=0\r\n endif\r\n elseif(chp.eq.'_') then\r\n! chx is not \"_\", skip in selph(lp)%ohasename up to \"_\". If no _ skip\r\n! if we find a \"_\" continue compare the characters following this\r\n do while(chx.ne.'_')\r\n if(lpx.ge.len(selph(lp)%phasename)) then\r\n! we have reached the end of selph(lp), skip this phase\r\n lp=lp+1; lpp=0; lpx=0\r\n cycle bigloop\r\n endif\r\n lpx=lpx+1; chx=selph(lp)%phasename(lpx:lpx)\r\n if(chx.eq.' ') then\r\n! we do not find any \"_\" but a space, skip this phase\r\n lp=lp+1; lpp=0; lpx=0\r\n cycle bigloop\r\n endif\r\n enddo\r\n! we found a \"_\" in selph(lp)%phasename. Backtrack both lpp and lpx\r\n lpx=lpx-1; lpp=lpp-1\r\n cycle bigloop\r\n endif\r\n endif\r\n! not the same character, compare with next phase in selph(array)\r\n lp=lp+1\r\n if(lp.le.nselph) then\r\n lpp=0; lpx=0\r\n cycle bigloop\r\n else\r\n! we have compared with all phases in selph(1..nselph)\r\n if(ok1.gt.0) then\r\n! write(*,*)\r\n50 format('We found phase: \"',a,'\" and \"',a,'\"')\r\n lp=ok1\r\n else\r\n lp=-1\r\n endif\r\n exit bigloop\r\n endif\r\n enddo bigloop\r\n1000 continue\r\n return\r\n end subroutine findabbrphname\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCentertpfun(tpfuname)\r\n! enter TPfun data in OC. MISSING check if needed. Function in wholexpr\r\n character*(*) tpfuname\r\n! the call to addmissingtp should only be used if the parameter is entered\r\n integer nn\r\n! check if tpfun uses other tpfun\r\n call addmissingtp(tpfuname) ! the wholexpr is a global variable\r\n! add bibref here otherwise it may be entered as missing TPfun \r\n! write(*,10)tpfuname,trim(wholexpr)\r\n10 format('In xtdbOCfun: ',a,2x,a,2x,a)\r\n return\r\n end subroutine OCentertpfun\r\n\r\n!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n\r\n subroutine OCenterbibitem(bibitem,text)\r\n! enter referenced bibitem in OC\r\n character*(*) bibitem,text\r\n! should only be used if the parameter is entered\r\n integer nbib,ll\r\n write(*,*)'In OCenterbibitem'\r\n ll=len_trim(bibitem)\r\n do nbib=1,nselbib\r\n if(bibitem.eq.selbib(nbib)%bibitem(1:ll)) goto 200\r\n enddo\r\n! bibitem not found\r\n goto 1000\r\n! found bibitem\r\n200 continue\r\n nselbib=nselbib+1\r\n selbib(nselbib)%bibitem=bibitem\r\n selbib(nselbib)%data=text\r\n selbib(nselbib)%status=1\r\n1000 continue\r\n return\r\n end subroutine OCenterbibitem\r\n\r\n! end module xtdblib\r\n\r\n" }, { "path": "src/models/gtp3F.F90", "content": "!\r\n! GTP3F included in gtp3.F90\r\n!\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n!> 10. Section: state variable manipulations\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine get_stable_state_var_value\r\n!\\begin{verbatim}\r\n subroutine get_stable_state_var_value(statevar,value,encoded,ceq)\r\n! called with a state variable character\r\n! If the state variable includes a phase it checks if the phase is stable ...\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n character statevar*(*),encoded*(*)\r\n double precision value\r\n!\\end{verbatim} %+\r\n integer lokcs,ics,ip\r\n! type(gtp_state_variable), pointer :: svr\r\n type(gtp_state_variable), target :: svrvar\r\n type(gtp_state_variable), pointer :: svr\r\n character modstatevar*28\r\n!\r\n! memory leak fix\r\n svr=>svrvar\r\n call decode_state_variable(statevar,svr,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! check if state variable inclused a phase\r\n! argtyp=0: no arguments\r\n! argtyp=1: component\r\n! argtyp=2: phase+compset\r\n! argtyp=3: phase+compset+component\r\n! argtyp=4: phase+compset+constituent\r\n modstatevar=statevar\r\n! write(*,*)'3F stable: ',modstatevar,svr%argtyp,phlista(svr%phase)%noofcs\r\n if(svr%argtyp.eq.2) then\r\n! if compset > 1 specified do nothing\r\n if(svr%compset.ne.1) goto 1000\r\n! svr%phase,svr%compset\r\n lokcs=phlista(svr%phase)%linktocs(svr%compset)\r\n! write(*,*)'3F phase: ',svr%compset,phlista(svr%phase)%noofcs,&\r\n! ceq%phase_varres(lokcs)%phstate,PHENTSTAB\r\n if(ceq%phase_varres(lokcs)%phstate.ne.PHENTSTAB) then\r\n! phase+compset is not stable, chek if there is other stable compset\r\n loop: do ics=1,phlista(svr%phase)%noofcs\r\n lokcs=phlista(svr%phase)%linktocs(ics)\r\n! write(*,*)'3F looping: ',ics,lokcs,ceq%phase_varres(lokcs)%phstate\r\n if(ceq%phase_varres(lokcs)%phstate.eq.PHENTSTAB) then\r\n! add a composition set index after phase name\r\n ip=index(modstatevar,',')\r\n if(ip.eq.0) ip=index(modstatevar,')')\r\n! maybe there is a #1 ??\r\n if(modstatevar(ip-2:ip-2).eq.'#') then\r\n modstatevar(ip-1:ip-1)=char(ics+ichar('0'))\r\n else\r\n modstatevar(ip:)='#'//char(ics+ichar('0'))\r\n modstatevar(ip+2:)=statevar(ip:)\r\n endif\r\n! write(*,*)'3F Modfied statevar: ',modstatevar\r\n exit loop\r\n endif\r\n enddo loop\r\n endif\r\n endif\r\n! looking for bug ... not here\r\n! write(*,*)'3F calling get_state_var_value'\r\n call get_state_var_value(modstatevar,value,encoded,ceq)\r\n! write(*,*)'3F back from get_state_var_value',value,' ',trim(encoded)\r\n1000 continue\r\n! possible memory leak\r\n! write(*,*)'3F exit get_stable_state_var_value'\r\n nullify(svr)\r\n return\r\n end subroutine get_stable_state_var_value\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine get_state_var_value\r\n!\\begin{verbatim} %-\r\n subroutine get_state_var_value(statevar,value,encoded,ceq)\r\n! called with a state variable character\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n character statevar*(*),encoded*(*)\r\n double precision value\r\n!\\end{verbatim}\r\n! integer indices(4)\r\n integer iunit,ip,lrot,mode\r\n! memory leak\r\n type(gtp_state_variable), target :: svrvar\r\n type(gtp_state_variable), pointer :: svr\r\n character actual_arg(2)*16,name*16\r\n!\r\n! write(*,*)'3F In get_state_variable_value: ',statevar\r\n iunit=0\r\n svr=>svrvar\r\n!check if there is a \".\" (dot) neaing it is a dot derivative\r\n if(index(statevar,'.').gt.0) then\r\n write(*,*)'3F dot derivatives must be entered as symbols: ',trim(statevar)\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n call decode_state_variable(statevar,svr,ceq)\r\n! write(*,20)statevar(1:len_trim(statevar)),svr%oldstv,svr%norm,&\r\n! svr%argtyp,svr%component,gx%bmperr\r\n20 format('3F gsvv 1: ',a,' : ',5i3)\r\n if(gx%bmperr.ne.0) then\r\n! goto 1000\r\n! it can be a state variable symbol ...\r\n!\r\n! Possible problem ... this can cause nesting as a state variable will\r\n! normally evaluate some state variables or other state variable functions\r\n!\r\n gx%bmperr=0\r\n name=statevar\r\n call capson(name)\r\n! call find_svfun(name,lrot,ceq)\r\n call find_svfun(name,lrot)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Neither state variable or symbol, maybe model-param-id?'\r\n gx%bmperr=4399; goto 1000\r\n else\r\n! get the value of the symbol, may involve other symbols and state variablse\r\n! The actual_arg is a facility not yet implemented and not allowed here\r\n! if mode=0 the stored value may be used, mode=1 always evaluate\r\n! write(*,*)'3F Found function: ',lrot\r\n actual_arg=' '\r\n mode=1\r\n if(btest(svflista(lrot)%status,SVFDOT)) then\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! this is OK if it is not a derivative\r\n! BUT be careful!! it can be a value that must be calculated explicitly!!\r\n if(btest(svflista(lrot)%status,SVFVAL)) then\r\n value=ceq%svfunres(lrot)\r\n! write(*,*)'3F Extracting saved value for: ',trim(name),value\r\n else\r\n! write(*,*)'3F call svaluate_svfun_old 1'\r\n value=evaluate_svfun_old(lrot,actual_arg,mode,ceq)\r\n if(gx%bmperr.eq.4217) goto 1000\r\n endif\r\n encoded=name\r\n endif\r\n else\r\n! it is a real state variable\r\n! write(*,*)'3F calling state_variable_val from get_state_var_value'\r\n call state_variable_val(svr,value,ceq)\r\n! write(*,*)'3F back from state_variable_val',value\r\n if(gx%bmperr.ne.0) goto 1000\r\n ip=1\r\n encoded=' '\r\n call encode_state_variable(encoded,ip,svr,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F encode error: ',trim(encoded),gx%bmperr\r\n gx%bmperr=0; encoded='dummy'\r\n endif\r\n! write(*,*)'3F get_state_var_value encoded: ',trim(encoded)\r\n endif\r\n1000 continue\r\n! possible memory leak\r\n nullify(svr)\r\n return\r\n end subroutine get_state_var_value\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine get_many_svar\r\n!\\begin{verbatim}\r\n subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq)\r\n! called with a state variable name with wildcards allowed like NP(*), X(*,CR)\r\n! mjj is dimension of values, kjj is number of values returned\r\n! encoded used to specify if phase data in phasetuple order ('Z')\r\n! >>>> BIG question: How to do with phases that are note stable?\r\n! If I ask for w(*,Cr) I only want the fraction in stable phases\r\n! but when this is used for GNUPLOT the values are written in a matix\r\n! and the same column in that phase must be the same phase ...\r\n! so I have to have the same number of phases from each equilibria.\r\n! tentative added feature: # instead of * means also metastable phases\r\n! BEWHERE # is used also for composition set and sublattice index!\r\n!\r\n! CURRENTLY if x(*,*) and x(*,A) mole fractions only in stable phases\r\n!\r\n! >>>>>>>>>>>>>>>> there is a segmentation fault in this subroutine when\r\n! called from ocplot2 in the map11.OCM\r\n! for the second plot as part of all.OCM\r\n! but not when called by itself. SUCK\r\n! probably caused by the fact that the number of composition sets are different\r\n! >>>>>>>>>>>>>>>>\r\n! A new segmentation fault for map2 when plotting with 2 maptops and the\r\n! first does not have a new composition set LIQUID_AUTO#2 created in the \r\n! second map. I do not understand how that has ever worked??\r\n! >>>>>>>>>>>>>>>>\r\n!\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n character statevar*(*),encoded*(*)\r\n double precision values(*)\r\n integer mjj,kjj\r\n!\\end{verbatim}\r\n integer indices(4),modind(4)\r\n double precision xnan,xxx\r\n integer jj,lokph,lokcs,k1,k2,k3,iref,jl,iunit,istv,enpos,maxen\r\n logical onlystable\r\n! memory leak\r\n type(gtp_state_variable), target :: svrvar\r\n type(gtp_state_variable), pointer :: svr\r\n! logical phtupord\r\n! check for character overflow, leave at least 100 at end\r\n maxen=len(encoded)-30\r\n! calculate the NaN bit pattern\r\n xnan=0.0d0\r\n! xnan=0.0d0/xnan\r\n encoded=' '\r\n enpos=1\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Error entering get_many_svar ',gx%bmperr,xnan\r\n endif\r\n!------------------------\r\n iunit=0\r\n modind=0\r\n! phtupord=.FALSE.\r\n! if(encoded(1:1).eq.'Z') then\r\n! when called from TQ interface the phase order should be as for phase tuples\r\n! phtupord=.TRUE.\r\n! endif\r\n! called from minimizer for testing\r\n svr=>svrvar\r\n call decode_state_variable(statevar,svr,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Failed decode statevar in get_many_svar',gx%bmperr\r\n goto 1000\r\n endif\r\n! write(*,*)'3F get_many_svar 1: ',trim(statevar),svr%argtyp,svr%phase\r\n! translate svr data to old indices etc\r\n istv=svr%oldstv\r\n iref=svr%phref\r\n iunit=svr%unit\r\n! svr%argtyp specifies values in indices:\r\n! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const\r\n indices=0\r\n if(svr%argtyp.eq.1) then\r\n indices(1)=svr%component\r\n elseif(svr%argtyp.eq.2) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n elseif(svr%argtyp.eq.3) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%component\r\n elseif(svr%argtyp.eq.4) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%constituent\r\n endif\r\n! write(*,*)'3F get_many_svar 2: ',trim(statevar),svr%argtyp,indices\r\n!\r\n! write(*,20)istv,indices,iref,iunit,gx%bmperr\r\n20 format('3F many 1: ',i5,4i4,3i7)\r\n! -----------------------------------------\r\n! Indices 1: one or all components (-1)\r\n! Indices 2+3: 0 or phase+set \r\n! Indices 1+2: phase+set\r\n! Indices 3: 0 or component (-1) or constituent (-2)\r\n! indices 4 never used\r\n! -----------------------------------------\r\n! -1 means element or component\r\n! -2 species or constituent\r\n! -3 phase\r\n! -4 composition set\r\n! indices(1)=-10 phase & compset means all phases also metastable \"#\"\r\n jj=0\r\n onlystable=.true.\r\n if(indices(1).ge.0) then\r\n if(indices(2).ge.0) then\r\n if(indices(3).ge.0) then\r\n! all indices given, a single value\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n elseif(indices(3).eq.-1) then\r\n! loop for components, indices 1+2 must be phase+compset\r\n do k3=1,noofel\r\n indices(3)=k3\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo\r\n elseif(indices(3).eq.-2) then\r\n! loop for constituents, indices 1+2 must be phase+compset\r\n call get_phase_record(indices(1),lokph)\r\n do k3=1,phlista(lokph)%tnooffr\r\n indices(3)=k3\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo\r\n else\r\n! indices(3) must be -2, -1 or >=0 so if we are here there is an error\r\n write(*,17)'3F Illegal set of indices 1',(indices(jl),jl=1,4)\r\n17 format(a,4i4)\r\n gx%bmperr=4317; goto 1000\r\n endif\r\n elseif(indices(2).eq.-3 .or. indices(2).eq.-10) then\r\n! if indices(1)>=0 then indices(2)<0 must means a loop for all phase+compset\r\n! write(*,*)'3F seg.fault ',noofph\r\n do k2=1,noofph\r\n indices(2)=k2\r\n call get_phase_record(indices(2),lokph)\r\n do k3=1,phlista(lokph)%noofcs\r\n indices(3)=k3\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call get_phase_compset(indices(2),indices(3),lokph,lokcs)\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n! if composition set not stable so return NaN (in xnan)\r\n if(test_phase_status(indices(2),indices(3),xxx,ceq).le. &\r\n PHENTUNST) then\r\n values(jj)=xnan\r\n elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then\r\n! the phase must not have negative driving force\r\n values(jj)=xnan\r\n else\r\n! problem that get_many returns values for unstable phases\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n23 format(a,2i3,2(1pe14.6))\r\n endif\r\n enddo\r\n enddo\r\n else\r\n! if indices(1)>=0 then indices(2) must be -3 or >=0, so if here it is error\r\n write(*,17)'3F Illegal set of indices 2',(indices(jl),jl=1,4)\r\n gx%bmperr=4317; goto 1000\r\n endif\r\n elseif(indices(1).eq.-1) then\r\n! loop for component as first indices, 2+3 can be fix phase+compset\r\n! NOTE: loop for x(*,*) is below with indices(1).eq.-3\r\n! write(*,*)'3F indices: ',indices\r\n if(indices(2).ge.0) then\r\n do k1=1,noofel\r\n indices(1)=k1\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo\r\n elseif(indices(2).eq.-3) then\r\n! loop for components and phase+compset\r\n do k1=1,noofel\r\n indices(1)=k1\r\n do k2=1,noofph\r\n indices(2)=k2\r\n call get_phase_record(indices(2),lokph)\r\n do k3=1,phlista(lokph)%noofcs\r\n indices(3)=k3\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call get_phase_compset(indices(2),indices(3),lokph,lokcs)\r\n! if composition not stable so return NaN\r\n call encode_state_variable3(encoded,enpos,istv,indices,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n if(test_phase_status(indices(2),indices(3),xxx,ceq).le. &\r\n PHENTSTAB) then\r\n! xnan means \"no value\"\r\n values(jj)=xnan\r\n elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then\r\n! the phase must not have negative driving force\r\n values(jj)=xnan\r\n else\r\n! here the value is extracted\r\n call state_variable_val3(istv,indices,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n enddo\r\n enddo\r\n enddo\r\n else\r\n! if we come here it must be an error\r\n write(*,17)'3F Illegal set of indices 3',(indices(jl),jl=1,4)\r\n gx%bmperr=4317; goto 1000\r\n endif\r\n! elseif(indices(1).eq.-3) then\r\n elseif(indices(1).eq.-3 .or. indices(1).eq.-10) then\r\n! loop for phase+compset as indices(1+2)\r\n! here we must be careful not to destroy original indices, use modind\r\n if(indices(1).eq.-10) onlystable=.FALSE.\r\n! write(*,*)'3F get_many NP(*) etc 1: ',gx%bmperr,indices(1),indices(3),&\r\n! onlystable,noofph\r\n phloop: do k1=1,noofph\r\n modind(1)=k1\r\n modind(2)=0\r\n call get_phase_record(modind(1),lokph)\r\n! write(*,19)'3F test 17',modind,gx%bmperr,xnan\r\n if(gx%bmperr.ne.0) goto 1000\r\n csloop: do k2=1,phlista(lokph)%noofcs\r\n modind(2)=k2\r\n call get_phase_compset(modind(1),modind(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! skip if phase+compset suspended\r\n! if(ceq%phase_varres(lokcs)%phstate.le.PHSUS)\r\n! if(indices(3).eq.0) then\r\n if(indices(3).le.0) then\r\n! This is typically listing of NP(*) for all phases\r\n modind(3)=0\r\n call encode_state_variable3(encoded,enpos,istv,modind,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F error encoding state variable'; goto 1000\r\n endif\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n! if the wildcard is # include also metastable\r\n if(onlystable .and. &\r\n ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then\r\n values(jj)=xnan\r\n else\r\n call state_variable_val3(istv,modind,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F error calling __val3'; goto 1000\r\n endif\r\n endif\r\n! elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then\r\n! call encode_state_variable3(encoded,enpos,istv,modind,&\r\n! iunit,iref,ceq)\r\n! if(gx%bmperr.ne.0) goto 1000\r\n! enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n! values(jj)=xnan\r\n elseif(indices(3).gt.0) then\r\n! This is typically listing of w(*,cr), only in stable range of phases\r\n modind(3)=indices(3)\r\n! write(*,*)'3F statevar 1A: ',modind(1),modind(2),modind(3)\r\n call get_phase_compset(modind(1),modind(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n call encode_state_variable3(encoded,enpos,istv,modind,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n jj=jj+1\r\n! write(*,*)'3F statevar 1B: ',trim(encoded),jj,&\r\n! lokph,ceq%phase_varres(lokcs)%phlink\r\n! write(*,*)'3F statevar 1B: ',jj,&\r\n! lokph,ceq%phase_varres(lokcs)%phlink\r\n if(jj.gt.mjj) goto 1100\r\n!--------------------------------------------------------------\r\n! Beware of segmentation faults at next call to state_variable_val3 !!!\r\n! This code should take care of the problem when new composition sets\r\n! have been created in different step/map commands and we then try\r\n! to extract wildcard state variables from these to plot.\r\n! ceq here can be a previous local ceq used for the step/map \r\n! without a compset created later.\r\n! write(*,333)'3F this composition set may not exist',&\r\n! lokcs,ceq%phase_varres(lokcs)%phstate,PHENTSTAB,&\r\n! ceq%phase_varres(lokcs)%phlink,lokph\r\n333 format(a,i4,2x,2i3,2x,2i4)\r\n if(.not.allocated(ceq%phase_varres(lokcs)%yfr)) then\r\n! if yfr is not allocated the composition set does not exist, skip this phase\r\n! write(*,*)'3F this composition set does not exist',&\r\n! ceq%phase_varres(lokcs)%phstate,PHENTSTAB\r\n values(jj)=xnan; goto 600\r\n endif\r\n!--------------------------------------------------------------\r\n if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then\r\n! if phase is not stable (phstate= -2, -1 or 0)set dummy value\r\n values(jj)=xnan\r\n else\r\n call state_variable_val3(istv,modind,iref,&\r\n iunit,values(jj),ceq)\r\n endif\r\n! write(*,*)'3F statevar 1C: ',jj,values(jj)\r\n! write(*,*)'3F statevar 1C: ',trim(encoded),jj,values(jj)\r\n! write(*,73)'3F listing w(*,A): ',istv,modind,iref,iunit,&\r\n! ceq%phase_varres(lokcs)%phstate,jj,values(jj)\r\n73 format(a,i5,2x,4i3,2x,2i4,2i5,1pe12.4)\r\n if(gx%bmperr.ne.0) goto 1000\r\n elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then\r\n! loop for all components or constitunets of stable phases\r\n! Maybe it should be included to have same number of values in all ranges?\r\n cycle csloop\r\n elseif(indices(3).eq.-1) then\r\n! loop for all components of all phases, skip unstable phases\r\n elloop: do k3=1,noofel\r\n modind(3)=k3\r\n call encode_state_variable3(encoded,enpos,istv,modind,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call state_variable_val3(istv,modind,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo elloop\r\n elseif(indices(3).eq.-2) then\r\n! loop for constituents of all phases\r\n conloop: do k3=1,phlista(lokph)%tnooffr\r\n modind(3)=k3\r\n call encode_state_variable3(encoded,enpos,istv,modind,&\r\n iunit,iref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enpos=enpos+1\r\n! check for overflow in encoded\r\n if(enpos.gt.maxen) goto 1100\r\n jj=jj+1\r\n if(jj.gt.mjj) goto 1100\r\n call state_variable_val3(istv,modind,iref,&\r\n iunit,values(jj),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo conloop\r\n else\r\n! error if here\r\n write(*,17)'3F Illegal set of indices 4',(indices(jl),jl=1,4)\r\n gx%bmperr=4317; goto 1000\r\n endif\r\n600 continue\r\n if(gx%bmperr.ne.0) then\r\n write(*,19)'3F error 3',modind,gx%bmperr\r\n19 format(a,4i4,i7)\r\n goto 1000\r\n endif\r\n enddo csloop\r\n enddo phloop\r\n! write(*,*)'3F jj: ',jj\r\n else\r\n! error if here\r\n write(*,17)'3F Illegal set of indices 5',(indices(jl),jl=1,4)\r\n gx%bmperr=4317; goto 1000\r\n endif\r\n1000 continue\r\n! possible memory leak, BUT nullify does not release memory\r\n nullify(svr)\r\n kjj=jj\r\n return\r\n1100 continue\r\n write(*,1102)enpos,maxen,jj,mjj\r\n1102 format('3F Overflow using get_many_svar: ',2i6,5x,2i6)\r\n gx%bmperr=4317; goto 1000\r\n end subroutine get_many_svar\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine decode_state_variable\r\n!\\begin{verbatim}\r\n subroutine decode_state_variable(statevar,svr,ceq)\r\n! converts a state variable character to state variable record\r\n character statevar*(*)\r\n type(gtp_state_variable), pointer :: svr\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n! this subroutine using state variable records is a front end of the next:\r\n!\\end{verbatim} %+\r\n! type(gtp_state_variable) :: svrec \r\n integer istv,indices(4),iref,iunit\r\n call decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq)\r\n1000 continue\r\n return\r\n end subroutine decode_state_variable\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine decode_state_variable3\r\n!\\begin{verbatim} %-\r\n subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq)\r\n! converts an old state variable character to indices \r\n! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe)\r\n! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected\r\n! NOTE: added storing information in a gtp_state_variable record svrec !!\r\n!\r\n! this routine became as messy as I tried to avoid\r\n! but I leave it to someone else to clean it up ...\r\n!\r\n! state variable and indices\r\n! Symbol no index1 index2 index3 index4 \r\n! T 1 -\r\n! P 2 -\r\n! MU 3 component or phase,component\r\n! AC 4 component or phase,component\r\n! LNAC 5 component or phase,component\r\n! index (in svid array)\r\n! U 10 (phase#set) 6 Internal energy (J)\r\n! UM 11 \" 6 per mole components\r\n! UW 12 \" 6 per kg\r\n! UV 13 \" 6 per m3\r\n! UF 14 \" 6 per formula unit\r\n! S 2x \" 7 entropy\r\n! V 3x \" 8 volume\r\n! H 4x \" 9 enthalpy\r\n! A 5x \" 10 Helmholtz energy\r\n! G 6x \" 11 Gibbs energy\r\n! NP 7x \" 12 moles of phase\r\n! BP 8x \" 13 mass of moles\r\n! DG 9x \" 15 Driving force\r\n! Q 10x \" 14 Internal stability\r\n! N 11x (component/phase#set,component) 16 moles of components\r\n! X 111 \" 17 mole fraction of components\r\n! B 12x \" 18 mass of components\r\n! W 122 \" 19 mass fraction of components\r\n! Y 13 phase#set,constituent#subl 20 constituent fraction\r\n!----- model variables <<<< these now treated differently\r\n! TC - phase#set - Magnetic ordering T\r\n! BMAG - phase#set - Aver. Bohr magneton number\r\n! MQ& - element, phase#set - Mobility\r\n! LNTH - phase#set - LN(Einstein temperature)\r\n!\r\n implicit none\r\n integer, parameter :: noos=20\r\n character*4, dimension(noos), parameter :: svid = &\r\n ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',&\r\n 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',&\r\n 'X ','B ','W ','Y ']\r\n! 1 2 3 4 5? 6 7 8 \r\n! 9 10 11 12 13 14 15 16\r\n! 17 18 19 20\r\n character statevar*(*)\r\n integer istv,iref,iunit\r\n integer, dimension(4) :: indices\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n! I shall try to use this record type instead of separate arguments: !!\r\n! type(gtp_state_variable), pointer :: svrec\r\n type(gtp_state_variable), pointer :: svr\r\n!\\end{verbatim}\r\n! type(gtp_state_variable), allocatable, target :: svr\r\n integer is,jp,kp,iph,ics,icon,icomp,norm,narg,icc\r\n double precision cmass,asum\r\n!\r\n character argument*60,arg1*24,arg2*24,ch1*1,lstate*60,propsym*60\r\n integer typty\r\n logical deblist\r\n istv=0\r\n! write(*,*)'3F in decode3 \"',trim(statevar),'\" ',istv\r\n! initiate svr internal variables\r\n deblist=.FALSE.\r\n! deblist=.TRUE.\r\n if(ocv()) deblist=.TRUE.\r\n if(deblist) write(*,*)'3F entering decode_statevariable: ',&\r\n statevar(1:len_trim(statevar))\r\n! write(*,*)'3F svr allocated'\r\n! memory leak\r\n! allocate(svr)\r\n! write(*,*)'3F svr assignment start'\r\n svr%oldstv=0\r\n svr%norm=0\r\n svr%unit=0\r\n! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const\r\n svr%argtyp=0\r\n svr%phref=0\r\n svr%phase=0\r\n svr%compset=0\r\n svr%component=0\r\n svr%constituent=0\r\n! write(*,*)'3F svr assignment end'\r\n!\r\n! For wildcard argument \"*\" return:\r\n! -1 for element or component\r\n! -2 for species or constituent\r\n! -3 for phase\r\n! -4 for composition set\r\n! -10 for also metastable phases and composition sets, using hash #\r\n istv=-1\r\n indices=0\r\n! iref=0 means user defined reference state\r\n iref=0\r\n! unit is not implemented (can apply to T, P, V, mass, etc)\r\n iunit=0\r\n iph=0\r\n ics=0\r\n norm=0\r\n! local character for state variable\r\n lstate=statevar\r\n call capson(lstate)\r\n if(deblist) write(*,*)'3F decode_state_var 1: ',lstate(1:20)\r\n! write(*,*)'3F decode_state_var 1: \"',trim(lstate),'\"'\r\n! compare first character\r\n ch1=lstate(1:1)\r\n! write(*,*)'3F decoding: ',trim(statevar),is,' ',ch1\r\n do is=1,noos\r\n if(ch1.eq.svid(is)(1:1)) goto 50\r\n enddo\r\n! it may be a property, parameter identifier\r\n if(deblist) write(*,*)'3F jump to 600!'\r\n goto 600\r\n!------------------------------------------------------------\r\n50 continue\r\n! There is an ambiguous case with first letter: \"AC\" and \"A\"\r\n! If is=4 it means we found an A, check if second letter is \"C\"\r\n if(is.eq.4) then\r\n if(lstate(2:2).ne.'C') then\r\n is=10\r\n endif\r\n endif\r\n! write(*,*)'3F we are here statevar ',trim(statevar),', ch1: ',ch1\r\n if(deblist) write(*,*)'3F dsv 1: ',ch1,is\r\n if(is.eq.1) then\r\n if(lstate(2:2).ne.' ') then\r\n! it must be a property like TC or THET\r\n goto 600\r\n endif\r\n! T\r\n istv=1; svr%oldstv=1; svr%statevarid=1; goto 1000\r\n elseif(is.eq.2) then\r\n! P\r\n if(lstate(2:2).ne.' ') goto 600\r\n istv=2; svr%oldstv=2; svr%statevarid=2; goto 1000\r\n elseif(is.gt.5) then\r\n goto 100\r\n endif\r\n!------------------------------------------------------------\r\n! MU 3 component, possible suffix S for SER reference\r\n chemp: if(is.eq.3) then\r\n if(lstate(1:2).ne.'MU') then\r\n goto 600\r\n endif\r\n istv=3\r\n jp=3\r\n elseif(is.eq.4) then\r\n! AC is 4 but just A or AM, AV etc can mean Helmholtz Energy or a property\r\n if(lstate(1:2).ne.'AC') then\r\n is=8; goto 100\r\n endif\r\n istv=4\r\n jp=3\r\n elseif(is.eq.5) then\r\n! LNAC 5 component\r\n if(lstate(1:4).ne.'LNAC') goto 600\r\n istv=5\r\n jp=5\r\n endif chemp\r\n! MU, AC and LNAC can have a suffix 'S', reference state, iref=0 is default\r\n if(lstate(jp:jp).eq.'S') then\r\n! This iref has not been treated correctly so far. The idea is now that\r\n! iref=0 means user defined reference state, if the user has not defined any\r\n! reference state it means SER. If the user specifies a suffix S it means\r\n! always SER even if the user has defined another reference state.\r\n! Maybe iref>0 will have some other meaing in the future ...\r\n iref=-1\r\n jp=jp+1\r\n endif\r\n! extract the argument, can be one or two indices\r\n svr%oldstv=istv; svr%statevarid=istv\r\n if(lstate(jp:jp).ne.'(') goto 1130\r\n kp=index(lstate,')')\r\n if(kp.lt.jp) then\r\n! write(*,*)'3F cannot find )',trim(lstate),jp,kp\r\n goto 1140\r\n endif\r\n argument=lstate(jp+1:kp-1)\r\n kp=index(argument,',')\r\n if(kp.gt.0) then\r\n! >>> if two arguments first is phase ??? different from TC\r\n arg1=argument(1:kp-1)\r\n arg2=argument(kp+1:)\r\n if(arg1(1:2).eq.'* ') then\r\n iph=-3\r\n else\r\n call find_phase_by_name(arg1,iph,ics)\r\n if(gx%bmperr.ne.0) goto 1150\r\n endif\r\n if(arg2(1:2).eq.'* ') then\r\n icon=-2\r\n else\r\n call find_constituent(iph,arg2,cmass,icon)\r\n if(gx%bmperr.ne.0) goto 1160\r\n call set_constituent_reference_state(iph,icon,asum)\r\n! write(*,*)'3F findconst for ref: ',arg2,cmass,icc\r\n if(gx%bmperr.ne.0) then\r\n gx%bmperr=4112; goto 1000\r\n endif\r\n endif\r\n! composition set irrelevant as chempot depend only on species stoichiometry\r\n indices(1)=iph\r\n indices(2)=icon\r\n svr%phase=iph\r\n svr%compset=1\r\n svr%constituent=icon\r\n svr%argtyp=4\r\n else\r\n if(argument(1:2).eq.'* ') then\r\n icomp=-1\r\n else\r\n call find_component_by_name(argument,icomp,ceq)\r\n if(gx%bmperr.ne.0) goto 1170\r\n endif\r\n indices(1)=icomp\r\n svr%component=icomp\r\n svr%argtyp=1\r\n endif\r\n goto 1000\r\n!=================================================================\r\n! extensive variable, is=6..20 or a model property\r\n100 continue\r\n jp=2\r\n! check second letter for some state variables\r\n if(deblist) write(*,105)is,norm,jp\r\n105 format('3F dsv 4: ',3i4)\r\n letter2: if(is.eq.12 .and. lstate(jp:jp).ne.'P') then\r\n! This is for Nx or a property\r\n is=16\r\n elseif(is.eq.13) then\r\n! this can be Bx for component, BP for phase or BMAG for Bohr magnetons\r\n if(lstate(jp-1:jp).eq.'BP') then\r\n jp=jp+1\r\n else\r\n! this is Bx or a property\r\n is=18\r\n endif\r\n elseif(is.eq.14 .and. lstate(jp-1:jp).ne.'DG') then\r\n! this is for Dx, can be a property\r\n! gx%bmperr=4107; goto 1000\r\n goto 600\r\n elseif(is.eq.12 .or. is.eq.14) then\r\n! This is NP or DG, increment jp to check the second character\r\n jp=jp+1\r\n elseif(is.eq.17 .or. is.eq.19) then\r\n! X and W can have a suffix % to indicate percentage\r\n if(lstate(jp:jp).eq.'%') then\r\n iunit=100\r\n jp=jp+1\r\n svr%unit=iunit\r\n endif\r\n endif letter2\r\n!---------------------------------------------------------------------\r\n! All this is for extensive properties \r\n! If we come here the first (and sometimes second) letter must have been:\r\n! A, B, BP, D, G, H, N, NP, Q, S, U, W, X, Y\r\n! and \"is\" is 10, 18, 13, 14, 11, 9, 16, 12, 15, 7, 6, 19, 17, 20\r\n! NOTE: for N and B the second character has been checked and jp incremented\r\n! if equal to P. The third (for NP and BP forth) character must \r\n! be normallizing (MWVF), a space or a (, otherwise it is a property\r\n if(deblist) write(*,*)'3F lstate: ',lstate(1:20),jp,is\r\n! these have no normalizing: Q, X, W, Y\r\n nomalize: if(is.le.14 .or. is.eq.16 .or. is.eq.18) then\r\n! ZM x1 (phase) per mole components\r\n! ZW x2 (phase) per kg\r\n! ZV x3 (phase) per m3\r\n! ZF x4 phase must be specified per formula unit\r\n ch1=lstate(jp:jp)\r\n jp=jp+1\r\n if(ch1.eq.'M') then\r\n norm=1\r\n elseif(ch1.eq.'W') then\r\n norm=2\r\n elseif(ch1.eq.'V') then\r\n norm=3\r\n elseif(ch1.eq.'F') then\r\n norm=4\r\n else\r\n! no or default normalization, backspace\r\n jp=jp-1\r\n endif\r\n svr%norm=norm\r\n if(deblist) write(*,*)'3F Normalize 1: ',is,jp,ch1,norm\r\n endif nomalize\r\n!---------------------------------------------------------------------\r\n! reference state can be specified by an S for SER\r\n! If no S the user specified reference states applies\r\n! UNLESS MIXED REFERENCE STATES FOR THE ELEMENTS\r\n if(lstate(jp:jp).eq.'S') then\r\n jp=jp+1\r\n iref=-1\r\n elseif(lstate(jp:jp+1).eq.'R(') then\r\n write(*,*)'3F Ignoring suffix \"R\" on ',trim(statevar),&\r\n ', user reference is default'\r\n jp=jp+1\r\n endif\r\n if(btest(ceq%status,EQMIXED)) then\r\n! user has different phases as reference state for the elements use SER\r\n! write(*,*)'3F Mixed reference state for the elements, SER used'\r\n! This is only set for integral U(6), S(7), H(9), A(10), G(11) (not V(8))\r\n if(is.ge.6 .and. is.le.11) iref=-1\r\n endif\r\n!---------------------------------------------------------------------\r\n! extract arguments if any. If arguments then lstate(jp:jp) should be (\r\n! Typically H(fcc#2), N(Cr), BP(fcc), Y(sigma#2,cr#3), TC(BCC#2)\r\n!300 continue\r\n if(deblist) write(*,*)'3F args: ',jp,lstate(1:jp+10)\r\n narg=0\r\n args: if(lstate(jp:jp).eq.'(') then\r\n kp=index(lstate,')')\r\n if(kp.le.0) then\r\n if(deblist) write(*,110)'3F dsv 5: ',is,jp,kp,lstate(1:20)\r\n write(*,110)'3F dsv 5: ',is,jp,kp,lstate(1:20)\r\n110 format(a,3i3,a)\r\n gx%bmperr=4103; goto 1000\r\n endif\r\n argument=lstate(jp+1:kp-1)\r\n kp=index(argument,',')\r\n arg: if(kp.gt.0) then\r\n arg1=argument(1:kp-1)\r\n arg2=argument(kp+1:)\r\n narg=2\r\n kp=index(arg2,',')\r\n if(kp.gt.0) then\r\n! too many arguments to a state variable\r\n gx%bmperr=4097; goto 1000\r\n endif\r\n else !no arg\r\n narg=1\r\n arg1=argument\r\n endif arg\r\n elseif(lstate(jp:jp).ne.' ') then\r\n! if additional character then it must be a property\r\n goto 600\r\n endif args\r\n!------------------\r\n! transform arguments to indices, different arguments for 6-\r\n! Handle arguments: U, S, V, H, A, G, NP, BP,DG, Q, N, X, B, W, Y\r\n! 6, 7, 8, 9,10, 11,12, 13,14,15,16,17,18,19,20\r\n if(narg.eq.1) then\r\n if(is.le.15 .or. is.ge.21) then\r\n! single argument is phase+composition set\r\n if(arg1(1:2).eq.'* ') then\r\n iph=-3\r\n ics=-4\r\n elseif(arg1(1:2).eq.'# ') then\r\n! include also values for metastable phases, only for single argument variables\r\n iph=-10\r\n ics=-10\r\n else\r\n call find_phase_by_name(arg1,iph,ics)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n indices(1)=iph\r\n indices(2)=ics\r\n svr%phase=iph\r\n svr%compset=ics\r\n svr%argtyp=2\r\n elseif(is.eq.20) then\r\n! state variable Y must have 2 arguments\r\n gx%bmperr=4098; goto 1000\r\n else\r\n! single argument is component for is=16-19\r\n if(arg1(1:2).eq.'* ') then\r\n icomp=-1\r\n else\r\n call find_component_by_name(arg1,icomp,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n indices(1)=icomp\r\n svr%component=icomp\r\n svr%argtyp=1\r\n endif\r\n elseif(narg.eq.2) then\r\n! two arguments only for is=16-20, first phase, second component or constit\r\n if(is.le.15 .or. is.ge.21) then\r\n gx%bmperr=4110; goto 1000\r\n endif\r\n if(arg1(1:2).eq.'* ') then\r\n iph=-3\r\n ics=-4\r\n else\r\n call find_phase_by_name(arg1,iph,ics)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n indices(1)=iph\r\n indices(2)=ics\r\n svr%phase=iph\r\n svr%compset=ics\r\n if(is.eq.20) then\r\n if(arg2(1:2).eq.'* ') then\r\n icc=-2\r\n else\r\n call find_constituent(iph,arg2,cmass,icc)\r\n! write(*,*)'3F findconst 2: ',trim(arg2),cmass,icc\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n svr%component=0\r\n svr%constituent=icc\r\n svr%argtyp=4\r\n else\r\n if(arg2(1:2).eq.'* ') then\r\n icc=-1\r\n else\r\n call find_component_by_name(arg2,icc,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n svr%component=icc\r\n svr%argtyp=3\r\n endif\r\n! note indices(4) never used as icc is constituent index, arg2 must have\r\n! a #sublattice to find the correct, otherwise always the first occurence\r\n! In a sigma (Fe)(Cr)(Cr,Fe) y(sigma,cr)=1 but y(sigma,cr#3) gives Cr in third\r\n indices(3)=icc\r\n elseif((is.ge.12 .and. is.le.15) .or. is.eq.17 .or. is.ge.19) then\r\n! There must be an argument for NP, BP, DG, Q, X, W, Y, TC and BMAG\r\n gx%bmperr=4111; goto 1000\r\n elseif(norm.eq.4) then\r\n! there must be a phase specification for a quantity per formula unit\r\n gx%bmperr=4115; goto 1000\r\n endif\r\n! if(is.eq.17 .or. is.eq.19) then\r\n! is=is-1\r\n! svr%norm=1\r\n if(is.eq.16) svr%norm=1\r\n if(is.eq.18) svr%norm=2\r\n! endif\r\n!-----------------------\r\n500 continue\r\n!-----------------------------------------------------------------------\r\n! U 1x (phase,composition set) Internal energy (J)\r\n! S 2x entropy\r\n! V 3x volume\r\n! H 4x enthalpy\r\n! A 5x Helmholtz energy\r\n! G 6x Gibbs energy\r\n! NP 7x phase moles of phase\r\n! BP 8x phase mass of phase\r\n! N 9x (component/phase,component) moles >>14\r\n! X 9x component/phase,component mole fraction >>15\r\n! B 10x (component/phase,component) mass >>16\r\n! W 10x mass fraction >>17\r\n! Y 11 phase,constituent#sublattice constituent fraction >>18\r\n! Q 12 Internal stability >>19\r\n! DG 13x Driving force\r\n! TC, BM, MQ& etc (model variables)\r\n svr%statevarid=is\r\n extensive: if(is.eq.6) then\r\n! U 1x (phase) Internal energy (J)\r\n istv=10+norm\r\n elseif(is.eq.7) then\r\n! S 2x entropy\r\n istv=20+norm\r\n elseif(is.eq.8) then\r\n! V 3x volume\r\n istv=30+norm\r\n elseif(is.eq.9) then\r\n! H 4x enthalpy\r\n istv=40+norm\r\n elseif(is.eq.10) then\r\n! A 5x Helmholtz energy\r\n istv=50+norm\r\n elseif(is.eq.11) then\r\n! G 6x Gibbs energy\r\n istv=60+norm\r\n elseif(is.eq.12) then\r\n! NP 7x phase moles of phase\r\n istv=70+norm\r\n elseif(is.eq.13) then\r\n! BP 8x phase mass of phase\r\n istv=80+norm\r\n elseif(is.eq.14) then\r\n! DG 9x Driving force\r\n istv=90+norm\r\n elseif(is.eq.15) then\r\n! Q 10x Internal stability\r\n istv=100+norm\r\n elseif(is.eq.16 .or. is.eq.17) then\r\n! N 11x (component/phase,component) moles\r\n! X=NM 111 mole fraction\r\n! X% 111, iunit=100 mole percent\r\n if(is.eq.16) then\r\n istv=110+norm\r\n else\r\n istv=111\r\n endif\r\n elseif(is.eq.18 .or. is.eq.19) then\r\n! B 12x (component/phase,component) mass\r\n! W=BW 122 mass fraction\r\n! W% 122, iunit=100 mass percent\r\n if(is.eq.18) then\r\n istv=120+norm\r\n else\r\n istv=122\r\n endif\r\n elseif(is.eq.20) then\r\n! Y 130 phase#comp.set,constituent#sublat constituent fraction\r\n istv=130\r\n! write(*,'(a,5i5)')'3F Y: ',istv,icc,indices(1),indices(2),svr%constituent\r\n else\r\n! the symbol may be a property\r\n if(deblist) write(*,*)'3F maybe a property ',is\r\n goto 600\r\n endif extensive\r\n goto 1000\r\n!------------------------------------------------\r\n! handling of properties like TC, BMAGN, MQ etc\r\n600 continue\r\n! the symbol may be a property symbol\r\n propsym=statevar\r\n! second argument 0 means a symbol\r\n call find_defined_property(propsym,0,typty,iph,ics)\r\n if(deblist) write(*,*)'3F at 600: ',propsym(1:len_trim(propsym)),typty\r\n if(gx%bmperr.ne.0) then\r\n svr%oldstv=-1; goto 1000\r\n endif\r\n indices(1)=iph\r\n indices(2)=ics\r\n svr%phase=iph\r\n svr%compset=ics\r\n!----------------------------- unfinished ?????\r\n! typty>100 means a model-parameter-id with associated component such as MQ&FE\r\n if(typty.gt.100) then\r\n! typty: third argument is constituent (or component??)\r\n istv=-typty/100\r\n indices(3)=typty+100*istv\r\n svr%argtyp=4\r\n elseif(typty.gt.1) then\r\n istv=-typty\r\n svr%argtyp=3\r\n svr%argtyp=2\r\n else\r\n! unknown propery\r\n write(*,*)'3F Unknown state variable or property',typty\r\n gx%bmperr=4318; goto 1000\r\n endif\r\n svr%oldstv=istv\r\n svr%statevarid=istv\r\n svr%constituent=indices(3)\r\n if(deblist) write(*,611)'3F Property: ',is,istv,typty,indices\r\n611 format(a,10i4)\r\n!------------------------------------------------\r\n1000 continue\r\n! accept the current istv as svr%oldstv, store a suffix S on MU as phref<0\r\n svr%oldstv=istv\r\n svr%phref=iref\r\n if(deblist) write(*,1001)'3F exit decode: ',istv,(indices(is),is=1,4),&\r\n norm,iref,iunit,svr%oldstv,svr%phase,svr%compset,svr%component,&\r\n svr%constituent,svr%norm,svr%phref,svr%unit,svr%argtyp,&\r\n svr%statevarid,gx%bmperr\r\n1001 format(a,i5,4i3,2x,3i5/17x,i5,4i3,2x,6i5)\r\n return\r\n!---------------- errors -------------------------------\r\n! Wrong first character of state variable\r\n1100 continue\r\n gx%bmperr=4099; goto 1000\r\n! M not followed by U\r\n!1110 continue\r\n! gx%bmperr=4100; goto 1000\r\n! L not followed by NAC\r\n!1120 continue\r\n! gx%bmperr=4101; goto 1000\r\n! No opening ( for arguments\r\n1130 continue\r\n gx%bmperr=4102; goto 1000\r\n! No closing ) for arguments\r\n1140 continue\r\n gx%bmperr=4103; goto 1000\r\n! Unknown phase used as argument in state variable\r\n1150 continue\r\n gx%bmperr=4104; goto 1000\r\n! No such constituent\r\n1160 continue\r\n gx%bmperr=4105; goto 1000\r\n! No such component\r\n1170 continue\r\n gx%bmperr=4106; goto 1000\r\n!\r\n end subroutine decode_state_variable3 !allocate\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_phase_molmass\r\n!\\begin{verbatim}\r\n subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq)\r\n! calculates mole fractions and mass fractions for a phase#set\r\n! xmol and wmass are fractions of components in mol or mass\r\n! totmol is total number of moles and totmass total mass of components.\r\n! amount is number of moles of components per formula unit.\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer iph,ics\r\n double precision, dimension(*) :: xmol,wmass\r\n double precision amount,totmol,totmass\r\n!\\end{verbatim}\r\n integer ic,jc,lokph,lokcs,ll,iel,lokel,ie,kk,loksp,nspel\r\n integer compnos(maxspel)\r\n double precision as,yz,xsum,wsum,stoi(maxspel),smass,qsp\r\n double precision, dimension(maxel) :: x2mol,w2mass\r\n!\r\n do ic=1,noofel\r\n xmol(ic)=zero\r\n wmass(ic)=zero\r\n enddo\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n ic=0\r\n!\r\n! bug here when calculating MAP11 because we create new composition sets\r\n! when we map the different lines\r\n if(ocv()) write(*,14)'3F cpm: ',iph,ics,lokph,lokcs\r\n14 format(a,10i5)\r\n allsubl: do ll=1,phlista(lokph)%noofsubl\r\n! an error here in MAP11.OCM as the number of composition sets varied\r\n! in the different map commands\r\n if(.not.allocated(ceq%phase_varres(lokcs)%sites)) then\r\n if(ics.eq.2) then\r\n! fix to allow list and amend lines from mapping when a phase\r\n! may have added composition sets ...\r\n call get_phase_compset(iph,1,lokph,lokcs)\r\n else\r\n write(*,*)'phase ',trim(phlista(lokph)%name),&\r\n ' has no composition set ',ics\r\n endif\r\n amount=zero; gx%bmperr=4072; goto 700\r\n endif\r\n as=ceq%phase_varres(lokcs)%sites(ll)\r\n allcons: do kk=1,phlista(lokph)%nooffr(ll)\r\n ic=ic+1\r\n if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then\r\n yz=ceq%phase_varres(lokcs)%yfr(ic)\r\n loksp=phlista(lokph)%constitlist(ic)\r\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\r\n! the elements are the components\r\n do iel=1,splista(loksp)%noofel\r\n lokel=splista(loksp)%ellinks(iel)\r\n ie=ellista(lokel)%alphaindex\r\n if(ie.ne.0) then\r\n xmol(ie)=xmol(ie)+&\r\n as*yz*splista(loksp)%stoichiometry(iel)\r\n endif\r\n enddo\r\n else\r\n! when we have other components than the elements\r\n! we must convert the element stoichiometry to component stoichiometry\r\n! write(*,*)'3F other components than elements'\r\n call get_species_component_data(loksp,nspel,compnos,stoi,&\r\n smass,qsp,ceq)\r\n do iel=1,nspel\r\n xmol(compnos(iel))=xmol(compnos(iel))+as*yz*stoi(iel)\r\n enddo\r\n endif\r\n endif\r\n enddo allcons\r\n enddo allsubl\r\n! normallize, All ok here\r\n! write(*,713)'A',noofel,(xmol(iq),iq=1,noofel)\r\n713 format('3F x:',a,i2,10f8.4)\r\n!800 continue\r\n xsum=zero\r\n wsum=zero\r\n! here xmol(i) is equal to the number of moles of element i per formula unit\r\n! set wmass(i) to the mass of of element i per mole formula unit and sum\r\n do ic=1,noofel\r\n! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass\r\n wmass(ic)=xmol(ic)*ceq%complist(ic)%mass\r\n xsum=xsum+xmol(ic)\r\n wsum=wsum+wmass(ic)\r\n enddo\r\n! write(*,713)'3F cpmm: ',noofel,xsum,(xmol(ic),ic=1,noofel)\r\n do ic=1,noofel\r\n xmol(ic)=xmol(ic)/xsum\r\n wmass(ic)=wmass(ic)/wsum\r\n enddo\r\n! write(*,713)'3F cpmm: ',noofel,xsum,(xmol(ic),ic=1,noofel)\r\n! This is the current number of formula unit of the phase, \r\n! It is zero if not stable\r\n amount=ceq%phase_varres(lokcs)%amfu\r\n! ceq%phase_varres(lokcs)%abnorm(1) is moles atoms for one formula unit\r\n! ceq%phase_varres(lokcs)%abnorm(2) is mass for one formula unit\r\n700 continue\r\n totmol=amount*xsum\r\n totmass=amount*wsum\r\n! write(*,717)'3F z:',noofel,lokcs,totmol,totmass,amount,&\r\n! wsum,ceq%phase_varres(lokcs)%abnorm(2)\r\n717 format(a,i3,i6,6(1pe12.4))\r\n! all seems OK here\r\n! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),&\r\n! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass\r\n! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),&\r\n! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass\r\n811 format('cphmm: ',6(1pe12.4))\r\n! write(*,*)'cpmm: ',totmol,totmass\r\n! all calculation so far in elements, convert to current components\r\n! NOTE: sum of mole fractions can be zero or negative with other \r\n! components than elements\r\n76 format(a,10F7.4)\r\n78 format(a,2i3,3(1PE12.4))\r\n! do ic=1,noofel\r\n! write(*,298)(ceq%invcompstoi(jc,ic),jc=1,noofel)\r\n! enddo\r\n!298 format('3F: ',6(1pe12.4))\r\n goto 1000\r\n!---------------------------------------------\r\n! what is this ... converting to user defined components ... (not implemented)\r\n x2mol=zero\r\n w2mass=zero\r\n do ic=1,noofel\r\n do jc=1,noofel\r\n x2mol(ic)=x2mol(ic)+ceq%invcompstoi(jc,ic)*xmol(jc)\r\n! write(*,78)'addon: ',ic,jc,x2mol(ic),ceq%invcompstoi(jc,ic),xmol(jc)\r\n w2mass(ic)=w2mass(ic)+ceq%invcompstoi(ic,jc)*wmass(jc)\r\n enddo\r\n enddo\r\n! do ic=1,noofel\r\n! write(*,99)'ci: ',(ceq%invcompstoi(jc,ic),jc=1,noofel)\r\n! enddo\r\n99 format(a,7e11.3)\r\n! write(*,76)'cmm2: ',(x2mol(ic),ic=1,noofel)\r\n do ic=1,noofel\r\n xmol(ic)=x2mol(ic)\r\n wmass(ic)=w2mass(ic)\r\n enddo\r\n! something wrong between writing label 713 above and here !!!!!!!!!!!!!\r\n! write(*,713)'B',noofel,(xmol(iq),iq=1,noofel)\r\n1000 continue\r\n return\r\n end subroutine calc_phase_molmass\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_phase_mol\r\n!\\begin{verbatim}\r\n subroutine calc_phase_mol(iph,xmol,ceq)\r\n! calculates mole fractions for phase iph, compset 1 in equilibrium ceq\r\n! used for grid generation and some other things\r\n! returns current constitution in xmol equal to mole fractions of components\r\n implicit none\r\n integer iph\r\n double precision xmol(*)\r\n TYPE(gtp_equilibrium_data),pointer :: ceq\r\n!\\end{verbatim}\r\n integer ic,lokph,lokcs,ll,kk,loksp,lokel,iel,ie,compnos(maxspel),nspel\r\n double precision as,yz,xsum,smass,qsp,stoi(maxspel)\r\n do ic=1,noofel\r\n xmol(ic)=zero\r\n enddo\r\n lokph=phases(iph)\r\n lokcs=phlista(lokph)%linktocs(1)\r\n ic=0\r\n allsubl: do ll=1,phlista(lokph)%noofsubl\r\n as=ceq%phase_varres(lokcs)%sites(ll)\r\n allcons: do kk=1,phlista(lokph)%nooffr(ll)\r\n ic=ic+1\r\n if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then\r\n yz=ceq%phase_varres(lokcs)%yfr(ic)\r\n loksp=phlista(lokph)%constitlist(ic)\r\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\r\n! the elements are the components\r\n do iel=1,splista(loksp)%noofel\r\n lokel=splista(loksp)%ellinks(iel)\r\n ie=ellista(lokel)%alphaindex\r\n if(ie.ne.0) then\r\n xmol(ie)=xmol(ie)+&\r\n as*yz*splista(loksp)%stoichiometry(iel)\r\n endif\r\n enddo\r\n else\r\n! when we have other components than the elements\r\n! we must convert the element stoichiometry to component stoichiometry\r\n! write(*,*)'3F other components than elements'\r\n call get_species_component_data(loksp,nspel,compnos,stoi,&\r\n smass,qsp,ceq)\r\n do iel=1,nspel\r\n xmol(compnos(iel))=xmol(compnos(iel))+as*yz*stoi(iel)\r\n enddo\r\n endif\r\n\r\n endif\r\n enddo allcons\r\n enddo allsubl\r\n! normallize\r\n xsum=zero\r\n do ic=1,noofel\r\n xsum=xsum+xmol(ic)\r\n enddo\r\n do ic=1,noofel\r\n xmol(ic)=xmol(ic)/xsum\r\n enddo\r\n1000 continue\r\n return\r\n end subroutine calc_phase_mol\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_molmass\r\n!\\begin{verbatim}\r\n subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq)\r\n! summing up N and B for each component over all phases with positive amount\r\n! Check that totmol and totmass are correct ....\r\n implicit none\r\n double precision, dimension(*) :: xmol,wmass\r\n double precision totmol,totmass\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n double precision am,amult,tmol,tmass\r\n double precision, dimension(maxel) :: xph,wph\r\n integer ic,iph,lokph,ics,lokcs\r\n do ic=1,noofel\r\n xmol(ic)=zero\r\n wmass(ic)=zero\r\n enddo\r\n totmol=zero\r\n totmass=zero\r\n allph: do iph=1,noofph\r\n lokph=phases(iph)\r\n if(.not.btest(phlista(lokph)%status1,phhid)) then\r\n allcs: do ics=1,phlista(lokph)%noofcs\r\n lokcs=phlista(lokph)%linktocs(ics)\r\n! ceq%phase_varres(lokcs)%amfu is current number of formula units\r\n! ceq%phase_varres(lokcs)%abnorm(1) is number of real atoms in a formula unit\r\n am=ceq%phase_varres(lokcs)%amfu*&\r\n ceq%phase_varres(lokcs)%abnorm(1)\r\n if(am.gt.zero) then\r\n call calc_phase_molmass(iph,ics,xph,wph,tmol,tmass,amult,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,17)'3F amult:',iph,ics,am,amult,tmol,tmass\r\n! write(*,18)'3F x0: ',(xph(ic),ic=1,noofel)\r\n! write(*,18)'3F w0: ',(wph(ic),ic=1,noofel)\r\n17 format(a,2i4,6(1pe14.6))\r\n18 format(a,8(F9.5))\r\n do ic=1,noofel\r\n xmol(ic)=xmol(ic)+am*xph(ic)\r\n wmass(ic)=wmass(ic)+tmass*wph(ic)\r\n enddo\r\n totmass=totmass+tmass\r\n totmol=totmol+tmol\r\n endif\r\n enddo allcs\r\n endif\r\n enddo allph\r\n! we have summed the number of moles and mass of all elements in all phases\r\n! xsum=zero\r\n! wsum=zero\r\n! do ic=1,noofel\r\n! xsum=xsum+xmol(ic)\r\n! wsum=wsum+wmass(ic)\r\n! enddo\r\n if(totmass.gt.zero) then\r\n do ic=1,noofel\r\n xmol(ic)=xmol(ic)/totmol\r\n wmass(ic)=wmass(ic)/totmass\r\n enddo\r\n! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel)\r\n! write(*,21)'3F w2: ',totmass,(wmass(ic),ic=1,noofel)\r\n21 format(a,1pe12.4,8(0pF9.5))\r\n! else\r\n! write(*,*)'There is no mass at all in the system!'\r\n! gx%bmperr=4185; goto 1000\r\n endif\r\n! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel)\r\n! write(*,21)'3F w1: ',totmass,(wmass(ic),ic=1,noofel)\r\n! else\r\n! this is not an error if no calculation has been made\r\n! write(*,28)'3F: calc_molmass: No mole fractions',totmol,totmass,xsum,&\r\n! (xmol(ic),ic=1,noofel)\r\n28 format(a,3(1pe12.4)/'3F. ',10f7.4)\r\n! gx%bmperr=4185; goto 1000\r\n! endif\r\n! wsum=zero\r\n! do ic=1,noofel\r\n! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass\r\n! wsum=wsum+wmass(ic)\r\n! write(*,44)'3F cmm4: ',ic,xmol(ic),wmass(ic),&\r\n! ellista(elements(ic))%mass,wsum,totmass\r\n44 format(a,i3,6(1pe12.4))\r\n! enddo\r\n! if(wsum.gt.zero) then\r\n! do ic=1,noofel\r\n! wmass(ic)=wmass(ic)/wsum\r\n! enddo\r\n! endif\r\n1000 continue\r\n return\r\n end subroutine calc_molmass\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine sumprops\r\n!\\begin{verbatim}\r\n subroutine sumprops(props,ceq)\r\n! summing up G, S, V, N and B for all phases with positive amount\r\n! Check if this is correct\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n double precision props(5)\r\n!\\end{verbatim}\r\n integer lokph,lokcs,ics\r\n double precision am\r\n if(gx%bmperr.ne.0) write(*,*)'3F error entering sumprops ',gx%bmperr\r\n props=zero\r\n allph: do lokph=1,noofph\r\n! write(*,*)'3F sumprops: ',lokph\r\n if(.not.btest(phlista(lokph)%status1,phhid)) then\r\n! lokcs=phlista(lokph)%cslink\r\n allcs: do ics=1,phlista(lokph)%noofcs\r\n! phase_varres(lokcs)%amfu is the amount formula units of the phase\r\n! phase_varres(lokcs)%abnorm(1) is the moles of real atoms/formula unit\r\n! am is the number of moles of real atoms of the phase\r\n lokcs=phlista(lokph)%linktocs(ics)\r\n! skip phases that are not entered\r\n if(ceq%phase_varres(lokcs)%phstate.eq.phdorm) cycle allcs\r\n! segmentation fault here ?? during plotting using several STEP/MAP\r\n! when new comp.sets may be allocated\r\n! skip composition sets with no allocated yfr ....\r\n if(.not.allocated(ceq%phase_varres(lokcs)%yfr)) then\r\n! write(*,*)'3F skipping unallocated comp.set.',lokcs\r\n cycle allcs\r\n endif\r\n am=ceq%phase_varres(lokcs)%amfu*&\r\n ceq%phase_varres(lokcs)%abnorm(1)\r\n! write(*,7)'3F sumprops 2: ',lokph,lokcs,am,&\r\n! ceq%phase_varres(lokcs)%abnorm(1),&\r\n! ceq%phase_varres(lokcs)%abnorm(2),props(5)\r\n7 format(a,2i5,6(1pe12.4))\r\n! valgrind complains this jump if for an uninitiallized valiable ??\r\n if(am.gt.zero) then\r\n! properties are G, G.T=-S, G.P=V and moles and mass of real atoms\r\n! Note gval(*,1) is per mole formula unit and ceq%phase_varres(lokcs)%abnorm(1)\r\n! is the number of real atoms per formula unit\r\n! write(*,13)'3F props1:',lokcs,props(1),props(2),props(3),am,&\r\n! ceq%phase_varres(lokcs)%abnorm(1)\r\n props(1)=props(1)+am*ceq%phase_varres(lokcs)%gval(1,1)/&\r\n ceq%phase_varres(lokcs)%abnorm(1)\r\n! write(*,10)props(1),am,ceq%phase_varres(lokcs)%gval(1,1),&\r\n! ceq%phase_varres(lokcs)%abnorm(1)\r\n10 format('3F props: ',6(1pe12.4))\r\n props(2)=props(2)+am*ceq%phase_varres(lokcs)%gval(2,1)/&\r\n ceq%phase_varres(lokcs)%abnorm(1)\r\n props(3)=props(3)+am*ceq%phase_varres(lokcs)%gval(3,1)/&\r\n ceq%phase_varres(lokcs)%abnorm(1)\r\n props(4)=props(4)+am\r\n! write(*,13)'3F props2:',lokcs,props(1),props(2),props(3),&\r\n! props(4),ceq%phase_varres(lokcs)%gval(3,1)\r\n13 format(a,i3,6(1pe12.4))\r\n! ceq%phase_varres(lokcs)%abnorm(2) should be the current mass\r\n! %abnorm(2) is actual mass, its should be multiplied with %amfu, not am!!\r\n! This value is calculated in set_constitution ... check there if problems\r\n props(5)=props(5)+ceq%phase_varres(lokcs)%amfu*&\r\n ceq%phase_varres(lokcs)%abnorm(2)\r\n! write(*,75)'3F sumprops: ',lokcs,am,&\r\n! ceq%phase_varres(lokcs)%abnorm(2),props(5)\r\n75 format(a,i4,6(1pe12.4))\r\n! write(*,11)'3F sumprops: ',lokcs,props(1),props(4),props(5),&\r\n! ceq%phase_varres(lokcs)%abnorm(2)\r\n! write(*,11)'3F sumprops ',lokcs,am,props(4),&\r\n! ceq%phase_varres(lokcs)%abnorm(1)\r\n11 format(a,i4,6(1pe12.4))\r\n endif\r\n enddo allcs\r\n endif\r\n enddo allph\r\n1000 continue\r\n if(gx%bmperr.ne.0) write(*,*)'3F error exiting sumprops ',gx%bmperr\r\n return\r\n end subroutine sumprops\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine encode_state_variable\r\n!\\begin{verbatim}\r\n subroutine encode_state_variable(text,ip,svr,ceq)\r\n! writes a state variable in text form position ip. ip is updated\r\n character text*(*)\r\n integer ip\r\n type(gtp_state_variable), pointer :: svr\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer istv,indices(4),iunit,iref\r\n! write(*,*)'3F ************* encode: '\r\n iref=svr%phref\r\n iunit=svr%unit\r\n! if svr%oldstv>=10 then istv should be 10*(svr%oldstv-5)+svr%norm\r\n! if(svr%oldstv.ge.10) then\r\n! istv=10*(svr%oldstv-5)+svr%norm\r\n! write(*,*)'3F encode: ',svr%oldstv,svr%norm,istv\r\n! else\r\n istv=svr%oldstv\r\n! endif\r\n! svr%argtyp specifies values in indices:\r\n! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const\r\n indices=0\r\n if(svr%argtyp.eq.1) then\r\n indices(1)=svr%component\r\n elseif(svr%argtyp.eq.2) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n elseif(svr%argtyp.eq.3) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%component\r\n elseif(svr%argtyp.eq.4) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%constituent\r\n endif\r\n call encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq)\r\n1000 continue\r\n return\r\n end subroutine encode_state_variable\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine encode_state_variable3\r\n!\\begin{verbatim} %-\r\n subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq)\r\n! writes a state variable in text form position ip. ip is updated\r\n! the internal coding provides in istv, indices, iunit and iref\r\n! ceq is needed as compopnents can be different in different equilibria ??\r\n! >>>> unfinished as iunit and iref not really cared for\r\n implicit none\r\n integer, parameter :: noos=20\r\n character*4, dimension(noos), parameter :: svid = &\r\n ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',&\r\n 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',&\r\n 'X ','B ','W ','Y ']\r\n character*(*) text\r\n integer, dimension(4) :: indices\r\n integer istv,ip,iunit,iref\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer jp,ics,kstv,iph,norm,sublat\r\n double precision mass\r\n!\r\n character stsymb*60\r\n character*1, dimension(4), parameter :: cnorm=['M','W','V','F']\r\n!\r\n sublat=0\r\n! write(*,*)'3F encode: ',istv\r\n if(istv.le.0) then\r\n! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc\r\n! translate to 21, 22, 23 ...\r\n kstv=19-istv\r\n goto 200\r\n endif\r\n! T or P\r\n if(istv.le.2) then\r\n text(ip:ip)=svid(istv)\r\n ip=ip+1\r\n goto 1000\r\n endif\r\n stsymb=' '\r\n! potential: if(istv.le.6) then\r\n potential: if(istv.le.5) then\r\n! Potential, MU, AC or LNAC, possible suffix 'S' for SER\r\n stsymb=svid(istv)\r\n jp=len_trim(stsymb)+1\r\n if(iref.lt.0) then\r\n! New use of svr%phref and iref, <0 means use SER as reference state\r\n stsymb(jp:jp)='S'\r\n jp=jp+1\r\n endif\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n if(indices(2).eq.0) then\r\n! problem ... component names can be different in different equilibria ....\r\n call get_component_name(indices(1),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n else\r\n! always use composition set 1\r\n ics=1\r\n call get_phase_name(indices(1),ics,stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','; jp=jp+1\r\n call findsublattice(indices(1),indices(3),sublat)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! call get_phase_constituent_name(indices(1),indices(2),&\r\n! stsymb(jp:),sublat)\r\n! I am not sure if indices(2) is constituent numbered for each sublattice\r\n! or numbered from the beginning, assume the latter !!\r\n! call get_constituent_name(indices(1),indices(2),&\r\n! stsymb(jp:),mass)\r\n! modified 190710/BoS as constituent index is in 3\r\n call get_constituent_name(indices(1),indices(3),&\r\n stsymb(jp:),mass)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n if(sublat.gt.1) then\r\n stsymb(jp:)='#'//char(ichar('0')+sublat)//')'\r\n jp=jp+3\r\n else\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n endif\r\n endif\r\n goto 800\r\n endif potential\r\n if(istv.lt.10) then\r\n! write(*,*)'3F unknown potential'\r\n gx%bmperr=4158; goto 1000\r\n endif\r\n! Extensive property has istv>=10\r\n norm=mod(istv,10)\r\n kstv=(istv+1)/10+5\r\n! write(*,3)'3F encode 3: ',kstv,indices\r\n!3 format(a,5i5)\r\n if(kstv.eq.16 .and. norm.eq.1) then\r\n! NM should be X\r\n if(indices(1).ne.0) kstv=17\r\n elseif(kstv.eq.17) then\r\n! BW should be W\r\n if(norm.eq.2 .and. indices(1).ne.0) then\r\n kstv=19\r\n else\r\n kstv=18\r\n endif\r\n elseif(kstv.ge.18) then\r\n! Y\r\n! kstv=kstv+2\r\n kstv=20\r\n endif\r\n! write(*,11)'3F esv 7: ',istv,kstv,indices\r\n11 format(a,10i4)\r\n stsymb=svid(kstv)\r\n jp=len_trim(stsymb)+1\r\n! write(*,*)'3F norm 1A: ',kstv,norm\r\n if(kstv.le.16 .or. kstv.eq.18) then\r\n if(norm.gt.0 .and. norm.le.4) then\r\n! write(*,*)'3F norm 1B: ',kstv,norm\r\n stsymb(jp:jp)=cnorm(norm)\r\n jp=jp+1\r\n elseif(norm.ne.0) then\r\n! write(*,*)'3F norm 1C: ',kstv,norm\r\n gx%bmperr=4118; goto 1000\r\n endif\r\n endif\r\n if(iref.lt.0) then\r\n! we can have reference states for G H etc.\r\n stsymb(jp:jp)='S'\r\n jp=jp+1\r\n endif\r\n goto 500\r\n!----------------- \r\n! parameter property symbols\r\n200 continue\r\n iph=indices(1)\r\n ics=indices(2)\r\n if(indices(3).ne.0) then\r\n kstv=-100*istv+indices(3)\r\n else\r\n kstv=-istv\r\n endif\r\n! this call creates the symbol or gives an error\r\n! write(*,*)'3F parameter property symbol: ',kstv,iph,ics\r\n call find_defined_property(stsymb,1,kstv,iph,ics)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n goto 800\r\n!------------------\r\n! handle indices\r\n500 continue\r\n noind: if(indices(3).gt.0) then\r\n! 3 indices, phase, comp.set and constituent allowed for Y\r\n! or phase, comp.set and component, allowed for N, X, B and W\r\n! or phase, comp.set and constituent allowed for MQ&\r\n if(kstv.eq.20) then\r\n! this is Y\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','\r\n jp=jp+1\r\n call findsublattice(indices(1),indices(3),sublat)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! call get_phase_constituent_name(indices(1),indices(3),&\r\n! stsymb(jp:),sublat)\r\n call get_constituent_name(indices(1),indices(3),&\r\n stsymb(jp:),mass)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,*)'3F encode y:',indices,sublat\r\n! sublattice is the last argument\r\n jp=len_trim(stsymb)+1\r\n if(sublat.gt.1) then\r\n stsymb(jp:)='#'//char(ichar('0')+sublat)//')'\r\n jp=jp+3\r\n else\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n endif\r\n! write(*,*)'3F encode: \"',trim(stsymb),'\"'\r\n elseif(kstv.ge.16 .and. kstv.le.19) then\r\n! allow for percent or %\r\n if(iunit.eq.100) then\r\n stsymb(jp:jp+1)='%('\r\n jp=jp+2\r\n else\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n endif\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','\r\n jp=jp+1\r\n call get_component_name(indices(3),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n else\r\n gx%bmperr=4117; goto 1000\r\n endif\r\n elseif(indices(2).gt.0) then\r\n! 2 indices, can only be phase and comp.set\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n elseif(indices(1).gt.0) then\r\n! 1 index, can only be component\r\n! allow for percent or %\r\n if(iunit.eq.100) then\r\n stsymb(jp:jp+1)='%('\r\n jp=jp+2\r\n else\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n endif\r\n call get_component_name(indices(1),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n! >>>> unfinished\r\n endif noind\r\n!\r\n800 continue\r\n if(ip+jp.gt.len(text)) then\r\n write(*,*)'State variable value output exceed character variable length'\r\n gx%bmperr=4319; goto 1000\r\n endif\r\n text(ip:ip+jp-1)=stsymb\r\n ip=ip+jp\r\n if(text(ip:ip).eq.' ') then\r\n! remove a trailing space occuring in some cases\r\n ip=ip-1\r\n endif\r\n1000 continue\r\n return\r\n end subroutine encode_state_variable3\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine encode_state_variable_record\r\n!\\begin{verbatim}\r\n subroutine encode_state_variable_record(text,ip,svr,ceq)\r\n! writes a state variable in text form position ip. ip is updated\r\n! the svr record provide istv, indices, iunit and iref\r\n! ceq is needed as compopnents can be different in different equilibria ??\r\n! >>>> unfinished as iunit and iref not really cared for\r\n implicit none\r\n integer, parameter :: noos=20\r\n character*4, dimension(noos), parameter :: svid = &\r\n ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',&\r\n 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',&\r\n 'X ','B ','W ','Y ']\r\n character*(*) text\r\n type(gtp_state_variable) :: svr\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer jp,ics,kstv,iph,norm,sublat\r\n integer, dimension(4) :: indices\r\n integer istv,ip,iunit,iref\r\n double precision mass\r\n!\r\n character stsymb*60\r\n character*1, dimension(4), parameter :: cnorm=['M','W','V','F']\r\n!\r\n istv=svr%oldstv\r\n norm=svr%norm\r\n iunit=svr%unit\r\n indices=0\r\n if(svr%argtyp.eq.1) then\r\n indices(1)=svr%component\r\n elseif(svr%argtyp.eq.2) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n elseif(svr%argtyp.eq.3) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%component\r\n elseif(svr%argtyp.eq.4) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%constituent\r\n endif\r\n! there is some cloudy thinking here. If the user has defined his own\r\n! reference state that should be used. The information is stored in the\r\n! component record (ceq%complist(i)%phlink\r\n! But if the user specifies MUS(i) one should use SER ... how to transfer that\r\n! information to the calculating routines?\r\n! By default svr%phref=0, then use user defined. If phref<0 use SER ??\r\n iref=svr%phref\r\n!\r\n if(istv.le.0) then\r\n! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc\r\n! translate to 21, 22, 23 ...\r\n kstv=19-istv\r\n goto 200\r\n! gx%bmperr=4116; goto 1000\r\n endif\r\n! T or P\r\n if(istv.le.2) then\r\n text(ip:ip)=svid(istv)\r\n ip=ip+1\r\n goto 1000\r\n endif\r\n stsymb=' '\r\n! potential: if(istv.le.6) then\r\n potential: if(istv.le.5) then\r\n! Potential, MU, AC or LNAC, possible suffix 'S' for SER\r\n stsymb=svid(istv)\r\n jp=len_trim(stsymb)+1\r\n! if(iref.ne.0) then\r\n if(iref.lt.0) then\r\n! new use of phref and iref, <0 means use SER and suffix S\r\n stsymb(jp:jp)='S'\r\n jp=jp+1\r\n endif\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n if(indices(2).eq.0) then\r\n! problem ... component names can be different in different equilibria ....\r\n call get_component_name(indices(1),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n else\r\n! always use composition set 1 and assume sublattice 1 ??\r\n ics=1\r\n sublat=1\r\n call get_phase_name(indices(1),ics,stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','; jp=jp+1\r\n call findsublattice(indices(1),indices(3),sublat)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! call get_phase_constituent_name(indices(1),indices(2),&\r\n! stsymb(jp:),sublat)\r\n call get_constituent_name(indices(1),indices(2),&\r\n stsymb(jp:),mass)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n if(sublat.gt.1) then\r\n stsymb(jp:)='#'//char(ichar('0')+sublat)//')'\r\n jp=jp+3\r\n else\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n endif\r\n endif\r\n stsymb(jp:jp)=')'\r\n goto 800\r\n endif potential\r\n if(istv.lt.10) then\r\n! write(*,*)'3F unknown potential'\r\n gx%bmperr=4158; goto 1000\r\n endif\r\n! Extensive property has istv>=10\r\n norm=mod(istv,10)\r\n kstv=(istv+1)/10+5\r\n! write(*,3)'3F encode 3: ',kstv,indices\r\n!3 format(a,5i5)\r\n if(kstv.eq.16 .and. norm.eq.1) then\r\n! NM should be X\r\n if(indices(1).ne.0) kstv=17\r\n elseif(kstv.eq.17) then\r\n! BW should be W\r\n if(norm.eq.2 .and. indices(1).ne.0) then\r\n kstv=19\r\n else\r\n kstv=18\r\n endif\r\n elseif(kstv.ge.18) then\r\n! Y\r\n! kstv=kstv+2\r\n kstv=20\r\n endif\r\n! write(*,11)'3F esv 7: ',istv,kstv,indices\r\n11 format(a,10i4)\r\n stsymb=svid(kstv)\r\n jp=len_trim(stsymb)+1\r\n! write(*,*)'3F norm 2: ',kstv,norm\r\n if(kstv.le.16 .or. kstv.eq.18) then\r\n if(norm.gt.0 .and. norm.le.4) then\r\n stsymb(jp:jp)=cnorm(norm)\r\n jp=jp+1\r\n elseif(norm.ne.0) then\r\n gx%bmperr=4118; goto 1000\r\n endif\r\n endif\r\n goto 500\r\n!----------------- \r\n! parameter property symbols\r\n200 continue\r\n iph=indices(1)\r\n ics=indices(2)\r\n if(indices(3).ne.0) then\r\n kstv=-100*istv+indices(3)\r\n else\r\n kstv=-istv\r\n endif\r\n! this call creates the symbol or gives an error\r\n call find_defined_property(stsymb,1,kstv,iph,ics)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n goto 800\r\n!------------------\r\n! handle indices\r\n500 continue\r\n noind: if(indices(3).gt.0) then\r\n! 3 indices, phase, comp.set and constituent allowed for Y\r\n! or phase, comp.set and component, allowed for N, X, B and W\r\n! or phase, comp.set and constituent allowed for MQ&\r\n if(kstv.eq.20) then\r\n! this is Y\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','\r\n jp=jp+1\r\n call findsublattice(indices(1),indices(3),sublat)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! call get_phase_constituent_name(indices(1),indices(3),&\r\n! stsymb(jp:),sublat)\r\n call get_constituent_name(indices(1),indices(3),&\r\n stsymb(jp:),mass)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n if(sublat.gt.1) then\r\n stsymb(jp:)='#'//char(ichar('0')+sublat)//')'\r\n jp=jp+3\r\n else\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n endif\r\n elseif(kstv.ge.16 .and. kstv.le.19) then\r\n! allow for percent or %\r\n if(iunit.eq.100) then\r\n stsymb(jp:jp+1)='%('\r\n jp=jp+2\r\n else\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n endif\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=','\r\n jp=jp+1\r\n call get_component_name(indices(3),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n else\r\n gx%bmperr=4117; goto 1000\r\n endif\r\n elseif(indices(2).gt.0) then\r\n! 2 indices, can only be phase and comp.set\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n call get_phase_name(indices(1),indices(2),stsymb(jp:))\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n elseif(indices(1).gt.0) then\r\n! 1 index, can only be component\r\n! allow for percent or %\r\n if(iunit.eq.100) then\r\n stsymb(jp:jp+1)='%('\r\n jp=jp+2\r\n else\r\n stsymb(jp:jp)='('\r\n jp=jp+1\r\n endif\r\n call get_component_name(indices(1),stsymb(jp:),ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n jp=len_trim(stsymb)+1\r\n stsymb(jp:jp)=')'\r\n jp=jp+1\r\n! >>>> unfinished\r\n endif noind\r\n!\r\n800 continue\r\n text(ip:ip+jp-1)=stsymb\r\n ip=ip+jp\r\n if(text(ip:ip).eq.' ') then\r\n! remove a trailing space occuring in some cases\r\n ip=ip-1\r\n endif\r\n1000 continue\r\n return\r\n end subroutine encode_state_variable_record\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine findsublattice\r\n!\\begin{verbatim}\r\n subroutine findsublattice(iph,constix,sublat)\r\n! find sublattice of constituent constix in phase lokph\r\n! is lokph index to gtp_phaserecord or gtp_phase_varres??\r\n! constix is constituent index\r\n implicit none\r\n integer iph,constix,sublat\r\n!\\end{verbatim}\r\n integer ix,lokph,nn\r\n if(iph.gt.0 .and. iph.le.noofph) then\r\n lokph=phases(iph)\r\n else\r\n gx%bmperr=4050; goto 1000\r\n endif\r\n! write(*,*)'3F args: ',iph,lokph,constix\r\n! write(*,*)'3F phase: ',phlista(lokph)%name\r\n if(constix.le.0) then\r\n write(*,*)'3F no such constituent in this phase',constix\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! nn=1\r\n! BUG!! found 21.03.18 after 5 years !!\r\n nn=0\r\n loop: do sublat=1,phlista(lokph)%noofsubl\r\n nn=nn+phlista(lokph)%nooffr(sublat)\r\n if(constix.le.nn) exit loop\r\n enddo loop\r\n if(constix.gt.nn) then\r\n write(*,*)'3F no such constituent in this phase',constix\r\n gx%bmperr=4399\r\n endif\r\n1000 continue\r\n return\r\n end subroutine findsublattice\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine state_variable_val\r\n!\\begin{verbatim}\r\n subroutine state_variable_val(svr,value,ceq)\r\n! calculate the value of a state variable in equilibrium record ceq\r\n! It transforms svr data to old format and calls state_variable_val3\r\n type(gtp_state_variable), pointer :: svr\r\n double precision value\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer istv, indices(4),iref,iunit\r\n!\r\n iref=svr%phref\r\n iunit=svr%unit\r\n! searching for experimental bug\r\n! write(*,*)'3F state_variable_val: ',svr%statevarid,iref,iunit\r\n! if(svr%oldstv.gt.10) then\r\n! istv=10*(svr%oldstv-5)+svr%norm\r\n! else\r\n istv=svr%oldstv\r\n! endif\r\n! svr%argtyp specifies values in indices:\r\n! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const\r\n indices=0\r\n if(svr%argtyp.eq.1) then\r\n indices(1)=svr%component\r\n elseif(svr%argtyp.eq.2) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n elseif(svr%argtyp.eq.3) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%component\r\n elseif(svr%argtyp.eq.4) then\r\n indices(1)=svr%phase\r\n indices(2)=svr%compset\r\n indices(3)=svr%constituent\r\n elseif(svr%argtyp.ne.0) then\r\n write(*,*)'3F state variable has illegal argtyp: ',svr%argtyp\r\n gx%bmperr=4320; goto 1000\r\n endif\r\n! write(*,910)'3F svv: ',istv,indices,iref,iunit,value\r\n910 format(a,i3,2x,4i3,2i3,1pe14.6)\r\n! write(*,*)'3F calling state_variable_val3: '\r\n call state_variable_val3(istv,indices,iref,iunit,value,ceq)\r\n if(gx%bmperr.ne.0) then\r\n! write(*,920)'3F error 7: ',gx%bmperr,istv,svr%oldstv,svr%argtyp\r\n!920 format(a,i5,2x,2i15,i2)\r\n! else\r\n! write(*,*)'3F value: ',value\r\n endif\r\n! write(*,*)'3F back from state_variable_val3: ',value\r\n1000 continue\r\n return\r\n end subroutine state_variable_val\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine state_variable_val3\r\n!\\begin{verbatim} %-\r\n subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq)\r\n! calculate the value of a state variable in equilibrium record ceq\r\n! istv is state variable type (integer)\r\n! indices are possible specifiers\r\n! iref indicates use of possible reference state, 0 current, -1 SER\r\n! iunit is unit, (K, oC, J, cal etc). For % it is 100\r\n! value is the calculated values. for state variables with wildcards use\r\n! get_many_svar\r\n implicit none\r\n integer, dimension(4) :: indices\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer istv,iref,iunit\r\n double precision value\r\n!\\end{verbatim}\r\n double precision props(5),xmol(maxel),wmass(maxel),stoi(10)\r\n double precision, allocatable :: cmpstoi(:)\r\n double precision vt,vp,amult,vg,vs,vv,div,aref,vn,bmult,tmass,tmol\r\n double precision qsp,gref,spmass,rmult,tsave,rtn,spextra(10)\r\n integer kstv,norm,lokph,lokcs,icx,jp,ncmp,ic,iprop,loksp,nspel,iq,nspx\r\n integer endmember(maxsubl),ielno(maxspel)\r\n value=zero\r\n ceq%rtn=globaldata%rgas*ceq%tpval(1)\r\n! write(*,10)'3F svval3: ',istv,indices,iref,iunit,gx%bmperr,value\r\n10 format(a,i4,4i4,3i5,1PE17.6)\r\n potentials: if(istv.lt.0) then\r\n! negative istv indicate parameter property symbols\r\n kstv=-istv\r\n goto 200\r\n! gx%bmperr=4097; goto 1000\r\n elseif(istv.ge.10) then\r\n goto 50\r\n elseif(istv.eq.1) then\r\n! this is T\r\n value=ceq%tpval(1)\r\n elseif(istv.eq.2) then\r\n! this is P\r\n value=ceq%tpval(2)\r\n elseif(istv.le.5) then\r\n! the check of reference state state is made at label 500 \r\n if(istv.eq.3) then\r\n! MUx(component) or MU(phase,constituent), x can be S for SER\r\n goto 500\r\n elseif(istv.eq.4) then\r\n! ACx(component) or AC(phase,constituent)\r\n goto 500\r\n elseif(istv.eq.5) then\r\n! LNACx(component) or LNAC(phase,constituent)\r\n goto 500\r\n endif\r\n! wrong or state variable not implemented\r\n write(*,10)'3F not impl 1: ',istv,indices,iref,iunit,gx%bmperr,value\r\n goto 1100\r\n else\r\n! wrong or state variable not implemented\r\n! write(*,10)'3F not impl 2: ',istv,indices,iref,iunit,gx%bmperr,value\r\n goto 1100\r\n endif potentials\r\n! normal return\r\n goto 1000\r\n!----------------------------------------------------------\r\n! extensive variable (N, X, G ...) or model variable (TC, BMAG)\r\n50 continue\r\n norm=mod(istv,10)\r\n kstv=istv/10\r\n! this may not be necessary in all cases but do it anyway:\r\n! sum over all stable phases, props(1..3) are G, G.T and G.P,\r\n! props(4) is amount of moles of components, props(5) is mass of components\r\n call sumprops(props,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! if verbose on\r\n if(ocv()) write(*,51)'3F stv A: ',props\r\n51 format(a,5(1PE12.3))\r\n! kstv can be 1 to 15 for different properties\r\n! norm can be 1, 2, 3 or 4 for normalizing. 0 for not normallizing\r\n! M W V F\r\n! OLD: iref can be 0 or 1 for reference state\r\n! iref can be 0 for using current referennce state\r\n! iref <0 for default reference state (SER)\r\n le10: if(kstv.le.10) then\r\n! kstv= 1 2 3 4 5 6 7 8 9 10\r\n! state var; U, S, V, H, A, G, NP, BP, DG and Q\r\n vt=ceq%tpval(1)\r\n vp=ceq%tpval(2)\r\n! ceq%rtn=globaldata%rgas*ceq%tpval(1)\r\n amult=ceq%rtn\r\n! write(*,*)'3F stv B: ',norm,kstv,indices(1),vt,vp,amult\r\n if(indices(1).eq.0) then\r\n! global value for the whole system\r\n vg=props(1)\r\n vs=-props(2)\r\n vv=props(3)\r\n! normalizing: 0 none,1=M (moles), 2=W (mass), 3=W(volume), 4=F(formula unit)\r\n! write(*,*)'3F norm: ',norm,props(1)\r\n if(norm.eq.1) then\r\n! props(4) is total number of moldes\r\n div=props(4)\r\n elseif(norm.eq.2) then\r\n! props(5) is total mass\r\n div=props(5)\r\n elseif(norm.eq.3) then\r\n! Normalizing per volume, there frequently no volume data\r\n div=props(3)\r\n if(div.eq.zero) then\r\n gx%bmperr=4114; goto 1000\r\n endif\r\n elseif(norm.eq.4) then\r\n gx%bmperr=4115; goto 1000\r\n else\r\n div=one\r\n endif\r\n! for phase specific the aref should be independent of amult and div ??\r\n! for system wide these are unity\r\n rmult=one\r\n! write(*,555)'3F pp: ',vg,props\r\n555 format(a,6(1pe12.4))\r\n else\r\n! phase specific, indices are phase and composition set\r\n call get_phase_compset(indices(1),indices(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n vg=ceq%phase_varres(lokcs)%gval(1,1)\r\n vs=-ceq%phase_varres(lokcs)%gval(2,1)\r\n vv=ceq%phase_varres(lokcs)%gval(3,1)\r\n! normalizing: 0 none,1=M (moles), 2=W (mass), 3=W(volume), 4=F(formula unit)\r\n! I have to think more here should normalizing be per phase or for total?\r\n! GM(BCC) is for one mole BCC, M refer per mole of phase even if not stable\r\n! NPM(BCC) is more fraction of BCC relative to total amount in system\r\n! write(*,*)'3F norm 2: ',norm,props(1),div\r\n if(norm.eq.1) then\r\n! phase property normalized per phase like HM or SM\r\n div=ceq%phase_varres(lokcs)%abnorm(1)\r\n! phase property normalized for whole system as NPM\r\n if(kstv.eq.7) div=props(4)\r\n rmult=div\r\n elseif(norm.eq.2) then\r\n! abnorm(2) should be the mass per formulat unit\r\n div=ceq%phase_varres(lokcs)%abnorm(2)\r\n! phase property normalized for whole system as NPM\r\n if(kstv.eq.8) div=props(5)\r\n rmult=div\r\n elseif(norm.eq.3) then\r\n div=ceq%phase_varres(lokcs)%gval(3,1)\r\n if(div.eq.zero) then\r\n gx%bmperr=4114; goto 1000\r\n endif\r\n rmult=div\r\n elseif(norm.eq.4) then\r\n! per formula unit of a particular phase\r\n! div=ceq%phase_varres(lokcs)%abnorm(1)\r\n! write(*,*)'3F normalize F:',div\r\n! rmult=one\r\n div=one\r\n rmult=div\r\n else\r\n! no normalizing for a specific phase, value for current amount\r\n! NOTE amult is already RT\r\n amult=amult*ceq%phase_varres(lokcs)%amfu\r\n rmult=ceq%phase_varres(lokcs)%amfu\r\n div=one\r\n! div=ceq%phase_varres(lokcs)%abnorm(1)\r\n endif\r\n! for phase specific the aref is for one mole of atoms and should \r\n! be independent of amult and div ??\r\n! if(amult.eq.zero) then\r\n! rmult=zero\r\n! else\r\n! rmult=div/amult\r\n! endif\r\n endif\r\n! here the reference state should be considered\r\n! aref=zero\r\n if(iref.eq.0) then\r\n! iref=0 means user defined reference state >>>> unfinished\r\n!??????????????????????????????????\r\n! UNFINISHED\r\n! If O has reference state but no other elements then ignore refstate\r\n! for integral quantities UNLESS all components has the same reference\r\n! state ....\r\n! write(*,52)'3F Ref state:',iref,kstv,indices(1),indices(2),rmult\r\n52 format(a,4i4,1pe12.4)\r\n! IMPORTANT !!! calculate reference state may destroy valies in %gval\r\n call calculate_reference_state(kstv,indices(1),indices(2),aref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! value here seems OK\r\n! write(*,53)'3F Reference state:',iref,aref,rmult\r\n elseif(iref.lt.0) then\r\n aref=zero\r\n else\r\n! positive value of iref is undefined\r\n write(*,*)'3F Reference state undefined: ',iref\r\n aref=zero\r\n endif\r\n! if phase specific the scaling for phase specific must be compensated\r\n aref=rmult*aref\r\n! write(*,53)'3F at kstv1: ',kstv,props,aref,div\r\n! write(*,53)'3F more:',0,amult,vg,vp,vv,amult*(vg-vp*vv-aref)/div\r\n53 format(a,i3,7(1PE11.3))\r\n kstv1: if(kstv.eq.1) then\r\n! 1: U = G + TS - PV = G - T*G.T - P*G.P\r\n value=amult*(vg+vt*vs-vp*vv-aref)/div\r\n elseif(kstv.eq.2) then\r\n! 2: S = -G.T\r\n value=amult*(vs-aref)/div\r\n! write(*,54)value,amult,vs,aref,div\r\n54 format('3F svv: ',5(1pe12.4))\r\n elseif(kstv.eq.3) then\r\n! 3: V = G.P\r\n value=amult*(vv-aref)/div\r\n! write(*,54)amult,vv,aref,div,value\r\n elseif(kstv.eq.4) then\r\n! 4: H = G + TS = G - T*G.T\r\n! Problem with vg here when reference state is set\r\n if(ocv()) write(*,177)'3F H:',vg+vt*vs,aref,amult,div,rmult\r\n177 format(a,6(1pe12.4))\r\n value=amult*(vg+vt*vs-aref)/div\r\n elseif(kstv.eq.5) then\r\n! 5: A = G - PV = G - P*G.P\r\n value=amult*(vg-vp*vv-aref)/div\r\n! write(*,53)'3F more:',0,amult,vg,vp,vv,value\r\n elseif(kstv.eq.6) then\r\n! 6: G\r\n! write(*,177)'3F G:',vg,aref,amult,div\r\n value=amult*(vg-aref)/div\r\n elseif(kstv.eq.7) then\r\n! 7: NP\r\n! write(*,*)'3F npm:',norm,div\r\n! div is normalizing, can be 1.0 or total volume\r\n value=ceq%phase_varres(lokcs)%abnorm(1)* &\r\n ceq%phase_varres(lokcs)%amfu/div\r\n elseif(kstv.eq.8) then\r\n! 8: BP\r\n! abnorm(2) should be the mass per formula unit\r\n value=ceq%phase_varres(lokcs)%abnorm(2)* &\r\n ceq%phase_varres(lokcs)%amfu/div\r\n elseif(kstv.eq.9) then\r\n! 9: DG (driving force)\r\n! write(*,202)'3F svval DG:',lokcs,ceq%phase_varres(lokcs)%dgm,div\r\n202 format(a,i5,2(1pe12.4))\r\n value=ceq%phase_varres(lokcs)%dgm/div\r\n elseif(kstv.eq.10) then\r\n! 10: Q (stability, thermodynamic factor)\r\n! gx%bmperr=4081; goto 1000\r\n call calc_qf(lokcs,value,ceq)\r\n! else\r\n! write(*,*)'3F svval after 10:',kstv\r\n endif kstv1\r\n! write(*,53)'3F more:',-1,amult,vg,vp,vv,value\r\n goto 1000\r\n endif le10\r\n!----------------------------------------------------------------------\r\n! here with kstv>10\r\n! kstv= 11 12 13 \r\n! state var: N B Y \r\n le12: if(kstv.le.12) then\r\n! normallizing for N (kstv=11) and B (kstv=12)\r\n! write(*,88)'3F svv 12: ',indices(1),norm,props(4),props(5)\r\n88 format(a,2i3,6(1pe12.4))\r\n if(indices(1).eq.0) then\r\n! no first index means the sum over all phases\r\n! props(4) is amount of moles of components, props(5) is mass of components\r\n if(kstv.eq.11) then\r\n vn=props(4)\r\n else\r\n vn=props(5)\r\n endif\r\n! normalizing\r\n if(norm.eq.1) then\r\n div=props(4)\r\n elseif(norm.eq.2) then\r\n div=props(5)\r\n elseif(norm.eq.3) then\r\n! we may not have any volume data ...\r\n div=props(3)\r\n if(div.eq.zero) then\r\n gx%bmperr=4114; goto 1000\r\n endif\r\n elseif(norm.eq.4) then\r\n gx%bmperr=4115; goto 1000\r\n else\r\n div=one\r\n endif\r\n! This is N or B without index but possibly normallized\r\n! write(*,89)'3F svv, N or B: ',vn,div\r\n89 format(a,5(1pe12.4))\r\n value=vn/div\r\n else\r\n! one or two indices, overall of phase specific component amount\r\n if(indices(2).eq.0) then\r\n! one index is component specific, N(comp.), B(CR) etc. Sum over all phases\r\n! props(4) is amount of moles of components, props(5) is mass of components\r\n call calc_molmass(xmol,wmass,tmol,tmass,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,89)'3F mm: ',tmol,tmass\r\n! write(*,93)'3F x: ',(xmol(icx),icx=1,noofel)\r\n! write(*,93)'3F w: ',(wmass(icx),icx=1,noofel)\r\n93 format(a,9F7.4)\r\n icx=1\r\n if(kstv.eq.11) then\r\n bmult=props(4)\r\n else\r\n bmult=props(5)\r\n endif\r\n else\r\n! two indices is phase and component specific. bmult is amount of phase\r\n call calc_phase_molmass(indices(1),indices(2),&\r\n xmol,wmass,tmol,tmass,bmult,ceq)\r\n icx=3\r\n! write(*,92)'3F cpmm: ',indices(icx),tmol,tmass,bmult,&\r\n! wmass(1),wmass(2),wmass(3)\r\n92 format(a,i3,3(1pe12.4),3(0pF8.5))\r\n endif\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,13)'3F gsvv 19: ',norm,(xmol(iq),iq=1,noofel)\r\n777 format('gsvv 77: ',10(f7.4))\r\n if(kstv.eq.11) then\r\n! total moles of component\r\n vn=xmol(indices(icx))\r\n amult=tmol\r\n! added next line 2015-08-20 to get correct N(sigma,mo)\r\n bmult=tmol\r\n! write(*,777)kstv,icx,indices(icx),norm,vn,amult,bmult\r\n!777 format('3F N(i): ',4i4,3(1pe12.4))\r\n else\r\n! total mass of component\r\n vn=wmass(indices(icx))\r\n amult=tmass\r\n! added next line 2015-08-20 to get correct N(sigma,mo)\r\n bmult=tmass\r\n endif\r\n! write(*,13)'3F gsvv 8: ',norm,vn,amult,bmult,tmol,tmass\r\n13 format(a,i3,7(1PE10.2))\r\n norm3: if(norm.eq.1) then\r\n! NM or X\r\n if(tmol.ne.zero) then\r\n value=amult*vn/tmol\r\n! write(*,'(a,5F8.4)')'3F MQMQA: ',amult,vn,tmol\r\n else\r\n! problem at x(phase,component) was zero when phase fix with zero amount\r\n! value=zero\r\n value=vn\r\n endif\r\n! percent %\r\n! write(*,*)'3F x%: ',iunit,value\r\n if(iunit.eq.100) value=1.0D2*value\r\n elseif(norm.eq.2) then\r\n! NW or W\r\n if(tmass.gt.zero) then\r\n value=amult*vn/tmass\r\n else\r\n value=zero\r\n endif\r\n! problem when plotting w(*,C) for phase fix with 0 amount\r\n! value=wmass(indices(icx))\r\n value=vn\r\n! percent %\r\n if(iunit.eq.100) value=1.0D2*value\r\n elseif(norm.eq.3) then\r\n! NV\r\n if(props(3).gt.zero) then\r\n value=amult*vn/props(3)\r\n else\r\n gx%bmperr=4114\r\n endif\r\n elseif(norm.eq.4) then\r\n! NF or BF with one or two indices\r\n if(indices(2).eq.0) then\r\n gx%bmperr=4115; goto 1000\r\n else\r\n value=vn\r\n endif\r\n else\r\n! N(comp), N(phase,comp), B(comp) or B(phase,comp)\r\n value=bmult*vn\r\n endif norm3\r\n endif\r\n goto 1000\r\n endif le12\r\n!-----------------------------------------------------------------\r\n! special for Y\r\n if(kstv.eq.13) then\r\n! 13: Y\r\n call get_phase_compset(indices(1),indices(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n value=ceq%phase_varres(lokcs)%yfr(indices(3))\r\n else\r\n! wrong state variable specification\r\n value=zero\r\n gx%bmperr=4113\r\n endif\r\n goto 1000\r\n!-----------------------------------------------------------------\r\n! values of parameter property symbols\r\n! >>> this can easily be generallized ... next time around ...\r\n! here with state variable <0, system and user defined properties\r\n200 continue\r\n! write(*,*)'3F svv3 at 200:',kstv,ndefprop\r\n! if(ndefprop.ne.33) then\r\n! THIS IS A VERY CRUDE CHECK! Please check also the SELECT below !!!\r\n! it may need to be modified !!!\r\n! if(ndefprop.ne.31) then modified to 32 to include VS\r\n! if(ndefprop.ne.33) then\r\n if(ndefprop.ne.36) then\r\n write(*,*)'3F The model parameter identifiers has been changed!',36\r\n write(*,*)'3F You must correct state_variable_val3 in GTP3F.F90!'\r\n! you may also have to change the case indices!!\r\n stop\r\n endif\r\n! write(*,*)'3F kstv: ',kstv\r\n select case(kstv)\r\n case default\r\n write(kou,*)'Unknown parameter identifier: ',kstv\r\n! I need to separate out mpi's that have constituent index ...\r\n! updated 2019.12.14\r\n!-------------------------------------------------------------------\r\n! These are model_parameter_ident in June 2018:\r\n! 1 G T P 0 Energy\r\n! 2 TC - P 2 Combined Curie/Neel T\r\n! 3 BMAG - - 1 Average Bohr magneton numb\r\n! 4 CTA - P 2 Curie temperature\r\n! 5 NTA - P 2 Neel temperature\r\n! 6 IBM - P &; 12 Individual Bohr magneton num\r\n! 7 THET - P 2 Debye or Einstein temp\r\n! 8 V0 - - 1 Volume at T0, P0\r\n! 9 VA T - 4 Thermal expansion\r\n! 10 VB T P 0 Bulk modulus\r\n! 11 VC T P 0 Extra volume parameter\r\n! 12 VS - - 1 Diffusion volume \r\n! 13 MQ T P &; 10 Mobility activation energy\r\n! 14 MF T P &; 10 RT*ln(mobility freq.fact.)\r\n! 15 MG T P &; 10 Magnetic mobility factor\r\n! 16 G2 T P 0 Liquid two state parameter\r\n! 17 THT2 - P 2 Smooth slope function T\r\n! 18 DCP2 - P 2 Smooth slope funtion step\r\n! 19 LPX T P 0 Lattice param X axis\r\n! 20 LPY T P 0 Lattice param Y axis\r\n! 21 LPZ T P 0 Lattice param Z axis\r\n! 22 LPTH T P 0 Lattice angle TH\r\n! 23 EC11 T P 0 Elastic const C11\r\n! 24 EC12 T P 0 Elastic const C12\r\n! 25 EC44 T P 0 Elastic const C44\r\n! 26 UQT T P &; 0 UNIQUAC residual parameter\r\n! 27 RHO T P 0 Electric resistivity\r\n! 28 VISC T P 0 Viscosity\r\n! 29 LAMB T P 0 Thermal conductivity\r\n! 30 HMVA T P 0 Enthalpy of vacancy form.\r\n! 31 TSCH - P 2 Schottky anomality T\r\n! 32 CSCH - P 2 Schottky anomality Cp/R.\r\n! 33 QCZ - - 1 MQMQA coordination factor\r\n! I am not sure how to handle changes ...\r\n!-------------------------------------------------------------------\r\n!...................................... without constituent index\r\n! case(1:5,7:12,16:25,27:31) OLD\r\n! case(1:5,7:12,16:25,27:32) \r\n case(1:5,7:12,16:25,27:33) \r\n! not with constituent index: 6: individual Bohr magneton number\r\n! not with constituent index: 13:15: Mobilities\r\n! not with constituent index: 26: UNIQUAC \r\n call get_phase_compset(indices(1),indices(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! nprop is number of properties calculated. Property 1 is always G\r\n find1: do jp=2,ceq%phase_varres(lokcs)%nprop\r\n! the listprop array contain identification of the property stored there\r\n if(ceq%phase_varres(lokcs)%listprop(jp).eq.kstv) then\r\n value=ceq%phase_varres(lokcs)%gval(1,jp)\r\n goto 1000\r\n endif\r\n enddo find1\r\n!....................................... with constituent index\r\n! These have a constituent index\r\n case(6,13:15,26)\r\n! 6: IBM& Individual Bohr magneton number\r\n! 13-15: MQ& etc mobility values\r\n! 26: UNIQUAC parameter tau\r\n! write(*,*)'3F svv3 mob1: ',indices(1),indices(2)\r\n call get_phase_compset(indices(1),indices(2),lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! property is kstv*100+indices(3) (constituent index)\r\n iprop=100*kstv+indices(3)\r\n! write(*,485)'3F svv3 mob2: ',indices(1),indices(2),iprop,&\r\n! ceq%phase_varres(lokcs)%nprop\r\n485 format(a,2i3,10i5)\r\n find2: do jp=2,ceq%phase_varres(lokcs)%nprop\r\n! write(*,485)'3F calcprop: ',ceq%phase_varres(lokcs)%listprop(jp)\r\n if(ceq%phase_varres(lokcs)%listprop(jp).eq.iprop) then\r\n value=ceq%phase_varres(lokcs)%gval(1,jp)\r\n goto 1000\r\n endif\r\n enddo find2\r\n write(*,*)'3F model parameter value has not been calculated'\r\n gx%bmperr=4361\r\n end select\r\n!.......................................\r\n! all legal case values goto somewhere else\r\n! gx%bmperr=4113; goto 1000\r\n goto 1000\r\n!-----------------------------------------------------------------\r\n! chemical potentials, activites etc, istv is 3, 4 or 5 for MU, AC and LNAC\r\n! there can be a reference state\r\n500 continue\r\n! ceq%rtn=globaldata%rgas*ceq%tpval(1)\r\n! if one argument that is a component, if two these are phase and constituent\r\n! here indices(2) is considered to specify a reference state ...???\r\n! write(*,502)'3F refstate 500: ',iref,indices(1),indices(3)\r\n502 format(a,10i4)\r\n! if(indices(2).ne.0) then\r\n! species index is in indices(3) !!!!\r\n if(indices(3).ne.0) then\r\n! This has nothing to do with reference state ... ??? see else link for that\r\n! I wonder if this code is ever used ...\r\n! write(*,502)'3F species: ',iref,indices(1),indices(3)\r\n lokph=phases(indices(1))\r\n loksp=phlista(lokph)%constitlist(indices(3))\r\n! split the species in elements, convert to components, add chemical potentials\r\n call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp,nspx,spextra)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(qsp.ne.zero) then\r\n! write(*,*)'3F Cannot calculate potential of charged species'\r\n gx%bmperr=4159; goto 1000\r\n endif\r\n allocate(cmpstoi(noofel))\r\n cmpstoi=zero\r\n! get_species_data gives only elements with non-zero stoiciometry\r\n do ic=1,nspel\r\n cmpstoi(ielno(ic))=stoi(ic)\r\n enddo\r\n! write(*,507)'3F elstoi:',loksp,nspel,indices(3),(cmpstoi(ic),ic=1,noofel)\r\n507 format(a,3i3,10(1pe12.4))\r\n! elements2components1 is in gtp3G\r\n! ncmp returned as number of elements, cmpstoi is stoichiometry of ALL elements\r\n! stoi is no longer used ...\r\n call elements2components1(nspel,stoi,ncmp,cmpstoi,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,508)'3F el2comp:',loksp,nspel,(cmpstoi(ic),ic=1,noofel)\r\n508 format(a,2i3,10(1pe12.4))\r\n value=zero\r\n do ic=1,ncmp\r\n value=value+cmpstoi(ic)*ceq%complist(ic)%chempot(1)\r\n enddo\r\n! >>>> subtract reference state: i.e. calculate G for the phase with \r\n! just this constituent. Note indices(1) is phase record, change to index\r\n! write(*,*)'3F refphase: ',indices(1),value\r\n ic=phlista(indices(1))%alphaindex\r\n! set endmember=0 to allow vacancies ...\r\n! HM, here I think it can only be a single species .... 190710/BoS\r\n endmember=0\r\n! changed from indices(2) which is composition set number\r\n endmember(1)=indices(3)\r\n! This routine returns G for current number of atoms\r\n call calcg_endmemberx(indices(1),endmember,gref,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,'(a,i3,2x,10i3)')'3F callcg_endmember 1: ',indices(1),endmember\r\n value=value-gref*ceq%rtn\r\n! write(*,511)'3F refstate: ',indices(1),indices(3),gref*ceq%rtn,value\r\n511 format(a,2i3,6(1pe12.4))\r\n! possibly convert to AC or LNAC\r\n goto 700\r\n else\r\n! write(*,*)'3F elselink: ',indices\r\n if(indices(1).le.0 .or. indices(1).gt.noofel) then\r\n! write(*,*)'3F Asking for nonexisting chemical potential'\r\n gx%bmperr=4171; goto 1000\r\n endif\r\n! iref=0 is default meaning user defined reference state,\r\n! if iref<0 use SER as reference state, ignoring user defined reference state\r\n!\r\n! If a component has a defined reference state that is in complist(indices(1))\r\n if(iref.eq.0 .and. ceq%complist(indices(1))%phlink.ne.0) then\r\n! write(*,*)'3F Reference state: ',indices(1),indices(2),&\r\n! ceq%complist(indices(1))%phlink\r\n! phlink is phase, endmember is enmember, tpref<0 means current T\r\n! we should also have a stoichiometry factor ??\r\n! endmember(1)=indices(2)\r\n tsave=ceq%tpval(1)\r\n if(ceq%complist(indices(1))%tpref(1).gt.zero) then\r\n! reference state is at a fixed T, negative tpref(1) means current T\r\n ceq%tpval(1)=ceq%complist(indices(1))%tpref(1)\r\n endif\r\n! write(*,*)'3F calling calcg_endmember: ',&\r\n! ceq%complist(indices(1))%phlink,&\r\n! ceq%complist(indices(1))%endmember\r\n ic=ceq%complist(indices(1))%phlink\r\n! ic=phlista(ic)%alphaindex\r\n! write(*,*)'3F refphase: ',indices(1),ic,phlista(indices(1))%alphaindex\r\n! ic=phlista(indices(1))%alphaindex\r\n! the first index should be phase index, not location\r\n! We may have to restore gval after this!!!\r\n! write(*,*)'3F callcg_endmember 2: ',-ic\r\n call calcg_endmember(-ic,ceq%complist(indices(1))%endmember,gref,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Error calculating refstate for chemical pot'\r\n goto 1000\r\n endif\r\n! RT for current T\r\n rtn=globaldata%rgas*ceq%tpval(1)\r\n ceq%tpval(1)=tsave\r\n aref=ceq%complist(indices(1))%chempot(1)\r\n! value=ceq%complist(indices(1))%chempot(1)-gref*rtn\r\n value=aref-gref*rtn\r\n! write(*,513)'3F gref: ',indices(1),value/rtn,aref/rtn,gref,rtn\r\n513 format(a,i3,5(1pe14.6))\r\n ceq%complist(indices(1))%chempot(2)=value\r\n else\r\n! the value in chempot(1) should always be referenced to SER\r\n! the value in chempot(2) should always be for the user reference\r\n value=ceq%complist(indices(1))%chempot(1)\r\n endif\r\n! write(*,*)'3F chempot: ',indices(1),&\r\n! ceq%complist(indices(1))%chempot(1),&\r\n! ceq%complist(indices(1))%chempot(2)\r\n goto 700\r\n endif\r\n! convert from MU to AC or LNAC if necessary\r\n700 continue\r\n! ceq%rtn=globaldata%rgas*ceq%tpval(1)\r\n if(istv.eq.4) then\r\n! AC = exp(mu/RT)\r\n value=exp(value/ceq%rtn)\r\n elseif(istv.eq.5) then\r\n! LNAC = mu/RT\r\n value=value/ceq%rtn\r\n endif\r\n!-----------------------------------------------------------------\r\n1000 continue\r\n! write(*,53)'3F more:',-1,amult,vg,vp,vv,value\r\n if(allocated(cmpstoi)) deallocate(cmpstoi)\r\n return\r\n1100 continue\r\n gx%bmperr=4078\r\n! write(*,*)'3F State variable value not implemented yet'\r\n goto 1000\r\n end subroutine state_variable_val3\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_qf\r\n!\\begin{verbatim}\r\n subroutine calc_qf(lokcs,value,ceq)\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! using the Darken matrix with second derivatives: OK FOR SUBSTITUTIONAL\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n! For ionic liquid and charged crystalline phases one should\r\n! calculate eigenvectors to find neutral directions.\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n! integer lokph,nsl\r\n! lokph=ceq%phase_varres(lokcs)%phlink\r\n! nsl=phlista(lokph)%noofsubl\r\n! write(*,*)'3F calc_qf: ',lokph,lokcs,nsl\r\n! if(nsl.eq.1) then\r\n! For substitutional solutions\r\n! write(*,*)'3F nsl 1: ',nsl\r\n! call calc_qf_old(lokcs,value,ceq)\r\n! else\r\n! For any onther model \r\n! write(*,*)'3F nsl 2: ',nsl\r\n call calc_qf_romain(lokcs,value,ceq)\r\n! endif\r\n end subroutine calc_qf\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n subroutine calc_qf_romain(lokcs,value,ceq)\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! using Romain Le Tellier proposal eliminating one dependent fraction in\r\n! each sublattice and also one ion if charge balance. Also ignore sublattices\r\n! with a single constituent\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n! Algorithm: use the Hessian modified by eliminating one constituent \"k_n\"\r\n! in each sublattice and one ionic constituent (if any)\r\n! The terms of this \"redused\" Hessaian will be\r\n! \\sum_i\\ne k_n \\sum_j\\ne k_n d2G/dy_idy_j - \r\n! \\sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \\sum_k_m d2G/dy_kndy_km)\r\n! \r\n integer lokph,ii,jj,nsl,ncol,jrow,lrow,subrow,jcol,lcol,subcol,tnfr,nn,info\r\n! skip the last constituent in each sublattice, \r\n! skip sublattices with a single constituent\r\n! skip one charged constituent ... NOT IMPLEMENTED\r\n! The reduced Hessian (symmetric)\r\n double precision, allocatable, dimension(:) :: hessian\r\n! work and result arrays. mm is needed when external charge balance\r\n double precision, allocatable, dimension(:) :: work,eigenval,ionfact,mm\r\n! this is needed as argument but never used\r\n double precision eigenvect(1)\r\n type(gtp_phase_varres), pointer :: varres\r\n logical debug,excb\r\n!\r\n! debug=.true.\r\n debug=.false.\r\n varres=>ceq%phase_varres(lokcs)\r\n lokph=varres%phlink\r\n nsl=phlista(lokph)%noofsubl\r\n tnfr=phlista(lokph)%tnooffr\r\n ncol=tnfr-nsl\r\n if(ncol.eq.0) then\r\n! fixed composition\r\n value=one; goto 1000\r\n endif\r\n if(btest(phlista(lokph)%status1,PHEXCB)) then\r\n! external charge balance, we need mm\r\n! allocate(mm(phlista(lokph)%tnooffr)\r\n! excb=.TRUE.\r\n write(*,*)'Stability check of charged phases not implemented'\r\n value=1.0D2\r\n goto 1000\r\n else\r\n excb=.FALSE.\r\n endif\r\n! write(*,*)'3F allocate: ',ncol*(ncol+1)/2,tnfr,nsl\r\n allocate(hessian(ncol*(ncol+1)/2))\r\n! loop for all rows\r\n ii=0\r\n subrow=1\r\n lrow=phlista(lokph)%nooffr(subrow)\r\n jrow=0\r\n nn=0\r\n row: do while(ii.lt.tnfr)\r\n ii=ii+1\r\n if(ii.eq.lrow) then\r\n subrow=subrow+1\r\n if(subrow.gt.nsl) exit row\r\n lrow=lrow+phlista(lokph)%nooffr(subrow)\r\n if(phlista(lokph)%nooffr(subrow).eq.1) then\r\n ii=ii+1; subrow=subrow+1\r\n if(subrow.gt.nsl) exit row\r\n lrow=lrow+phlista(lokph)%nooffr(subrow)\r\n endif\r\n cycle row\r\n endif\r\n! loop for all columns\r\n jcol=jrow\r\n jrow=jrow+1\r\n jj=ii-1\r\n subcol=subrow\r\n lcol=lrow\r\n col: do while(jj.lt.tnfr)\r\n jj=jj+1\r\n if(jj.eq.lcol) then\r\n subcol=subcol+1\r\n if(subcol.gt.nsl) exit col\r\n lcol=lcol+phlista(lokph)%nooffr(subcol)\r\n if(phlista(lokph)%nooffr(subcol).eq.1) then\r\n jj=jj+1\r\n subcol=subcol+1\r\n if(subcol.gt.nsl) exit col\r\n lcol=lcol+phlista(lokph)%nooffr(subcol)\r\n endif\r\n cycle col\r\n endif\r\n nn=nn+1\r\n jcol=jcol+1\r\n! write(*,'(a,3(2i4,2x))')'3F hessian: ',jrow,jcol,ii,jj,lrow,lcol\r\n hessian(ixsym(jrow,jcol))=varres%d2gval(ixsym(ii,jj),1)-&\r\n varres%d2gval(ixsym(ii,lrow),1)-&\r\n varres%d2gval(ixsym(jj,lcol),1)+&\r\n varres%d2gval(ixsym(lrow,lcol),1)\r\n enddo col\r\n enddo row\r\n if(debug) then\r\n do ii=1,ncol\r\n write(*,'(\"3F H: \",5(1pe12.4))')(hessian(ixsym(jj,ii)),jj=1,ncol)\r\n enddo\r\n endif\r\n if(ncol.eq.1) then\r\n value=hessian(1)\r\n goto 1000\r\n endif\r\n! use LAPACK routine, note Hessian is destroyed inside dspev\r\n allocate(eigenval(ncol))\r\n! work is work array at least 2*ncol, info is return code\r\n allocate(work(2*ncol))\r\n info=0\r\n! 'N' means only eigenvalues, 'U' means Hessian is upper triangle\r\n! ncol is dimension of Hessian, eigenval is calculated, \r\n! dummy values for eigenvect, 1\r\n call dspev('N','U',ncol,hessian,eigenval,eigenvect,1,work,info)\r\n if(info.eq.0) then\r\n if(debug) write(*,120)(eigenval(ii),ii=1,ncol)\r\n120 format('Eigenvalues: ',6(1pe10.2))\r\n! return the first value, negative if unstable\r\n value=eigenval(1)\r\n else\r\n! <0 the \"info\" argument has illegal value\r\n! >0 \"info\" off-diagonal elements if intermediate tridiagonal did not converge \r\n value=zero\r\n write(*,*)'Error calculating eigenvalues of phase matrix',info\r\n gx%bmperr=4321\r\n endif\r\n! \r\n1000 continue\r\n! basically we are only interested if value is <0 or >0 ...\r\n if(value.gt.1.0D2) then\r\n value=1.0D2\r\n elseif(value.lt.-1.0D2) then\r\n value=-1.0D2\r\n endif\r\n return\r\n end subroutine calc_qf_romain\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n subroutine calc_qf_romain_old(lokcs,value,ceq)\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! using Romain Le Tellier proposal eliminating one dependent fraction in\r\n! each sublattice and also one ion if charge balance. Also ignore sublattices\r\n! with a single constituent\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n! Algorithm: use the Hessian modified by eliminating one constituent \"k_n\"\r\n! in each sublattice and one ionic constituent (if any)\r\n! The terms of this \"redused\" Hessaian will be\r\n! \\sum_i\\ne k_n \\sum_j\\ne k_n d2G/dy_idy_j - \r\n! \\sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \\sum_k_m d2G/dy_kndy_km)\r\n! \r\n integer ncol,nsl,nion,ii,jj,ll,lokph,iy,nf,kk,info,iskip,jskip,tnfr\r\n! kskip needed when external charge balance as one may have two skipped\r\n! constituents in same sublattice\r\n integer icol,jrow,kskip\r\n! constituents that should be skipped, one per sublattice and charge, max 10\r\n integer skipped(10)\r\n! The reduced Hessian (symmetric)\r\n double precision, allocatable, dimension(:) :: hessian\r\n! work and result arrays. mm is needed when external charge balance\r\n double precision, allocatable, dimension(:) :: work,eigenval,ionfact,mm\r\n! this is needed as argument but never used\r\n double precision eigenvect(1)\r\n type(gtp_phase_varres), pointer :: varres\r\n double precision xxx,backstop,yyy\r\n logical excb,debug\r\n character phname*24\r\n!\r\n write(*,*)'3F entering calc_gf_romain',lokcs\r\n value=zero\r\n varres=>ceq%phase_varres(lokcs)\r\n lokph=phasetuple(varres%phtupx)%ixphase\r\n if(btest(phlista(lokph)%status1,PHEXCB)) then\r\n! external charge balance, we need mm\r\n! allocate(mm(phlista(lokph)%tnooffr)\r\n! excb=.TRUE.\r\n write(*,*)'Stability check of charged phases not implemented'\r\n value=1.0D2\r\n goto 1000\r\n else\r\n excb=.FALSE.\r\n endif\r\n! Step 1: eliminate one constituent per sublattice (highest fraction)\r\n! if external charge balance we need to eliminate one ion (the first)\r\n! NOTE ionic liquid does not have external charge balance and d2G/dyidyj\r\n! include the variation of sites(?)\r\n skipped=0\r\n nsl=phlista(lokph)%noofsubl\r\n iy=1\r\n kskip=1\r\n do ll=1,nsl\r\n! write(*,'(a,3i3,2x,10i3)')'3F debug ',lokph,nsl,ll,skipped\r\n if(phlista(lokph)%nooffr(ll).gt.1) then\r\n xxx=zero\r\n do nf=1,phlista(lokph)%nooffr(ll)\r\n if(varres%yfr(iy).gt.xxx) then\r\n! skip constituent with largest fraction in each sublattice\r\n! this gives sometimes a cusp in the middle for binaries ... not nice\r\n xxx=varres%yfr(iy)\r\n if(excb) then\r\n skipped(kskip)=iy\r\n else\r\n skipped(ll)=iy\r\n endif\r\n endif\r\n iy=iy+1\r\n enddo\r\n else\r\n! totally skip sublattices with a sngle constituent\r\n! negative value means second derivative wrt this fraction totally skipped\r\n skipped(ll)=-iy\r\n iy=iy+1\r\n endif\r\n enddo\r\n! dimension of the Hessian. One more should be added if ionic (not now!)\r\n tnfr=phlista(lokph)%tnooffr\r\n ncol=tnfr-nsl\r\n if(ncol.gt.1) then\r\n call get_phase_name(lokph,1,phname)\r\n write(*,*)'3F Q for ',trim(phname),' with ',ncol,' Hessian'\r\n debug=.true.\r\n else\r\n debug=.false.\r\n endif\r\n allocate(hessian((ncol*(ncol+1))/2))\r\n! write(*,*)'3F allocated Hessian',lokcs,ncol*(ncol+1)/2\r\n nf=nsl\r\n! write(*,'(a,10i4)')'3F skipped: ',skipped\r\n! in all terms of the Hessian we have to add the sum of all pairs of\r\n! fractions that are skipped\r\n! PROBABLY WRONG, WE MUST HAVE SEVERAL BACKSTOPS DEPENDING ON SUBLATTICES ...\r\n backstop=zero\r\n! if we have ionic constituents nf is larger than nsl one more ...\r\n back1: do ii=1,nf\r\n if(skipped(ii).lt.0) cycle back1\r\n back2: do jj=ii,nf\r\n if(skipped(jj).lt.0) cycle back2\r\n! this is sum_k1 \\sum_k2 d2G/dy_k1dy_k2\r\n backstop=backstop+varres%d2gval(ixsym(skipped(ii),skipped(jj)),1)\r\n! write(*,*)'3F backstop 1: ',skipped(ii),skipped(jj),backstop\r\n enddo back2\r\n enddo back1\r\n! write(*,*)'3F backstop 2: ',0,0,backstop\r\n! do ii=1,tnfr\r\n! write(*,'(a,5(1pe12.4))')'3F d2G/dyidyj: ',&\r\n! (varres%d2gval(ixsym(ii,jj),1),jj=1,phlista(lokph)%tnooffr)\r\n! enddo\r\n! The terms of this \"reduced\" Hessaian will be\r\n! \\sum_i\\ne k_n \\sum_j\\ne k_n d2G/dy_idy_j - \r\n! \\sum_k_n( d2G/dy_idy_kn+ d2G/dy_jdy_kn - \\sum_k_m d2G/dy_kndy_km)\r\n iskip=1\r\n jskip=1\r\n icol=1\r\n jrow=1\r\n loop1: do ii=1,tnfr\r\n if(ii.eq.abs(skipped(iskip))) then\r\n! write(*,*)'3F Skipping ii: ',ii,skipped(ii)\r\n iskip=iskip+1\r\n jskip=iskip\r\n cycle loop1\r\n endif\r\n xxx=zero\r\n! write(*,'(a,2i4,2x,10i3)')'3F bug 1: ',ii,nf,skipped\r\n do kk=1,nf\r\n! PROBABLY WRONG, INCLUDE ONLY THOSE IN CURRENT SUBLATTICE ...\r\n if(skipped(kk).gt.0) then\r\n xxx=xxx+varres%d2gval(ixsym(ii,skipped(kk)),1)\r\n endif\r\n enddo\r\n! write(*,*)'3F Calculate xxx for ii: ',ii,xxx\r\n! here the big loop to calculate the Hessian\r\n loop2: do jj=ii,tnfr\r\n if(jj.eq.abs(skipped(jskip))) then\r\n! PROBABLY WRONG, INCLUDE ONLY THOSE IN CURRENT SUBLATTICE ...\r\n! write(*,*)'3F Skipping jj: ',jj,skipped(jj)\r\n jskip=jskip+1\r\n cycle loop2\r\n endif\r\n yyy=xxx\r\n! write(*,'(a,2i4,2x,10i3)')'3F bug 2: ',ii,nf,skipped\r\n do kk=1,nf\r\n if(skipped(kk).gt.0) then\r\n yyy=yyy+varres%d2gval(ixsym(jj,skipped(kk)),1)\r\n endif\r\n enddo\r\n! write(*,*)'3F calculate term',ii,jj\r\n! write(*,*)'3F Calculate yyy for ii and jj: ',ii,jj,yyy\r\n! kxysm is indexing a symmetrix matrix when jj >= ii\r\n! ixsym is indexing a symmetrix matrix whatever values of ii and jj\r\n! multiply with the fractions to avoid extrapolation to infinity \r\n! at low fractions ... meaningless\r\n xxx=varres%d2gval(ixsym(ii,jj),1)-yyy+backstop\r\n! if(xxx.gt.1.0d2) xxx=1.0d2\r\n! write(*,*)'3F index Hessian: ',icol,jrow,ixsym(icol,jrow)\r\n hessian(ixsym(icol,jrow))=xxx\r\n! varres%yfr(ii)*varres%yfr(jj)*(varres%d2gval(ixsym(ii,jj),1)-&\r\n! yyy+backstop)\r\n! write(*,'(a,4i3,4(1pe12.4))')'3F hessian ',icol,jrow,ii,jj,&\r\n! hessian(ixsym(icol,jrow)),varres%d2gval(ixsym(ii,jj),1),&\r\n! -yyy,backstop\r\n! limit the terms in the Hession ...\r\n icol=icol+1\r\n enddo loop2\r\n jrow=jrow+1\r\n icol=jrow\r\n enddo loop1\r\n! if ncol > 1 calculate eigenvalues\r\n if(ncol.eq.1) then\r\n value=hessian(1)\r\n goto 1000\r\n endif\r\n if(debug) then\r\n do ii=1,ncol\r\n write(*,'(\"3F Hessian: \",5(1pe12.4))')(hessian(ixsym(jj,ii)),jj=1,ncol)\r\n enddo\r\n endif\r\n! use LAPACK routine, note Hessian is destroyed inside dspev\r\n allocate(eigenval(ncol))\r\n! work is work array at least 2*ncol, info is return code\r\n allocate(work(2*ncol))\r\n info=0\r\n! 'N' means only eigenvalues, 'U' means Hessian is upper triangle\r\n! ncol is dimension of Hessian, eigenval is calculated, \r\n! dummy values for eigenvect, 1\r\n call dspev('N','U',ncol,hessian,eigenval,eigenvect,1,work,info)\r\n if(info.eq.0) then\r\n if(debug) write(*,120)(eigenval(ii),ii=1,ncol)\r\n120 format('Eigenvalues: ',6(1pe10.2))\r\n! return the first value, negative if unstable\r\n value=eigenval(1)\r\n else\r\n value=zero\r\n write(*,*)'Error calculating eigenvalues of phase matrix',info\r\n gx%bmperr=4321\r\n endif\r\n! \r\n1000 continue\r\n! basically we are only interested if value is <0 or >0 ...\r\n if(value.gt.1.0D2) then\r\n value=1.0D2\r\n elseif(value.lt.-1.0D2) then\r\n value=-1.0D2\r\n endif\r\n return\r\n end subroutine calc_qf_romain_old\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_qf_otis\r\n!\\begin{verbatim}\r\n subroutine calc_qf_otis(lokcs,value,ceq)\r\n! NOT USED -----------------------------\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! using Otis reduced Hessian method. Should work indpent of model!!\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n! Algorithm:\r\n! 1. Create a Jacobian matrix with massbalance and constraint n columns, m rows\r\n! 2. Use an QR factorization of this, select the first n-m columns as Z\r\n! 3. Calculate F = Z^T H Z where H is all second derivatives of G wrt fractions\r\n! 4. Calculate eigenvalues of F. If all positive no problem!\r\n! \r\n integer ncol,mrow,lda,info,ll,nsl,lokph,ii,jj\r\n double precision, allocatable, dimension(:,:) :: jac,zeta,fff\r\n double precision, allocatable, dimension(:) :: tau,work,eigenv\r\n double precision dummy(1,1)\r\n type(gtp_phase_varres), pointer :: varres\r\n!\r\n write(*,*)'G3 Subroutine calc_qf_otis not implemented'\r\n gx%bmperr=4499; goto 1000\r\n!\r\n varres=>ceq%phase_varres(lokcs)\r\n! Step 1: Jacobian: ncol columns, mrow rows\r\n value=zero\r\n ncol=1\r\n mrow=1\r\n allocate(jac(ncol,mrow))\r\n jac=zero\r\n!\r\n! Step 2: QR factorisation, n>m\r\n allocate(tau(ncol))\r\n allocate(work(ncol))\r\n lda=ncol\r\n info=0\r\n call dgeqr2(mrow,ncol,jac,lda,tau,work,info)\r\n if(info.ne.0) then\r\n write(*,*)'Error return from DGEGR2: ',info,lokph\r\n goto 1000\r\n endif\r\n! How to extract Q?? Documentation of DGEQR2:\r\n!> The matrix Q is represented as a product of elementary reflectors\r\n!>\r\n!> Q = H(1) H(2) . . . H(k), where k = min(m,n).\r\n!>\r\n!> Each H(i) has the form\r\n!>\r\n!> H(i) = I - tau * v * v**T\r\n!>\r\n!> where tau is a real scalar, and v is a real vector with\r\n!> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\r\n!> and tau in TAU(i).\r\n! zeta should be a matrix with the first ncol x ncol-mrow part of Q\r\n allocate(zeta(ncol,ncol-mrow))\r\n zeta=zero\r\n!\r\n! Step 3: multiply Z^T * H * Z\r\n allocate(fff(ncol,ncol))\r\n fff=zero\r\n do ii=1,ncol\r\n do jj=1,ncol\r\n fff(ii,jj)=fff(ii,jj)+zeta(ii,jj)*varres%d2gval(ixsym(ii,jj),1)\r\n enddo\r\n enddo\r\n jac=zero\r\n do ii=1,ncol\r\n do jj=1,ncol\r\n jac(ii,jj)=jac(ii,jj)+fff(ii,jj)*zeta(ii,jj)\r\n enddo\r\n enddo\r\n!\r\n! Step 4: calculate eigenvalues\r\n! use LAPACK routine, note d2g is destroyed inside dspev\r\n! write(*,*)'LAPACK routine DSPEV not implemented'\r\n allocate(eigenv(ncol))\r\n info=0\r\n call dspev('N','U',ncol,fff,eigenv,dummy,1,work,info)\r\n if(info.eq.0) then\r\n! write(*,120)(eigenv(ii),ii=1,ncol)\r\n120 format('Eigenvalues: ',6(1pe10.2))\r\n! return the most negative value\r\n value=eigenv(1)\r\n else\r\n write(*,*)'Error calculating eigenvalues of phase matrix',info\r\n gx%bmperr=4321\r\n endif\r\n! \r\n1000 continue\r\n return\r\n end subroutine calc_qf_otis\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_qf_sub\r\n!\\begin{verbatim}\r\n subroutine calc_qf_sub(lokcs,value,ceq)\r\n! NOT USED -----------------------------\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! using the Darken matrix with second derivatives: OK FOR SUBSTITUTIONAL\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n! For ionic liquid and charged crystalline phases one should\r\n! calculate eigenvectors to find neutral directions.\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n integer info,nofc,nofc2,nmax,ii,jj,lokph,nsl,cc,rr,zz,pp,qq\r\n double precision, allocatable :: d2g(:),eigenv(:),work(:)\r\n double precision dummy(1,1),dmuidyii\r\n integer, allocatable :: skip(:)\r\n type(gtp_phase_varres), pointer :: varres\r\n! number of constituents\r\n! ignore sublattices with single constituents ....\r\n varres=>ceq%phase_varres(lokcs)\r\n nofc=size(varres%yfr)\r\n lokph=varres%phlink\r\n! nofc=size(ceq%phase_varres(lokcs)%yfr)\r\n! lokph=ceq%phase_varres(lokcs)%phlink\r\n nsl=phlista(lokph)%noofsubl\r\n allocate(skip(nsl+1))\r\n info=1\r\n nmax=0\r\n do ii=1,nsl\r\n if(phlista(lokph)%nooffr(ii).eq.1) then\r\n nmax=nmax+1\r\n skip(nmax)=info\r\n! write(*,*)'3F QF skipping column/row ',info\r\n endif\r\n info=info+phlista(lokph)%nooffr(ii)\r\n enddo\r\n if(nmax.eq.nsl) then\r\n! phase has no variable composition\r\n value=one\r\n goto 1000\r\n endif\r\n skip(nmax+1)=phlista(lokph)%tnooffr+1\r\n! write(*,*)'QF dimension: ',nofc,nmax\r\n nofc=nofc-nmax\r\n nofc2=nofc*(nofc+1)/2\r\n allocate(d2g(nofc2))\r\n allocate(eigenv(nofc))\r\n allocate(work(3*nofc))\r\n nsl=1\r\n cc=0\r\n rr=0\r\n! Calculation of matrix elements modeified 2019.11.01/BoS\r\n! See documentation for Darken stability in minimizer documentation\r\n! dGA/dxB = d2GM/dxAdxB -\r\n! \\sum_C x_C (d2GM/dxAdxC+d2GM/dxBdxC + \\sum_D x_D d2GM/dxCdxD)\r\n! This may not work when sublattices ?... but difficult to calculate dG_I/dn_I\r\n! PROBLMES WHEN USER DEFINED REFERENCE STATES !! ??\r\n! For Cr-Fe when plot of gm(bcc) before q(bcc) then q(bcc) is rubbish\r\n!\r\n row: do ii=1,nofc+nmax\r\n if(ii.eq.skip(nsl)) then\r\n! skip this row. A clumsy way to skip sublattices with a single constituent\r\n nsl=nsl+1\r\n cycle row\r\n endif\r\n cc=cc+1\r\n rr=cc-1\r\n column: do jj=ii,nofc+nmax\r\n do zz=1,nmax\r\n! skip this column. A clumsy way to skip sublattices with a single constituent\r\n if(jj.eq.skip(zz)) cycle column\r\n enddo\r\n rr=rr+1\r\n! write(*,17)'QF calc: ',ii,jj,' to ',cc,rr\r\n17 format(a,2i4,a,2i4)\r\n dmuidyii=varres%d2gval(ixsym(ii,jj),1)\r\n! write(*,33)'3F start: ',ii,jj,0,dmuidyii\r\n33 format(a,3i3,3(1pe12.4))\r\n! d2g(ixsym(cc,rr))=ceq%phase_varres(lokcs)%d2gval(ixsym(ii,jj),1)\r\n! extra summation over all constituents (except those alone in a sublattice)\r\n extra1: do qq=1,nofc+nmax\r\n do zz=1,nmax\r\n! skip this term. A clumsy way to skip sublattices with a single constituent\r\n if(qq.eq.skip(zz)) cycle extra1\r\n enddo\r\n dmuidyii=dmuidyii-varres%yfr(qq)*(varres%d2gval(ixsym(ii,qq),1)+&\r\n varres%d2gval(ixsym(jj,qq),1))\r\n! write(*,33)'3F minus: ',ii,jj,qq,dmuidyii,&\r\n! varres%yfr(qq)*varres%d2gval(ixsym(ii,qq),1),&\r\n! varres%yfr(qq)*varres%d2gval(ixsym(jj,qq),1)\r\n extra2: do pp=1,nofc+nmax\r\n do zz=1,nmax\r\n! skip this term. A clumsy way to skip sublattices with a single constituent\r\n if(pp.eq.skip(zz)) cycle extra2\r\n enddo\r\n dmuidyii=dmuidyii+varres%yfr(qq)*varres%yfr(pp)*&\r\n varres%d2gval(ixsym(pp,qq),1)\r\n! write(*,33)'3F adding: ',0,pp,qq,dmuidyii,&\r\n! varres%yfr(qq)*varres%yfr(pp)*varres%d2gval(ixsym(pp,qq),1)\r\n enddo extra2\r\n enddo extra1\r\n! write(*,33)'3F result: ',cc,rr,0,dmuidyii\r\n d2g(ixsym(cc,rr))=dmuidyii\r\n enddo column\r\n enddo row\r\n! do ii=1,nofc\r\n! write(*,21)'3F d2Gdy2: ',(varres%d2gval(ixsym(ii,jj),1),jj=1,nofc)\r\n! enddo\r\n! do ii=1,nofc\r\n! write(*,21)'3F dmudy: ',(d2g(ixsym(ii,jj)),jj=1,nofc)\r\n! enddo\r\n21 format(a,6(1pe12.4))\r\n!\r\n!-------------------------------------------------------------------\r\n! uncomment the call to dspev in order to make Q work\r\n! AND link to LAPACK\r\n!-------------------------------------------------------------------\r\n! use LAPACK routine, note d2g is destroyed inside dspev\r\n! write(*,*)'LAPACK routine DSPEV not implemented'\r\n call dspev('N','U',nofc,d2g,eigenv,dummy,1,work,info)\r\n! info=-1000\r\n if(info.eq.0) then\r\n! write(*,120)(eigenv(ii),ii=1,nofc)\r\n120 format('3F Eigenvalues: ',6(1pe10.2))\r\n! return the most negative value\r\n value=eigenv(1)\r\n else\r\n write(*,*)'Error calculating eigenvalues of phase matrix',info\r\n gx%bmperr=4321\r\n endif\r\n1000 continue\r\n return\r\n end subroutine calc_qf_sub\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calc_qf_old\r\n!\\begin{verbatim}\r\n subroutine calc_qf_old(lokcs,value,ceq)\r\n! NOT USED -----------------------------\r\n! calculates eigenvalues of the second derivative matrix, stability function\r\n! this old version that seems to work for Ag-Cu ...\r\n! lokcs is index of phase_varres\r\n! value calculated value returned\r\n! ceq is current equilibrium\r\n! For ionic liquid and charged crystalline phases one should\r\n! calculate eigenvectors to find neutral directions.\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer :: lokcs\r\n double precision value\r\n!\\end{verbatim}\r\n integer info,nofc,nofc2,nmax,ii,jj,lokph,nsl,cc,rr,zz\r\n double precision, allocatable :: d2g(:),eigenv(:),work(:)\r\n double precision dummy(1,1)\r\n integer, allocatable :: skip(:)\r\n! number of constituents\r\n! ignore sublattices with single constituents ....\r\n! write(*,*)'3F in calc_qf_old: '\r\n nofc=size(ceq%phase_varres(lokcs)%yfr)\r\n lokph=ceq%phase_varres(lokcs)%phlink\r\n nsl=phlista(lokph)%noofsubl\r\n allocate(skip(nsl+1))\r\n info=1\r\n nmax=0\r\n do ii=1,nsl\r\n if(phlista(lokph)%nooffr(ii).eq.1) then\r\n nmax=nmax+1\r\n skip(nmax)=info\r\n! write(*,*)'QF skipping column/row ',info\r\n endif\r\n info=info+phlista(lokph)%nooffr(ii)\r\n enddo\r\n if(nmax.eq.nsl) then\r\n! phase has no variable composition\r\n value=one\r\n goto 1000\r\n endif\r\n skip(nmax+1)=phlista(lokph)%tnooffr+1\r\n! write(*,*)'QF dimension: ',nofc,nmax\r\n nofc=nofc-nmax\r\n nofc2=nofc*(nofc+1)/2\r\n allocate(d2g(nofc2))\r\n allocate(eigenv(nofc))\r\n allocate(work(3*nofc))\r\n nsl=1\r\n cc=0\r\n rr=0\r\n row: do ii=1,nofc+nmax\r\n if(ii.eq.skip(nsl)) then\r\n! skip this column\r\n nsl=nsl+1\r\n cycle row\r\n endif\r\n cc=cc+1\r\n rr=cc-1\r\n column: do jj=ii,nofc+nmax\r\n do zz=1,nmax\r\n if(jj.eq.skip(zz)) cycle column\r\n enddo\r\n rr=rr+1\r\n! write(*,17)'QF assigning ',ii,jj,' to ',cc,rr\r\n!17 format(a,2i4,a,2i4)\r\n d2g(ixsym(cc,rr))=ceq%phase_varres(lokcs)%d2gval(ixsym(ii,jj),1)\r\n enddo column\r\n enddo row\r\n!\r\n!-------------------------------------------------------------------\r\n! uncomment the call to dspev in order to make Q work\r\n! AND link to LAPACK\r\n!-------------------------------------------------------------------\r\n! use LAPACK routine, note d2g is destroyed inside dspev\r\n! write(*,*)'LAPACK routine DSPEV not implemented'\r\n call dspev('N','U',nofc,d2g,eigenv,dummy,1,work,info)\r\n! info=-1000\r\n if(info.eq.0) then\r\n! write(*,120)(eigenv(ii),ii=1,nofc)\r\n120 format('Eigenvalues: ',6(1pe10.2))\r\n! return the most negative value\r\n value=eigenv(1)\r\n else\r\n write(*,*)'Error calculating eigenvalues of phase matrix',info\r\n gx%bmperr=4321\r\n endif\r\n1000 continue\r\n return\r\n end subroutine calc_qf_old\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calculate_reference_state\r\n!\\begin{verbatim}\r\n subroutine calculate_reference_state(kstv,iph,ics,aref,ceq)\r\n! Calculate the user defined reference state for extensive properties\r\n! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G\r\n! It can be phase specific (iph.ne.0) or global (iph=0)\r\n! IMPORTANT\r\n! For integral quantitites (like calculated here) the reference state\r\n! is ignored unless all components have the same phase as reference (like Hmix)\r\n implicit none\r\n integer kstv,iph,ics\r\n double precision aref\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n! BIG BUG, the values of %gval is not restored!!\r\n! kstv=1 2 3 4 5 6 other values cared for elsewhere\r\n! U S V H A G\r\n integer iel,phref,allcomp\r\n double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6)\r\n double precision tmol,tmass,bmult\r\n!\r\n! write(*,*)'Reference states not implemented yet'; goto 1000\r\n! write(*,*)'3F reference state:',kstv,iph,ics\r\n if(kstv.lt.1 .or. kstv.gt.6) then\r\n! write(*,*)'3F No reference state for kstv: ',kstv\r\n goto 1000\r\n endif\r\n aref=zero\r\n bref=zero\r\n gref=zero\r\n xxx=zero\r\n allcomp=0\r\n! loop for all components to extract the value of their reference states\r\n! Multiply that with the overall composition (iph=0) or the phase composition\r\n xmol=zero\r\n do iel=1,noofel\r\n! this is the reference phase for component iel\r\n phref=ceq%complist(iel)%phlink\r\n if(kstv.eq.3) then\r\n! added when starting to handle P as variable. V should not depend\r\n! on a reference state unless all have the same phase as reference\r\n! write(*,*)'3F Reference for: ',iel,phref\r\n! removed as we should allow different reference stated for G and H\r\n if(allcomp.eq.0) then\r\n if(phref.gt.0) then\r\n allcomp=phref\r\n else\r\n! at least one component has no reference phase, ignore all refernce states\r\n aref=zero\r\n goto 900\r\n endif\r\n elseif(phref.ne.allcomp) then\r\n! different reference phases for the components, ignore the reference state\r\n! write(*,*)'3F Ignoring reference state as not same for all'\r\n aref=zero\r\n goto 900\r\n! phref is same, continue the loop\r\n! ignore any user defined reference state for the other components\r\n endif\r\n endif\r\n! UNFINISHED ?? For integral properties, kstv=1..\r\n100 continue\r\n if(phref.gt.0) then\r\n! we should use the phase index, not location in call below\r\n! write(*,*)'3F ref.ph: ',phref,phlista(phref)%alphaindex\r\n phref=phlista(phref)%alphaindex\r\n! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P\r\n! write(*,73)'3F R state: ',iel,phref,ceq%complist(iel)%endmember\r\n73 format(a,2i3,2x,10i4)\r\n! write(*,*)'3F callcg_endmember 3: ',phref\r\n call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Error return: ',gx%bmperr\r\n goto 1000\r\n endif\r\n if(iph.gt.0) then\r\n! multiply with mole fractions of phase iph,ics\r\n call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq)\r\n else\r\n! multiply with overall mole fractions\r\n call calc_molmass(xmol,wmass,tmol,tmass,ceq)\r\n endif\r\n! note xxx, bref and gref are arrays\r\n xxx=bref+xmol(iel)*gref\r\n! write(*,70)'3F rs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel)\r\n70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4))\r\n bref=xxx\r\n else\r\n! this is not really needed, it is bref that is used below\r\n gref=zero\r\n endif\r\n enddo\r\n! calculate the correct correction depending on kstv\r\n if(kstv.eq.1) then\r\n! U = G - T*G.T - P*G.P\r\n aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3)\r\n elseif(kstv.eq.2) then\r\n! S = - G.T\r\n aref=-bref(2)\r\n \r\n elseif(kstv.eq.3) then\r\n! V\r\n aref=bref(3)\r\n \r\n elseif(kstv.eq.4) then\r\n! H = G - T*G.T\r\n aref=bref(1)-ceq%tpval(1)*bref(2)\r\n \r\n elseif(kstv.eq.5) then\r\n! A = G - P*G.P\r\n aref=bref(1)-ceq%tpval(2)*bref(3)\r\n \r\n elseif(kstv.eq.6) then\r\n! G\r\n aref=bref(1)\r\n endif\r\n900 continue\r\n! write(*,75)kstv,aref\r\n75 format('3F ref:',i3,6(1pe12.4))\r\n1000 continue\r\n return\r\n end subroutine calculate_reference_state\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine calculate_reference_state_old\r\n!\\begin{verbatim}\r\n subroutine calculate_reference_state_old(kstv,iph,ics,aref,ceq)\r\n! Calculate the user defined reference state for extensive properties\r\n! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G\r\n! It can be phase specific (iph.ne.0) or global (iph=0)\r\n! IMPORTANT\r\n! For integral quantitites (like calculated here) the reference state\r\n! is ignored unless all components have the same phase as reference (like Hmix)\r\n implicit none\r\n integer kstv,iph,ics\r\n double precision aref\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n! BIG BUG, the values of %gval is not restored!!\r\n! kstv=1 2 3 4 5 6 other values cared for elsewhere\r\n! U S V H A G\r\n integer iel,phref,allcomp\r\n double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6)\r\n double precision tmol,tmass,bmult\r\n!\r\n! write(*,*)'Reference states not implemented yet'; goto 1000\r\n! write(*,*)'3F reference state:',kstv,iph,ics\r\n if(kstv.lt.1 .or. kstv.gt.6) then\r\n! write(*,*)'3F No reference state for kstv: ',kstv\r\n goto 1000\r\n endif\r\n aref=zero\r\n bref=zero\r\n gref=zero\r\n xxx=zero\r\n allcomp=0\r\n! loop for all components to extract the value of their reference states\r\n! Multiply that with the overall composition (iph=0) or the phase composition\r\n xmol=zero\r\n do iel=1,noofel\r\n! this is the reference phase for component iel\r\n phref=ceq%complist(iel)%phlink\r\n! write(*,*)'3F Reference for: ',iel,phref\r\n! added when starting to handle P as variable. V should not depend\r\n! on a reference state unless all have the same phase as reference\r\n if(allcomp.eq.0) then\r\n if(phref.gt.0) then\r\n allcomp=phref\r\n! write(*,*)'3F Setting allcomp: ',allcomp\r\n else\r\n! at least one component has no reference phase, ignore all refernce states\r\n aref=zero\r\n goto 900\r\n endif\r\n elseif(phref.ne.allcomp) then\r\n! different reference phases for the components, ignore the reference state\r\n! writing(*,*)'3F Ignoring reference state as not same for all'\r\n aref=zero\r\n goto 900\r\n! else\r\n! phref is same, continue the loop\r\n! ignore any user defined reference state for the other components\r\n endif\r\n! UNFINISHED ?? For integral properties, kstv=1..\r\n if(phref.gt.0) then\r\n! we should use the phase index, not location in call below\r\n! write(*,*)'3F ref.ph: ',phref,phlista(phref)%alphaindex\r\n phref=phlista(phref)%alphaindex\r\n! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P\r\n! write(*,73)'3F R state: ',iel,phref,ceq%complist(iel)%endmember\r\n73 format(a,2i3,2x,10i4)\r\n! write(*,*)'3F callcg_endmember 3: ',phref\r\n call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F Error return: ',gx%bmperr\r\n goto 1000\r\n endif\r\n if(iph.gt.0) then\r\n! multiply with mole fractions of phase iph,ics\r\n call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq)\r\n else\r\n! multiply with overall mole fractions\r\n call calc_molmass(xmol,wmass,tmol,tmass,ceq)\r\n endif\r\n! note xxx, bref and gref are arrays\r\n xxx=bref+xmol(iel)*gref\r\n! write(*,70)'3F rs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel)\r\n70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4))\r\n bref=xxx\r\n else\r\n! this is not really needed, it is bref that is used below\r\n gref=zero\r\n endif\r\n enddo\r\n! calculate the correct correction depending on kstv\r\n if(kstv.eq.1) then\r\n! U = G - T*G.T - P*G.P\r\n aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3)\r\n elseif(kstv.eq.2) then\r\n! S = - G.T\r\n aref=-bref(2)\r\n \r\n elseif(kstv.eq.3) then\r\n! V\r\n aref=bref(3)\r\n \r\n elseif(kstv.eq.4) then\r\n! H = G - T*G.T\r\n aref=bref(1)-ceq%tpval(1)*bref(2)\r\n \r\n elseif(kstv.eq.5) then\r\n! A = G - P*G.P\r\n aref=bref(1)-ceq%tpval(2)*bref(3)\r\n \r\n elseif(kstv.eq.6) then\r\n! G\r\n aref=bref(1)\r\n endif\r\n900 continue\r\n! write(*,75)kstv,aref\r\n75 format('3F ref:',i3,6(1pe12.4))\r\n1000 continue\r\n return\r\n end subroutine calculate_reference_state_old\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine enter_svfun\r\n!\\begin{verbatim}\r\n subroutine enter_svfun(cline,last,ceq)\r\n! enter a state variable function\r\n implicit none\r\n integer last\r\n character cline*(*)\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer, parameter :: npfs=20\r\n integer ks,maxsym,ipos,jt,js,kdot,nsymb,allowch,lbuf\r\n character name2*16,pfsym(npfs)*60,string*128,pfsymdenom*60,fbuff*256\r\n! integer istv(npfs),indstv(4,npfs),iref(npfs),iunit(npfs),lokv(npfs)\r\n integer iarr(10,npfs),lokv(npfs)\r\n! memory leak\r\n type(gtp_state_variable), target :: svrvar\r\n type(gtp_state_variable), pointer :: svr\r\n type(putfun_node), pointer :: lrot,datanod\r\n! \r\n! maxsym is negative to allow the user to enter abs(maxs) symbols\r\n! pfsym are the entered symbols\r\n! lokv is only internal strage in putfun\r\n! lrot is the root node of expression\r\n! nsymb is the number of user entered symbols\r\n! write(kou,17)'enter svgun ',last,cline(1:20),nsvfun\r\n17 format(a,i3,2x,a,i3)\r\n call gparcx('Symbol name: ',cline,last,ichar('='),name2,' ','?Enter symbol')\r\n call capson(name2)\r\n if(name2(1:1).eq.' ') then\r\n gx%bmperr=4137; goto 1000\r\n endif\r\n! write(*,*)'3F enter_svfun: ',last,name2,':',trim(cline)\r\n if(.not.proper_symbol_name(name2,0)) goto 1000\r\n! nsvfun is a global variable giving current number of state variable functions\r\n do ks=1,nsvfun\r\n if(name2.eq.svflista(ks)%name) then\r\n gx%bmperr=4136; goto 1000\r\n endif\r\n enddo\r\n kdot=0\r\n lbuf=0\r\n fbuff=' '\r\n! added allowch to handle symbols including & and #\r\n allowch=1\r\n! TO BE IMPLEMENTED: enter symbols with dummy arguments like CP(@P1)=HM(@P1).T\r\n! where @Pi is a phase, @Ci is a component and @Si is a species\r\n! these dummy variables must be defined in symbol name ?? why ?? maybe not\r\n! write(*,*)'3F symbol: \"',trim(cline),'\"',last\r\n77 continue\r\n call gparcx('Expression, end with \";\" :',cline,last,6,string,';',&\r\n '?Enter symbol')\r\n! there can be multiple lines, last end by ; or empty line\r\n if(index(string,';').le.0) then\r\n fbuff(lbuf+1:)=string\r\n lbuf=len_trim(fbuff)\r\n string=' '\r\n write(*,*)'3F Continue: '\r\n goto 77\r\n elseif(lbuf.gt.0) then\r\n string=fbuff\r\n endif\r\n if(index(string,';').eq.1) then\r\n write(*,*)'3F empty expression, maybe forgotten =?'\r\n gx%bmperr=4134; goto 1000\r\n endif\r\n! write(*,*)'3F expression: ',trim(string)\r\n maxsym=-npfs\r\n ipos=1\r\n call putfun(string,ipos,maxsym,pfsym,lokv,lrot,allowch,nsymb)\r\n if(pfnerr.ne.0 .or. .not.associated(lrot)) then\r\n write(*,*)'3F error in putfun: ',pfnerr,associated(lrot)\r\n pfnerr=0; gx%bmperr=4134; goto 1000\r\n endif\r\n! on return nsymb is the number of external symbols used in the function\r\n! these can be other functions or state variables or used defined identifiers\r\n! like Curie temperature etc. The symbols are in pfsym(1..nsymb)\r\n!\r\n! write(*,11)nsymb,(pfsym(js)(1:len_trim(pfsym(js))),js=1,nsymb)\r\n11 format('3F args: ',i2,': ',10(1x,a,','))\r\n! identify symbols as state variables, if derivative there is a dot\r\n iarr=0\r\n jt=0\r\n svr=>svrvar\r\n do js=1,nsymb\r\n kdot=index(pfsym(js),'.')\r\n if(kdot.gt.0) then\r\n! derivatives must be stored as two state variables\r\n! write(*,*)'3F Found dot derivative: ',kdot,pfsym(js)\r\n! Only allow a single symbol in this case!!!\r\n if(nsymb.gt.1) then\r\n! write(*,*)'3F Only a single symbol allowed!'\r\n gx%bmperr=4320; goto 1000\r\n endif\r\n jt=1\r\n! denominator, variable after . for with the derivative is taken\r\n pfsymdenom=pfsym(js)(kdot+1:)\r\n pfsym(js)(kdot:)=' '\r\n call decode_state_variable(pfsym(js),svr,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! store in the old way in iarr for two state variables\r\n iarr(1,js)=svr%oldstv\r\n iarr(2,js)=svr%norm\r\n iarr(3,js)=svr%unit\r\n iarr(4,js)=svr%phref\r\n iarr(5,js)=svr%argtyp\r\n iarr(6,js)=svr%phase\r\n iarr(7,js)=svr%compset\r\n iarr(8,js)=svr%component\r\n iarr(9,js)=svr%constituent\r\n iarr(10,js)=jt\r\n call decode_state_variable(pfsymdenom,svr,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! store in the old way in iarr for two state variables\r\n iarr(1,js+1)=svr%oldstv\r\n iarr(2,js+1)=svr%norm\r\n iarr(3,js+1)=svr%unit\r\n iarr(4,js+1)=svr%phref\r\n iarr(5,js+1)=svr%argtyp\r\n iarr(6,js+1)=svr%phase\r\n iarr(7,js+1)=svr%compset\r\n iarr(8,js+1)=svr%component\r\n iarr(9,js+1)=svr%constituent\r\n else\r\n! NOT a derivative\r\n call decode_state_variable(pfsym(js),svr,ceq)\r\n if(gx%bmperr.ne.0) then\r\n! symbol not a state variable, may be another function\r\n! write(*,*)'3F not state variable: ',gx%bmperr,' \"',&\r\n! pfsym(js)(1:len_trim(pfsym(js))),'\"'\r\n do ks=1,nsvfun\r\n if(pfsym(js).eq.svflista(ks)%name) then\r\n! write(*,*)'3F found another function: ',trim(pfsym(js))\r\n iarr(1,js)=-ks\r\n gx%bmperr=0\r\n goto 390\r\n endif\r\n enddo\r\n! here it can be a model parameter id such as THET(BCC) or MQ&FE(BCC)\r\n write(*,*)'3F argument not understood: \"',&\r\n pfsym(js)(1:len_trim(pfsym(js))),'\"',gx%bmperr\r\n gx%bmperr=4135; goto 1000\r\n else\r\n! It is a state variable or a model parameter identifier\r\n! to avoid confusing this with another function index subtract 1000\r\n! write(*,*)'3F state variable or model parameter id: \"',&\r\n! pfsym(js)(1:len_trim(pfsym(js))),'\"',gx%bmperr\r\n! write(*,'(a,10i5)')'3F svr: ',svr%oldstv,svr%norm,svr%unit,&\r\n! svr%phref,svr%argtyp,svr%phase,svr%compset,svr%component,&\r\n! svr%constituent\r\n! Store in the old way in iarr\r\n! iarr(1,js)=svr%oldstv-1000\r\n! write(*,*)'3F state variable or model parameter id',svr%oldstv\r\n if(svr%oldstv.lt.0) then\r\n iarr(1,js)=svr%oldstv-1000\r\n else\r\n iarr(1,js)=svr%oldstv\r\n endif\r\n iarr(2,js)=svr%norm\r\n iarr(3,js)=svr%unit\r\n iarr(4,js)=svr%phref\r\n iarr(5,js)=svr%argtyp\r\n iarr(6,js)=svr%phase\r\n iarr(7,js)=svr%compset\r\n iarr(8,js)=svr%component\r\n iarr(9,js)=svr%constituent\r\n endif\r\n endif\r\n390 continue\r\n enddo\r\n! for derivatives two iarr arrays\r\n! Found bug in store_putfun if just a variable entered, coefficient set to 0.0\r\n call store_putfun(name2,lrot,nsymb+jt,iarr)\r\n! The call above updates the global value of nsvfun so it means the new symbol\r\n if(nsymb.eq.0) then\r\n! this is just a constant numeric value ... store it locally. Why .and. ??\r\n if(.not.associated(lrot%left) .and. .not.associated(lrot%left)) then\r\n! write(*,*)'3F just a constant!!'\r\n! set bit to allow change the value but do not allow R to be changed\r\n if(nsvfun.gt.3) then\r\n svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVCONST)\r\n endif\r\n endif\r\n endif\r\n if(kdot.gt.0) then\r\n! this is a dot derivative, set bits\r\n svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVFVAL)\r\n svflista(nsvfun)%status=ibset(svflista(nsvfun)%status,SVFDOT)\r\n! write(*,*)'3F setting explicit bit: ',SVFDOT\r\n! endif\r\n else\r\n! this created a crash when entering a dot derivative, only notmal functions\r\n! there seems to be a problem that already existing state variable functions\r\n! are not evaluated so they give a correct value\r\n call evaluate_all_svfun_old(-1,ceq)\r\n if(gx%bmperr.ne.0) then\r\n! ignore any errors\r\n! write(*,*)' Error calculating the state variable functions!',gx%bmperr\r\n gx%bmperr=0\r\n endif\r\n endif\r\n! If a function is entered that cannot be calculated we get values such as NaN \r\n! ceq%svfunres(nsvfun)=zero\r\n! write(*,*)'3F store zero in svfunres',nsvfun,ceq%svfunres(nsvfun)\r\n1000 continue\r\n! NOTE eqnoval should be zeroed\r\n! NOTE svfval should be set if only calculated when explicitly referenced\r\n! possible memory leak\r\n nullify(svr)\r\n! write(*,*)'3F exit enter_svfun'\r\n return\r\n end subroutine enter_svfun\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine set_putfun_constant\r\n!\\begin{verbatim} %-\r\n subroutine set_putfun_constant(svfix,value)\r\n! changes the value of a putfun constant\r\n! svfix is index, value is new value\r\n! THIS CAN BE A FUNCTION WITH SVFVAL bit set, \r\n! in that case change it to a constant\r\n implicit none\r\n integer svfix\r\n double precision value\r\n!\\end{verbatim} %+\r\n type(putfun_node), pointer :: lrot\r\n! write(*,*)'We are in set_putfun_constant 1'\r\n if(btest(svflista(svfix)%status,SVFVAL)) then\r\n! converting a symbol from an expression to a constant\r\n! this means some loss of memory used for the expression\r\n svflista(svfix)%status=ibset(svflista(svfix)%status,SVCONST)\r\n svflista(svfix)%status=ibclr(svflista(svfix)%status,SVFVAL)\r\n! set number of arguments to zero ... this will make a mess ...\r\n! svflista(svfix)%narg=0\r\n! remove link to expression in in linkpnode ??\r\n! lrot=>svflista(svfix)%linkpnode\r\n! do we have to delete the expression? memory loss negligable ...\r\n endif\r\n if(.not.btest(svflista(svfix)%status,SVCONST)) then\r\n write(*,*)'Symbol is not a constant'\r\n gx%bmperr=4323\r\n else\r\n lrot=>svflista(svfix)%linkpnode\r\n! write(*,*)'3F constant: ',lrot%value,value\r\n svflista(svfix)%svfv=value\r\n! duplicate value, I am not sure where ...\r\n lrot%value=value\r\n endif\r\n1000 continue\r\n return\r\n end subroutine set_putfun_constant\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine store_putfun\r\n!\\begin{verbatim} %-\r\n subroutine store_putfun(name,lrot,nsymb,iarr)\r\n! enter an expression of state variables with name name with address lrot\r\n! nsymb is number of formal arguments\r\n! iarr identifies these\r\n implicit none\r\n character name*(*)\r\n type(putfun_node), pointer :: lrot\r\n integer nsymb\r\n integer iarr(10,*)\r\n!\\end{verbatim} %+\r\n! idot set if if derivative\r\n integer jf,jg,idot\r\n! write(*,*)'3F: store_putfun ',nsvfun\r\n nsvfun=nsvfun+1\r\n svflista(nsvfun)%status=0\r\n svflista(nsvfun)%tplink=0\r\n svflista(nsvfun)%eqnoval=0\r\n if(nsymb.gt.0) then\r\n allocate(svflista(nsvfun)%formal_arguments(10,nsymb))\r\n idot=10\r\n! dot derivatives have two consequtive symbols for the variable before/after\r\n do jf=1,nsymb\r\n! the order is: 1: state variable (negative means index to another symbol)\r\n! 2-5: norm, unit, phref, argtyp, \r\n! 6-10: phase, compset, component, constituent, derivative\r\n do jg=1,idot\r\n svflista(nsvfun)%formal_arguments(jg,jf)=iarr(jg,jf)\r\n enddo\r\n! write(*,77)(iarr(jg,jf),jg=1,idot)\r\n77 format('3F: store_putfun: ',20i3)\r\n enddo\r\n endif\r\n svflista(nsvfun)%name=name\r\n svflista(nsvfun)%linkpnode=>lrot\r\n svflista(nsvfun)%narg=nsymb\r\n! this is the number of actual argument needed (like @P, @C and @S)\r\n svflista(nsvfun)%nactarg=0\r\n! eqnoval indicate which equilibrium to use to get its value.\r\n! default is 0 meaning any equilibria, can be changed by AMEND SYMBOL\r\n svflista(nsvfun)%eqnoval=0\r\n1000 continue\r\n return\r\n end subroutine store_putfun\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine store_putfun_old\r\n!\\begin{verbatim} %-\r\n subroutine store_putfun_old(name,lrot,nsymb,&\r\n istv,indstv,iref,iunit,idot)\r\n! enter an expression of state variables\r\n! name: character, name of state variable function\r\n! lrot: pointer, to a putfun_node that is the root of the stored expression\r\n! nsymb: integer, number of formal arguments\r\n! istv: integer array, formal argument state variables typ\r\n! indstv: 2D integer array, indices for the formal state variables\r\n! iref: integer array, reference for the formal state variables\r\n! iunit: integer array, unit of the formal state variables\r\n implicit none\r\n type(putfun_node), pointer :: lrot\r\n integer nsymb\r\n integer, dimension(*) :: istv,iref,iunit,idot\r\n integer, dimension(4,*) :: indstv\r\n character name*(*)\r\n!\\end{verbatim}\r\n integer jf\r\n! write(*,*)'3F store_putfun ',nsvfun\r\n nsvfun=nsvfun+1\r\n if(nsymb.gt.0) then\r\n allocate(svflista(nsvfun)%formal_arguments(10,nsymb))\r\n do jf=1,nsymb\r\n svflista(nsvfun)%formal_arguments(1,jf)=istv(jf)\r\n svflista(nsvfun)%formal_arguments(2,jf)=indstv(1,jf)\r\n svflista(nsvfun)%formal_arguments(3,jf)=indstv(2,jf)\r\n svflista(nsvfun)%formal_arguments(4,jf)=indstv(3,jf)\r\n svflista(nsvfun)%formal_arguments(5,jf)=indstv(4,jf)\r\n svflista(nsvfun)%formal_arguments(6,jf)=iref(jf)\r\n svflista(nsvfun)%formal_arguments(7,jf)=iunit(jf)\r\n svflista(nsvfun)%formal_arguments(8,jf)=idot(jf)\r\n enddo\r\n endif\r\n svflista(nsvfun)%name=name\r\n svflista(nsvfun)%linkpnode=>lrot\r\n svflista(nsvfun)%status=0\r\n svflista(nsvfun)%narg=nsymb\r\n! this is the number of actual argument needed (like @P, @C and @S)\r\n svflista(nsvfun)%nactarg=0\r\n! eqnoval indicate which equilibrium to use to get its value.\r\n! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL\r\n svflista(nsvfun)%eqnoval=0\r\n1000 continue\r\n return\r\n end subroutine store_putfun_old\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine find_svfun\r\n!\\begin{verbatim}\r\n subroutine find_svfun(name,lrot)\r\n! finds a state variable function called name (no abbreviations)\r\n! ceq not needed!!??\r\n implicit none\r\n character name*(*)\r\n integer lrot\r\n! type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n! name must be in UPPER CASE and exact match required\r\n do lrot=1,nsvfun\r\n! write(*,*)'3F find_svfun: ',name,svflista(lrot)%name,lrot\r\n if(name.eq.svflista(lrot)%name) goto 500\r\n enddo\r\n write(*,*)'3F No such state variable function: ',name\r\n gx%bmperr=4188; goto 1000\r\n!\r\n500 continue\r\n! nothing more to do!\r\n1000 continue\r\n return\r\n end subroutine find_svfun\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine find_symbol_with_equilno\r\n!\\begin{verbatim}\r\n subroutine find_symbol_with_equilno(lrot,eqno)\r\n! finds a state variable function with equilibrium index\r\n implicit none\r\n integer lrot,eqno\r\n!\\end{verbatim} %+\r\n! skip the first 3 functions, R, RT and TC\r\n if(lrot.lt.0) lrot=3\r\n eqno=0\r\n! write(*,*)'3F find_sweq 1: ',lrot,nsvfun\r\n allfun: do while(lrot.lt.nsvfun)\r\n lrot=lrot+1\r\n if(svflista(lrot)%eqnoval.gt.0) then\r\n eqno=svflista(lrot)%eqnoval\r\n! for debugging\r\n! write(*,*)'3F symbol ',svflista(lrot)%name,' at equilibrium ',eqno\r\n goto 1000\r\n endif\r\n enddo allfun\r\n lrot=0\r\n1000 continue\r\n return\r\n end subroutine find_symbol_with_equilno\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine list_svfun\r\n!\\begin{verbatim} %-\r\n subroutine list_svfun(text,ipos,lrot,ceq)\r\n! list a state variable function\r\n implicit none\r\n character text*(*)\r\n integer ipos,lrot\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n! copied svflista(lrot)%formal_arguments(2..5,jt) to indices as gfortran error\r\n! integer indstv(4)\r\n type(gtp_state_variable), target :: svr2\r\n type(gtp_state_variable), pointer :: svr\r\n character symbols(20)*32,afterdot*32\r\n integer js,jt,ip,istv,kl,mm\r\n! write(*,*)'3F list_svfun 1:',svflista(lrot)%narg\r\n if(lrot.le.0 .or. lrot.gt.nsvfun) then\r\n gx%bmperr=4140; goto 1000\r\n endif\r\n if(svflista(lrot)%narg.eq.0) goto 500\r\n js=0\r\n jt=0\r\n100 continue\r\n jt=jt+1\r\n js=js+1\r\n ip=1\r\n symbols(js)=' '\r\n istv=svflista(lrot)%formal_arguments(1,jt)\r\n! write(*,*)'3F list_svfun: ',istv,js,jt\r\n if(istv.gt.-1000 .and. istv.lt.0) then\r\n! istv<-1000 means this is a model_parameter_identifier\r\n! function refer to another function (assuming never to have 1000 symbols ...\r\n symbols(js)=svflista(-istv)%name\r\n else\r\n! the 1:10 was a new bug discovered in GNU fortran 4.7 and later\r\n! PROBABLE MY BUG 2020-08-31/BOS, not declared allocatable ... SUCK\r\n svr=>svr2\r\n call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt))\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F failed creating state variable record'\r\n goto 1000\r\n endif\r\n call encode_state_variable(symbols(js),ip,svr,ceq)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)'3F failed encode state variable'\r\n goto 1000\r\n endif\r\n! write(*,*)'3F list_svfun: ',trim(symbols(js)),js,jt\r\n if(svflista(lrot)%formal_arguments(10,jt).ne.0) then\r\n! a derivative!!!\r\n! write(*,111)'3F A dot derivative of ',js,jt,symbols(js)\r\n111 format(a,2i3,': ',a)\r\n jt=jt+1\r\n afterdot=' '\r\n ip=1\r\n svr=>svr2\r\n call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt))\r\n call encode_state_variable(afterdot,ip,svr,ceq)\r\n! write(*,111)'3F wrt state variable ',js,jt,afterdot\r\n! symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot\r\n symbols(js)=trim(symbols(js))//'.'//afterdot\r\n! write(*,111)'3F alltogether ',js,jt,symbols(js)\r\n endif\r\n endif\r\n if(jt.lt.svflista(lrot)%narg) goto 100\r\n500 continue\r\n! add special information, first fill with blanks\r\n text(ipos:)=' '\r\n if(svflista(lrot)%eqnoval.gt.0) then\r\n! symbol should only be evaluated in equilibrium EQNOVAL\r\n write(text(ipos:ipos+3),470)svflista(lrot)%eqnoval\r\n470 format(i4)\r\n elseif(svflista(lrot)%tplink.gt.0) then\r\n! symbol is imported from or exported to TP function\r\n write(text(ipos:ipos+3),470)svflista(lrot)%tplink\r\n endif\r\n js=ipos+4\r\n ipos=ipos+7\r\n! Mark with a letter in position 5!\r\n if(btest(svflista(lrot)%status,SVNOAM)) then\r\n! symbol must not be amended (for R, RT and T_C)\r\n text(js:js)='N'\r\n elseif(btest(svflista(lrot)%status,SVCONST)) then\r\n! symbol is a constant (can be amended)\r\n text(js:js)='C'\r\n elseif(btest(svflista(lrot)%status,SVFDOT)) then\r\n! symbol is a dot derivative calculated only when explicitly referenced\r\n text(js:js)='D'\r\n elseif(btest(svflista(lrot)%status,SVFVAL)) then\r\n! symbol calculated only when explicitly referenced\r\n text(js:js)='V'\r\n elseif(btest(svflista(lrot)%status,SVFEXT)) then\r\n! symbol evaluated for an equilibrium, the equilibrium number already written\r\n text(js:js)='X'\r\n elseif(btest(svflista(lrot)%status,SVEXPORT)) then\r\n! symbol imported from TP function, function index is specified\r\n text(js:js)='E'\r\n elseif(btest(svflista(lrot)%status,SVIMPORT)) then\r\n! symbol exported to a TP function (assess coeff), function index is specified\r\n text(js:js)='I'\r\n endif\r\n! name and expression\r\n! kl=len_trim(svflista(lrot)%name)\r\n! text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= '\r\n text(ipos:)=trim(svflista(lrot)%name)//'='\r\n ipos=len_trim(text)+2\r\n! svflista(lrot)%linkpode is a pointer to a pufun_node record\r\n if(.not.associated(svflista(lrot)%linkpnode)) then\r\n text(ipos:)=' = no expression; '\r\n else\r\n! write(*,502)'3F wrtfun: ',jt,(trim(symbols(mm)),mm=1,jt)\r\n502 format(a,i3,10(' \"',a,'\", '))\r\n call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols)\r\n! where is pfnerr defined??\r\n if(pfnerr.ne.0) then\r\n write(kou,*)'Putfun error listing funtion ',pfnerr\r\n gx%bmperr=4142; goto 1000\r\n endif\r\n endif\r\n1000 continue\r\n return\r\n end subroutine list_svfun\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine make_stvrec\r\n!\\begin{verbatim}\r\n subroutine make_stvrec(svr,iarr)\r\n! stores appropriate values from a formal argument list to a state variable\r\n! function in a state variable record\r\n implicit none\r\n type(gtp_state_variable), pointer :: svr\r\n integer iarr(10)\r\n!\\end{verbatim}\r\n integer jt,norm,currid\r\n!\r\n! memory leak\r\n! allocate(svr)\r\n currid=0\r\n if(iarr(1).lt.-1000) then\r\n! Handling of parameter property symbols like TC, BMAGN etc\r\n! NOTE inside symbols -1000 used to separate from other symbols \r\n currid=iarr(1)+1000\r\n svr%statevarid=currid\r\n elseif(iarr(1).le.0) then\r\n write(*,*)'3F illegal argument to make_stvrec: ',iarr(1)\r\n elseif(iarr(1).lt.10) then\r\n! This is T, P, MU, AC, LNAC\r\n! 1 2 3 4 5\r\n svr%statevarid=iarr(1)\r\n currid=iarr(1)\r\n else\r\n! This is U, S, V, H, A, G, NP, BP, DG, Q, N, X, B, W, Y symbol\r\n! 6 7 8 9 10, 11, 12, 13, 14, 15, 16, 17, 18, 19. 20 new code\r\n! 10 20 30 40 50 60 70 80 90 100 110 111 120 122 130 old code\r\n! dvs iarr()=10 means U etc.\r\n jt=iarr(1)/10+5\r\n norm=mod(iarr(1),10)\r\n! special for x and w, note norm is set to normallizing\r\n if(jt.eq.16 .and. norm.eq.1) jt=17\r\n if(jt.eq.18 .and. norm.eq.2) jt=19\r\n svr%statevarid=jt\r\n currid=iarr(1)\r\n! write(*,*)'3F make: ',iarr(1),jt\r\n endif\r\n! write(*,11)iarr\r\n11 format('3F Arguments: ',10i5)\r\n! svr%oldstv=iarr(1)\r\n svr%oldstv=currid\r\n svr%norm=iarr(2)\r\n svr%unit=iarr(3)\r\n svr%phref=iarr(4)\r\n svr%argtyp=iarr(5)\r\n svr%phase=iarr(6)\r\n svr%compset=iarr(7)\r\n svr%component=iarr(8)\r\n svr%constituent=iarr(9)\r\n1000 continue\r\n return\r\n end subroutine make_stvrec\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine list_all_svfun\r\n!\\begin{verbatim}\r\n subroutine list_all_svfun(kou,ceq)\r\n! list all state variable funtions\r\n implicit none\r\n integer kou\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n character text*256\r\n integer ks,ipos\r\n write(kou,17)\r\n17 format('List of all state variable symbols'/' No Special Name= expression ;')\r\n!17 format('List of all state variable symbols'/' No Name= expression ;')\r\n do ks=1,nsvfun\r\n ipos=1\r\n call list_svfun(text,ipos,ks,ceq)\r\n if(pfnerr.ne.0) then\r\n gx%bmperr=4142; pfnerr=0; goto 1000\r\n endif\r\n write(kou,76)ks,text(1:ipos-1)\r\n76 format(i3,2x,a)\r\n enddo\r\n1000 continue\r\n return\r\n end subroutine list_all_svfun\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine evaluate_all_svfun_old\r\n!\\begin{verbatim}\r\n subroutine evaluate_all_svfun_old(kou,ceq)\r\n! THIS SUBROUTINE MOVED TO MINIMIZER but kept for initiallizing\r\n! cannot be used for state variable functions that are derivatives ...\r\n! evaluate and list values of all functions but it is still used somewhere\r\n implicit none\r\n integer kou\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n character actual_arg(10)*24\r\n integer kf\r\n double precision val\r\n if(kou.gt.0) write(kou,75)\r\n75 format('No Name ',12x,'Value')\r\n do kf=1,nsvfun\r\n! actual arguments needed if svflista(kf)%nactarg>0\r\n! write(*,*)'3F call svaluate_svfun_old 2'\r\n val=evaluate_svfun_old(kf,actual_arg,0,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,val\r\n77 format(i3,1x,a,1x,1PE15.8)\r\n enddo\r\n1000 continue\r\n return\r\n end subroutine evaluate_all_svfun_old\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable double precision function evaluate_svfun_old\r\n!\\begin{verbatim} %-\r\n double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq)\r\n! THIS SUBROUTINE MOVED TO MINIMIZER\r\n! but needed in some cases in this module ... ???\r\n! envaluate all funtions as they may depend on each other\r\n! actual_arg are names of phases, components or species as @Pi, @Ci and @Si\r\n! needed in some deferred formal parameters (NOT IMPLEMENTED YET)\r\n! if mode=1 always evaluate\r\n implicit none\r\n integer lrot,mode\r\n character actual_arg(*)*(*)\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n double precision argval(20)\r\n type(gtp_state_variable), target :: svr2\r\n type(gtp_state_variable), pointer :: svr\r\n integer jv,jt,istv,ieq\r\n! added to handle symbols that are model parameter id\r\n integer indices(4),iref,iunit\r\n double precision value\r\n argval=zero\r\n value=zero\r\n! calculate symbol * does not come here for H298 ...\r\n! write(*,*)'3F evaluate_svfun ',lrot,svflista(lrot)%narg,svflista(lrot)%name\r\n! locate function\r\n if(lrot.le.0 .or. lrot.gt.nsvfun) then\r\n gx%bmperr=4140; goto 1000\r\n endif\r\n if(btest(svflista(lrot)%status,SVFDOT)) then\r\n! write(*,*)'3F Warning has SVFDOT set, return error ',lrot\r\n gx%bmperr=4399; goto 1000\r\n elseif(btest(svflista(lrot)%status,SVFVAL) .and. mode.ne.1) then\r\n! this symbol is keeps it value unless evaluated explicitly (mode=1)\r\n! write(*,*)'3F Warning has SVFVAL set: ',lrot,svflista(lrot)%name,value\r\n value=ceq%svfunres(lrot)\r\n goto 1000\r\n elseif(btest(svflista(lrot)%status,SVFEXT)) then\r\n! the symbol is associated with a specific equilibrium we must fetch\r\n! its value from that equilibrium unless that is ceq!!\r\n ieq=svflista(lrot)%eqnoval\r\n! write(*,*)'3F SVFEXT set: ',lrot,ieq,svflista(lrot)%name\r\n if(ieq.gt.0 .and. ieq.ne.ceq%eqno) then\r\n value=eqlista(ieq)%svfunres(lrot)\r\n! save its value also in this equilibrium\r\n goto 900\r\n endif\r\n endif\r\n if(svflista(lrot)%narg.eq.0) goto 300\r\n!--------------------------------------------------------------------\r\n! get values of arguments ... THIS IS NOT IMPLEMENTED ... I think ??\r\n jv=0\r\n jt=0\r\n100 continue\r\n jt=jt+1\r\n istv=svflista(lrot)%formal_arguments(1,jt)\r\n! write(*,*)'3F get argument: ',istv,lrot,svflista(lrot)%eqnoval\r\n if(istv.lt.0) then\r\n! evidently istv<1 can also mean this is a model parameter identifier\r\n! how to know? Here only when entering the symbol?\r\n if(istv.lt.-1000) then\r\n ieq=-istv-1000\r\n! write(*,*)'3F model parameter identifier: ',ieq\r\n! write(*,*)'3F allocated: ',size(svflista(lrot)%formal_arguments)\r\n! write(*,'(a,10i5)')'3F svflista: ',&\r\n! svflista(lrot)%formal_arguments(5,jt),&\r\n! svflista(lrot)%formal_arguments(6,jt),&\r\n! svflista(lrot)%formal_arguments(7,jt)\r\n! VERY VERY CLUMSY, must be changes to use svr state variable record\r\n! indices are PHASE, COMPSET, COMPONENT, \r\n indices(1)=svflista(lrot)%formal_arguments(5,jt)\r\n indices(2)=svflista(lrot)%formal_arguments(6,jt)\r\n indices(3)=svflista(lrot)%formal_arguments(7,jt)\r\n indices(4)=0\r\n iref=0\r\n iunit=0\r\n call state_variable_val3(-ieq,indices,iref,iunit,value,ceq)\r\n! value=zero\r\n else\r\n! if eqnoval nonzero it indicates from which equilibrium to get its value\r\n ieq=svflista(lrot)%eqnoval\r\n if(ieq.eq.0) then\r\n value=ceq%svfunres(-istv)\r\n else\r\n value=eqlista(ieq)%svfunres(-istv)\r\n endif\r\n endif\r\n else\r\n! the 1:10 was a new bug discovered in GNU fortran 4.7 and later\r\n! FOUND PROBABLE BUG 2020-08-31/BOS %formal_arguments never allocated ???\r\n svr=>svr2\r\n call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt))\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(svflista(lrot)%formal_arguments(10,jt).eq.0) then\r\n! get state variable value\r\n call state_variable_val(svr,value,ceq)\r\n else\r\n! state variable derivative, error code set above, it must be handelled\r\n! by calling other routine and use meq_evaluate_svfun\r\n! write(*,*)'3F In evaluate_svfun_old!!!'\r\n! write(*,*)'Use \"calculate symbol\" for state variable derivatives!'\r\n gx%bmperr=4217\r\n! call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt))\r\n! call state_var_value_derivative(svr,svr2,value,ceq)\r\n! call meq_state_var_value_derivative(svr,svr2,value,ceq)\r\n endif\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n jv=jv+1\r\n argval(jv)=value\r\n if(jt.lt.svflista(lrot)%narg) goto 100\r\n! all (if any) arguments evaluated (or no arguments needed)\r\n!--------------------------------------------------------------------\r\n300 continue\r\n! write(*,333)'evaluate_svfun ',svflista(lrot)%name,argval(1),argval(2)\r\n!333 format(a,a,2(1PE15.6))\r\n! write(*,340)'3F evaluate svfun 1: ',mode,lrot\r\n340 format(a,5i4)\r\n modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then\r\n! If mode=0 and SVFVAL set return the stored value\r\n value=ceq%svfunres(lrot)\r\n! write(*,350)'3F evaluate svfun 2: ',0,lrot,value\r\n elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then\r\n! if mode=0 and SVFEXT set use value from equilibrium eqno\r\n ieq=svflista(lrot)%eqnoval\r\n if(ceq%eqno.eq.ieq) then\r\n value=evalf(svflista(lrot)%linkpnode,argval)\r\n if(pfnerr.ne.0) then\r\n write(*,*)'3F evaluate_svfun putfunerror 1',pfnerr\r\n gx%bmperr=4141; pfnerr=0; buperr=0; goto 1000\r\n endif\r\n ceq%svfunres(lrot)=value\r\n! write(*,350)'3F evaluate svfun 3: ',ieq,lrot,value\r\n else\r\n! Hm, we already did this earlier ... redundant?\r\n value=eqlista(ieq)%svfunres(lrot)\r\n endif\r\n! write(*,350)'3F evaluate svfun 4: ',ieq,lrot,value\r\n350 format(a,2i3,1pe12.4)\r\n else\r\n! if mode=1 always evaluate unless another equilibrium, we jumped to 900 above\r\n value=evalf(svflista(lrot)%linkpnode,argval)\r\n if(pfnerr.ne.0) then\r\n write(*,*)'3F evaluate_svfun putfunerror 2',pfnerr\r\n gx%bmperr=4141; pfnerr=0; buperr=0; goto 1000\r\n endif\r\n endif modeval\r\n! if(btest(svflista(lrot)%status,SVFVAL)) then\r\n! if(lrot.gt.4) write(*,*)'3F evaluated symbol: ',lrot,value\r\n! endif\r\n! save value in current equilibrium\r\n900 continue\r\n if(lrot.gt.0) then\r\n ceq%svfunres(lrot)=value\r\n! if(lrot.gt.4) write(*,*)'Saved symbol ',lrot,' in equil ',ceq%eqno,value\r\n endif\r\n1000 continue\r\n! write(*,*)'3F eval_svfun: ',lrot,value,size(ceq%svfunres)\r\n evaluate_svfun_old=value\r\n return\r\n end function evaluate_svfun_old\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\r\n" }, { "path": "src/models/gtp3G.F90", "content": "!\r\n! gtp3G included in gtp3.F90\r\n!\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n!> 11. Section: status for things\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine change_element_status\r\n!\\begin{verbatim}\r\n subroutine change_element_status(elname,nystat,ceq)\r\n! change the status of an element, can affect species and phase status\r\n! nystat:0=entered, 1=suspended, -1 special (exclude from sum of mole fraction)\r\n!\r\n! suspending elements for each equilibrium separately not yet implemented\r\n!\r\n implicit none\r\n character elname*(*)\r\n integer nystat\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer iel,lokel\r\n call find_element_by_name(elname,iel)\r\n if(gx%bmperr.ne.0) goto 1000\r\n lokel=elements(iel)\r\n write(*,*)'3G Changing element status not yet implemented'\r\n goto 1000\r\n if(btest(ellista(iel)%status,elsus)) then\r\n! element already suspended, quit it should be suspended again ....\r\n if(nystat.eq.1) goto 1000\r\n! element status should be changed from suspended to entered\r\n ellista(iel)%status=ibclr(ellista(iel)%status,elsus)\r\n call restore_species_implicitly_suspended\r\n call restore_phases_implicitly_suspended\r\n elseif(nystat.eq.1) then\r\n! element should be changed from entered to suspended\r\n ellista(iel)%status=ibset(ellista(iel)%status,elsus)\r\n call suspend_species_implicitly(ceq)\r\n call suspend_phases_implicitly(ceq)\r\n endif\r\n1000 continue\r\n return\r\n end subroutine change_element_status\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable logical function testelstat\r\n!\\begin{verbatim}\r\n logical function testelstat(iel,status)\r\n! return value of element status bit\r\n implicit none\r\n integer iel,status\r\n!\\end{verbatim}\r\n integer lokel\r\n if(iel.gt.0 .and. iel.lt.noofel) then\r\n lokel=elements(iel)\r\n if(btest(ellista(lokel)%status,status)) then\r\n! btest(iword,bit) .true. if bit set in iword\r\n! iword=ibclr(iword,bit) to clear bit bit in iword\r\n! iword=ibset(iword,bit) to set bit bit in iword\r\n testelstat=.true.\r\n else\r\n testelstat=.false.\r\n endif\r\n else\r\n gx%bmperr=4042\r\n endif\r\n end function testelstat\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine change_species_status\r\n!\\begin{verbatim}\r\n subroutine change_species_status(spname,nystat,ceq)\r\n! change the status of a species, can affect phase status\r\n! nystat:0=entered, 1=suspended\r\n implicit none\r\n integer nystat\r\n character spname*(*)\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer loksp\r\n call find_species_record(spname,loksp)\r\n if(gx%bmperr.ne.0) goto 1000\r\n write(*,*)'3G Changing species status not yet implemented'\r\n goto 1000\r\n if(btest(splista(loksp)%status,spsus)) then\r\n! species already suspended, quit if it should be suspended again ....\r\n if(nystat.eq.1) goto 1000\r\n! restore the species (and phases) unless implicitly suspended\r\n if(btest(splista(loksp)%status,spimsus)) then\r\n! species cannot be entered as it is implicitly suspended (some element susp)\r\n gx%bmperr=4085; goto 1000\r\n endif\r\n splista(loksp)%status=ibclr(splista(loksp)%status,spsus)\r\n call restore_phases_implicitly_suspended\r\n elseif(nystat.eq.1) then\r\n! suspend the species and possibly some phases\r\n splista(loksp)%status=ibset(splista(loksp)%status,spsus)\r\n call suspend_phases_implicitly(ceq)\r\n endif\r\n1000 continue\r\n return\r\n end subroutine change_species_status\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable logical function testspstat\r\n!\\begin{verbatim}\r\n logical function testspstat(isp,status)\r\n! return value of species status bit\r\n implicit none\r\n integer isp,status\r\n!\\end{verbatim}\r\n integer loksp\r\n if(isp.gt.0 .and. isp.le.noofsp) then\r\n loksp=species(isp)\r\n if(btest(splista(loksp)%status,status)) then\r\n! btest(iword,bit) .true. if bit set in iword\r\n! iword=ibclr(iword,bit) to clear bit bit in iword\r\n! iword=ibset(iword,bit) to set bit bit in iword\r\n testspstat=.true.\r\n else\r\n testspstat=.false.\r\n endif\r\n else\r\n gx%bmperr=4051\r\n endif\r\n end function testspstat\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable integer function get_phase_status\r\n!\\begin{verbatim}\r\n integer function get_phase_status(iph,ics,text,ip,val,ceq)\r\n! return phase status as text and amount formula units in val\r\n! for entered and fix phases also phase amounts.\r\n! OLD Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden\r\n implicit none\r\n character text*(*)\r\n integer iph,ics,ip\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n double precision val\r\n!\\end{verbatim} %+\r\n integer ists,lokph,lokcs,j\r\n! write current status\r\n ists=0\r\n val=-one\r\n if(iph.gt.0 .and. iph.le.noph()) then\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n!old if(btest(phlista(lokph)%status1,phhid)) then\r\n!old text='HIDDEN'; ip=6\r\n!old ists=5\r\n!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then\r\n! entered, fix, suspended, dormant\r\n! bit setting: 00 01 , 10 11\r\n!old if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n!old text='DORMANT'; ip=7\r\n!old ists=3\r\n!old else\r\n!old text='SUSPENDED'; ip=9\r\n!old ists=4\r\n!old endif\r\n!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n!old text='FIXED'; ip=5\r\n! val=ceq%phase_varres(lokcs)%amount(1)\r\n!old val=ceq%phase_varres(lokcs)%amfu\r\n!old ists=2\r\n!old else\r\n!old text='ENTERED'; ip=7\r\n!old val=ceq%phase_varres(lokcs)%amfu\r\n!old ists=1\r\n!old endif\r\n! new way, test PHSTATE\r\n j=ceq%phase_varres(lokcs)%phstate\r\n!z if(j.lt.-4 .or. j.gt.2) then\r\n! I had an erroor here when plotting map2 macro because after the second\r\n! map command I had 2 liquid compsets and during the first mapping I had\r\n! only one liquid so I think\r\n!z ip=j\r\n!z j=0\r\n!z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then\r\n!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n!z j=-2\r\n!z else ! suspended\r\n!z j=3\r\n!z endif\r\n!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n! fix\r\n!z j=2\r\n!z else ! entered\r\n!z j=0\r\n!z endif\r\n! save this status .... ???\r\n!z write(*,16)'3G PHSTATE wrong, fixing ...',iph,ics,j,ip,&\r\n!z ceq%phase_varres(lokcs)%status2\r\n!z ceq%phase_varres(lokcs)%phstate=j\r\n!z endif\r\n select case(j)\r\n case default\r\n write(*,16)'3G: PHSTATE not correct: ',iph,ics,j,ip,&\r\n ceq%phase_varres(lokcs)%status2\r\n16 format(a,4i3,2x,z16)\r\n gx%bmperr=4324\r\n case(phfixed) ! fix 2\r\n text='FIXED'\r\n ip=5\r\n val=ceq%phase_varres(lokcs)%amfu\r\n ists=phfixed\r\n case(-1,0,1) ! entered (unstable, unknown, stable)\r\n text='ENTERED'\r\n ip=7\r\n val=ceq%phase_varres(lokcs)%amfu\r\n ists=phentered\r\n case(phdorm) ! dormant -2\r\n text='DORMANT'\r\n ip=7\r\n ists=phdorm\r\n case(phsus) ! suspended -3\r\n text='SUSPENDED'\r\n ip=9\r\n ists=phsus\r\n case(phhidden) ! hidden -4\r\n text='HIDDEN'\r\n ip=6\r\n ists=phhidden\r\n end select\r\n else\r\n! write(*,*)'No such phase'\r\n gx%bmperr=4050; goto 1000\r\n endif\r\n get_phase_status=ists\r\n! write(*,*)'3G: PHSTAT value: ',ists\r\n! write(*,*)'3G: gps: ',ip\r\n1000 continue\r\n return\r\n end function get_phase_status\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable integer function test_phase_status\r\n!\\begin{verbatim}\r\n integer function test_phase_status(iph,ics,val,ceq)\r\n! Almost same as get_..., returns phase status as function value but no text\r\n! value is amfu\r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! this is different from in change_phase .... one has to make up one's mind\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer iph,ics\r\n double precision val\r\n!\\end{verbatim}\r\n integer ists,lokph,lokcs,j,ip\r\n character text*24\r\n! new code\r\n ists=0\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 900\r\n ists=ceq%phase_varres(lokcs)%phstate\r\n val=ceq%phase_varres(lokcs)%amfu\r\n goto 900\r\n!============================================= code below redundant?\r\n ists=0\r\n ip=1\r\n val=-one\r\n ists=get_phase_status(iph,ics,text,ip,val,ceq)\r\n goto 900\r\n!------------------\r\n if(iph.gt.0 .and. iph.le.noph()) then\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n! biet set means false ....\r\n!z if(btest(phlista(lokph)%status1,phhid)) then\r\n! hidden\r\n!z ists=5\r\n!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then\r\n! entered, fix, suspended, dormant\r\n! bit setting: 00 01 , 10 11\r\n!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n!z ists=3\r\n!z else\r\n!z ists=4\r\n!z endif\r\n!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then\r\n!z val=ceq%phase_varres(lokcs)%amfu\r\n!z ists=2\r\n!z else\r\n!z ists=1\r\n!z val=ceq%phase_varres(lokcs)%amfu\r\n!z endif\r\n! new way, test PHSTATE\r\n j=ceq%phase_varres(lokcs)%phstate\r\n select case(ceq%phase_varres(lokcs)%phstate)\r\n case default\r\n write(*,*)'PHSTAT outside range -4:2: ',j\r\n case(phfixed) ! fix +2\r\n if(ists.ne.2) write(*,*)'wrong PHSTAT',ists,j\r\n case(-1,0,1) ! entered (unstable, unknown, stable)\r\n if(ists.ne.1) write(*,*)'wrong PHSTAT',ists,j\r\n case(phdorm) ! dormant -2\r\n if(ists.ne.3) write(*,*)'wrong PHSTAT',ists,j\r\n case(phsus) ! suspended -3\r\n if(ists.ne.4) write(*,*)'wrong PHSTAT',ists,j\r\n case(phhidden) ! hidden -4\r\n if(ists.ne.5) write(*,*)'wrong PHSTAT',ists,j\r\n end select\r\n else\r\n! write(*,*)'No such phase'\r\n gx%bmperr=4050; goto 1000\r\n endif\r\n900 continue\r\n test_phase_status=ists\r\n1000 continue\r\n return\r\n end function test_phase_status\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine set_phase_status_bit\r\n!\\begin{verbatim}\r\n subroutine set_phase_status_bit(lokph,bit)\r\n! set the status bit \"bit\" in status1, cannot be done outside this module\r\n! as the phlista is private\r\n! These bits do not depend on the composition set\r\n implicit none\r\n integer lokph,bit\r\n!\\end{verbatim} %+\r\n integer lokcs,j\r\n if(bit.lt.0 .or. bit.gt.31) then\r\n write(*,*)'Illegal phase bit number'\r\n gx%bmperr=4325; goto 1000\r\n elseif(lokph.le.0 .or. lokph.gt.noofph) then\r\n write(*,*)'Illegal phase in call to set_phase_status_bit'\r\n gx%bmperr=4326; goto 1000\r\n endif\r\n! write(*,99)'sphs1bit: ',lokph,bit,phlista(lokph)%status1\r\n99 format(a,2i3,z8)\r\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,bit)\r\n if(bit.eq.PHHID) then\r\n! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to -4\r\n do j=1,phlista(lokph)%noofcs\r\n lokcs=phlista(lokph)%linktocs(j)\r\n! eventually, this must be set in all equilibrium records now just firsteq ??\r\n firsteq%phase_varres(lokcs)%phstate=-4\r\n enddo\r\n endif\r\n1000 continue\r\n return\r\n end subroutine set_phase_status_bit\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine clear_phase_status_bit\r\n!\\begin{verbatim} %-\r\n subroutine clear_phase_status_bit(lokph,bit)\r\n! clear the status bit \"bit\" in status1, cannot be done outside this module\r\n! as the phlista is private\r\n implicit none\r\n integer lokph,bit\r\n!\\end{verbatim} %+\r\n integer lokcs,j\r\n if(bit.lt.0 .or. bit.gt.31) then\r\n write(*,*)'Illegal phase bit number'\r\n gx%bmperr=4325; goto 1000\r\n endif\r\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,bit)\r\n if(bit.eq.PHHID) then\r\n write(*,*)'clear_bit: Not implemented to change PHSTATE'\r\n! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to 0\r\n do j=1,phlista(lokph)%noofcs\r\n lokcs=phlista(lokph)%linktocs(j)\r\n! eventually, this must be set in all equilibrium records now just firsteq ??\r\n firsteq%phase_varres(lokcs)%phstate=phentered\r\n enddo\r\n endif\r\n1000 continue\r\n return\r\n end subroutine clear_phase_status_bit\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable logical function test_phase_status_bit\r\n!\\begin{verbatim} %-\r\n logical function test_phase_status_bit(iph,ibit)\r\n! return TRUE is status bit ibit for phase iph, is set\r\n! because phlista is private. Needed to test for gas, ideal etc, \r\n! DOES NOT TEST STATUS like entered/fixed/dormant/suspended\r\n implicit none\r\n integer iph,ibit\r\n!\\end{verbatim}\r\n integer lokph\r\n if(iph.gt.0 .and. iph.le.noofph) then\r\n lokph=phases(iph)\r\n else\r\n gx%bmperr=4050; goto 1000\r\n endif\r\n if(btest(phlista(lokph)%status1,ibit)) then\r\n test_phase_status_bit=.true.\r\n else\r\n test_phase_status_bit=.false.\r\n endif\r\n1000 continue\r\n return\r\n end function test_phase_status_bit\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine change_many_phase_status\r\n!\\begin{verbatim}\r\n subroutine change_many_phase_status(phnames,nystat,val,ceq)\r\n! change the status of many phases. \r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! phnames is a list of phase names or *S (all suspeded) *D (all dormant) or\r\n! *E (all entered (stable, unknown, unstable), *U all unstable\r\n! If just * then change_phase_status is called directly\r\n! It calls change_phase_status for each phase\r\n implicit none\r\n character phnames*(*)\r\n integer nystat\r\n double precision val\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer qph,ics,oldstat,ipos,slen,lokph,lokcs,phcsx\r\n character name*24\r\n! CCI correted size of phnames\r\n! write(*,*)'3G phnames: ',trim(phnames),' >',phnames(1:1),'<'\r\n if(phnames(1:1).eq.'*') then\r\n! write(*,*)'3G star'\r\n if(phnames(2:2).eq.'S') then\r\n oldstat=-3\r\n elseif(phnames(2:2).eq.'D') then\r\n oldstat=-2\r\n elseif(phnames(2:2).eq.'E') then\r\n! all entered (stable, unstable, unknown)\r\n oldstat=0\r\n elseif(phnames(2:2).eq.'U') then\r\n! all unstable phases (not those which ar efix!)\r\n oldstat=1\r\n elseif(phnames(2:2).eq.' ') then\r\n qph=-1\r\n! write(*,*)'3G star',qph,ics,nystat,val\r\n call change_phase_status(qph,ics,nystat,val,ceq)\r\n goto 1000\r\n else\r\n write(*,*)'Illegal selection of old phase status after *'\r\n gx%bmperr=4327; goto 1000\r\n endif\r\n! loop for all phases to find those with correct old status\r\n do qph=1,noofph\r\n! we cannot loop for ics as we do not know lokph\r\n ics=1\r\n call get_phase_compset(qph,ics,lokph,lokcs)\r\n200 continue\r\n! stable phases has ceq%phase_varres(lokcs)%phstate = 1\r\n! fix phases =2\r\n ipos=oldstat-ceq%phase_varres(lokcs)%phstate\r\n! write(*,*)'3G entered: ',qph,ics,oldstat,ipos\r\n if((oldstat.ne.1 .and. ipos.eq.0) .or. &\r\n (oldstat.eq.0 .and. abs(ipos).eq.1) .or.&\r\n (oldstat.eq.1 .and. ipos.gt.0)) then\r\n! *U=nystat means all all with phstate <=0 that means ipos=1-0; 1-(-1)=2 etc\r\n! (oldstat.eq.1 .and. abs(ipos).gt.0)) then\r\n! this comp.set has correct old phase status\r\n call change_phase_status(qph,ics,nystat,val,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n! take next composition set if any, else next phase\r\n if(ics.lt.phlista(lokph)%noofcs) then\r\n ics=ics+1\r\n lokcs=phlista(lokph)%linktocs(ics)\r\n goto 200\r\n endif\r\n enddo\r\n else\r\n! we have one or more specific phase names separated by space or comma\r\n! ipos is updated inside getext, The 3rd argument of getext is JTYP\r\n! JTYP DEFINES THE TERMINATION OF A STRING\r\n! 1 TEXT TERMINATED BY SPACE OR \",\"\r\n! 2 TEXT TERMINATED BY SPACE\r\n! 3 TEXT TERMINATED BY \";\" OR \".\"\r\n! 4 TEXT TERMINATED BY \";\"\r\n! 5 TEXT UP TO END-OF-LINE\r\n! 6 TEXT UP TO AND INCLUDING \";\"\r\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\r\n ipos=0\r\n500 continue\r\n call getext(phnames,ipos,1,name,' ',slen)\r\n! write(*,*)'3G phase1: ',slen,' ',name\r\n if(name(1:1).eq.' ') goto 1000\r\n! write(*,*)'3G phase2: ',name\r\n! call find_phase_by_name(name,qph,ics)\r\n! phcsx=-1 means that all composition sets should have new status\r\n phcsx=-1\r\n call find_phasex_by_name(name,phcsx,qph,ics)\r\n if(gx%bmperr.ne.0) then\r\n write(*,*)' *** Warning no phase \"',trim(name),'\", phase ignored'\r\n! write(*,*)'No phase called \"',name(1:len_trim(name)),'\"'\r\n gx%bmperr=0\r\n else\r\n! we may have to make a loop for all composition sets\r\n! A phase without composition set specification but with several composition \r\n! sets should have all composition sets changed to the new status\r\n! UNLESS the status is FIX\r\n if(ics.lt.0) then\r\n! we should never loop to set all composition sets to FIXED\r\n! if another composition set than 1 was to be set fixed ics is not negative\r\n if(nystat.eq.PHFIXED) then\r\n slen=1\r\n else\r\n slen=-ics\r\n endif\r\n! write(*,*)'3G Status changed for several composition sets: ',slen\r\n do ics=1,slen\r\n call change_phase_status(qph,ics,nystat,val,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n enddo\r\n else\r\n! write(*,*)'3G changing status for a single phase',nystat\r\n call change_phase_status(qph,ics,nystat,val,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif\r\n endif\r\n goto 500\r\n endif\r\n1000 continue\r\n return\r\n end subroutine change_many_phase_status\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n!\r\n!\\addtotable subroutine get_phtup_status\r\n!\\begin{verbatim} %-\r\n! subroutine get_phtup_status(phtupx,status,ceq)\r\n! return the status of a phase tuple. Also used when setting phase fix etc.\r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! \r\n! implicit none\r\n! integer phtupx,status\r\n! TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n! the status is in phase_varres record, THIS IS NOT PRIVATE\r\n! 2 fix, 1,0,-1 entered, -2 dormant, -3 suspended\r\n! status=ceq%phase_varres(phasetuple(phtupx)%lokvares)%status2\r\n!1000 continue\r\n! return\r\n! end subroutine get_phtup_status\r\n!\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine change_phtup_status\r\n!\\begin{verbatim} %-\r\n subroutine change_phtup_status(phtupx,nystat,val,ceq)\r\n! change the status of a phase tuple. Also used when setting phase fix etc.\r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! qph can be -1 meaning all or a specifix phase index. ics compset\r\n! \r\n implicit none\r\n integer phtupx,nystat\r\n double precision val\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer lokph,iph,ics\r\n if(phtupx.lt.0) then\r\n! change status for all phases to nystat\r\n call change_many_phase_status('* ',nystat,val,ceq)\r\n else\r\n! lokph=phasetuple(phtupx)%phaseix\r\n lokph=phasetuple(phtupx)%lokph\r\n iph=phlista(lokph)%alphaindex\r\n ics=phasetuple(phtupx)%compset\r\n! write(*,77)'3G Test: ',phlista(lokph)%name,phtupx,lokph,iph,phases(iph)\r\n!77 format(a,a,10i5)\r\n call change_phase_status(iph,ics,nystat,val,ceq)\r\n endif\r\n1000 continue\r\n return\r\n end subroutine change_phtup_status\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine change_phase_status\r\n!\\begin{verbatim} %-\r\n subroutine change_phase_status(qph,ics,nystat,val,ceq)\r\n! change the status of a phase. Also used when setting phase fix etc.\r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! qph can be -1 meaning all or a specifix phase index. ics compset\r\n! \r\n implicit none\r\n integer qph,ics,nystat\r\n double precision val\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer lokph,lokcs,iph,ip,mcs\r\n character line*80,phname*32\r\n! write(*,11)'3G in change_phase_status: ',qph,ics,nystat,val\r\n11 format(a,3i5,1pe14.6)\r\n if(qph.eq.-1) then\r\n! this means all phases. All phases cannot be set fix\r\n if(nystat.eq.3) then\r\n gx%bmperr=4152; goto 1000\r\n endif\r\n iph=1\r\n ics=1\r\n else\r\n! a specific phase\r\n iph=qph\r\n endif\r\n! return here for next phase\r\n100 continue\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate\r\n if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then\r\n! this phase and composition set is fix, remove condition\r\n! unless the new status is also FIX\r\n if(nystat.ne.phfixed) then\r\n call get_phase_name(iph,ics,phname)\r\n line=' NOFIX='//phname(1:len_trim(phname))\r\n ip=1\r\n! write(*,*)'Remove fix phase: ',line(1:len_trim(line))\r\n call set_condition(line,ip,ceq)\r\n if(gx%bmperr.ne.0) then\r\n! write(*,*)'Failed to remove fix phase as condition'\r\n goto 1000\r\n endif\r\n endif\r\n endif\r\n bigif: if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then\r\n! phase is hidden, quit if it should be hidden again\r\n! bigif: if(btest(phlista(lokph)%status1,phhid)) then\r\n if(nystat.eq.phhidden) goto 900\r\n! phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid)\r\n!??? this phase must be added in phlista ??? no it is already there ???\r\n write(*,*)'Unifished handling of hide/not hide ...'\r\n gx%bmperr=4095; goto 900\r\n elseif(nystat.eq.phhidden) then\r\n! phase is not hidden but should be set as hidden,\r\n! Always applies to all composition sets\r\n! clear all entered/suspended/dormant/fix for all composition sets\r\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid)\r\n do mcs=1,phlista(lokph)%noofcs\r\n lokcs=phlista(lokph)%linktocs(mcs)\r\n ceq%phase_varres(lokcs)%phstate=phhidden \r\n! also set amounts and dgm to zero\r\n ceq%phase_varres(lokcs)%amfu=zero\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n enddo\r\n else !bigif\r\n lokcs=phlista(lokph)%linktocs(ics)\r\n! changing FIX/ENTERED/SUSPENDED/DORMANT for a composition set\r\n! input nystat:0=entered, 3=fix, 1=suspended, 2=dormant\r\n! bit setting: 00 01 , 10 11 !! BITS NO LONGER USED\r\n! write(*,71)'3G new status: ',iph,ics,lokph,lokcs,nystat,phentered,val\r\n71 format(a,6i5,1pe14.6)\r\n if(nystat.eq.phentered .or. nystat.eq.phentunst .or. &\r\n nystat.eq.phentstab) then\r\n! set enterered with amount val and dgm zero\r\n! write(*,*)'Setting phase as entered',nystat\r\n! ceq%phase_varres(lokcs)%phstate=phentered\r\n ceq%phase_varres(lokcs)%phstate=nystat\r\n ceq%phase_varres(lokcs)%amfu=val\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n elseif(nystat.eq.phsus) then\r\n! set suspended with amount and dgm zero\r\n ceq%phase_varres(lokcs)%phstate=phsus\r\n ceq%phase_varres(lokcs)%amfu=zero\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n elseif(nystat.eq.phdorm) then\r\n! set dormant with amount and dgm zero\r\n ceq%phase_varres(lokcs)%phstate=phdorm\r\n ceq%phase_varres(lokcs)%amfu=zero\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n elseif(nystat.eq.phfixed) then\r\n! to allow MAPPHASEFIX=3\r\n ceq%phase_varres(lokcs)%phstate=phfixed\r\n ceq%phase_varres(lokcs)%amfu=val\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n! also set as condition\r\n call get_phase_name(iph,ics,phname)\r\n line=' FIX='//phname(1:len_trim(phname))//' =='\r\n ip=len_trim(line)+2\r\n call wrinum(line,ip,6,0,val)\r\n if(buperr.ne.0) goto 1000\r\n ip=1\r\n! write(*,*)'phase fix condition: ',line(1:40)\r\n call set_condition(line,ip,ceq)\r\n endif\r\n endif bigif\r\n900 continue\r\n! check if loop\r\n if(qph.eq.-1) then\r\n lokph=phases(iph)\r\n if(ics.lt.phlista(lokph)%noofcs) then\r\n ics=ics+1\r\n elseif(iph.lt.noofph) then\r\n iph=iph+1\r\n ics=1\r\n else\r\n goto 1000\r\n endif\r\n goto 100\r\n endif\r\n1000 continue\r\n! write(*,*)'error code: ',gx%bmperr\r\n return\r\n end subroutine change_phase_status\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\r\n\r\n!\\addtotable subroutine mark_stable_phase\r\n!\\begin{verbatim} &-\r\n subroutine mark_stable_phase(iph,ics,ceq)\r\n! change the status of a phase. Does not change fix status\r\n! called from meq_sameset to indicate stable phases (nystat=1)\r\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\r\n! \r\n implicit none\r\n integer iph,ics\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer lokph,lokcs\r\n! write(*,11)'3G mark as stable: ',iph,ics,phentstab\r\n11 format(a,3i5,1pe14.6)\r\n call get_phase_compset(iph,ics,lokph,lokcs)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate\r\n if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then\r\n write(*,*)'Error calling mark_stable for hidden phase'\r\n gx%bmperr=4095; goto 1000\r\n elseif(ceq%phase_varres(lokcs)%phstate.le.phdorm) then\r\n write(*,*)'Cannot make suspended or doremant phases as stable'\r\n gx%bmperr=4095; goto 1000\r\n elseif(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then\r\n! do nothing\r\n goto 1000\r\n else\r\n ceq%phase_varres(lokcs)%phstate=phentstab\r\n endif\r\n1000 continue\r\n! write(*,*)'error code: ',gx%bmperr\r\n return\r\n end subroutine mark_stable_phase\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n!> 12. Section: unfinished things\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine set_unit\r\n!\\begin{verbatim}\r\n subroutine set_unit(property,unit)\r\n! set the unit for a property, like K, F or C for temperature\r\n! >>>> unfinished\r\n implicit none\r\n character*(*) property,unit\r\n!\\end{verbatim}\r\n write(*,*)'Not implemented yet'\r\n gx%bmperr=4078\r\n1000 continue\r\n return\r\n end subroutine set_unit\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine set_constituent_reference_state\r\n!\\begin{verbatim}\r\n subroutine set_constituent_reference_state(iph,icon,asum)\r\n! determine the end member to calculate as reference state for this constituent\r\n! Used when giving a chemical potential for a constituent like MU(GAS,H2O)\r\n implicit none\r\n integer iph,icon\r\n double precision asum\r\n!\\end{verbatim}\r\n type(gtp_endmember), pointer :: endmemrec\r\n integer lokph,nsl,ll,jcon,loksp,loksp2,lokcs\r\n!\r\n lokph=phases(iph)\r\n loksp=phlista(lokph)%constitlist(icon)\r\n nsl=phlista(lokph)%noofsubl\r\n endmemrec=>phlista(lokph)%ordered\r\n asum=one\r\n lokcs=phlista(lokph)%linktocs(1)\r\n if(nsl.eq.1) then\r\n asum=firsteq%phase_varres(lokcs)%sites(1)\r\n emlist1: do while(associated(endmemrec))\r\n if(endmemrec%fraclinks(nsl,1).eq.icon) goto 300\r\n endmemrec=>endmemrec%nextem\r\n enddo emlist1\r\n else\r\n! several sublattices OK if same species or vacancies in other sublattices\r\n asum=zero\r\n emlist2: do while(associated(endmemrec))\r\n do ll=1,nsl\r\n jcon=endmemrec%fraclinks(ll,1)\r\n if(jcon.ne.icon) then\r\n loksp2=phlista(lokph)%constitlist(jcon)\r\n if(loksp2.eq.loksp) then\r\n! same species in this sublattice, add sites to asum\r\n asum=asum+firsteq%phase_varres(lokcs)%sites(ll)\r\n elseif(.not.btest(splista(loksp2)%status,spva)) then\r\n! other species (not vacancies) in this sublattice, skip this end member\r\n goto 200\r\n endif\r\n else\r\n asum=asum+firsteq%phase_varres(lokcs)%sites(ll)\r\n endif\r\n enddo\r\n! this endmember OK\r\n goto 300\r\n! not this end member\r\n200 continue\r\n endmemrec=>endmemrec%nextem\r\n enddo emlist2\r\n endif\r\n! this phase cannot exist for species icon as pure\r\n gx%bmperr=4112; goto 1000\r\n300 continue\r\n1000 continue\r\n return\r\n end subroutine set_constituent_reference_state\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine elements2components1\r\n!\\begin{verbatim}\r\n subroutine elements2components1(nspel,dum,ncmp,cmpstoi,ceq)\r\n! converts a stoichiometry array for a species from elements to components\r\n! This subroutine, is it used to get activity for a constituent in gtp3F\r\n! dum is is no longer used\r\n implicit none\r\n integer nspel,ncmp\r\n! cmpstoi is stoichiometry as element, changed to be as components\r\n double precision cmpstoi(*),dum(*)\r\n double precision, allocatable :: stoi(:)\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n double precision, parameter :: small=1.0d-30\r\n integer ic,jc,ns\r\n allocate(stoi(noofel))\r\n do ic=1,noofel\r\n stoi(ic)=cmpstoi(ic)\r\n cmpstoi(ic)=zero\r\n enddo\r\n! use the ceq%complist(ic)%invcompstoi\r\n! do ic=1,noofel\r\n! cmpstoi(ic)=zero\r\n! enddo\r\n! not sure about the indices here .... ????\r\n! write(*,*)'e2c: ',noofel,nspel,stoi(1),ceq%invcompstoi(1,1)\r\n do ic=1,noofel\r\n! convert elements to components, if the elements are components no problem\r\n do jc=1,noofel\r\n cmpstoi(ic)=cmpstoi(ic)+ceq%invcompstoi(ic,jc)*stoi(ic)\r\n enddo\r\n enddo\r\n! write(*,7)'3G 1: ',(stoi(ic),ic=1,noofel)\r\n! write(*,7)'3G 2: ',(stoi(ic),ic=1,noofel)\r\n7 format(a,10(1pe12.4))\r\n! MODIFIED HERE 190710/BoS, return stoichiometry for ALL components\r\n ncmp=noofel\r\n goto 1000\r\n!---------------------\r\n! skip code below ... \r\n ncmp=0\r\n ic=0\r\n ns=0\r\n200 continue\r\n ic=ic+1\r\n if(ic.lt.noofel) then\r\n if(abs(cmpstoi(ic)).lt.small) then\r\n do jc=ic,noofel\r\n cmpstoi(jc)=cmpstoi(jc+1)\r\n enddo\r\n else\r\n ncmp=ncmp+1\r\n! write(*,*)'c2c1: ',ic,ncmp\r\n endif\r\n goto 200\r\n elseif(abs(cmpstoi(ic)).gt.small) then\r\n! write(*,*)'c2c2: ',ic,ncmp,cmpstoi(ic)\r\n ncmp=ncmp+1\r\n endif\r\n! write(*,190)ic,(cmpstoi(i),i=1,ncmp)\r\n!190 format('e2c3: ',i3,10F7.3)\r\n1000 continue\r\n return\r\n end subroutine elements2components1\r\n\r\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\!\r\n!> 13. Section: internal stuff\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n \r\n!\\addtotable subroutine termterm\r\n!\\begin{verbatim}\r\n subroutine termterm(string,ich,kpos,lpos,value)\r\n! search for first occurance of + - = > or <\r\n! if + or - then also extract possible value after sign\r\n! value is coefficient for NEXT term (if any)\r\n! IF WE FIND A ( accept all characters up to ), constitunets can have + or -\r\n! kpos is last character in THIS state variable, lpos where NEXT may start\r\n implicit none\r\n character string*(*)\r\n integer kpos,ich,lpos\r\n double precision value\r\n!\\end{verbatim}\r\n integer ipos,jpos,i1\r\n logical afterlp\r\n character ch1*1\r\n character (len=1), dimension(6), parameter :: chterm=&\r\n ['+','-','=','<','>',':']\r\n!\r\n afterlp=.FALSE.\r\n ich=0\r\n sloop: do ipos=1,len_trim(string)\r\n ch1=string(ipos:ipos)\r\n! I do not check for nested ( ) or ...\r\n if(ch1.eq.'(') then\r\n afterlp=.TRUE.\r\n elseif(ch1.eq.')') then\r\n afterlp=.FALSE.\r\n endif\r\n! accept all characters between ( )\r\n if(afterlp) cycle sloop\r\n do i1=1,6\r\n if(ch1.eq.chterm(i1)) then\r\n kpos=ipos; ich=i1; exit sloop\r\n endif\r\n enddo\r\n enddo sloop\r\n! different actions depending on ich\r\n! write(*,17)'3G termterm: ',trim(string),string(1:kpos),ich,kpos\r\n17 format(a,' \"',a,'\" >',a,'< ',2i3)\r\n select case(ich)\r\n case default\r\n write(*,*)'3G wrong ich case: ',ich\r\n case(0)\r\n! no terminator, just return with position pointer after the text\r\n continue\r\n kpos=len_trim(string)+1\r\n case(1,2)\r\n! there is a - or + sign, collect value in front of next term\r\n lpos=kpos+1\r\n call getrel(string,lpos,value)\r\n if(buperr.ne.0) then\r\n! a sign not followed by number means unity\r\n buperr=0; value=one\r\n else\r\n! lpos first character after number, a number must be followed by a \"*\"\r\n if(string(lpos:lpos).ne.'*') then\r\n write(*,*)'3G syntax error missing *: ',string(1:lpos+5),lpos\r\n gx%bmperr=4130\r\n else\r\n lpos=lpos+1\r\n endif\r\n endif\r\n if(ich.eq.2) value=-value\r\n case(3,4,5)\r\n! there is an = sign, or > or <, just set back the pointer\r\n kpos=ipos\r\n lpos=0\r\n case(6)\r\n! there is an : sign, meaning a condition number, must be followed by =\r\n if(string(kpos+1:kpos+1).ne.'=') then\r\n gx%bmperr=4328; goto 1000\r\n endif\r\n kpos=ipos+1\r\n lpos=0\r\n end select\r\n1000 continue\r\n! write(*,17)'3G termterm: ',trim(string),string(1:lpos),ich,lpos\r\n return\r\n end subroutine termterm\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine alphaelorder\r\n!\\begin{verbatim}\r\n subroutine alphaelorder\r\n! arrange new element in alphabetical order\r\n! also make alphaindex give alphabetical order\r\n implicit none\r\n!\\end{verbatim} %+\r\n character symb1*2\r\n integer i,j\r\n symb1=ellista(noofel)%symbol\r\n! write(6,*)'alphaelorder 1: ',symb1,noofel\r\n loop1: do i=1,noofel-1\r\n if(symb1.lt.ellista(elements(i))%symbol) then\r\n loop2: do j=noofel,i+1,-1\r\n elements(j)=elements(j-1)\r\n ellista(elements(j))%alphaindex=j\r\n enddo loop2\r\n! write(6,*)'alphaelorder 3: ',i\r\n elements(i)=noofel\r\n ellista(elements(i))%alphaindex=i\r\n exit\r\n endif\r\n enddo loop1\r\n! write(6,*)'alphaelorder 4: ',(elements(k),k=1,noofel)\r\n END subroutine alphaelorder\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine alphasporder\r\n!\\begin{verbatim}\r\n subroutine alphasporder\r\n! arrange new species in alphabetical order\r\n! also make alphaindex give alphabetical order\r\n implicit none\r\n!\\end{verbatim} %+\r\n character symb1*24\r\n integer i,j\r\n symb1=splista(noofsp)%symbol\r\n! write(6,*)'alphasporder 1: ',symb1(1:6),noofsp\r\n loop1: do i=1,noofsp-1\r\n if(symb1.lt.splista(species(i))%symbol) then\r\n! write(6,*)'alphasporder 2; ',symb1,splista(species(i))%symbol\r\n loop2: do j=noofsp,i+1,-1\r\n species(j)=species(j-1)\r\n splista(species(j))%alphaindex=j\r\n enddo loop2\r\n species(i)=noofsp\r\n! write(6,*)'alphasporder 3:',i\r\n splista(species(i))%alphaindex=i\r\n exit\r\n endif\r\n enddo loop1\r\n! write(6,*)'alphasporder 4: ',(species(k),k=1,noofsp)\r\n END subroutine alphasporder\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine alphaphorder\r\n!\\begin{verbatim}\r\n subroutine alphaphorder(tuple)\r\n! arrange last added phase in alphabetical order\r\n! also make alphaindex give alphabetical order\r\n! phletter G and L and I have priority\r\n! phletter F and B meaning FCC or BCC permutations(?) ignored\r\n! tuple is returned as position in phase tuple\r\n implicit none\r\n integer tuple\r\n!\\end{verbatim}\r\n character symb1*24,ch1*1,ch2*1\r\n integer iph,lokph,j,lokcs\r\n!\r\n symb1=phlista(noofph)%name\r\n ch1=phlista(noofph)%phletter\r\n! special care for F or B meaning with permutations ...\r\n if(ch1.eq.'F' .or. ch1.eq.'B') ch1='S'\r\n if(btest(phlista(noofph)%status1,PHLIQ)) ch1='L'\r\n! for some reason the MQMQA model does not have letter L\r\n if(btest(phlista(noofph)%status1,PHMQMQA)) then\r\n ch1='L'\r\n! write(*,*)'3G enter phase with MQMQA model'\r\n endif\r\n! one more phase in \"phases\" array\r\n phases(noofph)=noofph\r\n! write(6,75)'3G alphaphorder 1: ',noofph,ch1,symb1(1:6)\r\n75 format(A,I3,1x,A,1x,A)\r\n loop1: do iph=1,noofph-1\r\n lokph=phases(iph)\r\n ch2=phlista(lokph)%phletter\r\n! special care for F or B meaning with permutations ...\r\n if(ch2.eq.'F' .or. ch1.eq.'B') ch2='S'\r\n! we must test if MQMQA is any of the phases already sorted\r\n if(btest(phlista(lokph)%status1,PHMQMQA)) then\r\n ch2='L'\r\n! write(*,*)'3G phletter for phases: ',ch1,ch2\r\n endif\r\n! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2\r\n76 format(A,2I3,1x,A,1x,A)\r\n! phaseletter different, if ch1=G insert it here\r\n if(ch1.eq.'G') goto 300\r\n if(ch2.eq.'G') goto 200\r\n liquid: if(ch1.eq.'L') then\r\n if(ch2.eq.'G') goto 200\r\n if(ch2.eq.'L') goto 100\r\n goto 300\r\n endif liquid\r\n if(ch2.eq.'L') goto 200\r\n solution: if(ch1.eq.'S') then\r\n if(ch2.eq.'G' .or. ch2.eq.'L') goto 200\r\n if(ch2.eq.'S') goto 100\r\n goto 300\r\n endif solution\r\n if(ch2.eq.'S') goto 200\r\n compound: if(ch1.eq.'C') then\r\n if(ch2.eq.'C') goto 100\r\n goto 200\r\n endif compound\r\n! here phletter of lokph and the new phase are the same\r\n100 continue\r\n! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name\r\n if(symb1.lt.phlista(lokph)%name) goto 300\r\n200 continue\r\n enddo loop1\r\n! exit loop, add new phase last\r\n! lokph=phases(noofph)\r\n iph=phases(noofph)\r\n300 continue\r\n! write(*,*)'3G new phase position: ',iph\r\n! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name\r\n!77 format(A,2I3,1X,A)\r\n! insert phase here at iph, shift down trailing phase indices\r\n! also OK if new phase should be last\r\n loop2: do j=noofph,iph+1,-1\r\n! update index of trailing phases, loop from the end not to overwrite\r\n phases(j)=phases(j-1)\r\n phlista(phases(j))%alphaindex=j\r\n enddo loop2\r\n! index of new phase\r\n! write(6,*)'alphaphorder 4: ',lokph,iph,noofph\r\n phases(iph)=noofph\r\n phlista(noofph)%alphaindex=iph\r\n nooftuples=nooftuples+1\r\n tuple=iph\r\n! write(*,771)iph,phasetuple(iph),phlista(noofph)%name\r\n771 format('3G tuple: ',i5,': ',4(i8,1x),2x,a)\r\n! link to first compset set when phase_varres record connected\r\n! write(*,777)'3G phase tuple position: ',iph,noofph,lokph,lokcs,tuple\r\n777 format(a,10i5)\r\n return\r\n END subroutine alphaphorder\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine alphaphorder_old\r\n!\\begin{verbatim}\r\n subroutine alphaphorder_old(tuple)\r\n! arrange last added phase in alphabetical order\r\n! also make alphaindex give alphabetical order\r\n! phletter G and L and I have priority\r\n! tuple is returned as position in phase tuple\r\n implicit none\r\n integer tuple\r\n!\\end{verbatim}\r\n character symb1*24,ch1*1,ch2*1\r\n integer iph,lokph,j,lokcs\r\n!\r\n symb1=phlista(noofph)%name\r\n ch1=phlista(noofph)%phletter\r\n if(btest(phlista(noofph)%status1,PHLIQ)) ch1='L'\r\n! one more phase in \"phases\" array\r\n phases(noofph)=noofph\r\n! write(6,75)'3G alphaphorder 1: ',noofph,ch1,symb1(1:6)\r\n75 format(A,I3,1x,A,1x,A)\r\n loop1: do iph=1,noofph-1\r\n lokph=phases(iph)\r\n ch2=phlista(lokph)%phletter\r\n! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2\r\n76 format(A,2I3,1x,A,1x,A)\r\n! phaseletter different, if ch1=G insert it here\r\n if(ch1.eq.'G') goto 300\r\n if(ch2.eq.'G') goto 200\r\n liquid: if(ch1.eq.'L') then\r\n if(ch2.eq.'G') goto 200\r\n if(ch2.eq.'L') goto 100\r\n goto 300\r\n endif liquid\r\n if(ch2.eq.'L') goto 200\r\n solution: if(ch1.eq.'S') then\r\n if(ch2.eq.'G' .or. ch2.eq.'L') goto 200\r\n if(ch2.eq.'S') goto 100\r\n goto 300\r\n endif solution\r\n if(ch2.eq.'S') goto 200\r\n compound: if(ch1.eq.'C') then\r\n if(ch2.eq.'C') goto 100\r\n goto 200\r\n endif compound\r\n! here phletter of lokph and the new phase are the same\r\n100 continue\r\n! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name\r\n if(symb1.lt.phlista(lokph)%name) goto 300\r\n200 continue\r\n enddo loop1\r\n! exit loop, add new phase last\r\n! lokph=phases(noofph)\r\n iph=phases(noofph)\r\n300 continue\r\n! write(*,*)'3G new phase position: ',iph\r\n! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name\r\n!77 format(A,2I3,1X,A)\r\n! insert phase here at iph, shift down trailing phase indices\r\n! also OK if new phase should be last\r\n loop2: do j=noofph,iph+1,-1\r\n! update index of trailing phases, loop from the end not to overwrite\r\n phases(j)=phases(j-1)\r\n phlista(phases(j))%alphaindex=j\r\n enddo loop2\r\n! index of new phase\r\n! write(6,*)'alphaphorder 4: ',lokph,iph,noofph\r\n phases(iph)=noofph\r\n phlista(noofph)%alphaindex=iph\r\n nooftuples=nooftuples+1\r\n tuple=iph\r\n! write(*,771)iph,phasetuple(iph),phlista(noofph)%name\r\n771 format('3G tuple: ',i5,': ',4(i8,1x),2x,a)\r\n! link to first compset set when phase_varres record connected\r\n! write(*,777)'3G phase tuple position: ',iph,noofph,lokph,lokcs,tuple\r\n777 format(a,10i5)\r\n return\r\n END subroutine alphaphorder_old\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine check_alphaindex\r\n!\\begin{verbatim}\r\n subroutine check_alphaindex\r\n! just for debugging, check that ellist(i)%alphaindex etc is correct\r\n implicit none\r\n!\\end{verbatim}\r\n integer i,j,k,l\r\n write(kou,*)\r\n write(6,77)(ellista(elements(i))%symbol,i=1,noofel)\r\n77 format(20(1x,A2))\r\n write(6,78)(splista(species(i))%symbol,i=1,noofsp)\r\n78 format(20(1x,a6))\r\n write(6,*)'element alphaindex'\r\n check1: do i=1,noofel\r\n j=ellista(elements(i))%alphaindex\r\n write(6,*)i,j,elements(i),ellista(i)%symbol\r\n enddo check1\r\n write(6,*)'species alphaindex'\r\n check2: do i=1,noofsp\r\n j=species(i)\r\n k=splista(j)%alphaindex\r\n l=splista(species(j))%alphaindex\r\n write(6,79)i,k,j,l,splista(j)%symbol\r\n enddo check2\r\n79 format(4i4,1x,A)\r\n check3: do i=1,noofsp\r\n write(6,*)i,splista(i)%alphaindex,splista(i)%symbol\r\n enddo check3\r\n END subroutine check_alphaindex\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_constitlist\r\n!\\begin{verbatim}\r\n subroutine create_constitlist(constitlist,nc,klist)\r\n! creates a constituent list ...\r\n implicit none\r\n integer, dimension(*) :: klist\r\n integer, dimension(:), allocatable :: constitlist\r\n integer nc\r\n!\\end{verbatim}\r\n integer ic\r\n ALLOCATE(constitlist(nc))\r\n DO ic=1,nc\r\n constitlist(ic)=klist(ic)\r\n enddo\r\n return\r\n END subroutine create_constitlist\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_parrecords\r\n!\\begin{verbatim}\r\n subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq)\r\n! fractions and results arrays for a phase for parallel calculations\r\n! location is returned in lokcs\r\n! nsl is sublattices, nc number of constituents, nprop max number if propert,\r\n! iva is an array which is set as constituent status word (to indicate VA)\r\n! ceq is always firsteq ???\r\n!\r\n! BEWARE not adopted for threads\r\n!\r\n! >>> changed all firsteq below to ceq????\r\n!\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n integer, dimension(*) :: iva\r\n integer lokph,lokcs, nsl, nc, nprop\r\n!\\end{verbatim}\r\n integer ic,nnc\r\n! find free record, free list csfree maintained in FIRSTEQ only!\r\n! write(*,*)'3G maxcalcprop: ',nprop\r\n lokcs=csfree\r\n if(csfree.le.0) then\r\n! This means no free phase_varres records.\r\n! csfree is set to -1 by the statement csfree=phase_varres(lokcs)%next below\r\n! when reserving the last free record. The same for the other free lists\r\n gx%bmperr=4094; goto 1000\r\n endif\r\n! the free list of phase_varres record is only maintained in firsteq\r\n! but all equilibria have identical allocation of phase_varres records\r\n! the free list is created when starting OC, each record points to the next\r\n! After composition sets has been entered and deleted it may be different\r\n! highcs should always be the index of the highest used record\r\n csfree=firsteq%phase_varres(lokcs)%nextfree\r\n! write(*,*)'3G looking for free varres record 1:',lokcs,csfree\r\n! wrong ... if(csfree.gt.highcs) highcs=csfree\r\n! The varres record used will be, csfree is updated\r\n! write(*,*)'3G looking for free varres record 2:',lokcs,csfree\r\n firsteq%phase_varres(lokcs)%nextfree=0\r\n firsteq%phase_varres(lokcs)%status2=0\r\n ic=newhighcs(.true.)\r\n if(lokcs.gt.highcs) highcs=lokcs\r\n! added integer status array constat. Set CONVA bit from iva array\r\n! write(*,*)'Allocate constat 2: ',nc,lokcs\r\n if(.not.allocated(ceq%phase_varres(lokcs)%constat)) then\r\n! remove CSDEL if set\r\n firsteq%phase_varres(lokcs)%status2=&\r\n ibclr(firsteq%phase_varres(lokcs)%status2,CSDEL)\r\n! already allocated error for the Al-Ni case, why?\r\n! Maybe if composition set has been deleted without releasing allocated arrays?\r\n allocate(ceq%phase_varres(lokcs)%constat(nc))\r\n endif\r\n! write(*,*)'3G compset: ',trim(phlista(lokph)%name),nc,lokcs,&\r\n! size(ceq%phase_varres(lokcs)%constat)\r\n! write(*,33)nc,(iva(i),i=1,nc)\r\n do ic=1,nc\r\n ceq%phase_varres(lokcs)%constat(ic)=iva(ic)\r\n enddo\r\n! allocate fraction and default fraction arrays\r\n allocate(ceq%phase_varres(lokcs)%yfr(nc))\r\n allocate(ceq%phase_varres(lokcs)%mmyfr(nc))\r\n do ic=1,nc\r\n ceq%phase_varres(lokcs)%yfr(ic)=one\r\n ceq%phase_varres(lokcs)%mmyfr(ic)=zero\r\n enddo\r\n! write(*,*)'Allocated mmyfr: ',lokcs,nc,nprop\r\n! abnorm initiated to unity to avoid trouble at first calculation\r\n ceq%phase_varres(lokcs)%abnorm=one\r\n allocate(ceq%phase_varres(lokcs)%sites(nsl))\r\n!\r\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\r\n! for ionic liquid the sites may depend on composition\r\n! I get error these already allocated. Why ??\r\n if(.not.allocated(ceq%phase_varres(lokcs)%dpqdy)) then\r\n allocate(ceq%phase_varres(lokcs)%dpqdy(nc))\r\n allocate(ceq%phase_varres(lokcs)%d2pqdvay(nc))\r\n endif\r\n endif\r\n!\r\n! result arrays for a phase for use in parallel processing\r\n ceq%phase_varres(lokcs)%nprop=nprop\r\n allocate(ceq%phase_varres(lokcs)%listprop(nprop))\r\n allocate(ceq%phase_varres(lokcs)%gval(6,nprop))\r\n! write(*,*)'Allocated gval: ',nprop,nc\r\n allocate(ceq%phase_varres(lokcs)%dgval(3,nc,nprop))\r\n nnc=nc*(nc+1)/2\r\n! write(*,*)'Allocated dgval: ',nprop,nc,nnc\r\n allocate(ceq%phase_varres(lokcs)%d2gval(nnc,nprop))\r\n! write(*,*)'Allocated d2gval: ',nprop,nc,nnc\r\n! zero everything\r\n ceq%phase_varres(lokcs)%listprop=0\r\n! ceq%phase_varres(lokcs)%amount=zero\r\n ceq%phase_varres(lokcs)%amfu=zero\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n ceq%phase_varres(lokcs)%dgm=zero\r\n ceq%phase_varres(lokcs)%gval=zero\r\n ceq%phase_varres(lokcs)%dgval=zero\r\n ceq%phase_varres(lokcs)%d2gval=zero\r\n! Mark there is no disordered phase_varres record\r\n ceq%phase_varres(lokcs)%disfra%varreslink=0\r\n! write(*,*)'parrecords: ',lokcs,nsl,nc\r\n1000 continue\r\n return\r\n end subroutine create_parrecords\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_interaction\r\n!\\begin{verbatim}\r\n subroutine create_interaction(intrec,mint,lint,intperm,intlinks)\r\n! creates a parameter interaction record \r\n! with permutations if intperm(1)>0\r\n implicit none\r\n type(gtp_interaction), pointer :: intrec\r\n integer, dimension(2,*) :: lint,intlinks\r\n integer, dimension(*) :: intperm\r\n integer mint\r\n!\\end{verbatim}\r\n integer permut,emperm,nz,nq,lqq,ii,ll\r\n!\r\n! write(*,5)'create interaction:',mint,lint(1,mint),lint(2,mint),&\r\n! (intperm(ii),ii=1,6)\r\n5 format(a,i5,2x,2i3,2x,6i3)\r\n allocate(intrec)\r\n! note that the order of values in intperm here is not the same in \r\n! fccpermuts or bccpermuts ?? Intlinks is the same\r\n permut=intperm(1)\r\n if(permut.le.0) then\r\n! This is a default for no permutations, store 1's\r\n permut=0\r\n allocate(intrec%noofip(2))\r\n intrec%noofip(1)=1\r\n intrec%noofip(2)=1\r\n allocate(intrec%sublattice(1))\r\n allocate(intrec%fraclink(1))\r\n elseif(mint.eq.1) then\r\n! Intperm contains information as created by fccpermut or bccpermut\r\n! intperm(1) and 2 are related to mint=1 (level 1 interaction),\r\n! intperm(3) to mint=2\r\n! The values are stored in noofip(1) and intperm(2..) in noofip(2..)\r\n! For mint=1 intperm(1..2) are stored in noofipermt(1..2)\r\n! intperm(1) is the number of interaction permutations for each\r\n! endmember permutation.\r\n! intperm(2) are the number total number of permutations on level 1\r\n! The number of endmember permutations is thus intperm(2)/intperm(1)\r\n! write(*,17)'intrec: ',mint,intperm(1),intperm(2)\r\n permut=intperm(2)\r\n nz=intperm(2)\r\n allocate(intrec%noofip(2))\r\n intrec%noofip(1)=intperm(1)\r\n intrec%noofip(2)=intperm(2)\r\n allocate(intrec%sublattice(nz))\r\n allocate(intrec%fraclink(nz))\r\n nq=0\r\n elseif(mint.eq.2) then\r\n! For mint=2 intperm(3) is stored in noofip(1) and intperm(4..) after that\r\n! if intperm(3)>1 then there are intperm(3) number of limits in\r\n! intperm(2..) for each lower order interaction.\r\n! Example endmember A:A:A:A; no permutations\r\n! 1st level intperm(1)=1, intperm(2)=4; permutations AX:A:A:A, A:AX:A:A etc\r\n! 2nd level intperm(1)=4, inteprm(2..4)=(3, 2, 1, 0)\r\n! 3 permutations for AX:A:A:A: AX:AX:A:A; AX:A:AX:A; AX:A:A:AX\r\n! 2 permutations for A:AX:A:A: A:AX:AX:A A:AX:A:AX;\r\n! 1 permutation for A:A:AX:A: A:A:AX:AX;\r\n! 0 permutations for A:A:A:AX: none\r\n! If noofpermut>1 the index selected of noofip is by the permutation of \r\n! the lower order interaction\r\n! the value in intpermut(4+intperm(3)) is total number of permutations\r\n lqq=intperm(4+intperm(3))\r\n! write(*,17)'intrec: ',mint,intperm(3),(intperm(3+ii),ii=1,intperm(3))\r\n17 format(a,2i4,2x,10i4)\r\n permut=intperm(3)\r\n emperm=intperm(2)/intperm(1)\r\n allocate(intrec%noofip(permut+2))\r\n nz=0\r\n intrec%noofip(1)=intperm(3)\r\n do ii=1,permut\r\n intrec%noofip(1+ii)=intperm(3+ii)\r\n nz=nz+intperm(3+ii)\r\n enddo\r\n! write(*,19)'ci: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2)\r\n19 format(a,10i4)\r\n! AX:AX:A:A; 1 endmember permutation, 4 1st level permutations; 6 2nd level\r\n! emperm=1; intperm(3)=4, intparm(4..6)=(3,2,1,0), nz=1*6=6\r\n! AX:AX:B:B; 6 endmember permutation, 6 1st level permutations; 6 2nd level\r\n! emperm=6; nz=1; nz=1*6=6\r\n! number of permutations is related to the previous level\r\n! nz=nz*emperm\r\n nz=lqq\r\n! write(*,*)'Level 2 permutations: ',nz\r\n allocate(intrec%sublattice(nz))\r\n allocate(intrec%fraclink(nz))\r\n! Save at the end the total number of permutations stored\r\n intrec%noofip(permut+2)=nz\r\n nq=intperm(2)\r\n! write(*,19)'c2: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2)\r\n! write(*,17)'level 2 permutations: ',nz,emperm,nq,lqq\r\n else\r\n write(*,*)'Create_interaction called with too many permutations'\r\n gx%bmperr=4329; goto 1000\r\n endif\r\n if(permut.eq.0) then\r\n! this is again a default when there are no permutations\r\n intrec%sublattice(1)=lint(1,mint)\r\n intrec%fraclink(1)=lint(2,mint)\r\n else\r\n! We can have cases like noofiperumt(1)=1; noofip(2)=4 or\r\n! noofip(1)=4; noofip(2..5)=(4, 3, 2, 1)\r\n! nq is 0 for first level, intperm(2) for second level\r\n do ll=1,nz\r\n intrec%sublattice(ll)=intlinks(1,nq+ll)\r\n intrec%fraclink(ll)=intlinks(2,nq+ll)\r\n enddo\r\n! write(*,99)'isp: ',mint,&\r\n! (intrec%sublattice(ll),intrec%fraclink(ll),ll=1,nz)\r\n99 format(a,i2,8(2x,2i3))\r\n endif\r\n nullify(intrec%propointer)\r\n nullify(intrec%nextlink)\r\n nullify(intrec%highlink)\r\n! nullify Kohler-Toop link\r\n! write(*,*)'3G nullifying tooprec pointer'\r\n nullify(intrec%tooprec)\r\n intrec%status=0\r\n noofint=noofint+1\r\n intrec%antalint=noofint\r\n1000 continue\r\n return\r\n end subroutine create_interaction\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_endmember\r\n!\\begin{verbatim}\r\n subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks)\r\n! create endmember record with nsl sublattices with endm as constituents\r\n! noperm is number of permutations\r\n! endm is the basic endmember (if there are permutations)\r\n! elinks are the links to constituents for all permutations\r\n implicit none\r\n integer endm(*)\r\n integer lokph,noperm,nsl\r\n type(gtp_endmember), pointer :: newem\r\n integer, dimension(nsl,noperm) :: elinks\r\n!\\end{verbatim}\r\n integer is,ndemr,noemr,nn\r\n allocate(newem)\r\n nullify(newem%nextem)\r\n allocate(newem%fraclinks(nsl,noperm))\r\n if(noperm.eq.1) then\r\n do is=1,nsl \r\n newem%fraclinks(is,1)=endm(is)\r\n enddo\r\n else\r\n! write(*,*)'3G permutations: ',noperm,nsl\r\n! write(*,7)((elinks(is,nn),is=1,4),nn=1,noperm)\r\n7 format('3G ce1: ',4(4i3,2x))\r\n newem%fraclinks=elinks\r\n endif\r\n! zero or set values\r\n newem%noofpermut=noperm\r\n newem%phaselink=lokph\r\n noofem=noofem+1\r\n newem%antalem=noofem\r\n nullify(newem%propointer)\r\n nullify(newem%intpointer)\r\n! indicate that oendmemarr and denmemarr must be renewed ???\r\n noemr=0\r\n ndemr=0\r\n1000 continue\r\n return\r\n end subroutine create_endmember\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_proprec\r\n!\\begin{verbatim}\r\n subroutine create_proprec(proprec,proptype,degree,lfun,refx)\r\n! reservs a property record from free list and insert data\r\n! it is called from enter_parameter in gtp3B.F90\r\n! if there is already a property record (magnetic, MQMQA etc) for the parameter\r\n! this record is automatically linked at the end\r\n implicit none\r\n TYPE(gtp_property), pointer :: proprec\r\n integer proptype,degree,lfun\r\n character refx*(*)\r\n!\\end{verbatim} %+\r\n type(gtp_asymprop) :: asymdata\r\n integer j,iref,typty,powers,ppow,qpow\r\n character notext*32\r\n logical mqmqa\r\n!\r\n mqmqa=.false.\r\n if(proptype.ge.1000) then\r\n! this an MQMQA parameter\r\n write(*,*)'3G use special create_mqmqa_proprec'\r\n stop\r\n mqmqa=.true.\r\n! an MQMQA model parameters have special asymmetric composition dependence\r\n write(*,*)'3G special MQMQA excess parameter',proptype,degree\r\n typty=proptype/1000\r\n! this proptype is probably not needed nor useful\r\n if(typty.eq.1) then\r\n powers=proptype-1000\r\n proptype=34 ! GG\r\n elseif(typty.eq.2) then\r\n powers=proptype-2000\r\n proptype=35 !GQ\r\n elseif(typty.eq.3) then\r\n powers=proptype-3000\r\n proptype=36 !GB\r\n endif\r\n allocate(proprec)\r\n! MQMQA has a single function but it can be asymmetric\r\n allocate(proprec%degreelink(0:0))\r\n nullify(proprec%nextpr)\r\n! proptype for MQMQA is 34, 35, 36, the modelparameter i just G\r\n proprec%proptype=proptype\r\n! the typty 34, 35 and 36 is kept but changed to G when listing?\r\n! this typty is used to provide information after the ; in listing\r\n! 34 is ;G,p,q,r), 35 is ;Q,p,q,r) and 26 is ;B,p,q,r)\r\n proprec%modelparamid=propid(1)%symbol\r\n! proprec%modelparamid=propid(proptype)%symbol\r\n! write(*,*)'3G MQMQA parameter ',typty,proprec%proptype,powers\r\n! the proprec%extra should contains 3 powers, as 100*p + 10*q + r\r\n! for the equation \\varkappa_ij**p * \\varkappa_ji**q in Max eq. 23/24\r\n! The r is for a ternary parameter in eqs. 25/26. There is just one degree 0\r\n! NOW THERE IS A MQMQA property record for this\r\n proprec%extra=powers\r\n proprec%degree=0\r\n proprec%degreelink(0)=lfun\r\n! write(*,2)proptype,powers,degree,refx\r\n2 format('3G in create_proprec ',i2,i7,i3,' refx: ',a)\r\n! create an addition asymprop record for extra information\r\n! some of the information in this will be added from the calling routine\r\n! powers is for example 321 where 3 is ppow, 2 is qpow and 1 is rpow\r\n! very clumsy but I am tired of this model\r\n allocate(proprec%asymdata)\r\n proprec%asymdata%ppow=powers/100\r\n proprec%asymdata%qpow=(powers-100*proprec%asymdata%ppow)/10\r\n! proprec%proprec%asymdata%ppow=ppow\r\n! proprec%proprec%asymdata%qpow=qpow\r\n proprec%asymdata%rpow=powers-100*proprec%asymdata%ppow-&\r\n 10*proprec%asymdata%qpow\r\n! write(*,*)'3G value of rpow: ',proprec%asymdata%rpow\r\n! write(*,7)powers,proprec%asymdata%ppow,proprec%asymdata%qpow,&\r\n! proprec%asymdata%rpow\r\n7 format('3G allocated asymdata: ',i7,5x,3i3)\r\n! indices in proprec%asymdata%quad_ij _ii, _jj and _33 will be set by \r\n! calling routine\r\n proprec%reference=adjustl(refx)\r\n! index of asymdata%quad, %alpha, %beta and %ternary should be set <<<<<<\r\n goto 900\r\n!------------ end of MQMQA specific\r\n elseif(degree.lt.0 .or. degree.gt.9) then\r\n write(*,10)degree\r\n10 format('*** Error, degree of a parameter ',i2,'must be between 0 and 9')\r\n gx%bmperr=4063\r\n goto 1000\r\n endif\r\n! this is for all parameters EXCEPT the MQMQA excess\r\n allocate(proprec)\r\n! enter data in reserved record\r\n allocate(proprec%degreelink(0:degree))\r\n nullify(proprec%nextpr)\r\n! if(proptype.ge.100) write(*,*)'property type: ',proptype\r\n proprec%proptype=proptype\r\n! also save %modelparamid for unformatted files ...\r\n! this causes problems with the MQMQA ...\r\n if(proptype.gt.100) then\r\n! this is a property with a constituent suffix like MQ&FE\r\n proprec%modelparamid=propid(proptype/100)%symbol\r\n! write(*,*)'3G proptype ',propid(proptype/100)%symbol,proptype\r\n else\r\n proprec%modelparamid=propid(proptype)%symbol\r\n! write(*,*)'3G proptype ',propid(proptype)%symbol,proptype\r\n endif\r\n proprec%degree=degree\r\n do j=0,degree\r\n proprec%degreelink(j)=0\r\n enddo\r\n proprec%degreelink(degree)=lfun\r\n proprec%reference=adjustl(refx)\r\n proprec%extra=0\r\n! create reference record if new, can be amended later\r\n!------global counter\r\n noofprop=noofprop+1\r\n proprec%antalprop=noofprop\r\n! write(*,11)refx,noofprop\r\n11 format('create proprec: ',a,i7)\r\n! save the reference index\r\n900 continue\r\n call capson(refx)\r\n! write(*,*)'3G reference: ',refx\r\n notext='*** Not set by database or user '\r\n call tdbrefs(refx,notext,0,iref)\r\n1000 continue\r\n return\r\n end subroutine create_proprec\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine create_mqmqa_proprec\r\n!\\begin{verbatim}\r\n subroutine create_mqmqa_proprec(proprec,proptype,degree,lfun,refx)\r\n! reservs a property record from free list and insert data MQMQA version\r\n! it is called from enter_parameter in gtp3B.F90\r\n! if there is already a property record (magnetic, MQMQA etc) for the parameter\r\n! this record is automatically linked at the end\r\n implicit none\r\n TYPE(gtp_property), pointer :: proprec\r\n integer proptype,degree,lfun\r\n character refx*(*)\r\n!\\end{verbatim} %+\r\n type(gtp_asymprop) :: asymdata\r\n integer j,iref,typty,powers,ppow,qpow\r\n character notext*32\r\n logical mqmqa\r\n!\r\n! write(*,*)'3G using special MQMQA create_proprec'\r\n mqmqa=.false.\r\n if(proptype.ge.1000) then\r\n! this an MQMQA parameter\r\n mqmqa=.true.\r\n! an MQMQA model parameters have special asymmetric composition dependence\r\n if(mqmqtdb) write(*,*)'3G special MQMQA excess parameter',proptype,degree\r\n typty=proptype/1000\r\n! this proptype is probably not needed nor useful\r\n if(typty.eq.1) then\r\n powers=proptype-1000\r\n proptype=34 ! GG\r\n elseif(typty.eq.2) then\r\n powers=proptype-2000\r\n proptype=35 !GQ\r\n elseif(typty.eq.3) then\r\n powers=proptype-3000\r\n proptype=36 !GB\r\n endif\r\n!--------------------------\r\n! modifying the create_proprec for MQMQA crased reading some normal database\r\n! and I do not really understand how it work any longer\r\n! so I created a new version for MQMQA databases\r\n allocate(proprec)\r\n! MQMQA has a single function but it can be asymmetric\r\n allocate(proprec%degreelink(0:0))\r\n nullify(proprec%nextpr)\r\n! proptype for MQMQA is 34, 35, 36, the modelparameter i just G\r\n proprec%proptype=proptype\r\n! the typty 34, 35 and 36 is kept but changed to G when listing?\r\n! this typty is used to provide information after the ; in listing\r\n! 34 is ;G,p,q,r), 35 is ;Q,p,q,r) and 26 is ;B,p,q,r)\r\n proprec%modelparamid=propid(1)%symbol\r\n! proprec%modelparamid=propid(proptype)%symbol\r\n! write(*,*)'3G MQMQA parameter ',typty,proprec%proptype,powers\r\n! the proprec%extra should contains 3 powers, as 100*p + 10*q + r\r\n! for the equation \\varkappa_ij**p * \\varkappa_ji**q in Max eq. 23/24\r\n! The r is for a ternary parameter in eqs. 25/26. There is just one degree 0\r\n! NOW THERE IS A MQMQA property record for this\r\n proprec%extra=powers\r\n proprec%degree=0\r\n proprec%degreelink(0)=lfun\r\n! write(*,2)proptype,powers,degree,refx\r\n2 format('3G in create_proprec ',i2,i7,i3,' refx: ',a)\r\n! create an addition asymprop record for extra information\r\n! some of the information in this will be added from the calling routine\r\n! powers is for example 321 where 3 is ppow, 2 is qpow and 1 is rpow\r\n! very clumsy but I am tired of this model\r\n allocate(proprec%asymdata)\r\n proprec%asymdata%ppow=powers/100\r\n proprec%asymdata%qpow=(powers-100*proprec%asymdata%ppow)/10\r\n! proprec%proprec%asymdata%ppow=ppow\r\n! proprec%proprec%asymdata%qpow=qpow\r\n proprec%asymdata%rpow=powers-100*proprec%asymdata%ppow-&\r\n 10*proprec%asymdata%qpow\r\n! write(*,*)'3G value of rpow: ',proprec%asymdata%rpow\r\n! write(*,7)powers,proprec%asymdata%ppow,proprec%asymdata%qpow,&\r\n! proprec%asymdata%rpow\r\n7 format('3G allocated asymdata: ',i7,5x,3i3)\r\n! indices in proprec%asymdata%quad_ij _ii, _jj and _33 will be set by \r\n! calling routine\r\n proprec%reference=adjustl(refx)\r\n! index of asymdata%quad, %alpha, %beta and %ternary should be set <<<<<<\r\n noofprop=noofprop+1\r\n proprec%antalprop=noofprop\r\n! write(*,11)refx,noofprop\r\n11 format('3G create proprec: ',a,i7)\r\n goto 900\r\n!------------ end of MQMQA specific\r\n elseif(degree.lt.0 .or. degree.gt.9) then\r\n write(*,10)degree\r\n10 format('*** Error, degree of a parameter ',i2,'must be between 0 and 9')\r\n gx%bmperr=4063\r\n goto 1000\r\n endif\r\n! this is for all parameters EXCEPT the MQMQA excess\r\n allocate(proprec)\r\n! enter data in reserved record\r\n allocate(proprec%degreelink(0:degree))\r\n nullify(proprec%nextpr)\r\n! if(proptype.ge.100) write(*,*)'property type: ',proptype\r\n proprec%proptype=proptype\r\n! also save %modelparamid for unformatted files ...\r\n! this causes problems with the MQMQA ...\r\n if(proptype.gt.100) then\r\n! this is a property with a constituent suffix like MQ&FE\r\n proprec%modelparamid=propid(proptype/100)%symbol\r\n! write(*,*)'3G proptype ',propid(proptype/100)%symbol,proptype\r\n else\r\n proprec%modelparamid=propid(proptype)%symbol\r\n! write(*,*)'3G proptype ',propid(proptype)%symbol,proptype\r\n endif\r\n proprec%degree=degree\r\n do j=0,degree\r\n proprec%degreelink(j)=0\r\n enddo\r\n proprec%degreelink(degree)=lfun\r\n proprec%reference=adjustl(refx)\r\n proprec%extra=0\r\n! create reference record if new, can be amended later\r\n!------global counter\r\n noofprop=noofprop+1\r\n proprec%antalprop=noofprop\r\n! save the reference index\r\n900 continue\r\n call capson(refx)\r\n! write(*,*)'3G reference: ',refx\r\n notext='*** Not set by database or user '\r\n call tdbrefs(refx,notext,0,iref)\r\n1000 continue\r\n return\r\n end subroutine create_mqmqa_proprec\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine extend_proprec\r\n!\\begin{verbatim}\r\n subroutine extend_proprec(current,degree,lfun)\r\n! extends a property record and insert new data\r\n implicit none\r\n integer degree,lfun\r\n type(gtp_property), pointer :: current\r\n!\\end{verbatim}\r\n integer oldeg,j\r\n integer :: savedegs(0:9)\r\n! save degreelinks ... maybe not necessary ....\r\n oldeg=current%degree\r\n! write(*,*)'extend_proprec 1: ',current,degree,lfun,oldeg\r\n do j=0,9\r\n savedegs(j)=0\r\n enddo\r\n do j=0,oldeg\r\n savedegs(j)=current%degreelink(j)\r\n enddo\r\n! important to get it correct here\r\n deallocate(current%degreelink)\r\n allocate(current%degreelink(0:degree))\r\n current%degree=degree\r\n do j=0,current%degree\r\n current%degreelink(j)=0\r\n enddo\r\n do j=0,oldeg\r\n current%degreelink(j)=savedegs(j)\r\n enddo\r\n current%degreelink(degree)=lfun\r\n1000 continue\r\n return\r\n end subroutine extend_proprec\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine add_fraction_set\r\n!\\begin{verbatim}\r\n subroutine add_fraction_set(iph,id,ndl,totdis)\r\n! add a new set of fractions to a phase, usually to describe a disordered state\r\n! like the \"partitioning\" in old TC\r\n!\r\n! BEWARE this is only done for firsteq, illegal when having more equilibria\r\n!\r\n! id is a letter used as suffix to identify the parameters of this set\r\n! ndl is the last original sublattice included in the (first) disordered set\r\n! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are\r\n! disordered\r\n! totdis=0 if phase never disorder totally (like sigma)\r\n!\r\n! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4\r\n! icon=1 2 3 1 2 3 4 5 with ndl=2\r\n! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then\r\n! icon=2 4 1 3 1 2 3 4 with ndl=3\r\n! This subroutine will create the necessary data to calculate the\r\n! disordered fraction set from the site fractions.\r\n!\r\n! IMPORTANT (done): for each composition set this must be repeated\r\n! if new composition sets are created it must be repeated for these\r\n!\r\n! IMPORTANT (not done): order the constituents alphabetically in each disorderd\r\n! sublattice otherwise it will not be possible to enter parameters correctly\r\n!\r\n implicit none\r\n integer iph,ndl,totdis\r\n character id*1\r\n!\\end{verbatim}\r\n! ceq probably not needed as firsteq is declared as pointer\r\n! TYPE(gtp_equilibrium_data), target :: ceq\r\n TYPE(gtp_fraction_set), target :: fsdata\r\n! jsp(i) contains species locations of disordered constituent i\r\n! jy2x(i) is the disordered fraction to which site fraction i should be added\r\n! y2x(i) is the site ration factor for multiplying sitefraction i when added\r\n! ispord and ispold are needed to sort disordered constituents\r\n integer jsp(maxconst,2),jy2x(maxconst),iva(maxconst)\r\n integer ispord(maxconst),ispold(maxconst),nrj3(2),nrj4(2)\r\n integer lokph,lokcs,nsl,ii,nrj1,nrj2,nlat,lokx,l2\r\n integer ll,kk,jall,nnn,mmm,ioff,koff,jl,j1,j2,ix,is,jj,k,ijcs,nydis,nyttcs\r\n double precision sum,div\r\n!\r\n if(.not.allowenter(2)) then\r\n gx%bmperr=4125\r\n goto 1000\r\n endif\r\n! this subroutine can only be called when there is only one equilibrium\r\n lokph=phases(iph)\r\n! phase must not have any suspended constituents nor any composition sets\r\n if(phlista(lokph)%noofcs.gt.1) then\r\n gx%bmperr=4029; goto 1000\r\n else\r\n lokcs=phlista(lokph)%linktocs(1)\r\n if(btest(firsteq%phase_varres(lokcs)%status2,CSCONSUS)) then\r\n gx%bmperr=4030; goto 1000\r\n endif\r\n endif\r\n nsl=phlista(lokph)%noofsubl\r\n if(ndl.le.1 .or. ndl.gt.nsl) then\r\n! ndl must be larger than 2 and lesser or equal to nsl\r\n gx%bmperr=4076; goto 1000\r\n endif\r\n! location of first composition set, there may be more\r\n if(btest(phlista(lokph)%status1,phmfs)) then\r\n! disordered fractions already set\r\n gx%bmperr=4077; goto 1000\r\n endif\r\n! write(*,*)'3G in add_fr: ',iph,id,ndl,totdis\r\n! we must organise a constituent list for the disordered fractions by\r\n! scanning the constituents in the current phlista(lokph)%constitlist\r\n! we must also contruct the way site fractions should be added\r\n ii=0\r\n nrj1=1\r\n nrj2=0\r\n nlat=0\r\n lokx=0\r\n l2=1\r\n iva=0\r\n subloop: do ll=1,nsl\r\n constloop: do kk=1,phlista(lokph)%nooffr(ll)\r\n ii=ii+1\r\n if(nrj2.lt.nrj1) then\r\n nrj2=nrj2+1\r\n lokx=lokx+1\r\n jy2x(ii)=lokx\r\n jsp(nrj2,l2)=phlista(lokph)%constitlist(ii)\r\n! write(*,46)'new 1: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii)\r\n else\r\n do jall=nrj1,nrj2\r\n if(phlista(lokph)%constitlist(ii).eq.jsp(jall,l2)) then\r\n! this constituent already found in another sublattice to be merged\r\n! write(*,*)'same: ',jall,nlat,jall+nlat,ii,jy2x(jall+nlat)\r\n jy2x(ii)=jy2x(jall+nlat); goto 50\r\n endif\r\n enddo\r\n! new constituent\r\n nrj2=nrj2+1\r\n lokx=lokx+1\r\n jy2x(ii)=lokx\r\n jsp(nrj2,l2)=phlista(lokph)%constitlist(ii)\r\n! write(*,46)'new 2: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii)\r\n46 format(a,10i3)\r\n! if vacancy set that bit in iva\r\n if(btest(firsteq%phase_varres(lokcs)%constat(ii),conva)) then\r\n iva(nrj2)=ibset(iva(nrj2),conva)\r\n endif\r\n! write(*,*)'addfs 7B: ',ll,ii,nrj2\r\n50 continue\r\n endif\r\n enddo constloop\r\n if(ll.eq.ndl) then\r\n! next sublattices (if any) will be summed to second disordered sublattice\r\n nrj3(1)=nrj2\r\n nrj3(2)=0\r\n! bug??\r\n nlat=ii\r\n nrj1=1\r\n nrj2=0\r\n! nrj4 is the number of constituents in ordered phase thst is summed\r\n! to first disordered sublattice. Needed below to rearrange jy2x\r\n nrj4(1)=ii\r\n nrj4(2)=0\r\n if(ndl.lt.nsl) l2=2\r\n! write(*,*)'addfs 7C: ',ll,ndl,nrj1,nrj2,nrj3\r\n elseif(ll.eq.nsl) then\r\n! this may never be executed if ndl=nsl but we set nrj3(2)=0 above\r\n nrj3(2)=nrj2\r\n nrj4(2)=ii-nrj4(1)\r\n endif\r\n enddo subloop\r\n! write(*,53)'add_fraction_set 2: ',(jy2x(i),i=1,ii)\r\n53 format(a,20i3)\r\n! added fsites to handle the case when reading sigma etc from a TDB file\r\n! as the TDB file format assumes 1 site. Default is 1.0, changed externally\r\n fsdata%fsites=one\r\n! write(*,*)'3G Set fsites: ',fsdata%fsites,ndl,totdis,nnn\r\n!\r\n! write(*,53)'add_fraction_set 3: ',nrj1,nrj2,nrj3,nrj4\r\n fsdata%latd=ndl\r\n fsdata%tnoofyfr=phlista(lokph)%tnooffr\r\n fsdata%varreslink=lokcs\r\n! totdis=1 means disordered fcc, bcc, ncp. totdis=0 means sigma\r\n fsdata%totdis=totdis\r\n fsdata%id=id\r\n! one or 2 disordered sublattices\r\n nnn=1\r\n if(ndl.lt.nsl) nnn=2\r\n! try to allow more than one interstitial sublattice ... NO\r\n if(nsl-ndl.gt.1) then\r\n write(*,*)'3G *** Error max one sublattices outside the disordered set'\r\n gx%bmperr=4399\r\n goto 1000\r\n endif\r\n! write(*,'(a,10i5)')'3G disordered sublattices:',nsl,ndl,nnn,fsdata%latd\r\n allocate(fsdata%dsites(nnn))\r\n fsdata%ndd=nnn\r\n allocate(fsdata%nooffr(nnn))\r\n fsdata%nooffr(1)=nrj3(1)\r\n if(nnn.eq.2) fsdata%nooffr(2)=nrj3(2)\r\n! nrj3(1) are the number of constituents on first sublattice, nrj3(2) on 2nd\r\n mmm=nrj3(1)+nrj3(2)\r\n fsdata%tnoofxfr=mmm\r\n allocate(fsdata%splink(mmm))\r\n allocate(fsdata%y2x(phlista(lokph)%tnooffr))\r\n allocate(fsdata%dxidyj(phlista(lokph)%tnooffr))\r\n! write(*,*)'add_fs dxidyj: ',phlista(lokph)%tnooffr\r\n! the constituents in jsp(i..n,subl) must be ordered alphabetically!!!\r\n! get the species number in alphadetical order\r\n ioff=0\r\n koff=0\r\n do l2=1,nnn\r\n do jl=1,nrj3(l2)\r\n! write(*,*)'l2 loop: ',jsp(i,l2)\r\n ispord(jl)=splista(jsp(jl,l2))%alphaindex\r\n enddo\r\n! write(*,47)1,(ispord(i),i=1,nrj3(l2))\r\n47 format('add_fs ',i1,': ',20i3)\r\n! species, noofsp, origonal order\r\n call sortin(ispord,nrj3(l2),ispold)\r\n if(buperr.ne.0) then\r\n gx%bmperr=buperr; goto 1000\r\n endif\r\n! when rearranging jsp(1..n,l2) we must also rearrange y2x\r\n! for 2nd sublattice add nrj3(1) to ispold\r\n if(l2.eq.2) then\r\n ioff=nrj4(1)\r\n koff=nrj3(1)\r\n endif\r\n! write(*,47)2,(jy2x(ioff+i),i=1,nrj4(l2))\r\n! this must be possible to do smarter .....\r\n do j2=1,nrj4(l2)\r\n do j1=1,nrj3(l2)\r\n if(jy2x(ioff+j2).eq.ispold(j1)+koff) then\r\n jy2x(ioff+j2)=j1+koff; goto 77\r\n endif\r\n enddo\r\n77 continue\r\n enddo\r\n do j1=1,nrj3(l2)\r\n ispord(j1)=jsp(ispold(j1),l2)\r\n enddo\r\n do j1=1,nrj3(l2)\r\n jsp(j1,l2)=ispord(j1)\r\n enddo\r\n! write(*,47)5,(jsp(i,l2),i=1,nrj3(l2))\r\n enddo\r\n fsdata%splink=0\r\n!\r\n do jl=1,phlista(lokph)%tnooffr\r\n fsdata%y2x(jl)=jy2x(jl)\r\n enddo\r\n ix=0\r\n do l2=1,nnn\r\n do jl=1,nrj3(l2)\r\n ix=ix+1\r\n fsdata%splink(ix)=jsp(jl,l2)\r\n enddo\r\n enddo\r\n! write(*,*)'addfs splink: ',fsdata%splink\r\n!\r\n is=0\r\n sum=zero\r\n do ll=1,ndl\r\n! sum=sum+phlista(lokph)%sites(ll)\r\n sum=sum+firsteq%phase_varres(lokcs)%sites(ll)\r\n enddo\r\n fsdata%dsites(1)=sum\r\n if(ndl.lt.nsl) then\r\n sum=zero\r\n do ll=ndl+1,nsl\r\n! sum=sum+phlista(lokph)%sites(ll)\r\n sum=sum+firsteq%phase_varres(lokcs)%sites(ll)\r\n enddo\r\n fsdata%dsites(2)=sum\r\n endif\r\n!\r\n jj=0\r\n sum=fsdata%dsites(1)\r\n! write(*,*)'3G sum: ',ndl,sum,fsdata%dsites\r\n do ll=1,nsl\r\n if(ll.gt.ndl) sum=fsdata%dsites(2)\r\n! div=phlista(lokph)%sites(ll)/sum\r\n div=firsteq%phase_varres(lokcs)%sites(ll)/sum\r\n! write(*,78)'add_fs 5A ',div,phlista(lokph)%sites(ll),sum\r\n!78 format(a,6F10.7)\r\n do k=1,phlista(lokph)%nooffr(ll)\r\n jj=jj+1\r\n fsdata%dxidyj(jj)=div\r\n enddo\r\n enddo\r\n! write(*,99)'add_fs 5B ',fsdata%dxidyj\r\n99 format(a,6(F10.7))\r\n firsteq%phase_varres(lokcs)%disfra=fsdata\r\n firsteq%phase_varres(lokcs)%status2=&\r\n ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK)\r\n! we have to reserve a phase_varres record for calculations\r\n! ... det galler att halla tungan ratt i mun ...\r\n! nprop=10\r\n! call create_parrecords(nyttcs,nnn,mmm,nprop,iva,firsteq)\r\n call create_parrecords(lokph,nyttcs,nnn,mmm,maxcalcprop,iva,firsteq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,*)'3G created disordered phase_varres: ',csfree,highcs,nyttcs\r\n fsdata%varreslink=nyttcs\r\n! note ceq is firsteq but declared target\r\n! write(*,*)'3G disordered fraction set',nyttcs\r\n!*? fsdata%phdapointer=>ceq%phase_varres(nyttcs)\r\n firsteq%phase_varres(nyttcs)%phlink=lokph\r\n firsteq%phase_varres(nyttcs)%prefix=' '\r\n firsteq%phase_varres(nyttcs)%suffix=' '\r\n do ll=1,nnn\r\n firsteq%phase_varres(nyttcs)%sites(ll)=fsdata%dsites(ll)\r\n enddo\r\n firsteq%phase_varres(nyttcs)%status2=0\r\n firsteq%phase_varres(nyttcs)%status2=&\r\n ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS)\r\n! finally copy fsdata to the link in lokcs\r\n call copy_fracset_record(lokcs,fsdata,firsteq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! if there are several composition sets create fracset records for each\r\n200 continue\r\n! if(firsteq%phase_varres(lokcs)%next.gt.0) then\r\n! lokcs=firsteq%phase_varres(lokcs)%next\r\n do ijcs=2,phlista(lokph)%noofcs\r\n lokcs=phlista(lokph)%linktocs(ijcs)\r\n! one must also create parrecords for these !!!\r\n! call create_parrecords(nydis,nnn,mmm,nprop,iva,firsteq)\r\n call create_parrecords(lokph,nydis,nnn,mmm,maxcalcprop,iva,firsteq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n fsdata%varreslink=nydis\r\n! set pointer also\r\n!*? fsdata%phdapointer=firsteq%phase_varres(nydis)\r\n firsteq%phase_varres(nydis)%phlink=lokph\r\n firsteq%phase_varres(nydis)%prefix=' '\r\n firsteq%phase_varres(nydis)%suffix=' '\r\n do ll=1,nnn\r\n firsteq%phase_varres(nydis)%sites(ll)=fsdata%dsites(ll)\r\n enddo\r\n firsteq%phase_varres(nydis)%status2=0\r\n firsteq%phase_varres(nydis)%status2=&\r\n ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS)\r\n! This does not create a new record\r\n! firsteq%phase_varres(lokcs)%disfra=fsdata\r\n! but this seems to work\r\n call copy_fracset_record(lokcs,fsdata,firsteq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n firsteq%phase_varres(lokcs)%status2=&\r\n ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK)\r\n goto 200\r\n enddo\r\n! set status bit for multiple/disordered fraction sets and no of fraction sets\r\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHMFS)\r\n phlista(lokph)%nooffs=2\r\n1000 continue\r\n! write(*,*)'3G exit add_fraction_set: ',fsdata%fsites,nnn\r\n! NOTE fsdata&fsites updated in calling routine. A bit strange but ...\r\n return\r\n! nydis\r\n end subroutine add_fraction_set ! no ceq\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine copyfracs(fromeq,ceq)\r\n!\\begin{verbatim}\r\n subroutine copyfracs(fromeq,ceq)\r\n! Copy phase amounts and constitution from equilibrim fromceq to ceq\r\n! Useful to set start constitutions for miscibility gaps during assessments\r\n!\r\n implicit none\r\n integer fromeq\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer toph,fromph\r\n type(gtp_equilibrium_data), pointer :: fromceq\r\n type(gtp_phase_varres), pointer :: fromvar,tovar\r\n fromceq=>eqlista(fromeq)\r\n if(.not.allocated(fromceq%phase_varres)) then\r\n! if phase_varres not allocated this equilibrium has no data\r\n write(*,*)'No such equilibrium'\r\n goto 1000\r\n endif\r\n! each equilbrium have the same phases and same number of compstes !!!\r\n! thus the phase_varres correspond!\r\n! copy only to those nonsuspended in ceq which exist in fromceq\r\n! write(*,*)'gtp3A allocated: ',size(ceq%phase_varres)\r\n! phase_varres(1) is for the unused REFERENCE_STATE\r\n allnonsus: do toph=2,size(ceq%phase_varres)\r\n! there are more phase_varres allocated than used, but yfr no allocated\r\n tovar=>ceq%phase_varres(toph)\r\n if(.not.allocated(tovar%yfr)) exit allnonsus\r\n if(tovar%phstate.le.PHSUS) cycle allnonsus\r\n! write(*,*)'3A copy phasetuple ',tovar%phtupx\r\n! copy phase amounts and fractions from the same phase_varres record \r\n fromvar=>fromceq%phase_varres(toph)\r\n tovar%abnorm=fromvar%abnorm\r\n tovar%yfr=fromvar%yfr\r\n! these are calculated values but copy anyway\r\n tovar%sites=fromvar%sites\r\n tovar%amfu=fromvar%amfu\r\n tovar%dgm=fromvar%dgm\r\n enddo allnonsus\r\n1000 continue\r\n return\r\n end subroutine copyfracs\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine copy_fracset_record\r\n!\\begin{verbatim}\r\n subroutine copy_fracset_record(lokcs,disrec,ceq)\r\n! attempt to create a new disordered record ??? this can probably be done\r\n! with just one statement .. but as it works I am not changing right now\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n TYPE(gtp_fraction_set) :: disrec\r\n integer lokcs\r\n!\\end{verbatim}\r\n TYPE(gtp_fraction_set) :: discopy\r\n! the hard way ??\r\n discopy%fsites=disrec%fsites\r\n discopy%latd=disrec%latd\r\n discopy%ndd=disrec%ndd\r\n discopy%tnoofxfr=disrec%tnoofxfr\r\n discopy%tnoofyfr=disrec%tnoofyfr\r\n discopy%varreslink=disrec%varreslink\r\n!*? discopy%phdapointer=>disrec%phdapointer\r\n discopy%totdis=disrec%totdis\r\n discopy%id=disrec%id\r\n allocate(discopy%dsites(disrec%ndd))\r\n allocate(discopy%nooffr(disrec%ndd))\r\n allocate(discopy%splink(disrec%tnoofxfr))\r\n allocate(discopy%y2x(disrec%tnoofyfr))\r\n allocate(discopy%dxidyj(disrec%tnoofyfr))\r\n!\r\n discopy%dsites=disrec%dsites\r\n discopy%nooffr=disrec%nooffr\r\n discopy%splink=disrec%splink\r\n discopy%y2x=disrec%y2x\r\n discopy%dxidyj=disrec%dxidyj\r\n!\r\n! write(*,*)'copyfs 1: ',lokcs,discopy%varreslink,disrec%varreslink\r\n ceq%phase_varres(lokcs)%disfra=discopy\r\n! write(*,*)'copyfs 2: ',phase_varres(lokcs)%disfra%varreslink\r\n1000 continue\r\n return\r\n end subroutine copy_fracset_record\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine suspend_species_implicitly\r\n!\\begin{verbatim}\r\n subroutine suspend_species_implicitly(ceq)\r\n! loop through all entered species and suspend those with an element suspended\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer loksp,iel,lokel\r\n sploop: do loksp=1,noofsp\r\n if(.not.btest(splista(loksp)%status,spsus)) then\r\n elloop: do iel=1,splista(loksp)%noofel\r\n lokel=splista(loksp)%ellinks(iel)\r\n if(btest(ellista(lokel)%status,elsus)) then\r\n! an element is suspended, suspend this species implicitly\r\n splista(loksp)%status=ibset(splista(loksp)%status,spsus)\r\n splista(loksp)%status=ibset(splista(loksp)%status,spimsus)\r\n goto 200\r\n endif\r\n enddo elloop\r\n endif\r\n200 continue\r\n enddo sploop\r\n1000 continue\r\n return\r\n end subroutine suspend_species_implicitly\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine suspend_phases_implicitly\r\n!\\begin{verbatim}\r\n subroutine suspend_phases_implicitly(ceq)\r\n! loop through all entered phases and suspend constituents and\r\n! SUSPEND phases with all constituents in a sublattice suspended\r\n! dimension lokcs(9)\r\n implicit none\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim} %+\r\n integer lokph,lokcs,ncc,kk,kkl,nek,icon,ll,loksp,jl\r\n!\r\n! BEWARE not adopted fro parallel processing\r\n!\r\n phloop: do lokph=1,noofph\r\n if(.not.btest(phlista(lokph)%status1,phhid)) then\r\n! locate all composition sets and store indices in lokcs\r\n ncc=phlista(lokph)%noofcs\r\n kk=0\r\n sublloop: do ll=1,phlista(lokph)%noofsubl\r\n kkl=kk\r\n nek=0\r\n constloop: do icon=1,phlista(lokph)%nooffr(ll)\r\n kk=kk+1\r\n loksp=phlista(lokph)%constitlist(kk)\r\n if(btest(splista(loksp)%status,spsus)) then\r\n! a constituent is suspended, mark this also in constat for all comp.sets\r\n compsets: do jl=1,ncc\r\n lokcs=phlista(lokph)%linktocs(jl)\r\n ceq%phase_varres(lokcs)%constat(kk)=&\r\n ibset(ceq%phase_varres(lokcs)%constat(kk),consus)\r\n ceq%phase_varres(lokcs)%constat(kk)=&\r\n ibset(ceq%phase_varres(lokcs)%constat(kk),conimsus)\r\n! mark that some constituents are suspended in this composition set\r\n ceq%phase_varres(lokcs)%status2=&\r\n ibset(ceq%phase_varres(lokcs)%status2,CSCONSUS)\r\n enddo compsets\r\n goto 200\r\n else\r\n nek=nek+1\r\n endif\r\n enddo constloop\r\n if(nek.eq.0) then\r\n! this sublattice has all constituents suspended, hide/suspend the phase\r\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid)\r\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,phimhid)\r\n! also set amount to zero ??\r\n compsets2: do jl=1,ncc\r\n lokcs=phlista(lokph)%linktocs(jl)\r\n! ceq%phase_varres(lokcs)%amount=zero\r\n ceq%phase_varres(lokcs)%amfu=zero\r\n ceq%phase_varres(lokcs)%netcharge=zero\r\n enddo compsets2\r\n endif\r\n goto 300\r\n200 continue\r\n kk=kkl+phlista(lokph)%nooffr(ll)\r\n kkl=kk-1\r\n enddo sublloop\r\n300 continue\r\n endif\r\n enddo phloop\r\n1000 continue\r\n return\r\n end subroutine suspend_phases_implicitly\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine restore_species_implicitly_suspended\r\n!\\begin{verbatim}\r\n subroutine restore_species_implicitly_suspended\r\n! loop through all implicitly suspended species and restore those with\r\n! all elements enteded\r\n implicit none\r\n!\\end{verbatim} %+\r\n integer loksp,lokel\r\n sploop: do loksp=1,noofsp\r\n if(btest(splista(loksp)%status,spimsus)) then\r\n elloop: do lokel=1,splista(loksp)%noofel\r\n! an element is suspended, keep species suspended\r\n if(btest(ellista(lokel)%status,elsus)) goto 200\r\n enddo elloop\r\n! all elements entered, restore species as entered\r\n splista(loksp)%status=ibclr(splista(loksp)%status,spsus)\r\n splista(loksp)%status=ibclr(splista(loksp)%status,spimsus)\r\n endif\r\n200 continue\r\n enddo sploop\r\n1000 continue\r\n return\r\n end subroutine restore_species_implicitly_suspended\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine restore_phases_implicitly_suspended\r\n!\\begin{verbatim}\r\n subroutine restore_phases_implicitly_suspended\r\n! loop through all implicitly suspended phases and restore those with\r\n! at least one constituent entered in each sublattice\r\n implicit none\r\n!\\end{verbatim}\r\n integer lokph,ll,kk,kkl,icon,loksp\r\n phloop: do lokph=1,noofph\r\n if(btest(phlista(lokph)%status1,phimhid)) then\r\n kk=0\r\n sublloop: do ll=1,phlista(lokph)%noofsubl\r\n kkl=kk\r\n constloop: do icon=1,phlista(lokph)%nooffr(ll)\r\n kk=kk+1\r\n loksp=phlista(lokph)%constitlist(kk)\r\n if(.not.btest(splista(loksp)%status,spsus)) goto 200\r\n enddo constloop\r\n! all constituents in this sublattice are suspended, keep the phase hidden\r\n goto 300\r\n200 continue\r\n kk=kkl+phlista(lokph)%nooffr(ll)\r\n kkl=kk-1\r\n enddo sublloop\r\n! all sublattices have at least one constituent entered, restore it\r\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid)\r\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phimhid)\r\n300 continue\r\n endif\r\n enddo phloop\r\n1000 continue\r\n return\r\n end subroutine restore_phases_implicitly_suspended\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\r\n\r\n!\\addtotable subroutine add_to_reference_phase\r\n!\\begin{verbatim}\r\n subroutine add_to_reference_phase(loksp)\r\n! add this element to the reference phase\r\n! loksp: species index of new element\r\n implicit none\r\n integer loksp\r\n!\\end{verbatim}\r\n! one must extend all arrays in phlista, phase_varres and phase_varres\r\n integer lokph,noc,i,nprop,mc2,lokcs\r\n integer, dimension(maxel) :: isave\r\n lokph=0\r\n lokcs=phlista(lokph)%linktocs(1)\r\n! constitlist\r\n noc=phlista(lokph)%tnooffr\r\n do i=1,noc\r\n isave(i)=phlista(lokph)%constitlist(i)\r\n enddo\r\n deallocate(phlista(lokph)%constitlist)\r\n noc=noc+1\r\n allocate(phlista(lokph)%constitlist(noc))\r\n isave(noc)=loksp\r\n do i=1,noc\r\n phlista(lokph)%constitlist(i)=isave(i)\r\n enddo\r\n phlista(lokph)%tnooffr=noc\r\n phlista(lokph)%nooffr(1)=noc\r\n! phase_varres, no data need saving\r\n! write(*,*)'Deallocate constat 5: ',size(firsteq%phase_varres(lokcs)%constat)\r\n deallocate(firsteq%phase_varres(lokcs)%constat)\r\n deallocate(firsteq%phase_varres(lokcs)%yfr)\r\n deallocate(firsteq%phase_varres(lokcs)%mmyfr)\r\n! write(*,*)'Allocate constat 5: ',noc\r\n allocate(firsteq%phase_varres(lokcs)%constat(noc))\r\n firsteq%phase_varres(lokcs)%constat(noc)=0\r\n allocate(firsteq%phase_varres(lokcs)%yfr(noc))\r\n allocate(firsteq%phase_varres(lokcs)%mmyfr(noc))\r\n firsteq%phase_varres(lokcs)%yfr=one\r\n firsteq%phase_varres(lokcs)%mmyfr=zero\r\n nprop=firsteq%phase_varres(lokcs)%nprop\r\n deallocate(firsteq%phase_varres(lokcs)%dgval)\r\n deallocate(firsteq%phase_varres(lokcs)%d2gval)\r\n allocate(firsteq%phase_varres(lokcs)%dgval(3,noc,nprop))\r\n mc2=noc*(noc+1)/2\r\n allocate(firsteq%phase_varres(lokcs)%d2gval(mc2,nprop))\r\n! ready!!\r\n1000 continue\r\n return\r\n end subroutine add_to_reference_phase\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n" }, { "path": "src/models/gtp3H.F90", "content": "! gtp3H included in gtp3.F90\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\n!> 14. Additions and model properties\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\n! Additions have a unique number, given sequentially as implemented \n! These are all defined in gtp3.F90\n! integer, public, parameter :: INDENMAGNETIC=1\n! integer, public, parameter :: XIONGMAGNETIC=2\n! integer, public, parameter :: DEBYECP=3\n! integer, public, parameter :: EINSTEINCP=4\n! integer, public, parameter :: TWOSTATEMODEL1=5\n! integer, public, parameter :: ELASTICMODEL1=6\n! integer, public, parameter :: VOLMOD1=7\n! integer, public, parameter :: UNUSED_CRYSTBREAKDOWNMOD=8\n! integer, public, parameter :: SECONDEINSTEIN=9\n! integer, public, parameter :: SCHOTTKYANOMALY=10\n! integer, public, parameter :: DIFFCOEFS=11\n!------------------------------------\n! For each addition XX there is a subroutine create_XX\n! called from the add_addrecord\n! and a subroutine calc_XX \n! called from the addition_selector, called from calcg_internal\n! There is a common list routine\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\n\n!\\addtotable subroutine addition_selector\n!\\begin{verbatim}\n subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq)\n! called when finding an addition record while calculating G for a phase\n! addrec is addition record\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! phres is ?\n! lokph is phase location\n! mc is number of constitution fractions\n! ceq is current equilibrium record\n implicit none\n type(gtp_phase_add), pointer :: addrec\n integer moded,lokph,mc\n TYPE(gtp_phase_varres), pointer :: phres\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! write(*,*)'3H select addition: ',addrec%type\n addition: select case(addrec%type)\n case default\n write(kou,*)'3H No such addition type ',addrec%type,lokph\n gx%bmperr=4330\n! 1 Inden-Hillert magnetic\n case(indenmagnetic) ! Inden magnetic \n addrec%propval=zero\n call calc_magnetic_inden(moded,phres,addrec,lokph,mc,ceq)\n! 2 Inden-Hillert-Qing-Xiong magnetism\n case(xiongmagnetic) ! Inden-Qing-Xiong\n addrec%propval=zero\n call calc_xiongmagnetic(moded,phres,addrec,lokph,mc,ceq)\n! write(kou,*)'3H Inden-Qing-Xiong magn model not tested yet'\n! gx%bmperr=4332\n! 3 Debye Cp\n case(debyecp) ! Debye Cp\n addrec%propval=zero\n call calc_debyecp(moded,phres,addrec,lokph,mc,ceq)\n write(kou,*)'3H Debye Cp model not implemented yet'\n gx%bmperr=4331\n! 4 Einsten Cp\n case(einsteincp) ! Einstein Cp\n addrec%propval=zero\n call calc_einsteincp(moded,phres,addrec,lokph,mc,ceq)\n! gx%bmperr=4331\n! 5 Twostate liquid\n case(twostatemodel1) ! Two state model with composition variable G2\n addrec%propval=zero\n! write(*,*)'3H selecting calc_twostate_model1: ',mc\n call calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq)\n! changed below not to calculate G2 as a mixing parameter\n! call calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq)\n! 6 Elastic model\n case(elasticmodel1) ! Elastic model !\n addrec%propval=zero\n call calc_elastica(moded,phres,addrec,lokph,mc,ceq)\n write(kou,*)' Elastic model not implemented yet'\n gx%bmperr=4399\n! 7 Volume model\n case(volmod1) ! Simple volume model depending on V0, VA and VB\n addrec%propval=zero\n call calc_volmod1(moded,phres,addrec,lokph,mc,ceq)\n! 8 UNUSED\n! case(crystalbreakdownmod) ! Limiting heat capacity of extrapolated solid\n! addrec%propval=zero\n! call calc_crystalbreakdownmod(moded,phres,addrec,lokph,mc,ceq)\n! 9\n case(secondeinstein) ! Adding a second Einstein Cp\n addrec%propval=zero\n call calc_secondeinstein(moded,phres,addrec,lokph,mc,ceq)\n! 10\n case(schottkyanomaly) ! Adding a second Schottky anomaly Cp\n addrec%propval=zero\n call calc_schottky_anomaly(moded,phres,addrec,lokph,mc,ceq)\n! 11\n case(diffcoefs) ! Calculating diffusion coefficients\n addrec%propval=zero\n call calc_diffusion(moded,phres,addrec,lokph,mc,ceq)\n! gx%bmperr=4333\n! 12 see also 5, twostatemodel1 ! NOT USED\n case(twostatemodel2) ! Two state model with composition independent G2\n! addrec%propval=zero\n! write(*,*)'3H selecting calc_twostate_model1: ',mc\n! call calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq)\n! changed not to calculate G2 as a mixing parameter\n! call calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq)\n write(*,*)'3H Attempt to add obsolete liquid 2-state model'\n end select addition\n1000 continue\n return\n end subroutine addition_selector\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\n\n!\\addtotable subroutine add_addrecord\n!\\begin{verbatim}\n subroutine add_addrecord(lokph,extra,addtyp)\n! generic subroutine to add an addition typ addtyp (including Inden)\n implicit none\n integer lokph,addtyp\n character extra*(*)\n!\\end{verbatim}\n integer aff\n double precision xxx\n character name*24,more*4\n type(gtp_phase_add), pointer :: newadd,addrec,lastrec\n logical bcc\n!\n! write(*,*)'3H creating addrecord: ',trim(extra),addtyp,lokph\n! check if this addition already entered\n lastrec=>phlista(lokph)%additions\n addrec=>lastrec\n do while(associated(addrec))\n if(addrec%type.eq.addtyp) then\n write(*,*)'3H addition already entered ',trim(phlista(lokph)%name),&\n addtyp,lokph,extra \n goto 1000\n else\n lastrec=>addrec\n addrec=>lastrec%nextadd\n endif\n enddo\n! NOTE EET is not an addition, it is comparing the entropy of solid and liquid\n! create addition record\n! write(*,*)'3H adding addition record',lokph,addtyp\n addition: select case(addtyp)\n!-----------------------------------------\n case default\n write(kou,*)'No addtion type ',addtyp,lokph\n!-----------------------------------------\n case(indenmagnetic) ! Inden magnetic\n! 1\n if(extra(1:1).eq.'Y' .or. extra(1:1).eq.'y') then\n! bcc model\n aff=-1\n call create_magrec_inden(newadd,aff)\n else\n aff=-3\n call create_magrec_inden(newadd,aff)\n endif\n!-----------------------------------------\n case(xiongmagnetic) ! Inden-Qing-Xiong. Assume bcc if BCC part of phase name\n! 2\n! bcc=.false.\n! if(index('BCC',phlista(lokph)%name).gt.0) bcc=.true.\n if(extra(1:1).eq.'Y' .or. extra(1:1).eq.'y') then\n bcc=.TRUE.\n else\n bcc=.FALSE.\n endif\n! ibm=.FALSE.\n more=' '\n! extra(2:2) means using individual Bohr magneton numbers\n if(extra(2:2).eq.'I') more(1:1)='I'\n! extra(3:3) means using ferromagnetic as reference state\n if(extra(3:3).eq.'R') more(2:2)='R'\n! lokph because we need to check if average or individual Boghr magnetons\n! call create_xiongmagnetic(newadd,' ',bcc)\n! call create_xiongmagnetic(newadd,ibm,bcc)\n! write(*,*)'3H add extra: \"',trim(extra),'\" and more: \"',more,'\"'\n call create_xiongmagnetic(newadd,more,bcc)\n!-----------------------------------------\n case(debyecp) ! Debye Cp UNUSED\n! 3\n! call create_debyecp(newadd)\n!-----------------------------------------\n case(einsteincp) ! Einstein Cp\n! 4\n call create_einsteincp(newadd)\n!-----------------------------------------\n case(twostatemodel1) ! Liquid 2 state model\n! 5\n! NEW set bit to allow endmember parameter modification! Question asked in PMON6\n! write(*,*)'3H setting bit ph2state: ',PH2STATE\n! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE)\n! write(*,*)'3H extra \"',extra,'\"'\n if(extra(1:1).eq.'N') then\n phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE)\n write(*,*)'3H G2 is assumed to be composition independent'\n call create_newtwostate_model1(newadd)\n! return that the addition type has changed ...\n addtyp=twostatemodel2\n else\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PH2STATE)\n call create_twostate_model1(newadd)\n endif\n!-----------------------------------------\n case(elasticmodel1) ! Elastic model 1\n! 6\n call create_elastic_model_a(newadd)\n!-----------------------------------------\n case(volmod1) ! Volume model 1\n! 7\n call create_volmod1(newadd)\n!-----------------------------------------\n! case(crystalbreakdownmod) ! Crystal Breakdown model\n! 8 UNUSED\n! call create_crystalbreakdownmod(newadd)\n!-----------------------------------------\n case(secondeinstein) ! Second Einstein T\n! 9\n call create_secondeinstein(newadd)\n!-----------------------------------------\n case(schottkyanomaly) ! Schottky anomaly\n! 10\n call create_schottky_anomaly(newadd)\n!-----------------------------------------\n case(diffcoefs) ! diffusion coefficients\n! 11 \n call create_diffusion(newadd,lokph,extra)\n!-----------------------------------------\n end select addition\n!-----------------------------------------\n if(gx%bmperr.ne.0) goto 1000\n! initiate status word for this addition\n! newadd%status=0\n if(associated(phlista(lokph)%additions)) then\n! write(*,*)'3H adding new addition record to phase ',lokph,addtyp\n lastrec%nextadd=>newadd\n else\n! write(*,*)'3H adding first addition record to phase',lokph,addtyp\n phlista(lokph)%additions=>newadd\n endif\n1000 return\n end subroutine add_addrecord\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine need_propertyid\n!\\begin{verbatim}\n subroutine need_propertyid(id,typty)\n! get the index of the property needed\n implicit none\n integer typty\n character*4 id\n!\\end{verbatim} %+\n! here the property list is searched for \"id\" and its index stored in addrec\n do typty=1,ndefprop\n if(propid(typty)%symbol.eq.id) then\n goto 1000\n endif\n enddo\n write(*,*)'3H Parameter id ',id,' not found'\n gx%bmperr=4335\n typty=-1\n1000 continue\n return\n end subroutine need_propertyid\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine setpermolebit\n!\\begin{verbatim}\n subroutine setpermolebit(lokph,addtype)\n! set bit in addition record that addition is per mole\n! lokph is phase record\n! addtype is the addtion record type\n implicit none\n integer lokph,addtype\n!\\end{verbatim}\n type(gtp_phase_add), pointer :: addrec\n addrec=>phlista(lokph)%additions\n! write(*,*)'3H set size bit: ',addtype\n do while(associated(addrec))\n if(addrec%type.eq.addtype) then\n write(*,*)'3H setting bit ADDPERMOL for addition type ',addtype\n addrec%status=ibset(addrec%status,ADDPERMOL)\n goto 1000\n endif\n addrec=>addrec%nextadd\n enddo\n write(*,*)'3H Cannot find addition ',addtype\n1000 continue\n return\n end subroutine setpermolebit\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_magrec_inden\n!\\begin{verbatim}\n subroutine create_magrec_inden(addrec,aff)\n! enters the magnetic model\n implicit none\n type(gtp_phase_add), pointer :: addrec\n integer aff\n!\\end{verbatim} %+\n integer typty,ip,nc\n character text*128\n integer, parameter :: ncc=6\n double precision coeff(ncc)\n integer koder(5,ncc)\n! There is some trouble with memory leaks in expressions to fix!!!\n TYPE(tpfun_expression), target :: llow2,lhigh2\n TYPE(tpfun_expression), pointer :: llow,lhigh\n!\n if(aff.eq.-1) then\n! bcc, aff=-1\n! Magnetic function below Curie Temperature\n! problem in ct1xfn to start a function with +1 or 1\n text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//&\n '.00680037095*T**9-.00153008346*T**15 ;'\n! write(*,*)'3H emm 1: ',text(1:len_trim(text))\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n! write(*,17)'3H emm 1B:',nc,(coeff(i),i=1,nc)\n17 format(a,i3,5(1PE11.3))\n if(gx%bmperr.ne.0) goto 1000\n! Trouble with memory leaks for expressions to be fixed ...\n llow=>llow2\n! call ct1mexpr(nc,coeff,koder,llow)\n! Attempt to remove big memory leak\n call ct1mexpr(nc,coeff,koder,llow2)\n if(gx%bmperr.ne.0) goto 1000\n! Magnetic function above Curie Temperature\n text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//&\n '-4.27820805E-04*T**(-25) ; '\n! write(*,*)'3H emm 2: ',text(1:len_trim(text))\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n! call ct1mexpr(nc,coeff,koder,lhigh)\n! Attempt to remove big memory leak\n call ct1mexpr(nc,coeff,koder,lhigh2)\n if(gx%bmperr.ne.0) goto 1000\n else\n!------------\n! fcc, aff=-3\n! Magnetic function below Curie Temperature\n text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//&\n '-.0017449124*T**15 ; '\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n llow=>llow2\n! call ct1mexpr(nc,coeff,koder,llow)\n! Attempt to remove big memory leak\n call ct1mexpr(nc,coeff,koder,llow2)\n if(gx%bmperr.ne.0) goto 1000\n! Magnetic function above Curie Temperature\n text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//&\n '-2.84601512E-04*T**(-25) ; '\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n! call ct1mexpr(nc,coeff,koder,lhigh)\n ! Attempt to remove big memory leak\n call ct1mexpr(nc,coeff,koder,lhigh2)\n if(gx%bmperr.ne.0) goto 1000\n endif\n! reserve an addition record\n allocate(addrec)\n! store data in record\n allocate(addrec%explink(2))\n nullify(addrec%nextadd)\n addrec%status=0\n addrec%aff=aff\n addrec%type=indenmagnetic\n! attempt to remove memory leak\n! addrec%explink(1)=llow\n! addrec%explink(2)=lhigh\n! write(*,*)'3H magnetic expression links'\n addrec%explink(1)=llow2\n addrec%explink(2)=lhigh2\n! addrecs declared in gtp3.F90 but I am not sure it is needed or used\n addrecs=addrecs+1\n allocate(addrec%need_property(2))\n addrec%addrecno=addrecs\n addrec%need_property=0\n! here the property list is searched for TC and BM\n call need_propertyid('TC ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(1)=typty\n call need_propertyid('BMAG',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(2)=typty\n1000 continue\n return\n end subroutine create_magrec_inden\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_magnetic_inden\n!\\begin{verbatim}\n subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq)\n! calculates Indens magnetic contribution\n! NOTE: values for function not saved, should be done to save time.\n! Gmagn = RT*f(T/Tc)*ln(beta+1)\n! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2\n! phres: pointer, to phase\\_varres record\n! lokadd: pointer, to addition record\n! lokph: integer, phase record \n! mc: integer, number of constituents\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer moded,lokph,mc\n TYPE(gtp_phase_varres) :: phres\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer itc,ibm,jl,noprop,ik,k,jk,j,jxsym\n double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn,msize\n double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv\n double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2)\n double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2)\n logical addpermole\n! phres points to result record with gval etc for this phase\n TYPE(tpfun_expression), pointer :: exprot\n! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1)\n! dgdp = RT df/dtao*dtao/dP*ln(beta+1)\n! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy\n! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1)\n! +RT*df/dtao*d2tao/dT2*ln(beta+1)\n! d2gdtdp= ...\n! d2gdp2=\n! d2gdtdy=\n! d2gdpdy=\n! d2gdydy=\n! listprop(1) is the number of properties calculated\n! listprop(2:listprop(1)) give the typty of different properties\n! calculated in gval(*,i) etc\n! one has to find those with typty equal for need_property in the magnetic\n! record, i.e. typty=2 for TC and typty=3 for BM\n! the properties needed.\n!\n noprop=phres%listprop(1)-1\n itc=0; ibm=0\n! write(*,*)'3H cmi 2: ',mc,noprop,(phres%listprop(j),j=1,noprop)\n! Inden magnetic need properties in need_property(1..2)\n findix: do jl=2,noprop\n if(phres%listprop(jl).eq.lokadd%need_property(1)) then\n itc=jl\n elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then\n ibm=jl\n endif\n enddo findix\n if(itc.eq.0 .or. ibm.eq.0) then\n! it is no error if no TC or BM but then magnetic contribution is zero\n! write(*,12)phlista(lokph)%name\n12 format('3H Warning: Magnetic addition for phase ',a&\n /9x,'but no values for TC or BM, magnetic contribution zero')\n goto 1000\n endif\n tc=phres%gval(1,itc)\n beta=phres%gval(1,ibm)\n! Probably beta should be divided by atoms/formula unit ...\n! write(*,95)'3H Magnetic values in: ',itc,ibm,tc,beta,phres%abnorm(1)\n95 format(a,2i3,4(1PE12.3))\n if(tc.lt.zero) then\n! we should take care of the case when tc and beta have different signs\n! note: all derivatives of tc must be multiplied with iaff\n iafftc=one/lokadd%aff\n do ik=1,mc\n do k=1,3\n phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc)\n enddo\n do jk=ik,mc\n jxsym=kxsym(ik,jk)\n phres%d2gval(jxsym,itc)=&\n iafftc*phres%d2gval(jxsym,itc)\n! phres%d2gval(ixsym(ik,jk),itc)=&\n! iafftc*phres%d2gval(ixsym(ik,jk),itc)\n enddo\n enddo\n do k=1,6\n phres%gval(k,itc)=iafftc*phres%gval(k,itc)\n enddo\n tc=phres%gval(1,itc)\n! write(*,*)'3H Inden 1: ',tc,iafftc\n else\n iafftc=zero\n endif\n! avoid diving with zero, tc is a temperature so 0.01 degree is small\n if(tc.lt.one) tc=1.0D-2\n if(beta.lt.zero) then\n! note all derivatives of bm must be multipled by iaffbm\n! iaffbm=one/addlista(lokadd)%aff\n iaffbm=one/lokadd%aff\n do ik=1,mc\n do k=1,3\n phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm)\n enddo\n do jk=ik,mc\n jxsym=kxsym(ik,jk)\n phres%d2gval(jxsym,ibm)=&\n iaffbm*phres%d2gval(jxsym,ibm)\n enddo\n enddo\n do k=1,6\n phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm)\n enddo\n beta=phres%gval(1,ibm)\n! write(*,*)'3H Inden 2: ',beta,iaffbm\n endif\n!\n tv=ceq%tpval(1)\n rgasm=globaldata%rgas\n rt=rgasm*tv\n tao=tv/tc\n tao2(1)=tao\n! one should save values of ftao if tao2 is the same next time ....\n! but as tc depend on the constitution that is maybe not so often.\n if(tao.lt.one) then\n exprot=>lokadd%explink(1)\n else\n exprot=>lokadd%explink(2)\n endif\n call ct1efn(exprot,tao2,ftao,ceq%eq_tpres)\n logb1=log(beta+one)\n invb1=one/(beta+one)\n gmagn=rt*ftao(1)*logb1\n! if(ocv()) then\n! write(*,98)'3H m1: ',tc,beta,ftao(1),logb1,rt\n! write(*,98)'3H m2: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),iafftc\n!98 format(a,5(1PE14.6))\n! endif\n!\n dtaodt=one/tc\n dtaodp=-tao/tc*phres%gval(3,itc)\n addgval(1)=gmagn\n addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1\n addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm)\n! phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt\n! phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt\n! phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt\n! save these in record\n do j=1,3\n lokadd%propval(j)=addgval(j)\n phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt\n enddo\n! write(*,77)lokadd%type,(lokadd%propval(j),j=1,4)\n!77 format('3H Addition ',i2,': ',4(1pe12.4))\n! ignore second derivatives if no derivatives wanted\n if(moded.eq.0) then\n goto 1000\n endif\n! Now all derivatives\n! phres%gval(*,itc) are TC and derivatives wrt T and P\n! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y\n! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2\n! phres%gval(*,ibm) are beta and dervatives etc\n! TC and beta must not depend on T, only on P and Y\n! dtaodt=one/tc\n! dtaodp=-tao/tc*phres%gval(3,itc)\n! d2taodt2 is zero\n d2taodtdp=-one/tc*phres%gval(3,itc)\n d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc)\n! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P\n addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+&\n rt*ftao(4)*(dtaodt)**2*logb1\n addgval(5)=rgasm*ftao(2)*dtaodp*logb1+&\n rgasm*ftao(1)*invb1*phres%gval(3,ibm)+&\n rt*ftao(4)*dtaodt*dtaodp*logb1+&\n rt*ftao(2)*d2taodtdp*logb1+&\n rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm)\n addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+&\n rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+&\n rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-&\n rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+&\n rt*ftao(1)*invb1*phres%gval(6,ibm)\n! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked)\n do j=1,mc\n dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc\n dtao(2,j)=-phres%dgval(1,j,itc)/tc**2\n dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-&\n tao*phres%dgval(3,j,itc)/tc\n do k=j,mc\n jxsym=kxsym(j,k)\n d2tao(jxsym)=&\n 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2&\n -tao*phres%d2gval(jxsym,itc)/tc\n enddo\n enddo\n do j=1,mc\n! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe?\n daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+&\n rt*ftao(1)*invb1*phres%dgval(1,j,ibm)\n! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm)\n!43 format('3H Inden 4: ',i2,6(1pe12.5))\n! second derivative wrt to T and Y, checked\n daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+&\n rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+&\n rt*ftao(4)*dtaodt*dtao(1,j)*logb1+&\n rt*ftao(2)*dtao(2,j)*logb1+&\n rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm)\n! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,&\n! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),&\n! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,&\n! rgasm*ftao(2)*dtao(2,j)*logb1,&\n! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm)\n!56 format('3H calcmag : ',5(1PE13.5))\n! second derivative wrt P and Y, no P dependence\n daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+&\n rt*ftao(2)*dtao(3,j)*logb1+&\n rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-&\n rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+&\n rt*ftao(1)*invb1*phres%dgval(3,j,ibm)\n do k=j,mc\n! second derivatives wrt Y1 and Y2, wrong\n jxsym=kxsym(j,k)\n d2addgval(jxsym)=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+&\n rt*ftao(2)*d2tao(jxsym)*logb1+&\n rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+&\n rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-&\n rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+&\n rt*ftao(1)*invb1*phres%d2gval(jxsym,ibm)\n! d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+&\n! rt*ftao(2)*d2tao(ixsym(j,k))*logb1+&\n! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+&\n! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-&\n! rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+&\n! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm)\n! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,&\n! R rt*ftao(2)*d2tao(ixsym(j,k))*logb1,&\n! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),&\n! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),&\n! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),&\n! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm)\n!57 format('3H mag2y: ',6(1PE12.4))\n enddo\n enddo\n! now add all to the total G and its derivatives\n! NOTE if addpermole bit set we have to multiply with derivatives of\n! the size of the phase ...\n if(btest(lokadd%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize magadd 1: ',lokph,addpermole,msize\n! UNFINISHED: ignoring that msize depend on fractions\n else\n addpermole=.FALSE.; msize=one\n endif\n do j=1,mc\n! write(*,99)'3H magadd 1: ',1,j,phres%dgval(1,j,1),daddgval(1,j)/rt\n do k=1,3\n! first derivatives\n phres%dgval(k,j,1)=phres%dgval(k,j,1)+msize*daddgval(k,j)/rt\n enddo\n99 format(a,2i3,2(1pe16.8))\n do k=j,mc\n! second derivatives\n! write(*,99)'3H magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),&\n! d2addgval(ixsym(j,k))\n jxsym=kxsym(j,k)\n phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+&\n msize*d2addgval(jxsym)/rt\n! phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+&\n! msize*d2addgval(ixsym(j,k))/rt\n enddo\n enddo\n! write(*,*)'3H cm 7: ',phres%gval(1,1),addgval(1)/rt\n! note phres%gval(1..3,1) already calculated above\n do j=4,6\n lokadd%propval(j)=msize*addgval(j)\n phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt\n enddo\n1000 continue\n return\n end subroutine calc_magnetic_inden\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_xiongmagnetic\n!\\begin{verbatim}\n subroutine create_xiongmagnetic(addrec,more,bcc)\n! adds a Xiong type magnetic record, we must separate fcc and bcc by extra\n! copied from Inden magnetic model\n! The difference is that it uses CTA for Curie temperature and NTA for Neel\n! and individual (IBM=.TRUE.) or average Bohr magneton numbers \n! BCC is .TRUE. if it is a BCC phase\n implicit none\n! logical ibm,bcc\n logical bcc\n character more*(*)\n! integer lokph\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty,ip,nc,jj\n character text*128\n integer, parameter :: ncc=6\n double precision coeff(ncc),dval\n logical ibm,ferroref\n integer koder(5,ncc)\n! TYPE(tpfun_expression), pointer :: llow,lhigh\n TYPE(tpfun_expression) :: llow,lhigh\n!\n! from W Xiong et al Calphad (2012) 11-20\n!\n! G = RT g(tao) ln(b* + 1)\n!\n! tao = T/Tc\n! b*= \\Pi_i (b_i + 1)**(x_i) - 1\n!\n! tao<0 g(tao)=0\n!\n! tao<1 g(tao) = 1-1/D( 0.38438376/(p*tao)+0.63570895(1/p-1)*\n!\n! (tao**3/6 + tao**9/135 + tao**15/600 + tao**21/1617) )\n!\n! tao>1 g(tao) = tao**(-7)/D( 1/21 + tao**(-14)/630 + tao**(-28)/2975 + \n! tao**(-42)/8232)\n!\n! p=0.37 for bcc and p=0.25 for non-bcc (like fcc)\n!\n! for bcc: +1-.880323235*TAO**(-1)-.152870878*TAO**3-.00679426123*TAO**9\n! -.00152870878*TAO**15-5.67238878E-04*TAO**21\n!\n! -.0403514888*TAO**(-7)-.00134504963*TAO**(-21)\n! -2.84834039E-04*TAO**(-35)-1.02937472E-04*TAO**(-49)\n!\n! for non-bcc: \n!\n! +1-.842849633*TAO**(-1)-.174242226*TAO**3-.00774409892*TAO**9\n! -.00174242226*TAO**15-6.46538871E-04*TAO**21\n!\n! -.0261039233*TAO**(-7)-8.70130777E-04*TAO**(-21)\n! -1.84262988E-04*TAO**(-35)-6.65916411E-05*TAO**(-49)\n!\n! write(*,*)'3H Qing-Xiong magnetic model',bcc\n!\n! write(*,*)'3H create more: \"',more,'\"'\n ibm=.FALSE.\n if(more(1:1).eq.'I') ibm=.TRUE.\n! This is a secret way to set ferromgantic reference state for alloys\n ferroref=.FALSE.\n if(more(2:2).eq.'R') ferroref=.TRUE.\n if(bcc) then\n! Magnetic function below Curie/Neel Temperature, \n! problem in ct1xfn to start a function with +1 or 1\n if(ferroref) then\n text=' -.152870878*T**3-.00679426123*T**9'//&\n '-.00152870878*T**15-5.67238878E-04*T**21'\n else\n text=' +1-.880323235*T**(-1)-.152870878*T**3-.00679426123*T**9'//&\n '-.00152870878*T**15-5.67238878E-04*T**21'\n endif\n! CHANGE OF REFERENCE STATE OF THE ELEMENTS\n! text=' +1-.152870878*T**3-.00679426123*T**9'//&\n! '-.00152870878*T**15-5.67238878E-04*T**21'\n! write(*,*)'3H emm 1: ',trim(text)\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n! write(*,17)'3H emm 1B:',nc,(coeff(i),i=1,nc)\n17 format(a,i3,5(1PE11.3))\n if(gx%bmperr.ne.0) goto 1000\n call ct1mexpr(nc,coeff,koder,llow)\n if(gx%bmperr.ne.0) goto 1000\n! Magnetic function above Curie/Neel Temperature\n if(ferroref) then\n text=' -1+0.880323235*T**(-1)-.0403514888*T**(-7)'//&\n '-.00134504963*T**(-21)'//&\n '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)'\n else\n text='-.0403514888*T**(-7)-.00134504963*T**(-21)'//&\n '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)'\n endif\n! CHANGE OF REFERENCE STATE OF THE ELEMENTS\n! text=' +.880323235*T**(-1)-.0403514888*T**(-7)-.00134504963*T**(-21)'//&\n! '-2.84834039E-04*T**(-35)-1.02937472E-04*T**(-49)'\n! write(*,*)'3H emm 2: ',trim(text)\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n call ct1mexpr(nc,coeff,koder,lhigh)\n if(gx%bmperr.ne.0) goto 1000\n! this is 1/(p*D) in eq. A9 in Qing et al, p=0.37\n! dval=0.880323235D0\n dval=one/(0.49649686D0+0.37D0*(0.33461979D0-0.49649686D0))\n! write(*,*)'3H added Qing-Xiong magnetic contribution to a bcc phase'\n else\n!------------\n! fcc\n! Magnetic function below Curie/Neel Temperature\n! REFERENCE STATE AT T=0\n if(ferroref) then\n text=' -.174242226*T**3-.00774409892*T**9'//&\n '-.00174242226*T**15-6.46538871E-04*T**21'\n else\n text=' +1-.842849633*T**(-1)-.174242226*T**3-.00774409892*T**9'//&\n '-.00174242226*T**15-6.46538871E-04*T**21'\n endif\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n call ct1mexpr(nc,coeff,koder,llow)\n if(gx%bmperr.ne.0) goto 1000\n! Magnetic function above Curie/Neel Temperature\n if(ferroref) then\n text=' -1+0.843849633*T**(-1)-.0261039233*T**(-7)'//&\n '-8.70130777E-04*T**(-21)-1.84262988E-04*T**(-35)'//&\n '-6.65916411E-05*T**(-49)'\n else\n text=' -.0261039233*T**(-7)'//&\n '-8.70130777E-04*T**(-21)-1.84262988E-04*T**(-35)'//&\n '-6.65916411E-05*T**(-49)'\n endif\n ip=1\n nc=ncc\n call ct1xfn(text,ip,nc,coeff,koder,.FALSE.)\n if(gx%bmperr.ne.0) goto 1000\n call ct1mexpr(nc,coeff,koder,lhigh)\n if(gx%bmperr.ne.0) goto 1000\n! this is 1/(p*D) in eq. A9 in Qing et al for FCC, p=0.25; 1/p-1 =3.0\n! dval=4.0D0/(0.33461979D0+3.0D0*0.49649686D0)\n! dval=0.842849633D0\n dval=one/(0.49649686D0+0.25D0*(0.33461979D0-0.49649686D0))\n! write(*,*)'3H added Qing-Xiong magnetic contribution to a non-bcc phase'\n endif\n! reserve an addition record\n! write(*,*)'3H 1/(pD)= ',dval\n allocate(addrec)\n! store data in record\n allocate(addrec%explink(2))\n allocate(addrec%constants(1))\n nullify(addrec%nextadd)\n addrec%type=xiongmagnetic\n! beware of segmentation fault here !!! llow and llhigh no longer pointers\n addrec%explink(1)=llow\n addrec%explink(2)=lhigh\n addrec%constants(1)=dval\n addrecs=addrecs+1\n! Set bit 1 that there are properties\n addrec%status=0\n addrec%status=ibset(addrec%status,ADDHAVEPAR)\n if(bcc) addrec%status=ibset(addrec%status,ADDBCCMAG)\n! write(*,*)'3H Qing-Xiong magnetic addition: ',addrec%status,bcc,ADDBCCMAG\n allocate(addrec%need_property(3))\n addrec%addrecno=addrecs\n! here the property list is searched for CTA, NTA and IBM\n call need_propertyid('CTA ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(1)=typty\n! The individual Bohr magneton number or not set in PMON\n! WHEN READ FROM A UNFORMATTED FILE, DO WE KNOW LOKPH??\n! if(btest(phlista(lokph)%status1,PHBMAV)) then\n if(.not.ibm) then\n! This model use an effective Bohr magneton number b*=prod(b_i+1)**x_i -1\n call need_propertyid('BMAG ',typty)\n else\n! or an individual Bohr magneton number b*=prod(b_i+1)**x_i -1\n! write(*,*)'3H using induvidual Bohr magneton numbers',&\n! btest(phlista(lokph)%status1,PHBMAV)\n call need_propertyid('IBM ',typty)\n endif\n!---------------------------------------------------\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(2)=typty\n! NTA is not so important, anti-magnetic contributions usually small\n call need_propertyid('NTA ',typty)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0\n addrec%need_property(3)=0\n else\n addrec%need_property(3)=typty\n endif\n! write(*,*)'3H need properties: ',(addrec%need_property(jj),jj=1,3)\n1000 continue\n return\n end subroutine create_xiongmagnetic\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_xiongmagnetic\n!\\begin{verbatim}\n subroutine calc_xiongmagnetic(moded,phres,lokadd,lokph,mc,ceq)\n! calculates Indens-Qing-Xiong magnetic contribution\n! \n! Gmagn = RT*f(T/Tc)*ln(beta+1)\n! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2\n! phres: pointer, to phase\\_varres record\n! lokadd: pointer, to addition record\n! lokph: integer, phase record \n! mc: integer, number of constituents\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer moded,lokph,mc\n! phres points to result record with gval etc for this phase\n TYPE(gtp_phase_varres) :: phres\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer itc,itn,ibm,jl,noprop,ik,k,jk,j,jxsym,ip\n double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn,msize\n double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv,plus,fixit\n double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2)\n double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2)\n double precision tn,tcsave,tnsave,gmdo_inf,dgmdo_infdt,d2gmdo_infdt2\n double precision check(6)\n logical addpermole\n character line*128,tps(2)*3\n TYPE(tpfun_expression), pointer :: exprot\n! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1)\n! dgdp = RT df/dtao*dtao/dP*ln(beta+1)\n! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy\n! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1)\n! +RT*df/dtao*d2tao/dT2*ln(beta+1)\n! d2gdtdp= ...\n! d2gdp2=\n! d2gdtdy= suck\n! d2gdpdy=\n! d2gdydy=\n! listprop(1) is the number of properties calculated\n! listprop(2:listprop(1)) give the typty of different properties\n! calculated in gval(*,i) etc\n! one has to find those with typty equal for need_property in the magnetic\n! record, i.e. typty for CTA/NTA and typty for BMAG/IBM\n! the properties needed.\n!\n noprop=phres%listprop(1)-1\n itc=0; ibm=0; itn=0\n lokadd%propval=zero\n! write(*,*)'3H cmi 2: ',noprop,(phres%listprop(i),i=1,noprop)\n! Inden-Qing-Xiong magnetic need properties in need_property(1..3)\n findix: do jl=2,noprop\n if(phres%listprop(jl).eq.lokadd%need_property(1)) then\n itc=jl\n elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then\n! we may also use an \"average\" Bohr magneton number in BMAG\n ibm=jl\n elseif(phres%listprop(jl).eq.lokadd%need_property(3)) then\n itn=jl\n endif\n enddo findix\n! check that the needed properties are defined\n! write(*,*)'3H found magnetic properties: ',itc,ibm,itn\n if(ibm.eq.0 .or. (itc.eq.0 .and. itn.eq.0)) then\n! it is no error if no CTA, NTA or BMAG but then magnetic contribution is zero\n write(*,12)trim(phlista(lokph)%name),itc,itn,ibm\n12 format('3H *** Warning: Magnetic addition for phase ',a,&\n ' not calculated as '/&\n 10x,'some values for CTA, NTA or BMAG/IBM are zero',3i3)\n goto 1000\n else\n tc=-one\n tn=-one\n if(itc.gt.0) tc=phres%gval(1,itc)\n if(itn.gt.0) tn=phres%gval(1,itn)\n endif\n! I am not sure I calculate correct derivatives for indivudal Bohr magnetons ...\n if(.not.btest(phlista(lokph)%status1,PHBMAV)) then\n write(*,*)'3H *** Bohr magneton number derivatives not calculated'\n endif\n beta=phres%gval(1,ibm)\n! write(*,95)'3H Magnetic values in: ',itc,itn,ibm,tc,tn,beta\n95 format(a,3i3,3(1PE15.6))\n if(beta.le.zero .or. (tc.le.zero .and. tn.le.zero)) then\n! no magnetic contribution\n gmagn=zero\n addgval=zero\n daddgval=zero\n d2addgval=zero\n goto 1000\n endif\n! we should use the appropriate tao=t/tc or tao=t/tn\n! BUT WE MAY HAVE BOTH tc>0 and tn>0 !!\n! use AF model unless tc negative, both cannot be negative here (test above)\n! BUT WE MAY HAVE BOTH AS POSITIVE!!\n tcsave=tc\n if(tc.le.zero) then\n! no ferro but maybe antiferro. One of them must be positive here!!\n! Divide by AFF=3.0?\n! tc=tn/3.0D0\n! beta=beta/3.0D0\n tc=tn\n! we use this index below to extract its value\n itc=itn\n! elseif(tn.gt.zero) then\n! we have both AFM and FM, use FM, i.e. tc so nothing to do\n endif\n!\n tv=ceq%tpval(1)\n rgasm=globaldata%rgas\n rt=rgasm*tv\n tao=tv/tc\n tao2(1)=tao\n! one should save values of ftao if tao2 is the same next time ....\n! but as tc depend on the constitution that is maybe not so often.\n if(tao.lt.one) then\n exprot=>lokadd%explink(1)\n! VERY CLUMSY bug for debugging\n else\n exprot=>lokadd%explink(2)\n endif\n! plus=one\n plus=zero\n! calculate function and derivatives wrt T, functions already created\n call ct1efn(exprot,tao2,ftao,ceq%eq_tpres)\n! copied from list_addition\n! tps(1)='tao'\n! tps(2)='err'\n! ip=1\n! line=' '\n! call ct1wfn(exprot,tps,line,ip)\n! write(*,'(a,a,a/2(1pe12.4))')'f(tao)=',trim(line),';',tao,ftao(1)\n! write(*,'(a,2(1pe12.4))')'3H tao, f(tao): ',tao,ftao(1)\n! call wrice(kou,4,8,78,line(1:ip))\n! the functions entered in explink use reference state at T=infinity\n! correct for using reference state at T=0\n! -1.0D0+0.38438376D0*lokadd%constants(1)*T/tc\n! lokadd%constants(1) = 1/(p*D) in eq. A9 in paper by Qing\n! NOTE tc may depend on P, we need the dtaodp and d2taodp2\n dtaodp=-tao/tc*phres%gval(3,itc)\n d2taodtdp=-one/tc*phres%gval(3,itc)\n d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc)\n!\n fixit=0.38438376D0*lokadd%constants(1)\n! this is for BCC\n! fixit=0.880323235D0\n fixit=zero\n ftao(1)=ftao(1)+plus*(fixit*tv/tc-one)\n ftao(2)=ftao(2)+plus*fixit/tc\n ftao(3)=ftao(3)-plus*fixit*tv*dtaodp/tc**2\n! this is d2ftaodT2, no change\n! ftao(4)=ftao(4)\n! this is d2ftaodTdP\n ftao(5)=ftao(5)-plus*fixit*dtaodp/tc**2\n ftao(6)=ftao(6)+2.0D0*plus*fixit*tv*d2taodp2/tc**3\n! if(plus.gt.zero) then\n! write(*,'(a,e17.9,a,e12.4)')'3H f(tao) correction: -1+',&\n! fixit,'/tao;',beta\n! else\n! write(*,'(a,e14.6,a,e14.6)')'3H f(tao) correction: +1-',&\n! fixit,'/tao;',beta\n! endif \n!------------------------------------------------------ \n logb1=log(beta+one)\n invb1=one/(beta+one)\n gmagn=rt*ftao(1)*logb1\n!\n! Calculate Gmdo_inf/RT, which value to use for \"p\"?\n! THERE ARE T and composition derivatives of this also!!\n! gmdo_inf=-logb1*(one-0.38438376D0*lokadd%constants(1)/tao)\n! dgmdo_infdt=-logb1/tv\n! gmdo_inf=-rt*logb1*(one-0.38438376D0*lokadd%constants(1)/tc)\n! write(*,'(a,2(1pe14.6),a/5(1pe12.4))')'3H Gmdo(inf): ',&\n! rgasm*logb1*0.38438376D0*lokadd%constants(1)*tc,rgasm*logb1,'*T',&\n! rgasm,logb1,0.38438376D0,lokadd%constants(1),tc\n! gmdo_inf=-rgasm*logb1*(tv-0.38438376D0*lokadd%constants(1)*tc)\n! dgmdo_infdt=-rgasm*logb1\n! d2gmdo_infdt2=zero\n! write(*,88)'3H gmdo_inf: ',tv,gmdo_inf,dgmdo_infdt\n!88 format(a,F8.2,4(1pe12.4))\n!\n! write(*,98)'3H cm 97: ',tc,beta,ftao(1),logb1,rt\n! write(*,98)'3H cm 98: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),tcx,iafftc\n!98 format(a,5(1PE14.6))\n!\n dtaodt=one/tc\n! d2taodT2=zero\n! this already calculated above\n! dtaodp=-tao/tc*phres%gval(3,itc)\n! addgval(1)=gmagn+gmdo_inf\n! addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1+dgmdo_infdt\n! addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm)+&\n! d2gmdo_infdt2\n addgval(1)=gmagn\n addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1\n addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm)\n! make sure d2G/dT2 is calculated and stored so it can be listed\n addgval(4)=(2.0D0*ftao(2)+tv*ftao(4)*dtaodt)*rgasm*dtaodt*logb1\n! phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt\n! phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt\n! phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt\n! save these in record\n! NOTE if parallel calculation the same stored values %propval will be\n! written by all threads so they must not be used!!\n! write(*,77)lokadd%type,(lokadd%propval(j),j=1,4)\n!77 format('3H addition ',i2,': ',4(1pe12.4))\n! if(moded.eq.0) then\n if(moded.eq.0) then\n! They are included only for listing and debugging\n if(btest(lokadd%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n else\n msize=one\n endif\n do j=1,4\n lokadd%propval(j)=msize*addgval(j)\n phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt\n enddo\n! ignore second derivatives if no derivatives wanted\n goto 1000\n endif\n! Now all derivatives with respect to fractions ...\n! phres%gval(*,itc) are TC and derivatives wrt T and P\n! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y\n! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2\n! phres%gval(*,ibm) are beta and dervatives etc\n! TC and beta must not depend on T, only on P and Y\n! dtaodt=one/tc\n! dtaodp=-tao/tc*phres%gval(3,itc)\n! d2taodt2 is zero\n! d2taodtdp=-one/tc*phres%gval(3,itc)\n! d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc)\n! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P\n! addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+&\n! rt*ftao(4)*(dtaodt)**2*logb1\n addgval(5)=rgasm*ftao(2)*dtaodp*logb1+&\n rgasm*ftao(1)*invb1*phres%gval(3,ibm)+&\n rt*ftao(4)*dtaodt*dtaodp*logb1+&\n rt*ftao(2)*d2taodtdp*logb1+&\n rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm)\n addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+&\n rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+&\n rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-&\n rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+&\n rt*ftao(1)*invb1*phres%gval(6,ibm)\n! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked)\n do j=1,mc\n dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc\n dtao(2,j)=-phres%dgval(1,j,itc)/tc**2\n dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-&\n tao*phres%dgval(3,j,itc)/tc\n do k=j,mc\n jxsym=kxsym(j,k)\n d2tao(jxsym)=&\n 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2&\n -tao*phres%d2gval(jxsym,itc)/tc\n! d2tao(ixsym(j,k))=&\n! 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2&\n! -tao*phres%d2gval(ixsym(j,k),itc)/tc\n enddo\n enddo\n do j=1,mc\n! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe?\n daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+&\n rt*ftao(1)*invb1*phres%dgval(1,j,ibm)\n! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm)\n!43 format('3H Inden 4: ',i2,6(1pe12.5))\n! second derivative wrt to T and Y, checked\n daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+&\n rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+&\n rt*ftao(4)*dtaodt*dtao(1,j)*logb1+&\n rt*ftao(2)*dtao(2,j)*logb1+&\n rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm)\n! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,&\n! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),&\n! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,&\n! rgasm*ftao(2)*dtao(2,j)*logb1,&\n! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm)\n!56 format('3H calcmag : ',5(1PE13.5))\n! second derivative wrt P and Y, no P dependence\n daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+&\n rt*ftao(2)*dtao(3,j)*logb1+&\n rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-&\n rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+&\n rt*ftao(1)*invb1*phres%dgval(3,j,ibm)\n do k=j,mc\n! second derivatives wrt Y1 and Y2, wrong ??\n jxsym=kxsym(j,k)\n d2addgval(jxsym)=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+&\n rt*ftao(2)*d2tao(jxsym)*logb1+&\n rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+&\n rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-&\n rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+&\n rt*ftao(1)*invb1*phres%d2gval(jxsym,ibm)\n! d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+&\n! rt*ftao(2)*d2tao(ixsym(j,k))*logb1+&\n! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+&\n! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-&\n! rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+&\n! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm)\n! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,&\n! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,&\n! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),&\n! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),&\n! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),&\n! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm)\n!57 format('3H mag2y: ',6(1PE12.4))\n enddo\n enddo\n! now add all to the total G\n! NOTE if addpermole bit set we have to multiply with derivatives of\n! the size of the phase ...\n if(btest(lokadd%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize magadd 2: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n do j=1,mc\n do k=1,3\n! write(*,99)'3H magadd 1: ',k,j,rt*phres%dgval(k,j,1),daddgval(k,j)\n phres%dgval(k,j,1)=phres%dgval(k,j,1)+msize*daddgval(k,j)/rt\n enddo\n!99 format(a,2i3,2(1pe16.8))\n do k=j,mc\n! write(*,99)'3H magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),&\n! d2addgval(ixsym(j,k))\n jxsym=kxsym(j,k)\n phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+&\n msize*d2addgval(jxsym)/rt\n! phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+&\n! msize*d2addgval(ixsym(j,k))/rt\n enddo\n enddo\n! write(*,*)'3H cm 7: ',rt*phres%gval(1,1),addgval(1)\n! note phres%gval(1..3,1) already calculated above, multiplied with misize??\n do j=1,6\n lokadd%propval(j)=msize*addgval(j)\n phres%gval(j,1)=phres%gval(j,1)+msize*addgval(j)/rt\n enddo\n! we may have destroyed the original value of tc if we have AFM\n tc=tcsave\n! write(*,900)tc,tn,tao,beta,phres%gval(4,1),lokadd%propval(4)\n900 format('3H QX magn1: ',2F9.2,2F9.3,2(1pe12.4))\n! jump here if no magnetic contribution\n1000 continue\n! write(*,900)tc,tn,tao,beta,phres%gval(1,1),lokadd%propval(1)\n return\n end subroutine calc_xiongmagnetic\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_volmod1\n!\\begin{verbatim}\n subroutine create_volmod1(addrec)\n! create addition record for the simple volume model\n!\n! currently only V = V0 * exp(VA(T))\n! V0 is property (typty) 21, VA is 22 and reserved VB (Bulk modulus) 23 \n! but VB is not implemented yet\n implicit none\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty,kk\n! reserve an addition record\n allocate(addrec)\n! store data in record\n nullify(addrec%nextadd)\n addrec%status=0\n addrec%type=volmod1\n! addrecs declared in gtp3.F90 but I am not sure it is needed or used\n addrecs=addrecs+1\n addrec%addrecno=addrecs\n allocate(addrec%need_property(3))\n! properties needed\n call need_propertyid('V0 ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(1)=typty\n call need_propertyid('VA ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(2)=typty\n call need_propertyid('VB ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(3)=typty\n! write(*,*)'Added volume model 1'\n! store zero in 6 values for propval\n addrec%propval=zero\n1000 continue\n! write(*,*)'3H created volume addition',addrecs\n return\n end subroutine create_volmod1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_volmod1\n!\\begin{verbatim} %-\n subroutine calc_volmod1(moded,phres,lokadd,lokph,mc,ceq)\n! calculate the simple volume model, CURRENTLY IGNORING COMPOSITION DEPENDENCE\n!\n! G = P*V0(x)*exp(VA(T,x))\n! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2\n! phres: pointer, to phase\\_varres record\n! lokadd: pointer, to addition record\n! lokph: integer, phase record index\n! mc: integer, number of constituents\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer moded,lokph,mc\n! phres points to result record with gval etc for this phase\n TYPE(gtp_phase_varres) :: phres\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jl,iv0,iva,ivb,noprop\n double precision v0,va,vb,vol,deltap,pvol\n! propval are stored locally in addition record\n lokadd%propval=zero\n! if this bit not set there are no volume parameters\n if(.not.btest(lokadd%status,ADDHAVEPAR)) goto 1000\n iv0=0; iva=0; ivb=0;\n v0=zero; va=zero; vb=zero\n noprop=phres%listprop(1)-1\n findix: do jl=2,noprop\n if(phres%listprop(jl).eq.lokadd%need_property(1)) then\n iv0=jl\n v0=phres%gval(1,iv0)\n elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then\n iva=jl\n va=phres%gval(1,iva)\n elseif(phres%listprop(jl).eq.lokadd%need_property(3)) then\n ivb=jl\n vb=phres%gval(1,ivb)\n endif\n enddo findix\n! write(*,'(a,3i3)')'3H volmodel: ',iv0,iva,ivb\n! if iv0 is zero there are no volume data\n if(iv0.eq.0) goto 1000\n! reference pressure is 1 bar\n deltap=ceq%tpval(2)-1.0D5\n if(ivb.ne.zero) then\n! if ivb not zero there are bulk modulus data ... NOT IMPLEMENTED\n write(*,*)'3H Volume model with bulk modulus not implemented'\n else\n vol=v0/ceq%rtn\n if(iva.ne.zero) then\n! NOTE all values should be divided by RT\n vol=v0*exp(va)/ceq%rtn\n endif\n! write(*,*)'3H v0, va: ',v0,va\n pvol=deltap*vol\n! contribtions to G and derivatives, G, G.T, G.P=V, G.T.T, G.T.P, G.P.P\n! NOTE there may be other parameters which depend on P!\n phres%gval(1,1)=phres%gval(1,1)+pvol\n! G.T\n phres%gval(2,1)=phres%gval(2,1)+pvol*phres%gval(2,iva)\n! G.P\n phres%gval(3,1)=phres%gval(3,1)+vol\n! G.T.T\n phres%gval(4,1)=phres%gval(4,1)+&\n pvol*(phres%gval(2,iva)**2+phres%gval(4,iva))\n! G.T.P\n phres%gval(5,1)=phres%gval(5,1)+vol*phres%gval(2,iva)\n! G.P.P\n! for the moment ignore pressure and composition dependence ...\n! phres%gval(6,1)=phres%gval(6,1)\n endif\n! write(*,*)'Calculated volume ',pvol,vol,deltap\n! store some property values\n lokadd%propval(1)=pvol\n lokadd%propval(2)=pvol*phres%gval(2,iva)\n lokadd%propval(3)=vol\n lokadd%propval(4)=pvol*(phres%gval(2,iva)**2+phres%gval(4,iva))\n lokadd%propval(5)=vol*phres%gval(2,iva)\n lokadd%propval(6)=zero\n1000 continue\n return\n end subroutine calc_volmod1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_elastic_model_a\n!\\begin{verbatim}\n subroutine create_elastic_model_a(newadd)\n! addition record to calculate the elastic energy contribution\n implicit none\n type(gtp_phase_add), pointer :: newadd\n!\\end{verbatim} %+\n integer typty\n allocate(newadd)\n newadd%type=elasticmodel1\n allocate(newadd%need_property(5))\n newadd%status=0\n! needed properties\n newadd%need_property=0\n call need_propertyid('LPX ',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(1)=typty\n call need_propertyid('EC11',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(2)=typty\n call need_propertyid('EC12',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(3)=typty\n call need_propertyid('EC44',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(4)=typty\n call need_propertyid('LPTH',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(5)=typty\n! now elastica is declared as pointer, is that OK?\n allocate(newadd%elastica)\n1000 continue\n return\n end subroutine create_elastic_model_a\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_elastica\n!\\begin{verbatim}\n subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq)\n! calculates elastic contribution and adds to G and derivatives\n implicit none\n integer moded,lokph,mc\n type(gtp_phase_varres), pointer :: phres\n type(gtp_phase_add), pointer :: addrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer jl,ilpx,ilpth,iec11,iec12,iec44,noprop,i1,i2\n double precision sum1,sum2\n! get the current lattice parameters and elastic constants\n ilpx=0; ilpth=0; iec11=0; iec12=0; iec44=0\n noprop=phres%listprop(1)-1\n findix: do jl=2,noprop\n if(phres%listprop(jl).eq.addrec%need_property(1)) then\n ilpx=jl\n elseif(phres%listprop(jl).eq.addrec%need_property(2)) then\n iec11=jl\n elseif(phres%listprop(jl).eq.addrec%need_property(3)) then\n iec12=jl\n elseif(phres%listprop(jl).eq.addrec%need_property(4)) then\n iec44=jl\n elseif(phres%listprop(jl).eq.addrec%need_property(5)) then\n! this one may not be needed initially at least\n ilpth=jl\n endif\n enddo findix\n if(ilpx.eq.0 .or. iec11.eq.0 .or. iec12.eq.0 .or. iec44.eq.0) then\n write(*,11)'3H Missing elastic parameter index: ',ilpx,iec11,iec12,iec44\n11 format(a,5i4)\n endif\n! write(*,11)'3H indices: ',ilpx,iec11,iec12,iec44\n! take care of the special elastic record\n! ignore compsition derivatives at present ...\n! elastic constant matrix, Voigt notation, symetric\n addrec%elastica%cmat=zero\n addrec%elastica%cmat(1,1)=phres%gval(1,iec11)\n addrec%elastica%cmat(2,2)=phres%gval(1,iec11)\n addrec%elastica%cmat(3,3)=phres%gval(1,iec11)\n addrec%elastica%cmat(4,4)=phres%gval(1,iec44)\n addrec%elastica%cmat(5,5)=phres%gval(1,iec44)\n addrec%elastica%cmat(6,6)=phres%gval(1,iec44)\n addrec%elastica%cmat(1,2)=phres%gval(1,iec12)\n addrec%elastica%cmat(1,3)=phres%gval(1,iec12)\n addrec%elastica%cmat(2,3)=phres%gval(1,iec12)\n addrec%elastica%cmat(2,1)=phres%gval(1,iec12)\n addrec%elastica%cmat(3,1)=phres%gval(1,iec12)\n addrec%elastica%cmat(3,2)=phres%gval(1,iec12)\n! write(*,22)phres%gval(1,iec11),phres%gval(1,iec12),phres%gval(1,iec44)\n22 format('Elastic constants: ',3(1pe12.4))\n! write(*,19)(addrec%elastica%cmat(1,i1),i1=1,6)\n! write(*,19)(addrec%elastica%cmat(2,i1),i1=1,6)\n! write(*,19)(addrec%elastica%cmat(3,i1),i1=1,6)\n! write(*,19)(addrec%elastica%cmat(4,i1),i1=1,6)\n! write(*,19)(addrec%elastica%cmat(5,i1),i1=1,6)\n! write(*,19)(addrec%elastica%cmat(6,i1),i1=1,6)\n19 format('3H CIJ: ',6(1pe12.4))\n!....................\n! equilibrium lattice constant (cubic, just diagonal)\n addrec%elastica%latticepar=zero\n addrec%elastica%latticepar(1,1)=phres%gval(1,ilpx)\n addrec%elastica%latticepar(2,2)=phres%gval(1,ilpx)\n addrec%elastica%latticepar(3,3)=phres%gval(1,ilpx)\n! write(*,23)'3H Lattice parameter: ',phres%gval(1,ilpx)\n!....................\n! The equilibrium lattice distances are in LPX (cubic lattice)\n! The current lattice parameters are in ceq%phres%curlat(3,3)\n! generate epsa, Voigt notation\n! write(*,23)'3H curlat 1: ',(phres%curlat(i1,1),i1=1,3)\n! write(*,23)'3H curlat 2: ',(phres%curlat(i1,2),i1=1,3)\n! write(*,23)'3H curlat 3: ',(phres%curlat(i1,3),i1=1,3)\n23 format(a,3(1pe12.4))\n addrec%elastica%epsa(1)=(phres%curlat(1,1)-addrec%elastica%latticepar(1,1))&\n /addrec%elastica%latticepar(1,1)\n addrec%elastica%epsa(2)=(phres%curlat(2,2)-addrec%elastica%latticepar(2,2))&\n /addrec%elastica%latticepar(2,2)\n addrec%elastica%epsa(3)=(phres%curlat(3,3)-addrec%elastica%latticepar(3,3))&\n /addrec%elastica%latticepar(3,3)\n! as addrec%elastica%latticepar(2,3) is zero for cubic use (1,1)\n addrec%elastica%epsa(4)=&\n (2*(phres%curlat(2,3)-addrec%elastica%latticepar(2,3)))&\n /addrec%elastica%latticepar(1,1)\n addrec%elastica%epsa(5)=&\n (2*(phres%curlat(1,3)-addrec%elastica%latticepar(1,3)))&\n /addrec%elastica%latticepar(1,1)\n addrec%elastica%epsa(6)=&\n (2*(phres%curlat(1,2)-addrec%elastica%latticepar(1,2)))&\n /addrec%elastica%latticepar(1,1)\n! write(*,25)'3H ev1: ',(addrec%elastica%epsa(i1),i1=1,6)\n25 format(a,6(1pe12.4))\n!....................\n! calculate the elastic energy ... I do not know how to use F08 matrix mult\n sum1=zero\n do i1=1,6\n sum2=zero\n do i2=1,6\n sum2=sum2+addrec%elastica%cmat(i1,i2)*addrec%elastica%epsa(i2)\n enddo\n! write(*,23)'3H sum2: ',sum2\n sum1=sum1+addrec%elastica%epsa(i1)*sum2\n enddo\n addrec%elastica%eeadd(1)=5.0D-1*sum1\n write(*,30)'3H: Elastic energy: ',addrec%elastica%eeadd(1)\n30 format(a,1pe15.7)\n! TYPE gtp_elastic_modela\n! double precision, dimension(3,3) :: latticepar\n! epsilon in Voigt notation\n! double precision, dimension(6) :: epsa\n! elastic constant matrix in Voigt notation\n! double precision, dimension(6,6) :: cmat\n! calculated elastic energy addition (with derivative to T and P?)\n! double precision, dimension(6) :: eeadd\n! maybe more\n! end TYPE gtp_elastic_modela\n \n1000 continue\n return\n end subroutine calc_elastica\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_lattice_parameters\n!\\begin{verbatim}\n subroutine set_lattice_parameters(iph,ics,xxx,ceq)\n! temporary way to set current lattice parameters for use with elastic model a\n implicit none\n integer iph,ics\n double precision, dimension(3,3) :: xxx\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokph,lokcs\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n ceq%phase_varres(lokcs)%curlat=xxx\n! write(*,*)'3H Phase+set: ',lokph,lokcs\n! write(*,23)'3H slp 1: ',(ceq%phase_varres(lokcs)%curlat(i1,1),i1=1,3)\n! write(*,23)'3H slp 2: ',(ceq%phase_varres(lokcs)%curlat(i1,2),i1=1,3)\n! write(*,23)'3H slp 3: ',(ceq%phase_varres(lokcs)%curlat(i1,3),i1=1,3)\n23 format(a,3(1pe12.4))\n1000 continue\n return\n end subroutine set_lattice_parameters\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_einsteincp\n!\\begin{verbatim}\n subroutine create_einsteincp(newadd)\n implicit none\n type(gtp_phase_add), pointer :: newadd\n!\\end{verbatim} %+\n integer, parameter :: ncc=6\n integer typty\n!\n! G/RT = 1.5*R*THET + 3*ln( 1 - exp( -THET/T ) ) \n! No need to use TPFUN\n!\n! gtp_phase_add has variables:\n! integer :: type,addrecno,aff\n! integer, allocatable :: need_property\n! type(tpfun_expression), dimension, pointer :: explink\n! type(gtp_phase_add), pointer :: nextadd \n! for spme additions one may create other records but they must have\n! the variables type and nextadd\n!------------------------------------------\n allocate(newadd)\n! Both Einstein and Debye models use THET\n newadd%type=einsteincp\n newadd%status=0\n! call need_propertyid('THET',typty)\n call need_propertyid('LNTH',typty)\n if(gx%bmperr.ne.0) goto 1000\n allocate(newadd%need_property(1))\n newadd%need_property(1)=typty\n nullify(newadd%nextadd)\n1000 continue\n return\n end subroutine create_einsteincp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_einsteincp\n!\\begin{verbatim}\n subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq)\n! Calculate the contibution due to Einste Cp model for low T\n! moded 0, 1 or 2\n! phres all results\n! addrec pointer to addition record\n! lokph phase record\n! mc number of variable fractions\n! ceq equilibrum record\n!\n! G = 1.5*R*THET + 3*R*T*ln( 1 - exp( -THET/T ) ) \n! This is easier to handle inside the calc routine without TPFUN\n!\n implicit none\n integer moded,lokph,mc\n type(gtp_phase_varres), pointer :: phres\n type(gtp_phase_add), pointer :: addrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ith,noprop,extreme,j1,j2\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1,fact\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2,theta\n double precision gein,dgeindt,d2geindt2,msize,theta,test\n double precision addphm(6)\n logical addpermole\n double precision, allocatable :: dthet(:),d2thet(:),dein(:),d2ein(:)\n!\n noprop=phres%listprop(1)-1\n! write(*,*)'3H thet: ',phres%listprop(2),addrec%need_property(1)\n findix: do ith=2,noprop\n if(phres%listprop(ith).eq.addrec%need_property(1)) goto 100\n enddo findix\n! write(*,*)'3H No value of THET for phase ',trim(phlista(lokph)%name)\n write(*,*)'3H No value of LNTH for phase ',trim(phlista(lokph)%name)\n gx%bmperr=4336; goto 1000\n100 continue\n if(phres%gval(1,ith).le.one) then\n! write(*,69)'3H Illegal THET for phase ',trim(phlista(lokph)%name),&\n write(*,69)'3H Illegal LNTH for phase ',trim(phlista(lokph)%name),&\n phres%gval(1,ith)\n69 format(a,a,1pe12.4)\n gx%bmperr=4399; goto 1000\n endif\n! NOTE the parameter value is ln(thera)! take the exponential!\n! ln(thet) is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = 1.5*THET/T + 3*LN(1-exp(-THET/T)) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n! kvot=theta/T\n if(phres%gval(1,ith).gt.1.0D2) then\n! write(*,*)'3H Probably wrong value of THET, parameter should be ln(THET)'\n write(*,*)'3H Probably wrong value of LNTH, parameter should be ln(THET)'\n write(*,*)'3H error in phase: ',trim(phlista(lokph)%name)\n gx%bmperr=4399; goto 1000\n endif\n! The exp( ) because the parameter value is LN(THETA) \n theta=exp(phres%gval(1,ith))\n! kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n kvot=theta/ceq%tpval(1)\n! write(*,*)'3H LN(THET): ',trim(phlista(lokph)%name),phres%gval(1,ith),theta\n! write(*,'(a,4(1pe11.3))')'3H dTH/dyi: ',(phres%dgval(1,j1,ith),j1=1,mc)\n! write(*,'(a,4(2i2,1pe11.3))')'3H d2TH/dyidyj: ',&\n! ((j1,j2,phres%d2gval(ixsym(j1,j2),ith),j2=j1,mc),j1=1,mc)\n! We must convert all derivatives to real THET ?? no ??\n allocate(dthet(mc))\n allocate(d2thet(mc*(mc+1)/2))\n do j1=1,mc\n do j2=j1,mc\n d2thet(ixsym(j1,j2))=phres%d2gval(ixsym(j1,j2),ith)\n enddo\n dthet(j1)=phres%dgval(1,j1,ith)\n enddo\n! do j1=1,mc\n! do j2=j1,mc\n! d2thet(ixsym(j1,j2))=exp(phres%d2gval(ixsym(j1,j2),ith))\n! enddo\n! dthet(j1)=exp(phres%dgval(1,j1,ith))\n! enddo\n! write(*,'(a,4(1pe11.3))')'3H A dTH/dyi: ',(dthet(j1),j1=1,mc)\n! write(*,'(a,4(2i2,1pe11.3))')'3H A d2TH/dyidyj: ',&\n! ((j1,j2,d2thet(ixsym(j1,j2)),j2=j1,mc),j1=1,mc)\n! simpler .... if it is correct?? \n! dTHETA/dy_i = d/dyi(exp(LNTH))= exp(LNTH)*d/dy1(LNTH) = THETA*dLNTH/dy1 ??\n! do j1=1,mc\n! do j2=j1,mc\n! d2thet(ixsym(j1,j2))=theta*phres%d2gval(ixsym(j1,j2),ith)\n! enddo\n! dthet(j1)=theta*phres%dgval(1,j1,ith)\n! enddo\n! write(*,'(a,4(1pe11.3))')'3H B dTH/dyi: ',(dthet(j1),j1=1,mc)\n! write(*,'(a,4(2i2,1pe11.3))')'3H B d2TH/dyidyj: ',&\n! ((j1,j2,d2thet(ixsym(j1,j2)),j2=j1,mc),j1=1,mc)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n! kvotexpkvotm1=one\n expmkvot=zero\n kvotexpkvotm1=zero\n ln1mexpkvot=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n ln1mexpkvot=log(one-expmkvot)\n else\n! range of T and kvot where value varies, take care of composition derivatives\n extreme=0\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n ln1mexpkvot=log(one-expmkvot)\n! ln1mexpkvot=log(exp(kvot)-one)\n endif\n! kvot is +THETA/T; gein is integrated cp contribution to the Gibbs energy\n! gein is Einsten contribution/RT\n gein=1.5D0*kvot+3.0D0*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! second derivative wrt T\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above\n d2geindt2=zero\n else\n d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! NOTE if addpermole bit set we have to multiply with derivatives of\n! the size of the phase ...\n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize lowT: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize lowT: ',lokph,addpermole,msize\n endif\n! BEGIN NEW CODE ---------------------------------------------------------\n! wrong G^Ein/RT = gein = 1.5*THETA/T + 3*LN(exp(THETA/T) - 1) \n! G^Ein/RT = gein = 1.5*THETA/T + 3*LN(1-exp(-THETA/T)) \n! where z=ln(THETA); THETA=exp(z); z depend on composition; kvot=THETA/T\n! we have dz/dy_i etc in phres%dgval(1,i,ith); (note z does not depend on T)\n! d2z/dy_idy_j in phres%d2gval(ixsym(i,j))\n!\n! wrong G^Ein = RT*(G^Ein/RT) = 1.5*R*T*kvot + 3*R*T*ln(exp(kvot) - 1); \n! kvot=THETA/T\n! G^Ein = 1.5*R*THETA + 3*R*T*ln(1-exp(-THETA/T)); THETA=exp(z(y_i))\n!\n! dG^Ein/dy_i=1.5*R*dTHETA/dy_i+3*R*exp(-THETA/T)/(1-exp(-THETA/T))*dTHETA/dy_i\n! = (1.5+3*exp(-THETA/T)/(exp(-THETA/T)-1))*R*dTHETA/dy_i\n! Composition derivative of the Einstein function is\n! dEin/dy_i/RT = ((1.5+3*exp(-THETA/T)/(exp(-THETA/T)-1)/T)*dTHETA/dy_i\n! dTHETA/dy_i = exp(z)*dz/y_i = THETA*dz/dy_i\n! dEin/dy_i/RT = ((1.5+(3/T)*exp(-THETA/T)/(1-exp(-THETA/T)))*(THETA/T)*dz/dy_i\n! dTHETA/dy_i = exp(z)*dz/y_i = THETA*dz/y_i\n! REMEMBER kvot=THET/T; expmkvot=exp(-kvot); gasconstant R=globaldata%rgas\n!\n! This is composition derivatives of THET\n!\n! as I want NOTE expmkvot is exp(-kvot) !! NOW IT WORKS !!! SUCK\n fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot\n! the curve below better, correct shape ...\n! write(*,77)'3H Einstein dE/dy',lokph,1,theta,phres%dgval(1,1,ith),fact,&\n! phres%dgval(1,1,1),phres%dgval(1,1,1)+fact*phres%dgval(1,1,ith)\n77 format(a,2i2,5(1pe12.4))\n! allocate(dein(mc))\n! allocate(d2ein(mc*(mc+1)/2))\n! VERY MESSY CODING AND I DO NOT UNDERSTAND IT/BoS 2021.04.02\n do j1=1,mc\n! write(*,77)'3H Einstein dE/dy',lokph,j1,theta,phres%dgval(1,j1,ith),fact,&\n! phres%dgval(1,j1,1),phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith)\n! we must use dthet(j1)=THETA*dgval(1,j1,ith) and not dgval(1,j1,ith) !!\n! old phres%dgval(1,j1,1)=msize*(phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith))\n phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+msize*fact*dthet(j1)\n! write(*,*)'3H second derivatives missing for Einstein, SUCK'\n! dein(j1)=msize*fact*dthet(j1)\n do j2=j1,mc\n! d2Ein/dy1dy2 = (1.5R*theta+3*R*(exp(kvot)-1)**(-1))*d2theta/dy1dy2 -\n! 3*R*exp(kvot)/(T*(exp(kvot)-1))**2*dtheta/dy1*dtheta/dy2\n phres%d2gval(ixsym(j1,j2),1)=phres%d2gval(ixsym(j1,j2),1)+&\n msize*(fact*d2thet(ixsym(j1,j2))-&\n 3.0d0*exp(kvot)*(ceq%tpval(1)*(exp(kvot)-one))**(-2)*&\n dthet(j1)*dthet(j2))\n! d2ein(ixsym(j1,j2))=msize*(fact*d2thet(ixsym(j1,j2))-&\n! 3.0d0*exp(kvot)*(ceq%tpval(1)*(exp(kvot)-one))**(-2)*&\n! dthet(j1)*dthet(j2))\n enddo\n enddo\n! listing ....\n! write(*,'(a,4(1pe11.3))')'3H dein: ',(dein(j1),j1=1,mc)\n! write(*,'(a,4(2i2,1pe11.3))')'3H d2ein: ',&\n! ((j1,j2,d2ein(ixsym(j1,j2)),j2=j1,mc),j1=1,mc)\n!\n! END NEW CODE ----------------------------------------------------------\n! debug value of G\n! write(*,77)'3H Einstein ln(theta):',lokph,0,theta,gein,test,msize\n! return the values in phres%gval(*,1)\n phres%gval(1,1)=phres%gval(1,1)+msize*gein\n phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n addrec%propval(1)=msize*gein\n addrec%propval(2)=msize*dgeindt\n addrec%propval(4)=msize*d2geindt2\n! write(*,70)'3H Cp E3: ',ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n!\n! NOTE Missing implementation of derivatives wrt comp.dep of THET.\n! the THET parameter cannot depend on T\n! write(*,*)'3H calc_einsteincp not including composition dependence of thet'\n! addphm should be G^phys, dG^phys/dT, dG^phys/dP, d2G^phys/dT^2 etc\n addphm=zero\n addphm(1)=gein\n addphm(2)=dgeindt\n addphm(4)=d2geindt2\n! correct for formula unit\n call add_size_derivatives(moded,phres,addphm,lokph,mc,ceq)\n!\n1000 continue\n return\n end subroutine calc_einsteincp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine add_size_derivatives\n!\\begin{verbatim}\n subroutine add_size_derivatives(moded,phres,addphm,lokph,mc,ceq)\n! Many physical models are defined per mole of atoms, as the Gibbs energy\n! is calculate per mole formula unit this routine will handle the\n! additional derivatives needed when M*ADD(1 mole)\n! mc is number of constituent variables\n! addphm(1..6) is G, dG/dt, dG/dp, d2G/dt2, d2G/dtdp, d2G/dp2 for the addition\n implicit none\n integer moded,lokph,mc\n type(gtp_phase_varres), pointer :: phres\n! type(gtp_phase_add), pointer :: addrec\n type(gtp_equilibrium_data), pointer :: ceq\n double precision addphm(6)\n!\\end{verbatim} %+\n integer i1,i2,j1,j2,jxsym,k,s1,s2\n double precision site1,site2\n! Moles of constituents per mole formula units is:\n! M = \\sum_s a_s \\sum_i y_si; dM/dy = a_s\n! what about disordered fraction sets? ignore .... UNFINISHED??\n! sites are in phres%sites\n! number of constituents in siblattice s is in phlista(lokph)%nooffr(s)\n goto 1000\n write(*,*)'3H inside add_size_derivatives',lokph,addphm(1)\n s1=1\n s2=1\n site1=phres%sites(s1)\n j1=1\n do i1=1,mc\n!\n! G^phy_M = N*G^phy_m (already done)\n! dG^phy_M/dyi = (dN/dyi)*G^phy_m + N*(dG^phy_m/dyi) ??\n! d2G/dyidyj = (dN/dyi)*(dGm/dyj)+(dN/dyj)*(dGm/dyi)+N*(d2Gm/dyidyj) ignore\n! dN/dyi = a_s for sublattice s with constituent i \n! and d2N/dyidyj = 0\n!\n! I am not sure about this routine ....\n!\n! dGM/dyi = (dN/dyi)*Gm (+N*(dGM/dyi) already done)\n do k=1,3\n! this is dG/dy and d2G/dtdy and d2G/dpdy (k=1,2,3)\n phres%dgval(k,i1,1)=phres%dgval(k,i1,1)+site1*addphm(k)\n enddo\n write(*,*)'3H addition to mu',i1,site1*addphm(1)\n! write(*,*)'3H ignoring 2nd derivatives of size'\n!+ j2=1\n!+ site2=phres%sites(s2)\n!+ do i2=i1,mc\n! For the moment ignore all second derivatives !!\n! no second derivatives wrt same constituents twice\n!+ if(i2.gt.i1) then\n!+ site2=phres%sites(s2)\n!+ jxsym=kxsym(i1,i2)\n! d2G/dyidyj = (dN/dyi)*(dGm/dyj)+(dN/dyj)*(dGm/dyi) (+N*(d2Gm/dyidyj) done)\n!+ phres%d2gval(jxsym,1)=phres%d2gval(jxsym,1)+site1*site2*addphm(1)\n!+ endif\n!+ j2=j2+1\n!+ if(j2.gt.phlista(lokph)%nooffr(s2)) then\n!+ j2=1; s2=s2+1\n!+ if(s2.le.phlista(lokph)%noofsubl) site2=phres%sites(s2)\n!+ endif\n!+ enddo\n j1=j1+1\n if(j1.gt.phlista(lokph)%nooffr(s1)) then\n j1=1; s1=s1+1\n if(s1.le.phlista(lokph)%noofsubl) site1=phres%sites(s1)\n endif\n enddo\n1000 continue\n return\n end subroutine add_size_derivatives\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_schottky_anomaly\n!\\begin{verbatim}\n subroutine create_schottky_anomaly(newadd)\n! Adding a Schottky anomaly to Cp\n implicit none\n type(gtp_phase_add), pointer :: newadd\n!\\end{verbatim} %+\n integer, parameter :: ncc=6\n integer typty\n!\n! G/RT = SAM * ln( 1 + exp( SAM/T ) ) \n! No need to use TPFUN\n!\n! gtp_phase_add has variables:\n! integer :: type,addrecno,aff\n! integer, allocatable :: need_property\n! type(tpfun_expression), dimension, pointer :: explink\n! type(gtp_phase_add), pointer :: nextadd \n! for spme additions one may create other records but they must have\n! the variables type and nextadd\n!------------------------------------------\n allocate(newadd)\n! Schottky anomaly uses THT2 and DCP2, same as second Einstein\n newadd%status=0\n newadd%type=schottkyanomaly\n allocate(newadd%need_property(2))\n call need_propertyid('TSCH',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(1)=typty\n call need_propertyid('CSCH',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(2)=typty\n nullify(newadd%nextadd)\n1000 continue\n return\n end subroutine create_schottky_anomaly\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_schottky_anomaly\n!\\begin{verbatim}\n subroutine calc_schottky_anomaly(moded,phres,addrec,lokph,mc,ceq)\n! Calculate the contibution due to a Schottky anomaly\n! moded 0, 1 or 2\n! phres all results\n! addrec pointer to addition record\n! lokph phase record\n! mc number of variable fractions\n! ceq equilibrum record\n!\n! G = DCP2*T*ln( 1 + exp( -THT2/T ) ) \n! dG/dT = DCP2*(ln(1+exp(-THT2/T))+(THT/T)*(1+exp(+THT2/T))**(-1)\n! d2G/dT2 = -DCP2*THT2**2*T**(-3)*exp(THT2/T)*(1+exp(+THT2/T))**(-2)\n!\n implicit none\n integer moded,lokph,mc\n type(gtp_phase_varres), pointer :: phres\n type(gtp_phase_add), pointer :: addrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ith,jth,noprop,extreme,j1\n double precision kvot,expkvot,expmkvot,ln1pexpmkvot,kvotexpkvotp1,fact\n double precision gsch,dgschdt,d2gschdt2,dcp2,msize\n logical addpermole\n!\n noprop=phres%listprop(1)-1\n! write(*,*)'3H lnth: ',phres%listprop(2),addrec%need_property(1)\n ith=0\n jth=0\n findix: do j1=2,noprop\n if(phres%listprop(j1).eq.addrec%need_property(1)) then\n ith=j1\n elseif(phres%listprop(j1).eq.addrec%need_property(2)) then\n jth=j1\n endif\n enddo findix\n! ith is THT2 and jth is DCP2\n if(ith.eq.0 .or. jth.eq.0) then\n! write(*,*)'3H missing Schottky anomaly parameter for phase ',&\n! trim(phlista(lokph)%name)\n goto 1000\n endif\n! phres%gval(1,ith) and phres(1,jth) must not depend on T\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n dcp2=phres%gval(1,jth)\n if(kvot.le.zero) goto 1000\n! we should be careful with numeric overflow, for small T or large T\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n expmkvot=zero\n kvotexpkvotp1=zero\n ln1pexpmkvot=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n kvotexpkvotp1=kvot/(exp(kvot)+one)\n ln1pexpmkvot=log(one+expmkvot)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n kvotexpkvotp1=kvot/(exp(kvot)+one)\n ln1pexpmkvot=log(one+expmkvot)\n endif\n! \n! Note this is the G/RT value dcp2*ln(1+exp(tht2/T)\n! G = DCP2*T*ln( 1 + exp( -THT2/T ) ) \n gsch=dcp2*ln1pexpmkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n! dcp2*ln(1+exp(tht2))/T -(tht2/T**2)/exp\n! dG/dT = DCP2*(ln(1+exp(-THT2/T))+(THT/T)*(1+exp(+THT2/T))**(-1)\n dgschdt=DCP2*(ln1pexpmkvot-kvotexpkvotp1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above\n d2gschdt2=zero\n else\n! d2G/dT2 = -DCP2*THT2**2*T**(-3)*exp(THT2/T)*(1+exp(+THT2/T))**(-2)\n d2gschdt2=-DCP2*kvotexpkvotp1**2/(expmkvot*ceq%tpval(1))\n endif\n! first derivative for each constituent. The parameter value is ln(theta)\n! and we should divide by RT\n! fact=1.5D0*kvot+3.0D0*kvotexpkvotm1\n! do j1=1,mc\n! phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith)\n! enddo\n! return the values in phres%gval(*,1)\n! NOTE if addpermole bit set we have to multiply with derivatives of\n! the size of the phase ...\n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize schky: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n!\n phres%gval(1,1)=phres%gval(1,1)+msize*gsch\n phres%gval(2,1)=phres%gval(2,1)+msize*dgschdt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2gschdt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n addrec%propval(1)=msize*gsch\n addrec%propval(2)=msize*dgschdt\n addrec%propval(4)=msize*d2gschdt2\n! write(*,70)'3H Schottky: ',ceq%tpval(1),gsch,dgschdt,d2gschdt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n!\n! Missing implem of derivatives wrt comp.dep of thet. thet2 cannot depend on T\n!\n1000 continue\n return\n end subroutine calc_schottky_anomaly\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_secondeinstein\n!\\begin{verbatim}\n subroutine create_secondeinstein(newadd)\n implicit none\n type(gtp_phase_add), pointer :: newadd\n!\\end{verbatim} %+\n integer, parameter :: ncc=6\n integer typty\n!\n! G/RT = DCP2*ln( 1 - exp( -THT2/T ) ) \n! No need to use TPFUN\n!\n! gtp_phase_add has variables:\n! integer :: type,addrecno,aff\n! integer, allocatable :: need_property\n! type(tpfun_expression), dimension, pointer :: explink\n! type(gtp_phase_add), pointer :: nextadd \n! for spme additions one may create other records but they must have\n! the variables type and nextadd\n!------------------------------------------\n allocate(newadd)\n newadd%type=secondeinstein\n newadd%status=0\n! The second Einstein use THT2 and DCP2\n allocate(newadd%need_property(2))\n call need_propertyid('THT2',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(1)=typty\n call need_propertyid('DCP2',typty)\n if(gx%bmperr.ne.0) goto 1000\n newadd%need_property(2)=typty\n nullify(newadd%nextadd)\n write(*,*)'3H created 2nd Einstein: ',newadd%type\n1000 continue\n return\n end subroutine create_secondeinstein\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_secondeinstein\n!\\begin{verbatim}\n subroutine calc_secondeinstein(moded,phres,addrec,lokph,mc,ceq)\n! Calculate the contibution due to Einste Cp model for low T\n! moded 0, 1 or 2\n! phres all results\n! addrec pointer to addition record\n! lokph phase record\n! mc number of variable fractions\n! ceq equilibrum record\n!\n! G = 1.5*R*THET + 3*R*T*ln( 1 - exp( -THET/T ) ) \n! This is easier to handle inside the calc routine without TPFUN\n!\n implicit none\n integer moded,lokph,mc\n type(gtp_phase_varres), pointer :: phres\n type(gtp_phase_add), pointer :: addrec\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ith,jth,noprop,extreme,j1\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1,fact\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2\n double precision gein,dgeindt,d2geindt2,deltacp,msize\n logical addpermole\n!\n noprop=phres%listprop(1)-1\n! write(*,*)'3H tht2: ',phres%listprop(2),addrec%need_property(1),&\n! addrec%need_property(2)\n ith=0; jth=0;\n findix: do j1=2,noprop\n if(phres%listprop(j1).eq.addrec%need_property(1)) then\n ith=j1\n elseif(phres%listprop(j1).eq.addrec%need_property(2)) then\n jth=j1\n endif\n enddo findix\n if(ith.eq.0 .or. jth.eq.0) then\n write(*,*)'3H Missing second Einstein properties for phase ',&\n trim(phlista(lokph)%name)\n gx%bmperr=4336; goto 1000\n endif\n100 continue\n if(phres%gval(1,ith).le.one) then\n write(*,70)'3H Illegal LNTH for phase ',trim(phlista(lokph)%name),&\n phres%gval(1,ith)\n gx%bmperr=4399; goto 1000\n endif\n! NOTE the parameter value is ln(thera)! take the exponential!\n! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = phres%gval(1,jth)*R*LN(exp(THET/T) - 1) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n! kvotexpkvotm1=one\n expmkvot=zero\n kvotexpkvotm1=zero\n ln1mexpkvot=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n ln1mexpkvot=log(one-expmkvot)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n ln1mexpkvot=log(one-expmkvot)\n endif\n! \n! The Delta Cp value is given in phres%gval(1,jth) It can be negative!\n! and it can depend on P and composition !! NOT IMPLEMENTED !! BEWHERE\n! In normal Einstein deltacp=3.0\n deltacp=phres%gval(1,jth)\n gein=deltacp*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=deltacp*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T, kvotexpkvotm1=expmkvot=0 set above\n d2geindt2=zero\n else\n d2geindt2=-deltacp*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! write(*,16)'3H 2nd Einstein: ',kvot,deltacp,d2geindt2\n16 format(a,6(1pe12.4))\n! check if addition is per mole \n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2ndein: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n! first derivative for each constituent. The parameter value is ln(theta)\n! and we should divide by RT\n fact=deltacp*kvotexpkvotm1\n do j1=1,mc\n phres%dgval(1,j1,1)=phres%dgval(1,j1,1)+fact*phres%dgval(1,j1,ith)\n enddo\n! return the values in phres%gval(*,1)\n phres%gval(1,1)=phres%gval(1,1)+msize*gein\n phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n addrec%propval(1)=msize*gein\n addrec%propval(2)=msize*dgeindt\n addrec%propval(4)=msize*d2geindt2\n! write(*,70)'3H Cp E3: ',ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n!\n! Missing implem of derivatives wrt comp.dep of tht2 and dcp2.\n! Neither tht2 nor dcp2 can depend on T\n!\n1000 continue\n return\n end subroutine calc_secondeinstein\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_twostate_model1\n!\\begin{verbatim}\n subroutine create_twostate_model1(addrec)\n! newadd is location where pointer to new addition record should be stored\n implicit none\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty\n! this is bad programming as it cannot be deallocated but it will never be ...\n! maybe pointers can be deallocated?\n allocate(addrec)\n addrec%status=0\n! nullify pointer to next addition\n nullify(addrec%nextadd)\n!-----------------------------\n! The model consists of two contributions\n! The first is the harmonic vibrations of an ideal amprthous phase\n! this requires a THETA representing the Einstein T\n! The second is a term - RT*(1+exp(G2/RT))\n! which represent the change from \"solid like\" to \"liquid like\"\n!-----------------------------\n! I am not sure what this is used for\n addrecs=addrecs+1\n addrec%addrecno=addrecs\n! property needed\n allocate(addrec%need_property(2))\n call need_propertyid('G2 ',typty)\n addrec%need_property(1)=typty\n! call need_propertyid('THET ',typty)\n call need_propertyid('LNTH ',typty)\n addrec%need_property(2)=typty\n! type of addition\n addrec%type=twostatemodel1\n! store zero. Used to extract current value of this property\n addrec%propval=zero\n1000 continue\n! write(*,*)'Created two state liquid record'\n return\n end subroutine create_twostate_model1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_newtwostate_model1\n!\\begin{verbatim}\n subroutine create_newtwostate_model1(addrec)\n! newadd is location where pointer to new addition record should be stored\n implicit none\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty\n! this is bad programming as it cannot be deallocated but it will never be ...\n! maybe pointers can be deallocated?\n allocate(addrec)\n! nullify pointer to next addition\n nullify(addrec%nextadd)\n addrec%status=0\n!-----------------------------\n! The model consists of two contributions\n! The first is the harmonic vibrations of an ideal amprthous phase\n! this requires a THETA representing the Einstein T\n! The second is a term - RT*(1+exp(G2/RT))\n! which represent the change from \"solid like\" to \"liquid like\"\n!-----------------------------\n! I am not sure what this is used for\n addrecs=addrecs+1\n addrec%addrecno=addrecs\n! property needed G2 is not needed as composition independent\n allocate(addrec%need_property(1))\n! call need_propertyid('G2 ',typty)\n! addrec%need_property(1)=typty\n! call need_propertyid('THETA ',typty)\n call need_propertyid('LNTH ',typty)\n addrec%need_property(1)=typty\n! type of addition this is 12\n addrec%type=twostatemodel2\n! store zero. Used to extract current value of this property\n addrec%propval=zero\n1000 continue\n! write(*,*)'Created two state liquid record ',twostatemodel2\n return\n end subroutine create_newtwostate_model1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_twostate_model_john\n!\\begin{verbatim}\n subroutine calc_twostate_model_john(moded,phres,addrec,lokph,mc,ceq)\n! subroutine calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq)\n! CURRENTLY NOT USED\n! This routine works OK but I am testing a modification\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! addrec is addition record\n! phres is phase_varres record\n! lokph is phase location\n! mc is number of constitution fractions\n! ceq is current equilibrium record\n implicit none\n integer moded,lokph,mc\n TYPE(GTP_PHASE_ADD), pointer :: addrec\n TYPE(GTP_PHASE_VARRES), pointer :: phres\n TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq\n!\\end{verbatim} %+\n! two state model for extrapolating liquid to low T\n! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d))\n! where d is \"liquid like\" atoms. H is enthalpy to form defects\n! At equilibrium\n!\n! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET\n!\n! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT)\n! DG_d is the enthalpy of forming 1 mole of defects in the glassy state\n!\n!------------------------------\n! The value of Gd for the phase is calculated and added to G\n integer jj,noprop,ig2,ith,extreme,jth,kth\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2\n double precision gein,dgeindt,d2geindt2\n double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1\n double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2\n double precision expmg2p1,msize\n logical addpermole\n! This is Johns original model\n write(*,*)'3H THIS VERSION OF TWOSTATE MODEL SHOULD NOT BE USED!'\n stop\n! number of properties calculatied\n noprop=phres%listprop(1)-1\n! locate the THET and G2 property record \n ig2=0\n ith=0\n jth=0\n kth=0\n! check if addition is per mole \n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize john: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n findix: do jj=2,noprop\n if(phres%listprop(jj).eq.addrec%need_property(1)) then\n! current values of G2 is stored in phres%gval(1,ig2)\n ig2=jj;\n elseif(phres%listprop(jj).eq.addrec%need_property(2)) then\n! current value of THET are stored in phres%gval(1,ith)\n ith=jj\n! SECOND EINSTEIN CP CONTRBUTION ADDED SEPARATELY\n! elseif(phres%listprop(jj).eq.14) then\n! current value of LIQUID THET are stored in with index 14 VISC\n! jth=jj\n! theta2=exp(phres%gval(1,jth))\n! write(*,*)'3H found liquid theta: ',theta2\n! elseif(phres%listprop(jj).eq.27) then\n! current value of LIQUID THET are stored in with index 14 VISC\n! kth=jj\n! dcpl=phres%gval(1,kth)\n! write(*,*)'3H found liquid delta-cp: ',dcpl\n endif\n enddo findix\n if(ith.eq.0) then\n! write(*,*)'3H Cannot find value for amorphous THET'\n write(*,*)'3H warning no values for amorphous LNTH'\n gein=zero; dgeindt=zero; d2geindt2=zero\n goto 300\n! gx%bmperr=4367; goto 1000\n endif\n!----------------------------------\n! for the moment the composition dependence is ignored\n! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n!------ this THET part copied from calc_einstein\n! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n! kvot=theta/T\n! NOTE the stored value is ln(theta)! !!!\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n! expmkvot=exp(-kvot)\n! ln1mexpkvot=log(one-expmkvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n expmkvot=zero\n ln1mexpkvot=zero\n kvotexpkvotm1=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n endif\n! \n gein=1.5D0*kvot+3.0D0*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T\n d2geindt2=zero\n else\n d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! return the values in phres%gval(*,1)\n phres%gval(1,1)=phres%gval(1,1)+msize*gein\n phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2\n!\n! ?????????????????????????????\n!\n! NO DERIVATIVES WITH RESPECT TO FRACTIONS ??????????????????\n!\n! ?????????????????????????????\n!\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n! addrec%propval(1)=gein\n! addrec%propval(2)=dgeindt\n! addrec%propval(4)=d2geindt2\n! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n! thet cannot depend on T\n! Missing implementation of derivatives wrt comp.dep of thet.\n tv=ceq%tpval(1)\n!-------------------------- two state part DIVIDED BY RT\n! hump was an attempt to reduce the hump due to state change entropy\n! it does not seem to work ... in fact it is the same as scaling G^HT-G^LT\n! ****************** This is Johns orignal model *********************\n! hump=1.0\n! Jump here if no Einstein solid\n300 continue\n if(ig2.eq.0) then\n write(*,*)'Cannot find value for G2 two-state parameter'\n gx%bmperr=4367; goto 1000\n endif\n! NOTE g2val and derivatives in phres%gval(..) are not divided by RT !!\n g2val=phres%gval(1,ig2); dg2dt=phres%gval(2,ig2)\n dg2=zero; d2g2dt2=zero\n if(g2val.eq.zero .and. dg2dt.eq.zero) then\n! write(*,*)'3H: G2 parameter zero, ignoring bump',g2val\n goto 900\n endif\n! write(*,19)'3H +am ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n19 format(a,6(1pe11.3))\n rt=ceq%rtn\n! tv=ceq%tpval(1)\n rg=globaldata%rgas\n! expmg2=exp(-g2val/rt)\n! if(g2val/rt.gt.2.0D2) then\n! expmg2=exp(-g2val/(rt))\n! expg2=one/expmg2\n! elseif(g2val/rt.lt.1e-30) then\n! expmg2=exp(-g2val/(rt))\n! expg2=one/expmg2\n! else\n expmg2=exp(-g2val/(rt))\n expmg2p1=expmg2+one\n expg2=one/expmg2\n! endif\n! dg2=log(one+expmg2)\n dg2=log(expmg2p1)\n! write(*,19)'3H G2: ',g2val/rt,expmg2,dg2,dg2*rt\n! NOTE values added to gval(*,1) must be divided by RT\n! G = G - RT*ln(1+exp(-g2/RT))\n! G\n! phres%gval(1,1)=phres%gval(1,1)-dg2\n! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT\n! G.T\n! dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt)\n dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt)\n! phres%gval(2,1)=phres%gval(2,1)-dgfdt\n! G.P is zero\n! ****************** This is Johns orignal model *********************\n!-------------------------- tentative:\n! d2g2/dt2/(1+exp(g2/RT)+\n! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt\n! G.T.T \n! This what my derivation gives:\n! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)+&\n! works after Qing checked the signs\n d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-&\n ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n (rt*(one+expg2)**2))/rt\n! phres%gval(4,1)=phres%gval(4,1)+d2g2dt2\n! Maybe the error is here !! YES now it works!\n! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2\n! write(*,19)'3H dg2A: ',tv, g2val/rt, one/(one+expg2),&\n! -rg*tv**2*phres%gval(4,1),&\n! -rg*tv**2*d2g2dt2,\n! The Eistein contribution is OK\n! -rg*tv**2*d2geindt2\n! -rg*tv*phres%gval(4,ig2)/(one+expg2),&\n! -rg*tv*((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n! (rt*(one+expg2)**2)\n! write(*,19)'3H dg2B: ',phres%gval(4,ig2)/(one+expg2),&\n! (g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt,&\n! rt*(one+expg2)**2\n! G.T.P is zero\n! G.P.P is zero\n800 continue\n phres%gval(1,1)=phres%gval(1,1)-msize*dg2\n phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt\n phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2\n!\n!\n! write(*,19)'3H 2st:',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n! save local values divided by RT?\n! THIS ROUTINE CURRENTLY NOT USED <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n900 continue\n addrec%propval=zero\n addrec%propval(1)=msize*(gein-dg2)\n addrec%propval(2)=msize*(dgeindt-dgfdt)\n addrec%propval(4)=msize*(d2geindt2-d2g2dt2)\n1000 continue\n write(*,*)'3H YOU ARE USING WRONG LIQUID TWOSTATE MODEL'\n return\n end subroutine calc_twostate_model_john\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_twostate_model1\n!\\begin{verbatim}\n subroutine calc_twostate_model1(moded,phres,addrec,lokph,mc,ceq)\n! this routine is used when G2 and LNTH are composition dependent\n! subroutine calc_twostate_modelny(moded,phres,addrec,lokph,mc,ceq)\n! The routine _john works OK but I am testing a modification\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! addrec is addition record\n! phres is phase_varres record\n! lokph is phase location\n! mc is number of constitution fractions\n! ceq is current equilibrium record\n implicit none\n integer moded,lokph,mc\n TYPE(GTP_PHASE_ADD), pointer :: addrec\n TYPE(GTP_PHASE_VARRES), pointer :: phres\n TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq\n!\\end{verbatim} %+\n! two state model for extrapolating liquid to low T\n! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d))\n! where d is \"liquid like\" atoms. H is enthalpy to form defects\n! At equilibrium\n!\n! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET\n!\n! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT)\n! DG_d is the enthalpy of forming 1 mole of defects in the glassy state\n!\n!------------------------------\n! The value of Gd for the phase is calculated and added to G\n integer jj,noprop,ig2,ith,extreme,jth,kth\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2\n double precision gein,dgeindt,d2geindt2\n double precision xi,hump\n double precision, parameter :: humpfact=5.0D0\n logical addpermole\n! double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1\n double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2\n double precision expmg2p1,fact,g2sum,msize,fact2\n double precision, allocatable :: mux(:)\n integer, save :: maxwarnings=0\n! number of properties calculatied\n noprop=phres%listprop(1)-1\n! locate the THET and G2 property record \n ig2=0\n ith=0\n jth=0\n! check if addition is per mole \n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2-state: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n findix: do jj=2,noprop\n if(phres%listprop(jj).eq.addrec%need_property(1)) then\n! current values of G2 is stored in phres%gval(1,ig2)\n ig2=jj;\n elseif(phres%listprop(jj).eq.addrec%need_property(2)) then\n! current value of LNTH are stored in phres%gval(1,ith)\n ith=jj\n! elseif(phres%listprop(jj).eq.22) then\n! current value of DCP2 are stored in phres%gval(1,ith)\n! jth=jj\n endif\n enddo findix\n if(ith.eq.0) then\n! write(*,*)'3H Cannot find value for amorphous LNTH'\n if(maxwarnings.lt.20) then\n maxwarnings=maxwarnings+1\n write(*,*)'3H twostatemodel1 no values for amorphous LNTH:',maxwarnings\n endif\n gein=zero; dgeindt=zero; d2geindt2=zero\n goto 300\n! gx%bmperr=4367; goto 1000\n endif\n if(ig2.eq.0) then\n write(*,*)'3H twostate_model1 Cannot find G2 two-state parameter'\n gx%bmperr=4367; goto 1000\n endif\n!----------------------------------\n! for the moment the composition dependence is ignored\n! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n!------ this THET part copied from calc_einstein\n! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n! kvot=theta/T\n! NOTE the stored value is ln(theta! !!!\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n! expmkvot=exp(-kvot)\n! ln1mexpkvot=log(one-expmkvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n expmkvot=zero\n ln1mexpkvot=zero\n kvotexpkvotm1=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n endif\n! \n gein=1.5D0*kvot+3.0D0*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T\n d2geindt2=zero\n else\n d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! composition variable Variable LNTH\n fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot\n! the curve below better, correct shape ...\n do jj=1,mc\n phres%dgval(1,jj,1)=msize*(phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ith))\n enddo\n!-------------------------- jump here if no LNTH variable\n! return the values in phres%gval(*,1)\n300 continue\n phres%gval(1,1)=phres%gval(1,1)+msize*gein\n phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n! thet cannot depend on T\n! include the composition dependence of the eistein contribution? DONE ABOVE\n! End of Einstein part\n!----------------------------------------------------------------\n! write(*,*)'3H calc_twostate_model1 not including composition dependence thet'\n!-------------------------- two state part DIVIDE BY RT\n! NOTE the values in phres%gval(1,ig2), phres%dgval(1,jj,ig2)\n! are not divided by T.\n!\n rt=ceq%rtn\n tv=ceq%tpval(1)\n rg=globaldata%rgas\n g2val=phres%gval(1,ig2); dg2dt=phres%gval(2,ig2)\n dg2=zero; d2g2dt2=zero; expmg2=zero\n! write(*,*)'3H gval1: ',g2val\n if(g2val.eq.zero .and. dg2dt.eq.zero) then\n write(*,*)'3H: G2 parameter zero, ignoring 2-state model'\n goto 900\n endif\n d2g2dt2=phres%gval(4,ig2)\n goto 600\n!------------------------------------------\n600 continue\n! if g2val is positive we are in the amorphous region\n! if g2val is negative we are in the liquid region\n! The if statements here ensure expmg2 is between 1e-60 and 1e+60\n! write(*,'(a,6(1pe12.4))')'3H g2val: ',g2val,dg2dt,-g2val/rt\n if(-g2val/rt.gt.2.0D2) then\n! LIQUID REGION exp(200) >> 1, thus d2g=ln(1+exp(g2val))=g2val\n! and the derivatives are those above. DIVIDED BY RT?\n dg2=g2val/rt\n dgfdt=dg2dt/rt\n d2g2dt2=d2g2dt2/rt\n goto 700\n elseif(-g2val/rt.lt.-2.0D2) then\n! Low T AMORPHOUS REGION: exp(-200)=0; ln(1)=0 and everything is zero\n dg2=zero\n dg2dt=zero\n d2g2dt2=zero\n goto 900\n else\n! intermediate T range, we have to calculate, exp( -200 to +200) is OK\n expmg2=exp(-g2val/rt)\n expg2=one/expmg2\n expmg2p1=expmg2+one\n dg2=log(expmg2p1)\n! write(*,'(a,4(1pe12.4))')'3H intermed: ',phres%gval(1,ig2),&\n! g2val/rt,expmg2p1,dg2\n endif\n! write(*,19)'3H gval8: ',g2val/rt,expmg2,dg2\n! write(*,19)'3H dg2: ',tv,g2val,expmg2,dg2\n! write(*,19)'3H G2: ',tv,xi,g2val/rt,expmg2,dg2,dg2*rt\n! NOTE values added to phres%gval(*,1) must be divided by RT\n! G = G - RT*ln(1+exp(-g2/RT))\n! G\n! phres%gval(1,1)=phres%gval(1,1)-dg2\n! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT\n! G.T\n dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/rt\n! dgfdt=dg2+(g2val/tv-dg2dt)/(expg2+one)\n! G.P is zero\n!-------------------------- tentative:\n! d2g2/dt2/(1+exp(g2/RT)+\n! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt\n! G.T.T \n! Fixed sign problem\n! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-&\n d2g2dt2=(d2g2dt2/(one+expg2)-&\n ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n (rt*(one+expg2)**2))/rt\n700 continue\n! write(*,705)'3H 2SL: ',g2val/rt, dg2, dgfdt, dgfdt, d2g2dt2, tv,&\n! rt, expg2, dg2dt, msize, d2g2dt2*rt\n705 format(a,6(1pe12.4)/8x,6(1pe12.4))\n! THIS IS THE SUBROUTINE USED FOR 2STATE LIQUID with composition dependent GD\n! This should be OK/ 2020.02.27\n phres%gval(1,1)=phres%gval(1,1)-msize*dg2\n phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt\n phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2\n! values of T, \\xi, g, s and cp \n!\n! ADDING DERIVATIVES WITH RESPECT TO FRACTIONS !!!!!!!!!!!\n!\n fact=expmg2/(expmg2+one)/rt\n fact2=(fact/rt)**2/expmg2*phres%gval(2,ig2)\n! write(*,*)'3H calculating twostatemodel, wrong dg/dy?',fact2\n do jj=1,mc\n phres%dgval(1,jj,1)=phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2)\n! d2(G2)/dydT\n! phres%dgval(1,jj,1)=phres%dgval(2,jj,1)-fact2*phres%dgval(1,jj,ig2)\n! ignore other 2nd derivatives\n enddo\n goto 900\n!============================================================\n!----------skipping old code below\n! Searching for bug when entering G2 as a comp.dependent parameter rather\n! than as a part of the pure element data. Liquid with: T=1950; x(v)=.5\n! 1. OC exactly same as TC when G2 is part of pure elements:\n! G=-127282 J; a(ti)=2.9601E-4; a(v)=5.1269E-4 (SER refstate)\n! 2. When modeling G2 as a separate parameter we get:\n! TC: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4; <<<<<<<<<<<<\n! OC: G=-127223 J; ac(ti)=3.3896E-4; ac(v)=4.5099E-4 (divided by RT)\n! 3. The chemical potential wrong and give strange (wrong) phase diagram\n! OC: divide by T: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4 WoW\n! but the phase diagram still wrong, not same composition at BCC/LIQ minimum!!\n! BCC is identical in TC and OC, no problem with Einstein\n! 4. Calculating liquid at T=1920; x(v)=.1 gives different results:\n! TC: G=-122239 J; ac(ti)=5.4656E-4; ac(v)=1.2773E-4\n! OC: G=-122239 J; ac(ti)=5.2677E-4; ac(v)=1.7801E-4\n! T=1900, x(v)=.1 (for BCC!!)\n! TC: G=-120324 J; ac(ti)=5.6252E-4; ac(v)=1.4795E-4 BCC! DGM(liq)=-4.49E-3\n! OC: G=-120324 J; ac(ti)=5.6252E-4; ac(v)=1.4795E-4 BCC! DGM(liq)=-1.02E-2\n! T=1910, x(v)=.1 (TC gives 2-phase equil, BCC+LIQ, OC just BCC)\n! 5. After some more changes (introducing msize mm) which should NOT change\n! the result, it is bad again ... SUCK\n! OC: divide by T: G=-127223 J; ac(ti)=2.5623E-4; ac(v)=5.9662E-4\n! does some variable have random a value?? BCC stable at this calc\n! OC: divide by RT: G=-127223 J; ac(ti)=3.3896E-4; ac(v)=4.5099E-4 (as above)\n! mulip with 0.5/T: G=-127223 J; ac(ti)=3.0040E-4; ac(v)=5.0889E-4\n! muli with 0.52/T: G=-127223 J; ac(ti)=2.9849E-4; ac(v)=5.1214E-4\n! muli with 0.53/T: G=-127223 J; ac(ti)=2.9754E-4; ac(v)=5.1377E-4\n! this also gave reasonable phase diagram!!\n! mul with 0.533/T: G=-127223 J; ac(ti)=2.9726E-4; ac(v)=5.1426E-4\n! mu with 0.5335/T: G=-127223 J; ac(ti)=2.9721E-4; ac(v)=5.1434E-4\n! mu with 0.5338/T: G=-127223 J; ac(ti)=2.9818E-4; ac(v)=5.1439E-4\n! mul with 0.534/T: G=-127223 J; ac(ti)=2.9717E-4; ac(v)=5.1442E-4\n! mu with 0.5342/T: G=-127223 J; ac(ti)=2.9715E-4; ac(v)=5.1446E-4\n! phase diagram correct with multiplied factor with 0.534... Wow, why?\n! correct: G=-127223 J; ac(ti)=2.9714E-4; ac(v)=5.1446E-4\n! muli with 0.54/T: G=-127223 J; ac(ti)=2.9660E-4; ac(v)=5.1541E-4\n!---------------------------------------------\n! COMPLETELY NONSCIENTIFIC ... ENGINEERING \n!---------------------------------------------\n! the factor /rt because phres%dgval(1,jj,ig2) is not divided by RT\n! fact=expmg2/(expmg2+one)/rt\n! no RT?? No, activites zero\n! fact=expmg2/(expmg2+one)\n!>>>>>>>>>>>>>> this factor 0.5336 gives correct chemical potentials\n fact=0.5342D0*msize*expmg2/(expmg2+one)/tv\n!>>>>>>>>>>>>>> but I do not understad why\n! fact=msize*expmg2/(expmg2+one)/rt\n! sign?? - no good; \n! fact=10*expmg2/(expmg2+one)/rt\n!! fact=10*expmg2/(expmg2+one)/rt\n! fact=1.2E0*expmg2/(expmg2+one)/tv\n! write(*,'(a,6(1pe12.4))')'3H missing dg2/dy: ',expmg2,tv,msize,fact\n! temporary debug ...; calculate contribution to chemical potential\n! allocate(mux(mc))\n! mux=zero\n g2sum=dg2\n do jj=1,mc\n! check than x1*mu1+x2*mu2=g\n! g2sum=g2sum-phres%yfr(jj)*fact*phres%dgval(1,jj,ig2)\n! in dgval(i,j,k) index i=1 means d/y; 2 means d2/dydT, 3 means d2/dydP\n! index j is constituent; index k is property, k=1 is G\n! write(*,710)ig2,jj,phres%dgval(1,jj,1),phres%dgval(1,jj,ig2)/rt,&\n! fact*phres%dgval(1,jj,ig2),&\n! phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2),phres%yfr(jj)\n! phres%dgval(2,jj,1),phres%dgval(2,jj,ig2)/rt,&\n! phres%dgval(2,jj,1)+fact*phres%dgval(2,jj,ig2)\n710 format('3H G2: ',2i2,6(1pe11.3))\n phres%dgval(1,jj,1)=phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ig2)\n phres%dgval(2,jj,1)=phres%dgval(2,jj,1)+fact*phres%dgval(2,jj,ig2)\n enddo\n! do jj=1,mc\n! mux(jj)=g2sum+fact*phres%dgval(1,jj,ig2)\n! enddo! These should be the same!\n! g2sum=zero\n! do jj=1,mc\n! g2sum=g2sum+phres%yfr(jj)*mux(jj)\n! enddo\n! write(*,*)'3H same?: ',dg2,g2sum\n800 continue\n! write(*,19)'3H G9: ',tv,hump,dg2*rt,-dgfdt*rt,-d2g2dt2*rt*tv\n! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2\n! write(*,19)'3H dg2A: ',tv, g2val/rt, one/(one+expg2),&\n! -rg*tv**2*phres%gval(4,1),&\n! -rg*tv**2*d2g2dt2,\n! The Eistein contribution is OK\n! -rg*tv**2*d2geindt2\n! -rg*tv*phres%gval(4,ig2)/(one+expg2),&\n! -rg*tv*((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n! (rt*(one+expg2)**2)\n! write(*,19)'3H dg2B: ',phres%gval(4,ig2)/(one+expg2),&\n! (g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt,&\n! rt*(one+expg2)**2\n! G.T.P is zero\n! G.P.P is zero\n! write(*,19)'3H 2st:',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n! jump here skipping old code above\n!============================================================\n! save Einstein and G2 values in addrec, multiply with RT?\n900 continue\n addrec%propval=zero\n addrec%propval(1)=msize*(gein-dg2)\n addrec%propval(2)=msize*(dgeindt-dgfdt)\n addrec%propval(4)=msize*(d2geindt2-d2g2dt2)\n!\n1000 continue\n return\n! this routine is used when G2 and LNTH are composition dependent\n end subroutine calc_twostate_model1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_twostate_model2\n!\\begin{verbatim}\n subroutine calc_twostate_model2(moded,phres,addrec,lokph,mc,ceq)\n! subroutine calc_twostate_model_nomix(moded,phres,addrec,lokph,mc,ceq)\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! addrec is addition record\n!\n! IN THIS VERSION G2 is treated as a composition independent parameter \n! thus this just handles the Einsten Cp\n! NOTE Einstein LNTH should be composition dependent\n!\n! phres is phase_varres record\n! lokph is phase location\n! mc is number of constitution fractions\n! ceq is current equilibrium record\n implicit none\n integer moded,lokph,mc\n TYPE(GTP_PHASE_ADD), pointer :: addrec\n TYPE(GTP_PHASE_VARRES), pointer :: phres\n TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq\n!\\end{verbatim} %+\n! two state model for extrapolating liquid to low T\n! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d))\n! where d is \"liquid like\" atoms. H is enthalpy to form defects\n! At equilibrium\n!\n! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET\n!\n! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT)\n! DG_d is the enthalpy of forming 1 mole of defects in the glassy state\n!\n!------------------------------\n! The value of Gd for the phase is calculated and added to G\n integer jj,noprop,ig2,ith,extreme,jth,kth\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2\n double precision gein,dgeindt,d2geindt2\n double precision xi,hump\n double precision, parameter :: humpfact=5.0D0\n logical addpermole\n! double precision g2ein,dg2eindt,d2g2eindt2,theta2,dcpl\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1\n double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2\n double precision expmg2p1,fact,g2sum,msize\n double precision, allocatable :: mux(:)\n integer, save :: maxwarnings=0\n! number of properties calculatied\n noprop=phres%listprop(1)-1\n! locate the THET and G2 property record \n ig2=0\n ith=0\n jth=0\n! check if addition is per mole \n if(btest(addrec%status,ADDPERMOL)) then\n addpermole=.TRUE.; msize=phres%abnorm(1)\n! write(*,'(a,i4,l2,1pe12.4)')'3H msize 2-state: ',lokph,addpermole,msize\n else\n addpermole=.FALSE.; msize=one\n endif\n findix: do jj=2,noprop\n! start from 2 as phres%listprop(1) is always G\n if(phres%listprop(jj).eq.addrec%need_property(1)) then\n! current value of THET are stored in phres%gval(1,ith)\n ith=jj\n endif\n enddo findix\n if(ith.eq.0) then\n! write(*,*)'3H Cannot find value for amorphous LNTH'\n if(maxwarnings.lt.20) then\n maxwarnings=maxwarnings+1\n write(*,*)'3H twostatemodel2 no values for amorphous LNTH:',maxwarnings\n endif\n gein=zero; dgeindt=zero; d2geindt2=zero\n goto 1000\n! goto 300\n! gx%bmperr=4367; goto 1000\n endif\n! write(*,*)'3H Using composition independent G2 values, THET=',&\n! phres%gval(1,ith)\n! if(ig2.eq.0) then\n! write(*,*)'3H Cannot find value for G2 two-state parameter'\n! gx%bmperr=4367; goto 1000\n! endif\n!----------------------------------\n! for the moment the composition dependence is ignored\n! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n!------ this THET part copied from calc_einstein\n! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n! kvot=theta/T\n! NOTE the stored value is ln(theta)! !!!\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n! expmkvot=exp(-kvot)\n! ln1mexpkvot=log(one-expmkvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n expmkvot=zero\n ln1mexpkvot=zero\n kvotexpkvotm1=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n endif\n! \n gein=1.5D0*kvot+3.0D0*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T\n d2geindt2=zero\n else\n d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! derivatives with respect to composition dependence of THET\n fact=1.5D0*(one+expmkvot)/(one-expmkvot)*kvot\n do jj=1,mc\n phres%dgval(1,jj,1)=msize*(phres%dgval(1,jj,1)+fact*phres%dgval(1,jj,ith))\n enddo\n! Ignore second derivatives as this seems a small efect, \n!-------------------------- jump here if no THET variable\n! return the values in phres%gval(*,1)\n300 continue\n phres%gval(1,1)=phres%gval(1,1)+msize*gein\n phres%gval(2,1)=phres%gval(2,1)+msize*dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+msize*d2geindt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n!----------------------------------------------------------------\n! skip the 2-state model as G2 included in the ^oG for the endmember\n! goto 1000\n1000 continue\n return\n end subroutine calc_twostate_model2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_twostate_model_endmember\n!\\begin{verbatim}\n subroutine calc_twostate_model_endmember(proprec,g2values,ceq)\n! This calculated G2 (GD in some papers) for a pure endmember\n! No composition dependence\n! Value calculated here added to ^oG for the endmember\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! phres is phase_varres record\n! lokph is phase location\n! ceq is current equilibrium record\n implicit none\n TYPE(gtp_property), pointer :: proprec\n TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq\n double precision g2values(6)\n!\\end{verbatim}\n TYPE(gtp_property), pointer :: propg2\n integer lokfun,typty\n double precision tv,rt,rg,dg2,dgfdt,expg2,expmg2,expmg2p1\n double precision g2val,dg2dt,d2g2dt2,vals(6)\n g2values=zero\n! do not destroy the value of proprec!!\n propg2=>proprec\n! At present %proptype 16 is G2 but can be changed anytime!!\n! However, it will always be called G2 and need_property('G2 ',typty)\n! will return is current index\n call need_propertyid('G2 ',typty)\n! write(*,*)'3H found G2 typty: ',typty\n liq2state: do while(associated(propg2))\n! How to find addrec%need_property ....??\n! if(phres%listprop(jl).eq.addrec%need_property(1)) then\n! ilpx=jl\n! write(*,*)'3H property: ',propg2%proptype\n if(propg2%proptype.eq.typty) goto 77\n propg2=>propg2%nextpr\n enddo liq2state\n write(*,*)'Missing liquid twostate parameter G2'\n gx%bmperr=4399; goto 1000\n! found p \n77 continue\n! calculate G2 value at current T for the endmember\n lokfun=propg2%degreelink(0)\n call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,3(1pe12.4))')'3H G2 endmember: ',vals(1),vals(2),vals(4)\n g2val=vals(1)\n dg2dt=vals(2)\n d2g2dt2=vals(4)\n! \n rt=ceq%rtn\n tv=ceq%tpval(1)\n rg=globaldata%rgas\n! if g2val is positive we are in the amorphous region\n! if g2val is negative we are in the liquid region\n! The if statements here ensure expmg2 is between 1e-60 and 1e+60\n! write(*,'(a,6(1pe12.4))')'3H g2val: ',g2val,dg2dt,-g2val/rt\n if(-g2val/rt.gt.2.0D2) then\n! LIQUID REGION exp(200) >> 1, thus d2g=ln(1+exp(g2val))=g2val\n! and the derivatives are those above. DIVIDED BY RT?\n dg2=g2val/rt\n dgfdt=dg2dt/rt\n d2g2dt2=d2g2dt2/rt\n goto 700\n elseif(-g2val/rt.lt.-2.0D2) then\n! AMORPHOUS REGION: exp(-200)=0; ln(1)=0 and everything is zero\n dg2=zero\n dg2dt=zero\n d2g2dt2=zero\n goto 700\n else\n! intermediate T range, we have to calculate, exp( -200 to +200) is OK\n expmg2=exp(-g2val/rt)\n expg2=one/expmg2\n expmg2p1=expmg2+one\n dg2=log(expmg2p1)\n! write(*,'(a,4(1pe12.4))')'3H intermed: ',g2val/rt,expmg2p1,dg2\n endif\n! write(*,19)'3H gval8: ',g2val/rt,expmg2,dg2\n! write(*,19)'3H dg2: ',tv,g2val,expmg2,dg2\n! write(*,19)'3H G2: ',tv,xi,g2val/rt,expmg2,dg2,dg2*rt\n! NOTE values added to phres%gval(*,1) must be divided by RT\n! G = G - RT*ln(1+exp(-g2/RT))\n! G\n! phres%gval(1,1)=phres%gval(1,1)-dg2\n! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT\n! G.T\n dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/rt\n! dgfdt=dg2+(g2val/tv-dg2dt)/(expg2+one)\n! G.P is zero\n!-------------------------- tentative:\n! d2g2/dt2/(1+exp(g2/RT)+\n! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt\n! G.T.T \n! Fixed sign problem\n! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-&\n d2g2dt2=(d2g2dt2/(one+expg2)-&\n ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n (rt*(one+expg2)**2))/rt\n700 continue\n! return these values to be added to ^oG for the endmember\n! g2values(1)=-g2val/rt\n g2values(1)=-dg2\n! g2values(2)=-dg2dt\n g2values(2)=-dgfdt\n g2values(4)=d2g2dt2\n! write(*,'(a,3(1pe12.4))')'3H g2values: ',g2values(1),g2values(2),g2values(4)\n! No P derivatives (yet)\n! write(*,705)'3H 2SL: ',g2val/rt, dg2, dgfdt, dgfdt, d2g2dt2, tv,&\n! rt, expg2, dg2dt, msize, d2g2dt2*rt\n705 format(a,6(1pe12.4)/8x,6(1pe12.4))\n! each endmember has its own value of G2\n! phres%gval(1,1)=phres%gval(1,1)-msize*dg2\n! phres%gval(2,1)=phres%gval(2,1)-msize*dgfdt\n! phres%gval(4,1)=phres%gval(4,1)+msize*d2g2dt2\n! values of T, \\xi, g, s and cp \n!\n1000 continue\n return\n end subroutine calc_twostate_model_endmember\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_twostate_model_old\n!\\begin{verbatim}\n subroutine calc_twostate_model_old(moded,phres,addrec,lokph,mc,ceq)\n! Failed attempt to decrease the hump when the g2 parameter changes sign\n! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated\n! addrec is addition record\n! phres is phase_varres record\n! lokph is phase location\n! mc is number of constitution fractions\n! ceq is current equilibrium record\n implicit none\n integer moded,lokph,mc\n TYPE(GTP_PHASE_ADD), pointer :: addrec\n TYPE(GTP_PHASE_VARRES), pointer :: phres\n TYPE(GTP_EQUILIBRIUM_DATA), pointer :: ceq\n!\\end{verbatim}\n! two state model for extrapolating liquid to low T\n! DG = d(H-RT) + RT( dln(d)+(1-d)ln(1-d))\n! where d is \"liquid like\" atoms. H is enthalpy to form defects\n! At equilibrium\n!\n! d = exp(-H/RT) / (1 + e(-H/RT) ) is the integrated Einstein Cp -H/R is THET\n!\n! G^liq - G^amorph = G^amorph - RT ln(1+exp(-DG_d/RT)\n! DG_d is the enthalpy of forming 1 mole of defects in the glassy state\n!\n!------------------------------\n! The value of Gd for the phase is calculated and added to G\n integer jj,noprop,ig2,ith,extreme,m4\n! double precision del1,del2,del3,del4,gein,dgeindt,d2geindt2\n double precision gein,dgeindt,d2geindt2\n double precision kvot,expkvot,expmkvot,ln1mexpkvot,kvotexpkvotm1\n double precision g2val,dg2,expg2,expmg2,rt,tv,rg,dg2dt,dgfdt,d2g2dt2\n double precision hump,fq,dfq,d2fq,addq,daddq,d2addq,dd\n! number of properties calculatied\n noprop=phres%listprop(1)-1\n! locate the LNTH and G2 property record \n ig2=0\n ith=0\n findix: do jj=2,noprop\n if(phres%listprop(jj).eq.addrec%need_property(1)) then\n! current values of G2 is stored in phres%gval(1,ig2)\n ig2=jj;\n elseif(phres%listprop(jj).eq.addrec%need_property(2)) then\n! current value of THET are stored in phres%gval(1,ith)\n ith=jj\n endif\n enddo findix\n if(ith.eq.0) then\n write(*,*)'Cannot find value for amorphous LNTH'\n gx%bmperr=4399; goto 1000\n endif\n if(ig2.eq.0) then\n write(*,*)'Cannot find value for G2 two-state parameter'\n gx%bmperr=4399; goto 1000\n endif\n!----------------------------------\n! for the moment the composition dependence is ignored\n! write(*,19)'3H 2no1: ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n!------ this THET part copied from calc_einstein\n! thet is in gval(1,ith), derivatives in dgval(*,ith,*) and d2gval(ith,*)\n! G/RT = 1.5*THET/T + 3*R*LN(exp(THET/T) - 1) \n! NOTE ALL VALUES CALCULATED AS FOR G/RT\n! kvot=theta/T\n! NOTE the stored value is ln(theta! !!!\n kvot=exp(phres%gval(1,ith))/ceq%tpval(1)\n! write(*,70)'3H phres: ',ceq%tpval(1),phres%gval(1,1),phres%gval(2,1),&\n! phres%gval(3,1),phres%gval(4,1),kvot\n! we should be careful with numeric overflow, for small T or large T\n! no risk for overflow for exp(-kvot)\n! expmkvot=exp(-kvot)\n! ln1mexpkvot=log(one-expmkvot)\n if(kvot.gt.1.0D2) then\n! T is very small, kvot very large, exp(kvot) may cause overflow, \n! exp(-kvot) is very small, ln(1-exp(-kvot)) is close to zero\n! exp(kvot) may cause overflow, kvot/(exp(kvot)-1)=\n! kvot*exp(-kvot)/(1-exp(-kvot)) = (1-kvot+kvot**2/2-...)/(1-kvot/2+...) = 1\n extreme=-1\n expmkvot=zero\n ln1mexpkvot=zero\n kvotexpkvotm1=zero\n elseif(kvot.lt.1.0D-2) then\n! T is very big, kvot is very small, exp(-kvot) approch 1, 1-exp(-kvot)=kvot\n! exp(-kvot) is close unity, ln(1-exp(-kvot))=ln(1-(1-kvot+kvot**2/2+...)) =\n! ln(kvot-kvot**2/2+...)=ln(kvot)\n! exp(kvot) is close to unity: exp(kvot)-1 = kvot+kvot**2/2+ ...\n extreme=1\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n else\n! normal range of T and kvot\n extreme=0\n expmkvot=exp(-kvot)\n ln1mexpkvot=log(one-expmkvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n endif\n! \n gein=1.5D0*kvot+3.0D0*ln1mexpkvot\n! write(*,71)'3H Cp E1:',extreme,ceq%tpval(1),gein,ln1mexpkvot,expmkvot,&\n! kvotexpkvotm1\n! first derivative wrt T taking care of overflow\n dgeindt=3.0D0*(ln1mexpkvot-kvotexpkvotm1)/ceq%tpval(1)\n! This is d2G/dT**2/(RT) = -T**2/R*(Einstein Cp/RT) (or rather Cv/RT)\n if(extreme.eq.-1) then\n! take care of overflow at low T\n d2geindt2=zero\n else\n d2geindt2=-3.0D0*kvotexpkvotm1**2/(expmkvot*ceq%tpval(1)**2)\n endif\n! return the values in phres%gval(*,1)\n phres%gval(1,1)=phres%gval(1,1)+gein\n phres%gval(2,1)=phres%gval(2,1)+dgeindt\n! phres%gval(3,1)=phres%gval(3,1)\n phres%gval(4,1)=phres%gval(4,1)+d2geindt2\n! phres%gval(5,1)=phres%gval(5,1)\n! phres%gval(6,1)=phres%gval(6,1)\n addrec%propval(1)=gein\n addrec%propval(2)=dgeindt\n addrec%propval(4)=d2geindt2\n! write(*,71)'3H Cp E3: ',extreme,ceq%tpval(1),gein,dgeindt,d2geindt2\n70 format(a,F7.2,5(1pe12.4))\n71 format(a,i3,1x,F7.2,5(1pe12.4))\n! thet cannot depend on T\n! Missing implem of derivatives wrt comp.dep of thet.\n!-------------------------- two state part DIVIDE BY RT\n! NOTE g2val and derivatives not divided by RT !!\n g2val=phres%gval(1,ig2)\n dg2dt=phres%gval(2,ig2)\n dg2=zero; d2g2dt2=zero\n if(g2val.eq.zero .and. dg2dt.eq.zero) then\n write(*,*)'3H: G2 parameter zero, ignoring twostate model',g2val\n goto 900\n endif\n! write(*,19)'3H +am ',phres%gval(1,1),phres%gval(2,1),phres%gval(4,1)\n19 format(a,6(1pe11.3))\n rt=ceq%rtn\n tv=ceq%tpval(1)\n rg=globaldata%rgas\n! expmg2=exp(-g2val/rt)\n! if(g2val/rt.gt.2.0D2) then\n! expmg2=exp(-g2val/(rt))\n! expg2=one/expmg2\n! elseif(g2val/rt.lt.1e-30) then\n! expmg2=exp(-g2val/(rt))\n! expg2=one/expmg2\n! else\n expmg2=exp(-g2val/(rt))\n expg2=one/expmg2\n! endif\n! dg2=log(one+expmg2)\n dg2=log(one+expmg2)\n! write(*,19)'3H G2: ',g2val/rt,expmg2,dg2,dg2*rt\n! NOTE values added to gval(*,1) must be divided by RT\n! G = G - RT*ln(1+exp(-g2/RT))\n! G\n phres%gval(1,1)=phres%gval(1,1)-dg2\n! (R*ln(1+g2val) + (g2/tv-dg2/dt)/(1+exp(-g2/RT)))/RT\n! G.T\n! dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt)\n dgfdt=(rg*dg2+(g2val/tv-dg2dt)/(expg2+one))/(rt)\n phres%gval(2,1)=phres%gval(2,1)-dgfdt\n! G.P is zero\n!-------------------------- tentative:\n! d2g2/dt2/(1+exp(g2/RT)+\n! ((g2/tv)**2+(dg2/dt)**2-2*g2/tv*dg2/dt)*exp(g2/rt)/((1+exp(g2/RT)))**2/rt\n! G.T.T \n! This what my derivation gives:\n! d2g2dt2=(phres%gval(4,ig2)/(one+expg2)+&\n! Qing proposal, works after fixing the sign also below\n d2g2dt2=(phres%gval(4,ig2)/(one+expg2)-&\n! This is which is the same as TC\n! d2g2dt2=(-phres%gval(4,ig2)/(one+expg2)+&\n ((g2val/tv)**2+(dg2dt)**2-2.0D0*(g2val/tv)*dg2dt)*expg2/&\n (rt*(one+expg2)**2))/rt\n! Maybe the error is here !! YES now it works!\n phres%gval(4,1)=phres%gval(4,1)+d2g2dt2\n! phres%gval(4,1)=phres%gval(4,1)-d2g2dt2\n! G.T.P is zero\n! G.P.P is zero\n! This is my addition to the two-state model to control the size of the hump\n! goto 1000\n hump=1.0D0\n m4=2\n fq=g2val/rt\n dfq=dg2dt/rt-fq/tv\n d2fq=phres%gval(4,ith)/rt-2.0D0/(rt*tv)*(dg2dt+g2val/tv)\n dd=one+(2.0D-1*fq)**m4\n addq=hump/dd\n daddq=-m4*hump*fq**(m4-1)*dfq/dd**2\n d2addq=-m4*hump*fq**(m4-2)*((m4-1)*dfq**2+fq*d2fq)/dd**2+&\n 2.0d0*m4**2*hump*fq**(2*m4-2)*dfq**2/dd**3\n! ignoring T dependence\n d2addq=5.0D-5/dd\n phres%gval(1,1)=phres%gval(1,1)+addq\n phres%gval(2,1)=phres%gval(2,1)+daddq\n phres%gval(4,1)=phres%gval(4,1)+d2addq\n write(*,800)'3H added hump',tv,fq,dd,-rg*tv**2*d2addq\n800 format(a,6(1pe11.3))\n! save local values divided by RT?\n900 continue\n addrec%propval=zero\n addrec%propval(1)=gein-dg2\n addrec%propval(2)=dgeindt-dgfdt\n addrec%propval(4)=d2geindt2-d2g2dt2\n1000 continue\n return\n end subroutine calc_twostate_model_old\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_debyecp\n!\\begin{verbatim}\n subroutine create_debyecp(addrec)\n! enters a record for the debye model\n implicit none\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty\n! reserve an addition record\n allocate(addrec)\n! Set the type of addition and look for needed parameter properties\n addrec%type=debyecp\n addrec%status=0\n allocate(addrec%need_property(1))\n call need_propertyid('LNTH ',typty)\n if(gx%bmperr.ne.0) goto 1000\n addrec%need_property(1)=typty\n! missing things for the actual Cp function ...\n!\n write(kou,*)'Not implemented yet'; gx%bmperr=4078\n!\n1000 continue\n return\n end subroutine create_debyecp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_debyecp\n!\\begin{verbatim}\n subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq)\n! calculates Mauro Debye contribution\n! NOTE: values for function not saved, should be done to save calculation time.\n! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2\n! phres: pointer, to phase\\_varres record\n! lokadd: pointer, to addition record\n! lokph: integer, phase record \n! mc: integer, number of constituents\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer moded,lokph,mc\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_phase_varres) :: phres\n!\\end{verbatim}\n integer ith,noprop\n! value of THET and derivatives have type ??\n noprop=phres%listprop(1)-1\n! write(*,*)'3H cmi 2: ',noprop,(phres%listprop(i),i=1,noprop)\n! Find thet, index stored in need_property(1)\n do ith=2,noprop\n if(phres%listprop(ith).eq.lokadd%need_property(1)) goto 100\n enddo\n write(*,*)'3H No Debye temperature LNTH',lokph\n gx%bmperr=4336; goto 1000\n100 continue\n write(*,*)'3H Deby low T heat capacity model not implemented'\n gx%bmperr=4078\n1000 continue\n return\n end subroutine calc_debyecp\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_diffusion\n!\\begin{verbatim}\n subroutine create_diffusion(addrec,lokph,text)\n implicit none\n integer lokph\n character text*(*)\n type(gtp_phase_add), pointer :: addrec\n!\\end{verbatim} %+\n integer typty,jj,last,is,js,ks,loksp,loksp2,ll,nsl\n character typ*24,quest*38,spname*24\n double precision alpha\n type(gtp_diffusion_model), pointer :: diffcoef\n logical once\n! initiate\n quest='Dependent constituent in sublattice X:'\n! reserve an addition record\n allocate(addrec)\n! nullify pointer to next addition\n nullify(addrec%nextadd)\n addrec%status=0\n! Set the type of addition and look for needed parameter properties\n addrec%type=diffcoefs\n! Some information is needed\n last=1\n100 continue\n call gparcdx('Type of diffusion model: ',text,last,1,typ,'SIMPLE',&\n '?Amend diffusion')\n call capson(typ)\n! write(*,*)'3H typ: ',index('MAGNETIC',trim(typ)),trim(typ)\n if(index('SIMPLE',trim(typ)).eq.1) then\n write(*,*)'Simple diffusion model selected'\n jj=2\n elseif(index('MAGNETIC',trim(typ)).eq.1) then\n write(*,*)'Magnetic diffusion model selected'\n jj=3\n else\n write(*,*)'Dilute diffusion model selected'\n jj=1\n endif\n! allocate diffusion record for data\n allocate(addrec%diffcoefs)\n diffcoef=>addrec%diffcoefs\n! addrec%diffcoefs=>diffcoef\n! ???????????? must we have a diffusion record for each composition set??\n diffcoef%difftypemodel=jj\n diffcoef%status=0\n nullify(diffcoef%nextcompset)\n! dependent component for each sublattice\n nsl=phlista(lokph)%noofsubl\n allocate(diffcoef%depcon(nsl))\n is=1\n do ll=1,nsl\n quest(37:37)=char(ll+ichar('0'))\n once=.true.\n200 continue\n loksp=phlista(lokph)%constitlist(is)\n spname=splista(loksp)%symbol\n call gparcdx(quest,text,last,1,typ,spname,'?Amend diffusion')\n call find_species_record(typ,loksp2)\n if(gx%bmperr.ne.0) then\n if(once) then\n once=.false.\n write(*,*)'No such species'\n else\n goto 1000\n endif\n endif\n! we must also check this species is a constient in the sublattice!!\n if(loksp2.ne.loksp) then\n do js=is,is+phlista(lokph)%nooffr(ll)-1\n if(loksp2.eq.phlista(lokph)%constitlist(js)) goto 250\n enddo\n write(*,*)'This species is not a constituent of this sublattice'\n if(once) goto 200\n gx%bmperr=4399; goto 1000\n endif\n250 continue\n! is is always the first constituent in each sublattice\n diffcoef%depcon(ll)=loksp2\n is=is+phlista(lokph)%nooffr(ll)\n enddo\n! for jj=3 we must ask for ALPHA and ALPHA2 (with species names)\n if(jj.eq.3) then\n allocate(diffcoef%alpha(phlista(lokph)%nooffr(2)))\n call gparrdx('Value of ALPHA: ',text,last,alpha,0.3D0,'?Amend diffusion')\n diffcoef%alpha(1)=alpha\n if(nsl.eq.2 .and. phlista(lokph)%nooffr(2).gt.1) then\n ks=2\n is=phlista(lokph)%nooffr(1)\n loop: do ll=1,phlista(lokph)%nooffr(2)\n loksp=phlista(lokph)%constitlist(is+ll)\n! if constituent is Va ignore!!\n if(.not.btest(splista(loksp)%status,SPVA)) then\n spname=splista(loksp)%symbol\n quest='Value of ALPHA2&'//trim(spname)\n call gparrdx(quest,text,last,alpha,1.0D0,'?Amend diffusion')\n if(ks.le.size(diffcoef%alpha)) diffcoef%alpha(ks)=alpha\n ks=ks+1\n endif\n enddo loop\n endif\n! write(*,*)'3H alpha: ',diffcoef%alpha\n endif\n! write(*,*)'3H depcon: ',diffcoef%depcon\n! This addition may use MQ, MF, MG and maybe more\n allocate(addrec%need_property(3))\n call need_propertyid('MQ ',typty)\n addrec%need_property(1)=typty\n call need_propertyid('MF ',typty)\n addrec%need_property(2)=typty\n call need_propertyid('MG ',typty)\n addrec%need_property(3)=typty\n if(gx%bmperr.ne.0) goto 1000\n write(*,*)'Diffusion record created'\n! write(kou,*)'Not implemented yet'; gx%bmperr=4078\n1000 continue\n return\n end subroutine create_diffusion\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine diffusion_onoff\n!\\begin{verbatim}\n subroutine diffusion_onoff(phasetup,bitval)\n! switches the bit which calculates diffusion coefficients on/off\n! if bitval 0 calculate is turned on, 1 turn off\n implicit none\n integer bitval\n type(gtp_phasetuple) :: phasetup\n!\\end{verbatim} %+\n integer lokph\n type(gtp_phase_add), pointer :: addrec\n lokph=phasetup%lokph\n addrec=>phlista(lokph)%additions\n loop: do while(associated(addrec))\n if(addrec%type.eq.DIFFCOEFS) then\n if(bitval.eq.0) then\n addrec%diffcoefs%status=ibclr(addrec%diffcoefs%status,0)\n else\n addrec%diffcoefs%status=ibset(addrec%diffcoefs%status,0)\n endif\n exit loop\n endif\n enddo loop\n1000 continue\n return\n end subroutine diffusion_onoff\n\n !/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_diffusion\n!\\begin{verbatim}\n subroutine calc_diffusion(moded,phres,lokadd,lokph,mc,ceq)\n! calculates diffusion coefficients\n! NOTE: values for function not saved, should be done to save calculation time.\n! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2\n! phres: pointer, to phase\\_varres record\n! lokadd: pointer, to addition record\n! lokph: integer, phase record \n! mc: integer, number of constituents\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer moded,lokph,mc\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_phase_varres) :: phres\n!\\end{verbatim} %+\n type(gtp_diffusion_model), pointer :: diffcoef\n diffcoef=>lokadd%diffcoefs\n! write(*,*)'Diffusion phase and model: ',trim(phlista(lokph)%name),&\n! diffcoef%difftypemodel\n! write(*,*)'Dependent const: ',diffcoef%depcon\n! write(*,*)'Alpha: ',diffcoef%alpha\n! write(*,*)'Calculation on the diffusion record not implemented'\n1000 continue\n return\n end subroutine calc_diffusion\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_diffusion_matrix\n!\\begin{verbatim}\n subroutine get_diffusion_matrix(phtup,mdm,dcval,ceq)\n! extracts calculated diffusion coefficients for a phase tuple\n! phtup phase tuple\n! dcval diffusion matrix\n! ceq: pointer, to gtp_equilibrium_data\n implicit none\n integer mdm\n double precision dcval(mdm,*)\n TYPE(gtp_phasetuple) :: phtup\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_phase_add), pointer :: lokadd\n TYPE(gtp_phase_varres) :: phres\n1000 continue\n return\n end subroutine get_diffusion_matrix\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_addition\n!\\begin{verbatim}\n subroutine list_addition(unit,CHTD,phname,ftyp,lokadd)\n! list description of an addition for a phase on unit\n! used when writing databases files and phase data\n implicit none\n integer unit,ftyp\n! CHTD is letter for TDB files TYPE_DEFINITION ... suck\n character CHTD*1,phname*(*)\n TYPE(gtp_phase_add), pointer :: lokadd\n!\\end{verbatim} %+\n integer ip\n TYPE(tpfun_expression), pointer :: exprot\n character line*256,tps(2)*3,chc*2\n double precision ff\n!\n if(unit.eq.kou) then\n chc=' '\n else\n chc='$ '\n endif\n!\n! if(.not.btest(lokadd%status,ADDHAVEPAR)) then\n! skip additions with no parameters for this phase\n! REMOVED THIS because it creates confusion\n! If parameters added before addition specified then ADDHAVEPAR is not set\n! write(*,*)chc,'3H No parameters for addition: ',&\n! trim(additioname(lokadd%type))\n! goto 1000\n! else\n! write(*,*)'3H status word for this addition: ',lokadd%status\n! endif\n addition: select case(lokadd%type)\n case default\n write(unit,*)'Unknown addtion type: ',phname,lokadd%type\n case(indenmagnetic) ! Inden magnetic model\n if(ftyp.eq.2) then\n! TDB file: I do not think I have saved the enthalpy factor, bcc (-1) it is 0.4\n ff=0.28D0\n if(lokadd%aff.eq.-1) ff=0.4D0\n write(unit,88)CHTD,phname(1:len_trim(phname)),lokadd%aff,ff\n88 format(' TYPE_DEFINITION ',a,' GES A_P_D ',a,' MAGNETIC ',i3,F8.4,'!')\n else\n write(unit,100)lokadd%aff\n100 format(2x,'+ Magnetic model by Inden, anti-ferromagnetic factor:',i3,/&\n 4x,'Magnetic function below the ordering temperature TC',&\n ' with TAO=T/TC:')\n tps(1)='TAO'\n tps(2)='err'\n ip=1\n line=' '\n exprot=>lokadd%explink(1)\n call ct1wfn(exprot,tps,line,ip)\n call wrice(unit,4,8,78,line(1:ip))\n write(unit,110)\n110 format(4x,'Magnetic function above the ordering temperature TC ',&\n 'with TAO=T/TC:')\n ip=1\n line=' '\n exprot=>lokadd%explink(2)\n call ct1wfn(exprot,tps,line,ip)\n call wrice(unit,4,8,78,line(1:ip))\n! write current values of gmagn and values\n! write(unit,120)(lokadd%propval(ip),ip=1,4)\n!120 format(' Curr. contrib. G, G.T etc:',4(1pe12.4))\n endif\n!---------------------------------------------\n case(debyecp) ! Debye Cp model\n write(unit,200)chc\n200 format(a,'+ Debye Cp model, not implemented yet')\n!---------------------------------------------\n case(xiongmagnetic) ! Inden-Qing-Xiong\n write(unit,300)chc,lokadd%status\n300 format(a,'+ Inden magnetic model modified by Qing and Xiong ',Z8/&\n 4x,'with separate Curie and Neel temperatures.'/&\n 4x,'Magnetic function below the ordering temperature TC ',&\n ' with TAO=T/TC:')\n tps(1)='TAO'\n tps(2)='err'\n ip=1\n line=' '\n exprot=>lokadd%explink(1)\n call ct1wfn(exprot,tps,line,ip)\n call wrice(unit,4,8,78,line(1:ip))\n write(unit,110)\n ip=1\n line=' '\n exprot=>lokadd%explink(2)\n call ct1wfn(exprot,tps,line,ip)\n call wrice(unit,4,8,78,line(1:ip))\n!---------------------------------------------\n case(einsteincp) ! Einstein Cp model\n write(unit,400)chc\n400 format(a,'+ Einstein Cp model: 1.5R*exp(LNTH(x)) +',&\n ' 3RT*ln(1-exp(-exp(LNTH(x))/T))')\n!---------------------------------------------\n case(elasticmodel1) ! Elastic model 1\n write(unit,500)\n500 format(1x,'+ Elastic model 1, with P interpreted as a force in',&\n ' the X direction.')\n!---------------------------------------------\n case(twostatemodel1) ! Liquid two state model including Einstein\n write(unit,510)chc,chc\n510 format(a,'+ Liquid 2 state model: G(liq)-RT*ln(1+exp(-G2(x,T)/RT))'/&\n a,'+ Einstein Cp model: 1.5R*exp(LNTH(x)) ',&\n '+ 3RT*ln(1-exp(-exp(LNTH(x))/T))')\n!---------------------------------------------\n case(volmod1) ! Volume model 1\n write(unit,520)chc\n520 format(a,'+ Volume model P*V0(x)*exp(VA(x,T))')\n!---------------------------------------------\n! case(crystalbreakdownmod) ! Crystal breakdown model UNUSED, EET not listed\n! write(unit,530)chc\n!530 format(a,'+ Crystal breakdown model used above current value of CBT')\n!---------------------------------------------\n case(secondeinstein) ! Second Einstein Cp contribution\n write(unit,540)chc\n540 format(a,'+ Second Einstein: DCP2(x)*RT*ln(exp(ln(THT2(x))/T)-1)')\n!---------------------------------------------\n case(schottkyanomaly) ! Schottky Anomaly\n write(unit,550)chc\n550 format(a,'+ Schottky anomaly DSCH(x)*RT*ln(1+exp(-ln(TSCH(x))/T)) ')\n!---------------------------------------------\n! THIS MODEL IS OBSOLETE\n case(twostatemodel2) ! Liquid two state model with fix G2 and Einstein\n write(unit,511)chc,chc\n511 format(a,' + wrong Liquid 2 state model: G(liq)-RT*ln(1+exp(-G2(T)/RT))'/&\n a,' + Einstein Cp model: 1.5R*exp(LNTH(x)) ',&\n '+ 3RT*ln(1-exp(exp(LNTH(x))/T))')\n!---------------------------------------------\n end select addition\n1000 continue\n return\n end subroutine list_addition\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_addition_values\n!\\begin{verbatim}\n subroutine list_addition_values(unit,phres)\n! lists calculated values for this addition\n! Used for the command CALCULATE PHASE to inform about additions\n implicit none\n integer unit\n TYPE(gtp_phase_varres), pointer :: phres\n!\\end{verbatim}\n integer lokph,j1\n TYPE(gtp_phase_add), pointer :: addrec\n!\n lokph=phres%phlink\n addrec=>phlista(lokph)%additions\n do while(associated(addrec))\n! write(lut,77)addrec%type,(addrec%propval(j1),j1=1,4)\n77 format('Addition type ',i2,': ',4(1pe12.4))\n! ignore additions without parameters\n if(btest(addrec%status,ADDHAVEPAR)) &\n write(lut,78)additioname(addrec%type),(addrec%propval(j1),j1=1,4)\n78 format('Addition/RT ',a,':',4(1pe10.2))\n addrec=>addrec%nextadd\n enddo\n1000 continue\n return\n end subroutine list_addition_values\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_database_ternary\n!\\begin{verbatim}\n subroutine set_database_ternary(line)\n! separate a database line to parts to add a ternary extrapolation method\n implicit none\n character line*(*)\n! transform a database line with one or more ternary extrapolation methods\n! text is \"phase-name species1 species2 species3 mode (mabe several)\n!\\end{verbatim}\n integer lokph,ip,jp,iph,lcs\n character phase*24,species(3)*24,tkmode*6\n write(*,'(a,a,a)')'3H in set_database_ternary: \"',trim(line),'\"'\n! split line in individual parts, phase, species, tkmode\n ip=index(line,' ')\n phase=line(1:ip)\n call find_phase_by_name(phase,iph,lcs)\n if(gx%bmperr.ne.0) then\n write(*,*)'3H bad phase name ',trim(phase),' for ternary extrapolation'\n goto 1000\n endif\n lokph=phases(iph)\n do while(line(ip:ip).eq.' ')\n ip=ip+1\n enddo\n100 continue\n! only one space between constituents\n jp=index(line(ip:),' ')\n species(1)=line(ip:ip+jp-1)\n ip=ip+jp\n! A special case is for setting all ternaries as Kohler. Maybe simplest\n! to loop through all constituents and call add_ternary for each\n if(species(1)(1:1).eq.'*') then\n species(2)=' '\n species(3)=' '\n tkmode='KKK'\n write(*,*)'3H Setting all ternaries as Kohler not yet implemented'\n! Simplest maybe to loop though all ternaries and call\n! call add_ternary_extrapol_method(lokph,tkmode,species)\n! for each ...\n goto 1000\n endif\n! write(*,*)'3H after species 1: \"',trim(line(ip:)),'\"'\n jp=index(line(ip:),' ')\n species(2)=line(ip:ip+jp-1)\n ip=ip+jp\n! write(*,*)'3H after species 2: \"',trim(line(ip:)),'\"'\n jp=index(line(ip:),' ')\n species(3)=line(ip:ip+jp-1)\n ip=ip+jp\n! write(*,*)'3H after species 3: \"',trim(line(ip:)),'\"'\n jp=index(line(ip:),' ')\n tkmode=line(ip:ip+jp-1)\n! possibly there is a ; after the tkmode, remove it.\n lcs=index(tkmode,';')\n if(lcs.gt.0) then\n tkmode(lcs:)=' '\n endif\n! write(*,*)'3H TernaryXpol tkmode \"',tkmode,'\"'\n! write(*,77)trim(phlista(lokph)%name),trim(species(1)),trim(species(2)),&\n! trim(species(3)),tkmode\n77 format('3H call add_ternary: ',a,1x,a,1x,a,1x,a,1x,a)\n150 continue\n call add_ternary_extrapol_method(lokph,tkmode,species)\n! there can be several ternary mode in line ...\n! write(*,*)'3H back from add_ternary_extrapolation_method'\n if(gx%bmperr.eq.4051) then\n write(*,*)'3H Ternary extrapolation ignored as a constituent not present'\n gx%bmperr=0\n endif\n ip=ip+jp\n jp=len_trim(line)\n if(jp.gt.ip) then\n! skip spaces\n do while(line(ip:ip).eq.' ')\n ip=ip+1\n enddo\n if(line(ip:ip).ne.'!') then\n! write(*,*)'3H one more ternary: \"',trim(line(ip:)),'\"'\n goto 100\n endif\n endif\n!\n1000 continue\n return\n end subroutine set_database_ternary\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine add_ternary_extrapol_method\n!\\begin{verbatim}\n! subroutine add_ternary_extrapol_method(lokph,tkmode,species)\n subroutine add_ternary_extrapol_method(lokph,tkmode,species)\n! add a Toop or Kohler extrapolation method for a ternary subsystem to a phase\n! interactive or from database\n implicit none\n integer lokph\n character tkmode*(*)\n! mode is KKK, TiTiK, TiTjTk etc. with i j k integers 1, 2 or 3, TKM as captial \n! Complicated ...\n!\\end{verbatim}\n! conx is the constituent index in the phase\n! integer, parameter :: talloc=2\n integer jj,kk,loksp,conx(3),done,conix,uniqid\n type(gtp_endmember), pointer :: endmem\n type(gtp_interaction),pointer :: intrec12,intrec13,intrec23,intrec\n type(gtp_interaction),pointer :: intrec1,intrec2\n type(gtp_tooprec), pointer :: newtoop\n character dummy*24,xmode(3)*1,ch1*1,species(3)*24\n character amend*128\n! ktorg has : element order, fraction index, Took/Koler spec\n!\n integer xter3(3),toopcon(3),conind(3),nobin,tch\n logical checkdup,saveamend,onlym\n! for debugging\n integer nextmethod\n integer aheremethod12, aheremethod13,aheremethod23\n! this is incremented by 1 each time a record is created in any phase\n! integer, save ::uniqid=0\n!\n!\n tch=5\n write(*,8)trim(species(1)),trim(species(2)),trim(species(3)),&\n tkmode,trim(phlista(lokph)%name)\n! if(tch.ge.3) write(*,8)trim(species(1)),trim(species(2)),trim(species(3)),&\n! tkmode,trim(phlista(lokph)%name)\n8 format('3H add_ternary_extrapol ',a,' ',a,' ',a,' using ',a,' in ',a)\n if(phlista(lokph)%noofsubl.gt.1) then\n write(*,*)'3H Kohler/Toop not allowed for phases with sublattices'\n gx%bmperr=4399; goto 1000\n endif\n if(associated(phlista(lokph)%disordered)) then\n write(*,*)'3H Kohler/Toop not allowed for phases with disordered set'\n gx%bmperr=4399; goto 1000\n endif\n! A special case when all ternaries are set as Kohler ....\n! Note, the order of species will changed below but the\n! original amend text will be saved in one of the tooprec records for output\n if(trim(tkmode).eq.'KKK') then\n amend=trim(phlista(lokph)%name)//' TERNARY_EXTRA '//&\n ' '//trim(species(1))//' '//trim(species(2))//&\n ' '//trim(species(3))//' '//tkmode//' '\n! no final ! as list on TDB file may include several extrapol\n write(*,*)'3H Executing KKK amend ',trim(amend)!\n endif\n!\n!----------------------------------- to be considered \n! The asymmetric method is given in the order of binaries A-B, A-C and B-C\n! by 3 letters T, K or M. \n! The letter T must be followed by a number 1ndicating which of the 3\n! constituents that is the Toop element, for example T1T1K\n! means the first constituent is Toop when extrapolating A-B and A-C whereas\n! the binary A-B extrapolates is Kohler. Examples:\n! T1T1K means A-B and A-C is Toop with A as Toop and B-C is Kohler\n! KKK means Kohler by all\n! T1KT1 is illegal as A is not part of the (last) BC binary.\n! T2KT2 means A-B and B-C is Toop with B as toop and B-C is Kohler\n! T3T3K is wrong as A-B cannot have C as Toop element\n! T1KT1 is wrong as B-C cannot have A as Toop element\n! T1T3T2 has A as Toop in A-B, C as Toop in A-C and B as Toop in B-C\n! T1MM has Toop for A-B and ;uggianu for A-C and B-C\n! The relevant information is stored locally for each binary A-B, A-C and B-C\n! \n! this routine in gtp3X stores the asymmetry data in the asymmetry record' \n!\n! modified 111225/BoS to use subroutine set_ternary_asymmetry\n! also used when from reading from TDB/XTDB file\n call capson(species(1))\n call capson(species(2))\n call capson(species(3))\n call capson(tkmode)\n amend=trim(phlista(lokph)%name)//' '//trim(species(1))//' '//&\n trim(species(2))//' '//trim(species(3))//' '//trim(tkmode)//' ! '\n write(*,77)trim(amend)\n77 format('3H calling set_ternary_asymmetry in gtp3XQ with'/'\"',a,'\"')\n!\n! write(*,*)'3H This subroutine add_ternary_extrapol_method does not work yet'\n! gx%bmperr=4399; goto 1000\n!\n call set_ternary_asymmetry(amend)\n goto 1000\n!\n! code below redundant ------------------------------------\n!\n! For each binary the constituent indices are stored, indicating in the\n! and if any of them is a Toop element and if the third elemt is Kohler\n! A constituent can be Toop or Kohler in different ternaries\n!\n xter3=0; toopcon=0; jj=1; onlym=.TRUE.\n!---------------------------------------------------------------\n tkmodel: do kk=1,3\n! Check only Ti, K and M in tkmode, to simplfy indexing copy to xmode(3)*1\n! For a Toop constituent save index in toopcon\n! The code here is messy because I have had different ideas some redundant code\n xmode(kk)=tkmode(jj:jj)\n jj=jj+1\n if(.not.(xmode(kk).eq.'T' .or. xmode(kk).eq.'K' .or. &\n xmode(kk).eq.'M')) then\n write(*,*)'3H only letters T, K or M allowed for extrapolations: ',&\n tkmode\n gx%bmperr=4399; goto 1000\n endif\n if(xmode(kk).eq.'T') then\n! this converts ascii value to integer, subtract ascii value of character 0\n toopcon(kk)=ichar(tkmode(jj:jj))-ichar('0')\n jj=jj+1\n if(toopcon(kk).le.0 .or. toopcon(kk).gt.3) then\n write(*,*)'3H extrapolation T must be followed by intger 1, 2 or 3'\n gx%bmperr=4399; goto 1000\n endif\n! binary jj=1 j=2 jj=3\n! if kk=1: A-B A is Toop; B is Toop; illegal\n! kk=2: A-C A is Toop; illegal C is Toop \n! kk=3; B-C illegal B is Toop C is Toop \n if(kk.eq.1 .and. toopcon(kk).eq.3) then\n write(*,*)'3H illegal Toop constituent',kk,toopcon(kk)\n gx%bmperr=4399; goto 1000\n elseif(kk.eq.2 .and. toopcon(kk).eq.2) then\n write(*,*)'3H illegal Toop constituent',kk,toopcon(kk)\n gx%bmperr=4399; goto 1000\n elseif(kk.eq.3 .and. toopcon(kk).eq.1) then\n write(*,*)'3H illegal Toop constituent',kk,toopcon(kk)\n gx%bmperr=4399; goto 1000\n endif\n! Set that for ternary kk the Toop element is toopcon(kk)\n if(tch.ge.3) write(*,*)'3H Toop xter3 ',kk,' is : ',toopcon(kk)\n xter3(kk)=toopcon(kk)\n onlym=.FALSE.\n elseif(xmode(kk).eq.'K') then\n! the binary kk has Kohler method for 3rd element, save its negative value\n onlym=.FALSE.\n if(kk.eq.1) then\n! binary A-B has 3rd element as Kohler\n xter3(kk)=-3\n elseif(kk.eq.2) then\n! binary A-C has 2nd element as Kohler\n xter3(kk)=-2\n else\n! binary B-C has 1st element as Kohler\n xter3(kk)=-1\n endif\n if(tch.ge.3) write(*,*)'3H Kohler xter3 ',kk,' is : ',xter3(kk)\n! there is no 'else'\n! else\n endif\n enddo tkmodel\n!----------------------\n if(onlym) then\n write(*,'(a)')'3H All species have Muggianu extrapolation by default'\n goto 1000\n endif\n!----------------------------\n! find the 3 asymmetric constituents, store their constituent index in conind\n conx=0\n! write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H looking for constituents: ',conx,&\n! xter3,xmode\n all3: do jj=1,3\n call find_species_record_noabbr(species(jj),loksp)\n if(gx%bmperr.ne.0) then\n! needed for mqmqma model ... they have a number -Qij which may vary\n! write(*,*)'3H Constituent search allowing abbreviations'\n gx%bmperr=0\n call find_species_record(species(jj),loksp)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! check if species a constituent and save constinuent index in ktorder\n isconst: do kk=1,size(phlista(lokph)%constitlist)\n! write(*,'(a,5i5)')'3H constituent?',jj,kk,&\n! phlista(lokph)%constitlist(kk),loksp\n if(loksp.eq.phlista(lokph)%constitlist(kk)) then\n! element jj in the ternary has constituent index kk\n conx(jj)=kk\n if(tch.ge.3) write(*,'(a,2i4,2x,2i4)')'3H conx ',jj,kk,&\n phlista(lokph)%constitlist(kk),loksp\n! we found the constituent, take nest one\n cycle all3\n endif\n enddo isconst\n! the loop for constituents did not find the element\n write(*,*)'3H no such constituent: ',jj,species(jj)\n gx%bmperr=4052; goto 1000\n enddo all3\n!\n if(tch.ge.3) write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H found all const: ',conx,&\n xter3,xmode\n if(conx(1).eq.conx(2) .or. conx(1).eq.conx(3) .or. conx(2).eq.conx(3)) then\n write(*,*)'3H Same element twice, not a ternary!'\n gx%bmperr=4399; goto 1000\n endif\n!------------------------------- Kohler OK above\n! Rearrange in the order of the fraction indices\n Kohler: do kk=1,3\n if(xter3(kk).lt.0) xter3(kk)=-conx(-xter3(kk))\n enddo Kohler\n!-------------------------------\n! Replace any Toop constituents with its constiuent incex\n Toop: do kk=1,3\n if(xter3(kk).gt.0) xter3(kk)=conx(xter3(kk))\n enddo Toop\n!----------------------\n! convert toopcon to fraction index, those are in conx \n do kk=1,3\n if(toopcon(kk).gt.0) toopcon(kk)=conx(toopcon(kk))\n enddo\n! write(*,'(a,10i4)')'3H toopcon as fraction indices: ',toopcon\n!-------------------------------\n!\n if(tch.ge.3) write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H Replaced by index: ',conx,&\n xter3,xmode\n! Kohler OK here\n!\n! sort constituents in constituent order\n! xter3 here is either the toopcon or the Kohler constituent index\n! according to the original order the elements were entered\n! if 1>2 change order\n if(conx(1).gt.conx(2)) then\n jj=conx(1); conx(1)=conx(2); conx(2)=jj\n dummy=species(1); species(1)=species(2); species(2)=dummy\n! But this change means the order of the binaries changes from/to\n! A B C is A-B A-C B-C\n! B A C is B-A B-C A-C fisrt same, shift 2 and 3 \n! these rearrange the binaroes .... different order\n jj=xter3(2); xter3(2)=xter3(3); xter3(3)=jj\n ch1=xmode(2); xmode(2)=xmode(3); xmode(3)=ch1\n jj=toopcon(2); toopcon(2)=toopcon(3); toopcon(3)=jj\n if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 1: ',conx,&\n xter3,toopcon,xmode\n endif\n! check if 2>3\n if(conx(2).gt.conx(3)) then\n jj=conx(2); conx(2)=conx(3); conx(3)=jj\n dummy=species(2); species(2)=species(3); species(3)=dummy\n! B A C B-A B-C A-C\n! B C A B-C B-A C-A shift first and second, third the same\n jj=xter3(1); xter3(1)=xter3(2); xter3(2)=jj\n ch1=xmode(1); xmode(1)=xmode(2); xmode(2)=ch1\n jj=toopcon(1); toopcon(1)=toopcon(2); toopcon(2)=jj\n if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 2: ',conx,&\n xter3,toopcon,xmode\n endif\n! now 3 > (1,2) check again if 1>2\n if(conx(1).gt.conx(2)) then\n jj=conx(1); conx(1)=conx(2); conx(2)=jj\n dummy=species(1); species(1)=species(2); species(2)=dummy\n! B C A same shift as first\n! C B A\n jj=xter3(2); xter3(2)=xter3(3); xter3(3)=jj\n ch1=xmode(2); xmode(2)=xmode(3); xmode(3)=ch1\n jj=toopcon(2); toopcon(2)=toopcon(3); toopcon(3)=jj\n! if(tch.ge.3) write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 3: ',conx,&\n write(*,'(a,3(3i3,1x),3a2)')'3H Rearranged step 3: ',conx,&\n xter3,toopcon,xmode\n endif\n!**************** redundant after here\n write(*,'(\"3H The constituents in alphabetical order: \",3i3)')conx\n! The conx order is the (alphabetical) order of the constituents\n! The endmembers are in that order. The interactions are not ordered\n! xter3 is the original input order, conx is in alphabetical order\n! toopcon is the toop element in each, zero if none\n! Replace any Koher extrapolation with its constituent index\n! Kohler2: do kk=1,3\n! if(xter3(kk).lt.0) xter3(kk)=-conx(-xter3(kk))\n! enddo Kohler2\n! Replace any Toop constituents with its constiuent incex .... does not work\n! Toop2: do kk=1,3\n! if(xter3(kk).gt.0) xter3(kk)=conx(xter3(kk))\n! enddo Toop2\n! write(*,'(a,3i3,1x,3i3,1x,3a2)')'3H Sorted xter3 and conx: ',conx,&\n! xter3,xmode\n!---------------------------------------------------------\n! now we have to find the interaction records\n! Some binary parameter in the ternary may not have an interaction record. \n! there should be a check if this ternary is a duplicate ...!!!\n! Phases with one sublattice are always disordered and has no disordered link\n! Try to give reasonable error messages\n endmem=>phlista(lokph)%ordered\n if(.not.associated(endmem)) then\n write(*,*)'3H No endmembers or interaction in this phase!'\n gx%bmperr=4399; goto 1000\n endif\n! nullify pointers from binary interactions\n nullify(intrec1); nullify(intrec2)\n nullify(intrec12); nullify(intrec13); nullify(intrec23)\n!\n! look for endmember with lowest constituent index (they are ordered that way)\n if(tch.ge.3) write(*,'(a,3i3)')'3H search endmemembers: ',conx(1)\n! write(*,'(a,10I4)')'3H endmemfraclinks: ',endmem%fraclinks(1,1)\n! write(*,*)'3H where is line with 5 numbers written?'\n conix=1\n!*************** before or after here ?\n if(tch.ge.3) write(*,*)'3H start findem loop'\n findem: do while(associated(endmem))\n! write(*,'(a,3i3)')'3H endmem2: ',conix,endmem%fraclinks(1,1),conx(conix)\n if(endmem%fraclinks(1,1).eq.conx(conix)) then\n! we found the endmember with conx(conix) as constituent\n! if comix=1 look for interaction record with conx(2) or conx(3)\n if(tch.ge.3) write(*,*)'3H found endmember: ',conix,conx(conix)\n intrec=>endmem%intpointer\n findexcess: do while(associated(intrec))\n if(tch.ge.3) write(*,*)'3H loop interaction: ',2,conx(2)\n if(intrec%fraclink(1).eq.conx(2)) then\n! this must be interaction 1-2 ?? or 2-3 ??\n intrec12=>intrec\n write(*,222)trim(species(1)),trim(species(2)),conix\n222 format('3H Found interaction ',a,'-',a,' from endmember: ',i5)\n! we do not know the order of interaction 1-2 and 1-3\n if(associated(intrec13)) exit findexcess\n elseif(intrec%fraclink(1).eq.conx(3)) then\n if(conix.eq.1) then\n! this must be interaction 1-3, endmember 2\n intrec13=>intrec\n write(*,222)trim(species(1)),trim(species(3)),conix\n! we do not know the order of interaction 1-2 and 1-3\n if(associated(intrec12)) exit findexcess\n else\n! this must be interaction 2-3\n intrec23=>intrec\n write(*,222)trim(species(2)),trim(species(3)),conix\n exit findem\n endif\n endif\n if(tch.ge.3) write(*,*)'3H loop intrec: ',&\n endmem%fraclinks(1,1),intrec%fraclink(1)\n intrec=>intrec%nextlink\n enddo findexcess\n if(tch.ge.3) write(*,'(a,l2,i3,2x,3i3)')'3H exit findexcess',&\n associated(intrec),conix,conx(conix)\n! when we come here we have found 1-2 and 1-3 and look for 2-3\n if(conix.eq.1) then\n if(.not.associated(intrec12) .or. .not.associated(intrec13)) &\n write(*,224)conix,conx,endmem%fraclinks(1,1)\n224 format('3H some interactions missing',i3,2x,3i3,2x,i3)\n! increment conix and search for endmember conx(2)\n conix=2\n else\n if(.not.associated(intrec23)) &\n write(*,*)'3H some interactions are missing'\n exit findem\n endif\n endif\n endmem=>endmem%nextem\n enddo findem\n!*************** before here\n! write(*,*)'3H end findem loop'\n! we come here when we found or not found intrec12, intrec13 and intrec23\n!------------------------------------------------------------\n! check values of xter3\n if(tch.ge.3) then\n do kk=1,3\n write(*,44)trim(species(kk)),xter3(kk),conx(kk)\n44 format('3H constituent ',a,' xter3: ',i2,i5)\n enddo\n endif\n!--------------------------------------\n if(tch.ge.3) then\n write(*,111)conx(1),conx(2),conx(1),conx(3),conx(2),conx(3),&\n associated(intrec12),associated(intrec13),associated(intrec23)\n111 format('3H Found binary interaction records for ',3(i2,'-',i2),3x,3l2)\n write(*,*)'3H Allocate tooprecords!'\n endif\n!=================== now we create the tooprec records =====================\n! In gtp_phaserecord pointers toopfirst, tooplast include all tooprec records\n! It is needed to list the ternary extrapolation. It also has lasttoopid\n! The gtp_intrec has a tooprec pointer with tooprec data for that interaction\n! Each ternary AMEND TERNARY will be saved in one of the tooprec records \n if(.not.associated(phlista(lokph)%tooplast)) then\n! the phase ternary extrapolation record needed for listing only\n allocate(phlista(lokph)%toopfirst)\n phlista(lokph)%tooplast=>phlista(lokph)%toopfirst\n phlista(lokph)%lasttoopid=0\n! nullify the nexttoop pointer in toopfirst\n nullify(phlista(lokph)%toopfirst%nexttoop)\n nullify(phlista(lokph)%toopfirst%binint)\n phlista(lokph)%toopfirst%amend1=' '\n phlista(lokph)%toopfirst%amend2=' '\n phlista(lokph)%toopfirst%amend3=' '\n kk=size(phlista(lokph)%constitlist)\n! Hm, in a 4 component systems there are only 2 extrapolations?. But the\n! tooprec for a binary is involved in the extrapolations for other binaries\n nobin=kk*(kk-1)/2\n write(*,'(a,i3)')'3H allocating special binary extrapolations ',nobin\n phlista(lokph)%toopfirst%free=nobin\n else\n nobin=phlista(lokph)%toopfirst%free\n! write(*,'(a,i3)')'3H max special binary extrapolations ',nobin\n endif\n! phase record has pointers toopfirst and tooplast and integer lasttoopid\n! interaction record has pointer tooprec needed for calculations\n! the tooprec record are linked by nexttoop with a sequantial index toopid\n! Each original AMEND command is saved in one tooprec\n saveamend=.TRUE.\n! this is to indicate that a tooprec has been added\n! at the first calculation some checka are made to avoid duplicates\n! and it is set to zero\n phlista(lokph)%toopfirst%endmemel=-1\n! total number of binaries\n!------------------------ create a tooprec for binary 1-2\n! Check if intrec12 already has a tooprec, (nullified when intrec created)\n! conx(1) is the endmember fraction index\n! write(*,*)'3H creating tooprecords',associated(intrec12)\n if(.not.associated(intrec12)) then\n write(*,220)conx(1),conx(2),1,2,&\n trim(species(1)),trim(species(2))\n! trim(species(abs(conx(1)))),trim(species(abs(conx(2))))\n220 format('3H The binary ',i2,'-',i2,' (or ',i2,'-',i2,')',&\n ' with species: ',a,' - ',a,' has no excess')\n goto 300\n else\n! this routine returns with a new or old newtoop record\n if(tch.ge.3) write(*,*)'3H calling create_toop_record for 1-2'\n call create_toop_record(lokph,intrec12,conx(1),nobin)\n newtoop=>intrec12%tooprec\n jj=newtoop%free\n if(tch.ge.3) then\n write(*,221)'3H Toop1: ',(newtoop%toop1(kk),kk=1,size(newtoop%toop1))\n write(*,221)'3H Toop2: ',(newtoop%toop2(kk),kk=1,size(newtoop%toop1))\n write(*,221)'3H Kohler:',(newtoop%kohler(kk),kk=1,size(newtoop%toop1))\n221 format('3H arrays: ',a,45i3)\n endif\n endif\n! save Kohler constituent fraction (or zero if none)\n! write(*,'(a,3i3,2x,3i3)')'3H xter3, toopcon: ',xter3,toopcon\n if(xter3(1).lt.0) newtoop%Kohler(jj)=xter3(1)\n if(toopcon(1).gt.0) then\n!------------------------------------------------------------\n! This is the 1-2 binary of 1-2-3 with a Toop constituent 1, 2 or 3\n!------------------------------------------------------------\n! If toopcon(1)>0 it represents a Toop constituent\n! Then one should add the fraction of conx(3) to the NON-toopcon\n! if conx(1) is equal to toopcon(1) then Toop2(jj)=toopcon(1)\n! if conx(2) is equal to toopcon(1) then Toop1(jj)=toopcon(1)\n! otherwise toopcon(1) can be ignored as toopcon is not part of the binary\n! write(*,'(a,3i3,2x,3i3)')'3H Toop 1-2: ',toopcon,conx\n if(toopcon(1).eq.conx(1)) then\n! toopcon(1) is the first constituent in 1-2, add conx(3) to second fraction\n newtoop%Toop2(jj)=conx(3)\n elseif(toopcon(1).eq.conx(2)) then\n newtoop%Toop1(jj)=conx(3)\n endif\n endif\n if(tch.ge.3) then\n write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 1-2: ',jj,&\n newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),&\n intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),&\n intrec12%tooprec%kohler(jj)\n! extract the elements from the interaction record\n write(*,600)trim(species(1)),trim(species(2)),trim(species(3)),xter3,&\n conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj)\n! xter3 refers to the binary 1, 2 or 3\n! conx is constituent index\n endif\n! \n!-------------------------------------------------------------------\n if(saveamend) then\n if(len(newtoop%amend1).le.1) then\n! we can only save 1 amend command in each topec record ...\n! This can be a probem if elements are ordered alphabetically\n! one may run of of binaries to store A-B-X, A-B-Y etc\n newtoop%amend1=trim(amend)\n saveamend=.FALSE.\n! write(*,*)'3H Executing amend: ',newtoop%amend\n elseif(len(newtoop%amend2).le.1) then\n newtoop%amend2=trim(amend)\n saveamend=.FALSE.\n elseif(len(newtoop%amend3).le.1) then\n newtoop%amend3=trim(amend)\n saveamend=.FALSE.\n endif\n! if all were full hopefully there is another binary where it can be saved!!!\n endif\n! write(*,*)'3H Finished storing data for tooprec 1-2'\n!------------ repeat (almost) the same thing for binary 1-3 -------------\n! jump here if no intrec12 existed\n300 continue\n! Check if intrec3 exist and already has a tooprec\n if(.not.associated(intrec13)) then\n write(*,220)conx(1),conx(3),1,3,&\n trim(species(1)),trim(species(3))\n! trim(species(abs(conx(1)))),trim(species(abs(conx(3))))\n goto 400\n else\n! write(*,*)'3H calling create_toop_record for 1-3'\n call create_toop_record(lokph,intrec13,conx(1),nobin)\n newtoop=>intrec13%tooprec\n jj=newtoop%free\n! write(*,*)'3H data in newtoop 1-3: ',newtoop%free,jj\n endif\n! enter the data for 1-3 extrapolation A-C-B\n! if A is Toop the fraction index of A shoule be in toopcon(1)\n! if C is Toop the fraction index of B should be in toopcon(3)\n! if B is Kohler the negative fraction shoule be in xter(3)\n if(xter3(2).lt.0) newtoop%Kohler(jj)=xter3(2)\n if(toopcon(2).gt.0) then\n!------------------------------------------------------------\n! This is the 1-3 binary of 1-2-3 with a Toop constituent\n!------------------------------------------------------------\n! If toopcon(2)>0 that represent a Toop constituent\n! if conx(1) is equal to toopcon(2) then Toop2(jj)=conx(2)\n! if conx(3) is equal to toopcon(2) then Toop1(jj)=conx(2)\n! otherwise toopcon(2) can be ignored as it is not part of the binary 1-3\n! write(*,'(a,3i3,2x,3i3)')'3H Toop 1-3: ',toopcon,conx\n if(toopcon(2).eq.conx(1)) then\n! first element is Toop; add fraction of conx(2) to NON-toop element\n! newtoop%Toop2(jj)=toopcon(2)\n newtoop%Toop2(jj)=conx(2)\n elseif(toopcon(2).eq.conx(3)) then\n! newtoop%Toop1(jj)=toopcon(2)\n newtoop%Toop1(jj)=conx(2)\n endif\n endif\n if(tch.ge.3) then\n write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 1-3: ',jj,&\n newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),&\n intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),&\n intrec12%tooprec%kohler(jj)\n!\n write(*,600)trim(species(1)),trim(species(3)),trim(species(2)),xter3,&\n conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj)\nendif\n! we may not have managed to save the amend?\n if(saveamend) then\n if(len(newtoop%amend1).le.1) then\n newtoop%amend1=trim(amend)\n saveamend=.FALSE.\n elseif(len(newtoop%amend2).le.1) then\n newtoop%amend2=trim(amend)\n saveamend=.FALSE.\n elseif(len(newtoop%amend3).le.1) then\n newtoop%amend3=trim(amend)\n saveamend=.FALSE.\n endif\n endif\n! write(*,*)'3H Finished storing data for tooprec 1-3'\n!------------ repeat (almost) the same thing for binary 2-3 -------------\n! jump here if no intrec13 existed\n400 continue\n! Check if intrec23 exist and already has a tooprec\n if(.not.associated(intrec23)) then\n write(*,220)conx(2),conx(3),2,3,&\n trim(species(2)),trim(species(3))\n! trim(species(abs(conx(2)))),trim(species(abs(conx(3))))\n goto 500\n else\n! write(*,*)'3H calling create_toop_record for 2-3'\n call create_toop_record(lokph,intrec23,conx(2),nobin)\n newtoop=>intrec23%tooprec\n jj=newtoop%free\n! write(*,*)'3H data in newtoop 2-3: ',newtoop%free\n endif\n411 continue \n! enter the data for 2-3 extrapolation B-C-A\n! enter the data for 1-3 extrapolation A-C-B\n! if B is Toop the fraction index of B shoule be in extrapolatio(2)\n! if C is Toop the fraction index of C should be in extrapolatio(3)\n! if A is Kohler the negative fraction index of A shoule be in extrapolatio(1)\n! A negative value in Toop1 or Toop2 is ignored as well as a positive in Kohler\n! if(xter3(3).gt.0 .and. xter3(3).ne.toopcon(3)) newtoop%Toop1(jj)=toopcon(3)\n! if(xter3(3).gt.0 .and. xter3(3).ne.toopcon(3)) newtoop%Toop2(jj)=toopcon(3)\n if(xter3(3).lt.0) newtoop%Kohler(jj)=xter3(3)\n if(toopcon(3).gt.0) then\n!------------------------------------------------------------\n! This is the 2-3 binary of 1-2-3 with a Toop constituent\n!------------------------------------------------------------\n! If toopcon(3)>0 it represent a Toop constituent\n! if conx(2) is equal to toopcon(3) then add conx(1) to the NON-toop element\n! if conx(3) is equal to toopcon(3) then the same\n! otherwise toopcon(3) can be ignored as it is not part of the binary! \n! write(*,'(a,3i3,2x,3i3)')'3H Toop 2-3: ',toopcon,conx\n if(toopcon(3).eq.conx(2)) then\n! toopcon(3) is the first constituent in 2-3\n! newtoop%Toop2(jj)=toopcon(3)\n newtoop%Toop2(jj)=conx(1)\n elseif(toopcon(3).eq.conx(3)) then\n! newtoop%Toop1(jj)=toopcon(3)\n newtoop%Toop1(jj)=conx(1)\n endif\n endif\n if(tch.ge.3) then\n write(*,'(a,i3,2x,3i3,2x,3i3)')'3H newtoop 2-3: ',jj,&\n newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj),&\n intrec12%tooprec%toop1(jj),intrec12%tooprec%toop2(jj),&\n intrec12%tooprec%kohler(jj)\n endif\n!************* furure check ****************\n! if any of Toop1, Toop2 and Kohler arrays have the same fraction index \n! more than once one should add/subract only once. I think it can happen\n! for real cases, maybe one can eliminate duplicate indices when calculating\n! Added check in zeroth tooprec in %free set to -1 when adding ternary\n!----------------------------------------------------\n if(tch.ge.3) then\n write(*,600)trim(species(2)),trim(species(3)),trim(species(1)),xter3,&\n conx,toopcon,newtoop%toop1(jj),newtoop%toop2(jj),newtoop%kohler(jj)\n600 format('3H Binary ',a,'-',a,' extrapolerad to ',a,': ',4(3i3,2x))\n endif\n if(saveamend) then\n if(len(newtoop%amend1).le.1) then\n newtoop%amend1=trim(amend)\n saveamend=.FALSE.\n elseif(len(newtoop%amend2).le.1) then\n newtoop%amend2=trim(amend)\n saveamend=.FALSE.\n elseif(len(newtoop%amend3).le.1) then\n newtoop%amend3=trim(amend)\n saveamend=.FALSE.\n else\n write(*,603)trim(amend)\n603 format('3XQ WARNING *** failed to save amend ternary command:'/a/&\n ' maybe try to order constituents differently')\n endif\n endif\n! write(*,*)'3H Finished storing data for tooprec 2-3'\n!---------------------------------------------\n! jump here if no intrec13 existed\n500 continue\n if(.not.associated(newtoop)) then\n write(*,*)'3H there are no interaction parameters to extrapolate'\n goto 1000\n endif\n\n!===================================================================\n! Puuuuuuuuuuuuuuuuuhhhhhhhhhhhhhhhhhhhh\n1000 continue\n return\n! Error: Found duplicate method\n1100 continue\n write(*,*)'3H Error creating ternary extrapolation'\n! write(*,1110)duplicate%uniqid,duplicate%const1,duplicate%const2,&\n! duplicate%const3,conx(1),conx(2),conx(3)\n! write(*,1110)duplicate%uniqid,trim(species(1)),trim(species(2)),&\n! trim(species(3)),conx(1),conx(2),conx(3)\n1110 format('3H Error: The ternary ',a,1x,a,1x,a,1x,' &\n already has a ternary extrapolation',3i3)\n gx%bmperr=4399; goto 1000\n! Error: Trying to enter a method with wrong set of constituents\n1200 continue\n! write(*,1210)trim(species(1)),trim(species(2)),trim(species(3)),conx,&\n! duplicate%const1,duplicate%const2,duplicate%const3\n1210 format('3H Error: ternary system with ',a,'-',a,'-',a,': ',3i3,&\n ' does not fit method: ',3i3)\n end subroutine add_ternary_extrapol_method\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_ternary_extrapol_data\n!\\begin{verbatim}\n! subroutine list_ternary_extrapol_data(lut)\n subroutine list_ternary_extrapol_data(lut)\n! lists the data structure generated by Toop/Kohler ternary commands\n implicit none\n integer lut\n! outout unit lut\n!\\end{verbatim}\n type(gtp_tooprec), pointer :: tooprec\n character species(3)*24\n integer lokph,i1,i2,nz\n loop1: do lokph=1,noofph\n tooprec=>phlista(lokph)%tooplast\n if(.not.associated(tooprec)) cycle loop1\n!\n write(lut,10)trim(phlista(lokph)%name)\n10 format('The ',a,' phase has ternary extrapolation methods')\n loop2: do while(associated(tooprec))\n! the last tooprec has toopid zero and is empty and %binint is nullified\n! if(tooprec%toopid.eq.0) exit loop2\n if(associated(tooprec%binint)) then\n! The endmember constituent is saved in the tooprec\n i1=tooprec%endmemel\n i2=tooprec%binint%fraclink(1)\n nz=tooprec%free\n! phlista(lookph)%constitlist(i1) is index to species list\n species(1)=splista((phlista(lokph)%constitlist(i1)))%symbol\n species(2)=splista((phlista(lokph)%constitlist(i2)))%symbol\n write(lut,100)i1,i2,trim(species(1)),trim(species(2)),tooprec%toopid\n100 format(3x,'Binary ',i2,'-',i2,' (',a,'-',a,&\n ') has Toop/Kohler extraplations:' ,i3)\n write(lut,110)'Toop1: ',(tooprec%toop1(i1),i1=1,nz)\n write(lut,110)'Toop2: ',(tooprec%toop2(i1),i1=1,nz)\n write(lut,110)'Kohler: ',(tooprec%kohler(i1),i1=1,nz)\n110 format(6x,a,10i3)\n! if there is an amend command list it\n if(len(tooprec%amend1).gt.1) write(lut,120) tooprec%amend1\n if(len(tooprec%amend2).gt.1) write(lut,120) tooprec%amend2\n if(len(tooprec%amend3).gt.1) write(lut,120) tooprec%amend3\n120 format(6x,'There is an amend command: ',a)\n endif\n tooprec=>tooprec%nexttoop\n enddo loop2\n enddo loop1\n1000 continue\n return\n end subroutine list_ternary_extrapol_data\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_toop_record\n!\\begin{verbatim}\n! subroutine create_toop_record\n subroutine create_toop_record(lokph,intrec,endmem,nobin)\n! this replaces a 3 times repeated part of add_ternary_extrapol_method\n! Also works for Kohler\n implicit none\n type(gtp_interaction), pointer :: intrec\n! lokph is phase index, endmem is fraction index for endmember, nobin is size\n integer lokph,endmem,nobin\n!\\end{verbatim}\n type(gtp_tooprec), pointer :: newtoop\n integer jj,kk\n! we come here if we have to create or extend a tooprecord\n! for storing a new ternary parameter with Toop/Kohler extrapolation\n! write(*,'(a,3i3)')'3H creating tooprec with endmember ',endmem\n if(.not.associated(intrec%tooprec)) then\n! write(*,*)'3H creating intrec%tooprec'\n allocate(newtoop)\n intrec%tooprec=>newtoop\n! write(*,*)'3H created intrec%tooprec'\n! add the new tooprec in the list from phlista(lokph)%tooplast and add uniqeid\n newtoop%nexttoop=>phlista(lokph)%tooplast\n phlista(lokph)%tooplast=>newtoop\n phlista(lokph)%lasttoopid=phlista(lokph)%lasttoopid+1\n newtoop%toopid=phlista(lokph)%lasttoopid\n! link the tooprecord from intrec13%tooprec and endmember fraction index\n intrec%tooprec=>newtoop\n! newtoop%endmemel=conx(1)\n newtoop%endmemel=endmem\n! Allocate space for data, this binary may have several ternary extrapolations\n allocate(newtoop%Toop1(nobin))\n allocate(newtoop%Toop2(nobin))\n allocate(newtoop%Kohler(nobin))\n newtoop%Toop1=0\n newtoop%Toop2=0\n newtoop%Kohler=0\n jj=1\n newtoop%free=jj\n newtoop%amend1=' '\n newtoop%amend2=' '\n newtoop%amend3=' '\n! set crosslinks with interaction record\n newtoop%binint=>intrec\n intrec%tooprec=>newtoop\n else\n! there is already a ternary extrapolation record, find place to store data\n newtoop=>intrec%tooprec\n jj=size(newtoop%Toop1)\n if(newtoop%free.eq.jj) then\n! Tested that it works to extend. Already stored values kept\n write(*,90)trim(phlista(lokph)%name),newtoop%toopid,jj,newtoop%free\n90 format('3H extending tooprecord for ',a,5i5)\n! This should dynamically expand the arrays, the old content is kept\n newtoop%Toop1 = [ newtoop%Toop1, ( 0, kk=1,jj+5 ) ]\n newtoop%Toop2 = [ newtoop%Toop2, ( 0, kk=1,jj+5 ) ]\n newtoop%Kohler = [ newtoop%Kohler, ( 0, kk=1,jj+5 ) ]\n! write(*,'(a,i5)')'3H extended size: ',size(newtoop%Toop1)\n! save the new dimension in phlista(lokph)%toopfirst%free))\n phlista(lokph)%toopfirst%free=jj+5\n endif\n! newtoop% free is the place to store new data in the arrays\n jj=newtoop%free+1\n newtoop%free=jj\n endif\n! write(*,*)'3H data in newtoop: ',newtoop%free\n! reurn to enter data in intrec, newtoop%free is place to store new data\n1000 continue\n return\n end subroutine create_toop_record\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/models/gtp3X.F90", "content": "!\n! gtp3X included in gtp3.F90, separate gtp3XQ for MQMQA\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 15. Section: calculate G and other things\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calcg\n!\\begin{verbatim}\n subroutine calcg(iph,ics,moded,lokres,ceq)\n! calculates G for phase iph and composition set ics in equilibrium ceq\n! checks first that phase and composition set exists\n! Data taken and stored in equilibrium record ceq\n! lokres is set to the phase_varres record with all fractions and results\n! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer iph,ics,moded,lokres\n!\\end{verbatim}\n integer jcs,lokcs,lokph\n! write(*,*)'3X in calcg',iph,ics,moded\n if(gx%bmperr.ne.0) then\n write(*,*)'3X Error code set when calling calcg: ',gx%bmperr\n goto 1000\n endif\n if(iph.le.0 .or. iph.gt.noofph) then\n! the selected_element_reference phase with iph=0 is calculated separtely\n gx%bmperr=4050; goto 1000\n endif\n lokph=phases(iph)\n if(lokph.le.0 .or.lokph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n endif\n! write(*,*)'3X calcg 1: ',phlista(lokph)%name\n! find fractions for this composition set\n if(ics.le.1) then\n jcs=1\n elseif(ics.le.phlista(lokph)%noofcs) then\n jcs=ics\n else\n! no such composition set\n! write(*,*)'3X calcg 1 error 4072'\n gx%bmperr=4072; goto 1000\n endif\n! if(phlista(1)%noofcs.gt.1) then\n! strange error that liquid (phase 1) has 3 composition set\n! write(*,*)'3X csbug: ',lokph,jcs,phlista(1)%noofcs\n! stop 'csbug'\n! endif\n! Find fraction record this composition set\n lokcs=phlista(lokph)%linktocs(ics)\n! write(*,*)'3X in calcg: ',lokcs\n!-----\n! mcs=1\n! lokcs=phlista(lokph)%cslink\n! do while(mcs.lt.jcs)\n! mcs=mcs+1\n! firsteq is the first equilibrium and a global variable in this module\n! lokcs=firsteq%phase_varres(lokcs)%next\n! if(lokcs.le.0) then\n! write(*,*)'3X calcg 2 error 4072'\n! gx%bmperr=4072; goto 1000\n! endif\n! enddo\n lokres=lokcs\n! write(*,*)'3X calcg 7: ',lokres,trim(ceq%eqname)\n! call using the local structure phase_varres\n! results can be obtained through lokres\n! write(*,17)'3X calcg: ',lokph,lokres,ceq%phase_varres(lokres)%yfr(1)\n17 format(a,2i4,1pe15.6)\n call calcg_internal(lokph,moded,ceq%phase_varres(lokres),ceq)\n1000 continue\n! if phlista(lokph)%toopfirst then set phlista(lokph)%toopfirst%endmemel to 0\n! to indicate that redundant toop/Kohler fraction indices\n if(associated(phlista(lokph)%toopfirst)) phlista(lokph)%toopfirst%endmemel=0\n! write(*,*)'3X back from calcg_internal'\n return\n end subroutine calcg\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calcg_internal\n!\\begin{verbatim}\n subroutine calcg_internal(lokph,moded,cps,ceq)\n! Central calculating routine calculating G and everyting else for a phase\n! ceq is the equilibrium record, cps is the phase_varres record for lokph\n! moded is type of calculation, 0=only G, 1 G and first derivatives\n! 2=G and all second derivatives\n! Can also handle the ionic liquid model now ....\n implicit none\n integer lokph,moded\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_phase_varres), target :: cps\n!\\end{verbatim}\n! fractype defines fraction type (1=constituent fractions)\n! empermut and ipermut permutation of fractions for phases with option F and B\n! permrecord, maxprec and sameint to handle permutation in the interaction tree\n integer, parameter :: permstacklimit=150\n integer fractype,epermut,ipermut,typty,pmq,maxprec,already\n integer sameint(5)\n integer, dimension(permstacklimit) :: lastpmq,maxpmq\n! character bug*60\n! dimension sites(maxsubl),pushpop(maxpp)\n double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:)\n double precision, dimension(:,:), allocatable :: dvals(:,:)\n double precision vals(6)\n! this array has the sum of constituents up to and including current sublattice\n integer incffr(0:maxsubl)\n! Kohler-Toop binary excess model link\n type(gtp_tooprec), pointer :: tooprec\n! in local gz: gz%intlevel level of interaction, gz%intcon and gz%intlat are\n! used also in cgint when calculating interactions.\n TYPE(gtp_parcalc) :: gz\n! disordered fraction set\n! TYPE(gtp_fraction_set) :: fracset,dislink\n TYPE(gtp_fraction_set), pointer :: fracset,dislink\n TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain\n TYPE(gtp_property), pointer :: proprec\n TYPE(gtp_endmember), pointer :: endmemrec\n TYPE(gtp_interaction), pointer :: intrec\n TYPE(gtp_pystack), pointer :: pystack\n TYPE(gtp_phase_add), pointer :: addrec\n! for an ordered phase like FCC with a disordered contribution one must\n! calculate the ordered part twice, one with original fractions and once\n! with these replaced by the disordered fractions. and subdrahera. This means\n! one must have space to save fractions and results\n! double precision, dimension(:), allocatable :: savey\n double precision, dimension(maxconst) :: savey\n double precision, dimension(:,:), allocatable :: saveg\n double precision, dimension(:,:,:), allocatable :: savedg\n double precision, dimension(:,:), allocatable :: saved2g\n double precision, dimension(:,:), allocatable :: tmpd2g\n! added when implicit none\n double precision rtg,pyq,ymult,add1,sum,yionva,fsites,xxx,sublf\n integer nofc2,nprop,nsl,msl,lokdiseq,ll,id,id1,id2,lm,qz\n integer lokfun,itp,nz,intlat,ic,jd,jk,ic1,jpr,ipy,i1,j1,jj,jxsym\n integer i2,j2,ider,is,kk,ioff,norfc,iw,iw1,iw2,lprop,jonva,icat\n integer nsit1,nsit2\n! cqc configurational entropy\n integer nclust\n double precision, allocatable, dimension(:,:) :: gclust\n! mqmqa endmember counting and other specials\n integer mqmqj,kend\n! double precision, dimension(:,:), allocatable :: fhv\n! double precision, dimension(:,:,:), allocatable :: dfhv\n! double precision, dimension(:,:), allocatable :: d2fhv\n double precision g2val(6)\n! to handle parameters with wildcard constituent and other things\n logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva,iliqneut\n! mobility parameters must not have wildcard constituents\n logical liq2state,wildmob,mqmqa\n! pointer to mqmqaf record with all fraction records for MQMQA\n! type(gtp_mqmqa_var), pointer :: mqf\n! debugging for partitioning and ordering\n integer idlist(9)\n! calculate RT to normalize all Gibbs energies, ceq is current equilibrium\n rtg=globaldata%rgas*ceq%tpval(1)\n ceq%rtn=rtg\n! if(ocv()) write(*,*)'3X in gcalc_internal: ',lokph\n!-----------------------\n chkperm=.false.\n mqmqa=.false.\n already=0\n if(btest(phlista(lokph)%status1,PHMQMQA)) then\n! write(*,*)'3X phase has MQMQA model'\n mqmqa=.TRUE.\n! if allocated inititate all excess checks to false, not a good place ....\n! if(allocated(mqmqa_data%csumx)) then\n! write(*,*)'3X in calcg_internal inititate mqmqa_data%csumx'\n! mqmqa_data%csumx=.FALSE.\n! endif\n endif\n if(btest(phlista(lokph)%status1,PHFORD) .or. &\n btest(phlista(lokph)%status1,PHBORD)) then\n! PHPALM is needed for phases with permutations such as ordered FCC/BCC/HCP\n chkperm=.true.\n if(.not.btest(phlista(lokph)%status1,PHPALM)) then\n! write(*,*)'3X calling palmtree ',lokph,cps%phtupx\n! This is needed only once unless parameters are changed. It numbers the\n! interaction records sequentially for the permutations\n! palmtree is in gtp3Y.F90 for some unknown reason ...\n call palmtree(lokph)\n if(gx%bmperr.ne.0) goto 1000\n! this must be zeroed if a new interaction parameter is added\n! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHPALM)\n endif\n endif\n!-----------------------------------------------------------------\n50 continue\n! local work arrays for products of Y and calculated parameters are allocated\n gz%nofc=phlista(lokph)%tnooffr\n nofc2=gz%nofc*(gz%nofc+1)/2\n! write(*,*)'3X in calcginternal ',btest(phlista(lokph)%status1,PHLIQ2STATE)\n! write(*,17)'3X calcg, ',lokph,gz%nofc,nofc2,size(cps%d2gval),cps%nprop,&\n! cps%yfr(1)\n!17 format(a,5i4,1pe15.6)\n! for disordered fraction sets gz%nofc must be from disordered fraction record\n! maybe these should not be allocated for moded=0 and 1\n! write(*,*)'3X allocate: ',gz%nofc,nofc2\n allocate(dpyq(gz%nofc))\n allocate(d2pyq(nofc2))\n! these return values from excess parameters that may depend on constitution\n allocate(dvals(3,gz%nofc))\n allocate(d2vals(nofc2))\n nullify(pystack)\n! do they have to be zeroed? YES!\n dpyq=zero\n d2pyq=zero\n! dimension for number of parameter properties\n nprop=cps%nprop\n! phres will point either to ordered or disordered results\n! phmain will always point to record for ordered phase_varres\n phmain=>cps\n phres=>cps\n! zero result arrays for all properties, maybe one should do it separately for\n! each property as it is found but it may be faster to do it like this anyway\n phres%gval=zero\n if(moded.gt.0) then\n phres%dgval=zero\n if(moded.gt.1) then\n phres%d2gval=zero\n endif\n endif\n! debugging mqmqa entropy\n sconfmqmqa=zero\n! copy current values of T, P and RT from gtp_phase_varres\n gz%tpv(1)=ceq%tpval(1)\n gz%tpv(2)=ceq%tpval(2)\n! write(*,*)'3X calcg_i: ',gz%tpv\n gz%rgast=ceq%tpval(1)*globaldata%rgas\n! gz%rgast=ceq%tpval(1)*ceq%rgas\n! this is used to check the number of times an ordered phase is calculated\n first=.true.\n!-------------------------------------------------------------------\n! calculate configurational entropy.\n nsl=phlista(lokph)%noofsubl\n ionicliq=.FALSE.\n iliqsave=.FALSE.\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n call config_entropy_i2sl(moded,nsl,phlista(lokph)%nooffr,phres,&\n phlista(lokph)%i2slx,gz%tpv(1))\n ionicliq=.TRUE.\n! iliqsave=.FALSE.\n iliqva=.FALSE.\n jonva=0\n elseif(mqmqa) then\n! \n! MQMQA FactSage entropy model\n! strange error OC dies when calling this using \"c g\" as first command\n! OK when using c ph .... , problem with arguments\n! write(*,222)moded,lokph,phlista(lokph)%tnooffr,phres%yfr(1),gz%tpv(1)\n222 format('3X call mqmqa entropy: ',3i3,2(1pe12.4))\n! in gtp3_XQ\n! attempt to extract configurational entropy, gval(2,1) id dG/dT\n sconfmqmqa=phres%gval(2,1)\n call config_entropy_mqmqa1(phres,moded,lokph,gz%tpv(1))\n! attempt to simplify the call .... \n! when we come back mqmqaf should have some arrays allocated ....\n! DO NOT SET THIS POINTER BEFORE ARRAYS ARE ALLOCATED IN CONFIG_ENTROPY_MQMQA\n! this pointer now obsolete, phres%mqmqaf used inside _mqmqa1\n! mqf=>phres%mqmqaf\n! write(*,'(a,1pe12.4)')'3X MQMQA cfgG:',phres%gval(1,1)*gz%rgast*phres%amfu\n! write(*,'(a,1pe12.4)')'3X MQMQA cfgG:',phres%gval(1,1)*gz%rgast\n! do mqmqj=1,mqf%npair\n! write(*,777)mqf%pair(mqmqj),(mqf%dpair(mqmqj,kk),kk=1,mqf%nconst)\n! write(*,777)mqf%pair(mqmqj),mqf%dpair(mqmqj,1),mqf%dpair(mqmqj,2),&\n! mqf%dpair(mqmqj,3)\n777 format('3X pairs:',F10.6,2x,10F9.5)\n! enddo\n! attempt to extract configurational entropy\n! write(*,*)'3X back from config_entropy_mqmqa1 '\n sconfmqmqa=(phres%gval(2,1)-sconfmqmqa)*rtg\n! write(*,'(\"3X MQMQA dG/dT: \",1pe12.4)')sconfmqmqa\n elseif(btest(phlista(lokph)%status1,PHQCE)) then\n! this is the corrected QC, Hillert-Selleby-Sundman model\n call config_entropy_qchillert(moded,phlista(lokph)%nooffr(1),&\n phres,phlista(lokph),gz%tpv(1))\n! write(*,480)'3X dg/dt/RT: 1: ',qcmodel,phres%yfr(3),&\n! phres%gval(1,1),phres%gval(2,1)\n480 format(a,i2,6(1pe12.4))\n! several old versions to be deleted ...\n! call config_entropy_cqc(moded,phlista(lokph)%tnooffr(1),&\n! phres,phlista(lokph),nclust,gclust,gz%tpv(1))\n\n elseif(btest(phlista(lokph)%status1,PHCVMCE)) then\n! the classical quasichemical or tetraherdon CVM model with LRO\n call config_entropy_qcwithlro(moded,phlista(lokph)%tnooffr,phres,&\n phlista(lokph),gz%tpv(1))\n! phstate\n elseif(btest(phlista(lokph)%status1,PHTISR)) then\n! the configurational model by E Kremer (Calphad 2022)\n call config_entropy_tisr(moded,phlista(lokph)%tnooffr,phres,&\n phlista(lokph),gz%tpv(1))\n elseif(btest(phlista(lokph)%status1,PHSROT)) then\n! the configurational model is a modified tetrahedron quasichemical model\n call config_entropy_srot(moded,phlista(lokph)%tnooffr,phres,&\n phlista(lokph),gz%tpv(1))\n! phstate\n elseif(btest(phlista(lokph)%status1,PHSSRO)) then\n! CVM tetraheron SRO (no LRO) configurational entropy\n call config_entropy_ssro(moded,lokph,phres,gz%tpv(1))\n! phstate\n elseif(btest(phlista(lokph)%status1,PHCVMTFL)) then\n! CVM tetraheron SRO (no LRO) configurational entropy\n call config_entropy_cvmtfl(moded,lokph,phres,gz%tpv(1))\n else\n!----------- the CF Bragg-Williams ideal configurational entropy per sublattice\n! NOTE: for phases with disordered fraction set this is calculated\n! ONLY for the original constituent fraction set with ordering sublattices\n call config_entropy(moded,nsl,phlista(lokph)%nooffr,phres,gz%tpv(1))\n endif\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3X segmentation fault 10'\n!-------------------------------------------------------------------\n! MQMQA separate calculation of G as well (as above) the entropy!!!\n! NO no 2state model, einstein, magnetism etc.\n if(mqmqa) then\n! write(*,*)'3X Separate routine for nonconfig MQMQA'\n call calc_mqmqa(lokph,phres,ceq)\n! write(*,*)'3X back from nonconfig MQMQA'\n goto 1000\n endif\n!-------------------------------------------------------------------\n! start BIG LOOP for all fraction variables and parameters\n! there may be several different properties in addition to G like TC, MQ& etc\n! each of these are stored in separate gval(*,ipy) where ipy is an integer\n! set for each property. lprop is incremented by one for each new property\n! found (each phase may have different) and in listprop the original type\n! of property is stored. listprop will always be associated with phmain\n!100 continue\n! yionva is used as indicator below if there are Va or just neutrals ...\n yionva=zero\n nevertwice=.true.\n lprop=2\n phmain%listprop=0\n phmain%listprop(1)=lprop\n! write(*,168)'3X lprop0:',lprop,0,(phmain%listprop(jj),jj=1,10)\n fractype=0\n! write(*,*)'3X calcg 99: ',lokph,cps%phtupx,cps%disfra%varreslink\n!--------------------------------------------------------------------\n! VERY STRANGE ERROR\n! wrong results calculating with disordered fraction set disappeared\n! when adding this write statements (and the one after the else statement\n! and the one with the text nevertwice: further below)\n! write(*,101)'3X calcg 100 ',nsl,phlista(lokph)%nooffs,&\n! btest(phmain%status2,CSORDER),phres%gval(1,1),cps%gval(1,1)\n101 format(a,2i4,1x,l,4(1pe14.4))\n!--------------------------------------------------------------------\n! loop for different types of fractions: site fractions, mole fractions ...\n fractyp: do while(fractype.lt.phlista(lokph)%nooffs)\n105 continue\n! write(*,7)'3X label 105: ',fractype,btest(phlista(lokph)%status1,PHSUBO),&\n! btest(phmain%status2,CSORDER),btest(phlista(lokph)%status1,PHMFS),&\n! fracset%totdis,phres%gval(1,1)\n7 format(a,i2,3(1x,l),i3,3(1pe12.4))\n fractype=fractype+1\n! write(*,*)'3X segmentation fault 20',fractype\n! return here for calculating with disordered fractions for same fraction type\n110 continue\n! gz%nofc is number of fraction variables, msl is number of sublattices\n! for this set of fractions!!! Ordering in FCC may have 5 sublattices with\n! 4 participating in ordering and one interstitial. The second fraction\n! set may have 2 sublattices, 1 for the 4 ordering and one interstitial\n! fracset=phmain%disfra\n fracset=>phmain%disfra\n! write(*,*)'3X segmentation fault 30',associated(fracset)\n ftype: if(fractype.eq.1) then\n!---------------------------------------------- ordered (or only) fraction set\n if(btest(phlista(lokph)%status1,PHMFS)) then\n! there is a disordered fractions set, we need additional fracset\n if(fracset%totdis.ne.0) then\n if(btest(phlista(lokph)%status1,PHSUBO)) then\n! if phsubo set skip subtracting the ordered part as disordered, just add\n goto 106\n endif\n! the phase can totally disorder, if disordered skip ordered part\n! the CSORDER bit set by calc_disfrac called from set_constitution\n if(btest(phmain%status2,CSORDER)) then\n! the phase is ordered, we have to calculate this part twice\n! write(*,*)'3X Setting nevertwice false'\n nevertwice=.false.\n! independent if ordered or disordered always calculate first fraction set\n else\n! the phase is disordered, skip ordered part and just calculate disordered\n! nevertwice is already set TRUE\n goto 105\n endif\n endif\n endif\n106 continue\n gz%nofc=phlista(lokph)%tnooffr\n msl=nsl\n incffr(0)=0\n do qz=1,nsl\n incffr(qz)=incffr(qz-1)+phlista(lokph)%nooffr(qz)\n enddo\n! write(*,*)'3X after 106: ',fractype,nevertwice\n! the results will be stored in the results arrays indicated by phres\n! it was set above for the ordered fraction set. \n else\n!-------------------------------------------------\n! disorderd/other fraction sets, take data from gtp_fraction_set\n! write(*,*)'3X Fraction type: ',fractype,cps%disfra%varreslink\n msl=fracset%ndd\n gz%nofc=fracset%tnoofxfr\n incffr(0)=0\n do qz=1,msl\n incffr(qz)=incffr(qz-1)+fracset%nooffr(qz)\n enddo\n! we have to deallocate and allocate local arrays, not if moded=0 or 1??\n deallocate(dpyq)\n deallocate(d2pyq)\n allocate(dpyq(gz%nofc))\n allocate(d2pyq(nofc2))\n if(ocv()) write(*,*)'3X Allocated dpyq 2'\n dpyq=zero\n deallocate(dvals)\n deallocate(d2vals)\n allocate(dvals(3,gz%nofc))\n allocate(d2vals(nofc2))\n if(ocv()) write(*,*)'3X Allocated vals 2'\n! the results will be stored in result arrays indicated by phres\n! for the disordered fraction set phres must be set here and the arrays zeroed\n! dislink=cps%disfra\n dislink=>cps%disfra\n! write(*,*)'3X Calc internal disordred part 1A',dislink%fsites\n lokdiseq=dislink%varreslink\n! write(*,*)'3X Calc internal disordred part 1B',lokdiseq\n phres=>ceq%phase_varres(lokdiseq)\n! Wow phres%gval etc not allocated !!\n if(.not.allocated(phres%gval)) then\n allocate(phres%gval(6,nprop))\n endif\n phres%gval=zero\n! write(*,*)'3X Calc internal disordred part 1c',&\n! allocated(phres%dgval),gz%nofc\n if(moded.gt.0) then\n if(.not.allocated(phres%dgval)) then\n allocate(phres%dgval(3,gz%nofc,nprop))\n endif\n phres%dgval=zero\n if(moded.gt.1) then\n nofc2=gz%nofc*(gz%nofc+1)/2\n! write(*,*)'3X segmentation fault 48: ',&\n! allocated(phres%d2gval),nofc2\n if(.not.allocated(phres%d2gval)) then\n allocate(phres%d2gval(nofc2,nprop))\n endif\n phres%d2gval=zero\n endif\n endif\n! write(*,*)'3X Calc internal disordred part 2'\n endif ftype\n!==========================================================\n! there can be ordered and disordered fraction sets selected by fractype\n if(fractype.eq.1) then\n endmemrec=>phlista(lokph)%ordered\n else\n endmemrec=>phlista(lokph)%disordered\n endif\n!\n! here we take one endmember at a time but to speed up when having several\n! CPU we give one endmamber plus its interaction tree to each tread. \n! To handle this all endmember records should be in an array. An attempt to\n! implement this was made in calcg_internal2 but not updated for permutations\n!\n! empermut, lastpmq and maxpmq controls permutations (option F and B)\n! maxpmq is set to zero for each new endmember but keep its content\n! during calculation of all permutations of the same endmember and interactions\n! big loop for all permutation of fractions (ordering option F and B)\n! including all interaction parameters linked from this endmember\n!\n endmemloop: do while(associated(endmemrec))\n!\n! The array maxpmq is used for interaction permutations. It must be\n! initialized to zero at the first endmember permutation. It is set to\n! limits for the interacton permutations for all interaction records.\n maxpmq=0\n maxprec=0\n epermut=0\n sameint=0\n!--------------------------------- quick test of mqmqa reference state\n if(mqmqa) then\n stop '3X MQMQA separate routine'\n endif\n empermut: do while(epermut.lt.endmemrec%noofpermut)\n epermut=epermut+1\n! calculate py, calculate parameter, calculate contribution to G etc\n! py is product of all fractions, dpy are first derivatives and d2py second\n pyq=one\n if(moded.gt.0) then\n! moded=0, only G, =1 only G and dG/dy, moded=2 all Gm dG/dy and d2G/dy2\n dpyq=zero\n if(moded.gt.1) then\n d2pyq=zero\n endif\n endif\n wildmob=.FALSE.\n pyqloop: do ll=1,msl\n id=endmemrec%fraclinks(ll,epermut)\n! debugging 4SL with wildcards\n idlist(ll)=id\n! remove next line when all fixed\n! if(ll.lt.5) clist(ll)=id\n! id negative means wildcard, independent of the fraction in this sublattice\n if(id.lt.0) then\n gz%yfrem(ll)=one\n wildmob=.TRUE.\n else\n gz%yfrem(ll)=phres%yfr(id)\n if(gz%yfrem(ll).lt.bmpymin) gz%yfrem(ll)=bmpymin\n if(gz%yfrem(ll).gt.one) gz%yfrem(ll)=one\n endif\n! gz%endcon is used for interaction parameters below\n gz%endcon(ll)=id\n pyq=pyq*gz%yfrem(ll)\n! write(*,33)ll,epermut,id,gz%yfrem(ll),pyq\n33 format('3X py: ',i3,2i5,2(1pe12.4))\n if(ionicliq .and. ll.eq.2) then\n! For ionic liquid we must check when Va or neutral in second sublattice\n! i2slx(1) is index of vacancy, i2slx(2) is first neutral\n if(id.eq.phlista(lokph)%i2slx(1) .and. yionva.eq.zero) then\n iliqva=.TRUE.\n yionva=gz%yfrem(ll)\n jonva=phlista(lokph)%i2slx(1)\n! We found Va. Save all calculated values as the follwing terms should all\n! be multiplied with Q (done after finishing calculation)\n! nprop=phmain%nprop\n! we have already extracted nprop above .... \n allocate(saveg(6,nprop))\n saveg=phres%gval\n! if(ocv()) write(*,*)'3X saveg allocated 1A:',size(saveg),&\n! gz%nofc,nofc2,nprop,moded\n if(moded.gt.0) then\n! only allocate if needed, some \"out of memory\" problems here calculating grid\n! with just ionic liquid phase\n allocate(savedg(3,gz%nofc,nprop))\n allocate(saved2g(nofc2,nprop))\n savedg=phres%dgval\n saved2g=phres%d2gval\n endif\n! if(ocv()) write(*,*)'3X saveg allocated 1B: '\n! write(*,*)'3X Config G 3A: ',phres%gval(1,1)*rtg\n phres%gval=zero\n phres%dgval=zero\n phres%d2gval=zero\n! write(*,*)'3X Config G 3B: ',phres%gval(1,1)*rtg\n iliqsave=.TRUE.\n! write(*,117)'3X Saved ionliq G at Va id: ',&\n! id,yionva,saveg(1,1)\n117 format(a,i3,6(1pe12.4))\n elseif(id.eq.phlista(lokph)%i2slx(2) .and. jonva.eq.0) then\n! we have NO vacancy but a neutral in second sublattice\n iliqva=.FALSE.\n yionva=-one\n jonva=0\n why1: if(.not.iliqsave) then\n! We may have model without Va, for exampel (Ca+2)p(O-2,SiO4-4,SiO2)q, if so\n! we must save all calculated values as the rest should be multiplied with Q\n! nprop=phmain%nprop\n! we already know nprop from above\n allocate(saveg(6,nprop))\n allocate(savedg(3,gz%nofc,nprop))\n allocate(saved2g(nofc2,nprop))\n! if(ocv()) write(*,*)'3X saveg allocated 2:',size(saveg)\n saveg=phres%gval\n savedg=phres%dgval\n saved2g=phres%d2gval\n phres%gval=zero\n phres%dgval=zero\n phres%d2gval=zero\n iliqsave=.TRUE.\n! write(*,117)'3X Saved ionliq G at neutral id: ',&\n! id,yionva,saveg(1,1)\n! else\n! write(*,*)'3X neutral: ',jonva,yionva,iliqva\n endif why1\n endif\n endif\n enddo pyqloop\n if(moded.eq.0) goto 150\n!---------------------------------------------------- first derivatives of py\n dpyqloop: do ll=1,msl\n! here pyq is known, same loop as above to calculate dpyq(i)=pyq/y_i\n id=endmemrec%fraclinks(ll,epermut)\n if(id.gt.0) then\n! pyq was multiplied with gz%yfrem(11) above, now divide with it\n dpyq(id)=pyq/gz%yfrem(ll)\n! write(*,*)'3X dpq/dy: ',ll,id,dpyq(id)\n elseif(.not.ionicliq) then\n! wildcard in the sublattice and NOT ionic liquid\n do iw=incffr(ll-1)+1,incffr(ll)\n dpyq(iw)=pyq\n enddo\n elseif(ll.ne.1) then\n! wildcard in second subl of ionic liquid, same as for CEF\n do iw=incffr(ll-1)+1,incffr(ll)\n dpyq(iw)=pyq\n enddo\n! else\n! wildcard in first subl of ionic liquid then just ignore first derivatives\n! with respect to constituents in first sublattice\n! continue\n endif\n enddo dpyqloop\n if(moded.le.1) goto 150\n!---------------------------------------------------- second derivatives of py\n! searching for bug with interaction wildcards in 4SL\n! write(*,68)'3X d2P/dyi2A:',nofc2,(d2pyq(id),id=1,nofc2)\n! d2pyq is all zero here\n d2pyqloop1: do ll=1,msl\n id1=endmemrec%fraclinks(ll,epermut)\n! too complicated here ... jxsym=ixsym(ll,ll+1)\n d2pyloop2: do lm=ll+1,msl\n id2=endmemrec%fraclinks(lm,epermut)\n if(id1.gt.0) then\n if(id2.gt.0) then\n d2pyq(ixsym(id1,id2))=dpyq(id1)/gz%yfrem(lm)\n else\n! wildcard in sublattice lm, real component in ll\n! do iw=incffr(lm)+1,incffr(lm)\n! d2pyq(ixsym(id1,iw))=dpyq(id1)\n! enddo\n! This derivative should be zero!! /170324/BoS\n continue\n wildmob=.TRUE.\n endif\n else\n! wildcard in sublattice ll, real component in lm\n if(id2.gt.0) then\n! do iw=incffr(ll-1)+1,incffr(ll)\n! d2pyq(ixsym(id2,iw))=one\n! enddo\n! This should be zero!! /170324/BoS\n continue\n else\n! wildcards in both sublattice ll and lm\n! do iw1=incffr(ll-1)+1,incffr(ll)\n! do iw2=incffr(lm-1)+1,incffr(lm)\n! d2pyq(ixsym(iw1,iw2))=pyq\n! enddo\n! enddo\n! I think this should be zero too!! /170324/BoS\n endif\n wildmob=.TRUE.\n endif\n enddo d2pyloop2\n enddo d2pyqloop1\n! searching for bug with interaction wildcards in 4SL\n! write(*,67)'B:' ,pyq,(idlist(iw1),iw1=1,nsl)\n67 format('3X endmem',a,e12.4,9i4)\n! write(*,68)'3X d2P/dyi2B:',nofc2,(d2pyq(id),id=1,nofc2)\n68 format(a,i3,5(1pe12.4)/,(16x,5e12.4))\n!---- jump here if moded is 0 or 1\n150 continue\n!\n! if debugpar nonzero add call for debug_endmemberpar(....) here\n!\n!-----------------------------------------------------\n! d2pyq contains 2nd serivatives of endmember fractions.\n! write(*,228)'3X d2pyq 0:',d2pyq\n! write(*,*)'3X Config G 4A: ',phres%gval(1,1)*rtg\n! write(*,154)'3X endmember permutation: ',epermut,(clist(i),i=1,4)\n154 format(a,i5,4i4,'--------------------------------')\n155 format(a,i5,10i4)\n proprec=>endmemrec%propointer\n! for liquids with twostate models first calculate the g2 parameter\n if(btest(phlista(lokph)%status1,PH2STATE)) then\n write(*,*)'3X Phase ',trim(phlista(lokph)%name),&\n ' has PH2STATE bit set'\n call calc_twostate_model_endmember(proprec,g2val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,6(1pe12.4))')'3X g2val:',g2val\n liq2state=.true.\n else\n liq2state=.false.\n g2val=zero\n endif\n emprop: do while(associated(proprec))\n typty=proprec%proptype\n if(typty.ne.1) then\n! if property different from 1 (=G) find where to store it, use phmain link\n! First check if the parameter is a mobility and there are wildcrds\n if(wildmob) then\n! nowildcard(1..3) set in gtp_init in gtp3A.F90 for mobility parameters\n! typty is indicator*100 + constituent index\n do qz=1,3\n if(typty/100.eq.nowildcard(qz)) then\n write(*,*)&\n '3X mobilities must not have wildcards',lokph\n gx%bmperr=4374; goto 1000\n endif\n enddo\n endif\n do qz=2,lprop-1\n if(phmain%listprop(qz).eq.typty) goto 170\n enddo\n! a new property, save its typty in listprop and increment lprop\n! note that the property index typty is not used as index in gval etc\n! as that can be very large. lprop is incremented by 1 for each property\n! actually used in the model of the phase. lprop is last free index\n qz=lprop\n if(qz.gt.size(phmain%listprop)) then\n write(*,*)'Too many differnt parameter identifiers',qz\n gx%bmperr=4338; goto 1000\n endif\n phmain%listprop(qz)=typty\n! a bit stupid to allocate listprop, it should have fixed allocation ...\n if(allocated(phmain%listprop)) then\n! if(lprop.ge.nprop) then\n! VERY STRANGE ERROR, nprop is suddenly zero ....\n if(lprop.ge.size(phmain%listprop)) then\n write(*,169)'3X Too many parameter properties ',&\n lprop,nprop,typty,lokph,&\n size(phmain%listprop),phlista(lokph)%name\n169 format(a,3i3,2x,2i3,2x,a)\n gx%bmperr=4338; goto 1000\n endif\n else\n write(*,*)'3X Internal error, listprop not allocated',&\n lokph,phlista(lokph)%name\n gx%bmperr=4339; goto 1000\n endif\n lprop=lprop+1\n phmain%listprop(1)=lprop\n! listprop(1) is number of defined properties, listprop(2..) is property\n! write(*,168)'3X lprop: ',lprop,typty,&\n! (phmain%listprop(ipy),ipy=1,lprop)\n168 format(a,2i5,': ',10i5)\n! jump here is we already have found this property and know its ipy\n170 continue\n ipy=qz\n else\n ipy=1\n endif\n!================ here we calculate the endmember parameter ============\n! calculate function and derivatives wrt T and P\n! the results from eval_tpfun must also be different in different treads ...\n lokfun=proprec%degreelink(0)\n call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres)\n! write(*,167)'3X eval_tpfun: ',ipy,lokfun,pyq,vals(1),vals(1)/rtg\n167 format(a,2i5,6(1pe12.4))\n if(gx%bmperr.ne.0) goto 1000\n prop1: if(ipy.eq.1) then\n! property 1 i.e. Gibbs energy, should be divided by RT\n vals=vals/rtg\n if(liq2state) then\n! if phase has liquid twostate model add g2val!!\n! write(*,'(a,6(1pe12.4))')'3X +g2val',&\n! vals(1),g2val(1),vals(1)+g2val(1),&\n! vals(4),g2val(4),vals(4)+g2val(4)\n vals=vals+g2val\n endif\n endif prop1\n! write(*,*)'3X property type: ',typty,ipy,vals(1)\n!================ now we calculated the endmember parameter ============\n! take care of derivatives of fraction variables ...\n! write(*,173)'3X endmember: ',endmemrec%antalem,ipy,pyq,vals(1)\n173 format(a,2i4,4(1pe12.4))\n! multiply with py and derivatives. vals is composition independent\n! write(*,*)'3X Config G 4B: ',vals(1)*rtg\n! segmentation fault between 64 and 65 ....\n noderz2: if(moded.gt.0) then\n derloopz2: do id=1,gz%nofc\n do itp=1,3\n phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)+ &\n dpyq(id)*vals(itp)\n enddo\n if(moded.gt.1 .and. dpyq(id).gt.zero) then\n jxsym=kxsym(id,id+1)\n do jd=id+1,gz%nofc\n! trying to replace calls of ixsym ... OK here\n if(ixsym(id,jd).ne.jxsym) then\n write(*,*)'ISYM error 1',id,jd,ixsym(id,jd),jxsym\n stop\n endif\n! write(*,*)'3X segfault 64C',allocated(d2pyq),&\n! d2pyq(jxsym)\n! write(*,*)'3X segfault 64E',allocated(phres%d2gval)\n! phres%d2gval not allocated!!\n! write(*,*)'3X segfault 64F',phres%d2gval(jxsym,ipy)\n phres%d2gval(jxsym,ipy)= &\n phres%d2gval(jxsym,ipy)+ &\n d2pyq(jxsym)*vals(1)\n jxsym=jxsym+jd\n enddo\n endif\n enddo derloopz2\n endif noderz2\n do itp=1,6\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp)\n enddo\n! write(*,171)'3X phres7: ',ipy,phres%gval(1,1),phres%gval(1,ipy),&\n! pyq,vals(1)\n171 format(a,i3,6(1pe12.4))\n! strange values of mobilities for ordered phases ... EINSTEIN\n! if(ipy.ne.1) then\n! write(*,173)'3X gval: ',phmain%listprop(ipy),ipy,&\n! phres%gval(1,ipy),pyq,vals(1)\n! endif\n proprec=>proprec%nextpr\n! write(*,*)'3X Config G 4C: ',phres%gval(1,1)*rtg\n! debug problem with mobility calculation\n! if(ipy.eq.2) then\n! write(*,172)'3X mob: ',ipy,phmain%listprop(1),&\n! phmain%listprop(ipy),&\n! pyq,vals(1),pyq*vals(1),phres%gval(1,ipy)\n!172 format(a,3i4,6(1pe12.4))\n! endif\n enddo emprop\n!------------------------------------------------------------------\n! take link to first interaction records, use push and pop to save pyq etc\n! pmq keeps track of the location in LASTPMQ and MAXPMQ\n! for each interaction record in this binary interaction tree\n intrec=>endmemrec%intpointer\n gz%intlevel=0\n pmq=1\n! looking for Toop/Kohler calculations\n! write(*,*)'3X start interloop: ',associated(intrec)\n! pmq is initiated by palmtree above in the interaction records\n! write(*,*)'3X excess 0: ',associated(intrec),phres%gval(1,1)*rtg\n interloop: do while(associated(intrec))\n!----------------------------------------------------------------\n! come back here an interaction at a higher level or a poped next that must\n! be pushed \n200 continue\n gz%intlevel=gz%intlevel+1\n! write(*,*)'3X excess 1: ',gz%intlevel,phres%gval(1,1)*rtg\n! write(*,*)'3X is there a tooprec?: ',associated(intrec%tooprec)\n call push_pyval(pystack,intrec,pmq,&\n pyq,dpyq,d2pyq,moded,gz%nofc)\n! intrec%order is initiated by palmtree to set a sequential number\n pmq=intrec%order\n! check if there is a Kohler-Toop link (NOT YET)\n! write(*,*)'3X testing tooprec: ',associated(intrec%tooprec)\n if(associated(intrec%tooprec)) then\n! write(*,*)'3X Toop/Kohler model: ',&\n! associated(intrec%tooprec),chkperm,gz%intlevel\n tooprec=>intrec%tooprec\n if(chkperm) then\n write(*,*)'3X Toop/Kohler and permutations is illegal'\n gx%bmperr=4399; goto 1000\n endif\n! we need this additional information inside calc_toop\n! I find it very elegant just to include a pointer to the phase_varres record!\n tooprec%phres=>cps\n else\n nullify(tooprec)\n endif\n! write(*,155)'3X Pushed: ',pmq,gz%intlevel\n!-------------------------------------------------------------------\n! come back here for another permutation of same paremeter (no push needed)\n220 continue\n bford: if(chkperm) then\n setipermut: if(maxpmq(pmq).eq.0) then\n! ipermut must be initiated and saved in lastpmq\n ipermut=1; lastpmq(pmq)=ipermut\n! On level 1 the number of permutation is in first location\n! On level 2 it is more complicated but the first number of perm is in 2nd loc\n maxpmq(pmq)=intrec%noofip(gz%intlevel)\n else\n! lastpmq and maxpmq already initiated (NOTE: they are used for all\n! permutations of the same endmember, that is why they are stored here\n! They cannot be pushed on the stack as the stack is also popped\n ipermut=lastpmq(pmq)+1\n plimit: if(ipermut.gt.maxpmq(pmq)) then\n! maximum interaction level allowed when permutations is 2\n level: if(gz%intlevel.eq.1) then\n! This is always simple for level 1, \n maxpmq(pmq)=maxpmq(pmq)+&\n intrec%noofip(1)\n! write(*,155)'3X new limit: ',ipermut,&\n! maxpmq(pmq)\n if(ipermut.le.maxpmq(pmq)) goto 230\n elseif(gz%intlevel.gt.2) then\n write(*,*)'3X Max level 2 interactions allowed'\n gx%bmperr=4340; goto 1000\n else\n varying: if(intrec%noofip(1).eq.1) then\n! If this is 1 then noofip(2) is number of permutations each time\n maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2)\n if(ipermut.le.maxpmq(pmq)) goto 230\n else\n! This is more complicated, different number of permutations each time\n! Example: noofip=(3,2,1,0,12) means there are 3 different permutations\n! first time; 2 the second time; 1 the last time none;\n! 12 is the total number of permutationss (including first order)\n! Example 1: end member (A:A:A:A), no permutation\n! first int B in 1 with perms: 2nd int C in 2 with perms: (3,3,3,3,12)\n! (AB:A:A:A) (AB:AC:A:A) (AB:A:AC:A) (AB:A:A:AC)\n! (A:AB:A:A) (AC:AB:A:A) (A:AB:AC:A) (A:AB:A:AC)\n! (A:A:AB:A) (AC:A:AB:A) (A:AC:AB:A) (A:A:AB:AC)\n! (A:A:A:AB) (AC:A:A:AB) (A:AC:A:AB) (A:A:AC:AB)\n! Example 2: end member (A:A:A:A), no permutation\n! first int B in 1 with perms: 2nd int B in 2 with perms: (3,2,1,0,6)\n! (AB:A:A:A) (AB:AB:A:A) (AB:A:AB:A) (AB:A:A:AB)\n! (A:AB:A:A) (A:AB:AB:A) (A:AB:A:AB)\n! (A:A:AB:A) (A:A:AB:AB)\n! (A:A:A:AB) none\n! If mod(ipermut,noofip(1)) is 0 one should start from index 2\n nz=intrec%noofip(1)\n! write(*,155)'3X noofip: ',ipermut,pmq,&\n! maxpmq(pmq),(intrec%noofip(j),j=1,nz)\n if(maxpmq(pmq).gt.0) then\n! Previous increase of limit was greater than zero, special case for noofip=2\n if(intrec%noofip(1).eq.2) then\n maxpmq(pmq)=-maxpmq(pmq)\n else\n nz=mod(ipermut-1,intrec%noofip(1))\n if(nz.eq.0) then\n maxpmq(pmq)=-maxpmq(pmq)\n else\n maxpmq(pmq)=maxpmq(pmq)+&\n intrec%noofip(1+nz)\n endif\n endif\n if(ipermut.le.maxpmq(pmq)) goto 230\n else\n! Previous increase of limit was 0, start repeating values from noofip(2..\n maxpmq(pmq)=intrec%noofip(2)-&\n maxpmq(pmq)\n if(ipermut.le.maxpmq(pmq)) goto 230\n endif\n! write(*,155)'3X noperm: ',ipermut,pmq,&\n! lastpmq(pmq),maxpmq(pmq)\n endif varying\n! as we have passed the limit of permutations, take higher or next interaction\n!??? if(ipermut.le.maxpmq(pmq)) goto 230\n endif level\n! We have exeeded the permutation limit, we should not go to any\n! higher interaction but to a next interaction on same level (if any)\n! or go down one level\n if(associated(intrec%highlink)) then\n if(gz%intlevel.eq.2) then\n write(*,229)gz%intlevel\n229 format('3X Error, max 2 levels of interactions',/&\n ' with permutations!! ',i3)\n gx%bmperr=4340; goto 1000\n endif\n! Take the link to higher as no more permutations here\n goto 290\n endif\n!..............................\n! No higher level, if we cannot pop we must return to endmember\n if(gz%intlevel.eq.0) exit interloop\n! we must pop lower order interaction records here to get correct permutation\n call pop_pyval(pystack,intrec,pmq,&\n pyq,dpyq,d2pyq,moded,gz%nofc)\n gz%intlevel=gz%intlevel-1\n pmq=intrec%order\n!.................................\n! intrec must not be associated in the popint: do-loop\n nullify(intrec)\n goto 295\n endif plimit\n! We have now the permutation for this interaction in ipermut\n230 continue\n endif setipermut\n! Found the permutations for option F and B, save it in lastpmq(pmq)\n lastpmq(pmq)=ipermut\n! Without permutations just set ipermut=1\n else\n! write(*,*)'3X no permutations'\n ipermut=1\n endif bford\n!-------------------------------------------------------------------\n! Code below until label 290 the same with and without permutations\n! extract sublattice, constituent and fraction of interacting constituent\n! NOTE \"ic\" used several times below, do not manipulate it!!!\n intlat=intrec%sublattice(ipermut)\n ic=intrec%fraclink(ipermut)\n gz%intlat(gz%intlevel)=intlat\n gz%intcon(gz%intlevel)=ic\n! if intlat or ic is zero or less give error message and skip\n if(intlat.le.0 .or. ic.le.0) then\n if(already.eq.0 .or. intrec%antalint.ne.already) then\n already=intrec%antalint\n write(*,231)'3X error: ',phlista(lokph)%alphaindex,&\n (idlist(iw1),iw1=1,nsl),&\n (gz%intlat(iw1),gz%intcon(iw1),iw1=1,gz%intlevel)\n write(*,231)'3X intp: ',intrec%antalint,gz%intlevel,&\n ipermut,intlat,ic,pmq,maxpmq(pmq)\n231 format(a,10i5)\n endif\n goto 290\n endif\n gz%yfrint(gz%intlevel)=phres%yfr(ic)\n! write(*,*)'3X excess 2: ',ionicliq,iliqsave\n if(ionicliq .and. iliqsave) then\n if(intlat.eq.1 .and. yionva.gt.zero) then\n! iliqsave is TRUE for ionic_liquid and for excess parameters without anions\n! For cation interactions multiply with yionva. If no vacancies yionva=-1.0\n gz%yfrint(gz%intlevel)=phres%yfr(ic)*yionva\n! write(*,*)'3X *yionva: ',yionva,gz%yfrint(gz%intlevel)\n endif\n endif\n! calculate new PY incl derivatives. Moded to avoid unrequested derivatives\n!\n! IF interaction endmember is WILDCARD then the interaction is special,\n! L(*,A) is y_A *(1-y_A) where 1-y_A is the sum of all fractions except A\n! pyq = pyq * y_ic * (y_ix + y_iy + ... ) (all_other_in_same_sublattice))\n! derivatives are calculated for all constituents in intlat\n! note one can also have wildcards in other sublattices ....\n if(gz%endcon(intlat).gt.0) then\n wildc=.FALSE.\n ymult=gz%yfrint(gz%intlevel)\n else\n if(iliqsave) then\n! I sincerely hope wildcards are never used in 2nd subl of ionic liquids ...\n write(*,*)'3X Wildcard in second sublattice illegal for ionic liquids'\n gx%bmperr=4341; goto 1000\n endif\n wildc=.TRUE.\n wildmob=.TRUE.\n! write(*,*)'3X wildcard found!'\n ymult=gz%yfrint(gz%intlevel)*(one-gz%yfrint(gz%intlevel))\n endif\n! write(*,228)'3X d2pyq 1:',d2pyq\n!---------------------------------\n! write(*,*)'3X ionic liquid: ',iliqsave,yionva\n cationintandva: if(.not.iliqsave) then\n! iliqsave is TRUE when interaction in first sublattice and Va in second\n! write(*,228)'3X d2pyq 7:',d2pyq\n modedx: if(moded.gt.0) then\n! ...................................... loop for first derivatives\n iloop1: do id=1,gz%nofc\n if(moded.gt.1) then\n! ...................................... second derivatives\n! For all models except ionic liquids 2nd derivatives are simple ...\n iloop2B: do jd=id+1,gz%nofc\n! d2pyq(ixsym(id,jd))=d2pyq(ixsym(id,jd))*ymult\n jxsym=kxsym(id,jd)\n d2pyq(jxsym)=d2pyq(jxsym)*ymult\n enddo iloop2B\n d2pyq(ixsym(id,ic))=dpyq(id)\n endif\n! I FORGOT THIS LINE WHEN TRYING TO FIX IONIC LIQUID !!! TOTAL MESS !!!\n dpyq(id)=dpyq(id)*ymult\n enddo iloop1\n endif modedx\n else ! here we have cation interaction with Va in second subl.\n! SPECIAL FOR IONIC LIQUID\n! This is needed for interactions from endmembers with Va in second sublattice\n! as the model must be compatibel with a regular solution, like\n! (Mo+4,Pd+2,Rh+3)p(Va)q must be identical to (Mo,Pd,Rh) and\n! (Fe+2)p(Va,C)q must be identical to (Fe,C)\n! This requires that each cation fracition is multiplied with fraction of Va\n! Instead of just yA+yB+yVa one must have yA+yB+yVa**2\n! write(*,228)'3X pyq 0:',pyq\n! write(*,228)'3X dpyq 1:',dpyq\n! write(*,228)'3X divers:',ymult,yionva,gz%yfrem(1)\n if(jonva.le.0 .and. intlat.eq.1) then\n write(*,*)'Illegal cation interaction with neutral'\n gx%bmperr=4265; goto 1000\n endif\n! ...................................... loop for first derivatives\n iliqloop1: do id=1,gz%nofc\n seconder2: if(moded.gt.1) then\n! CODE BELOW IS UNCERTAIN\n! This IF loop is only executed when Va in second sublattice, i.e. when cation\n! interactions which should also be multiplied with the power of yionva\n! which is gz%intlevel+1\n! jonva=phlista(lokph)%i2slx(1) is index of vacancy, i2slx(2) is first neutral\n! index of the constituent in first sublattice is gz%endcon(1)\n! index of the constituent in second sublattice is gz%endcon(2) = jonva\n! index of interaction constituents are in gz%intcon(gz%intlevel+)\n! pyq, dpyq and d2pyq set for the endmember\n!\n! NOTE: some 2nd derivatives wrong for (Fe+2)p(Va,C)q and more ...\n! NOT tested (Ca+2)p(O-2,SiO4-4,SiO2)q\n! ...................................... loop for second derivatives\n iloop2X: do jd=id+1,gz%nofc\n jxsym=kxsym(id,jd)\n if(jd.le.phlista(lokph)%nooffr(1)) then\n! both id and jd are cations, interaction must be multiplied with yionva\n! d2pyq(ixsym(id,jd))=&\n! d2pyq(ixsym(id,jd))*ymult*yionva\n d2pyq(jxsym)=d2pyq(jxsym)*ymult*yionva\n! write(*,215)gz%intlevel,ic,id,jd,&\n! d2pyq(ixsym(id,jd)),ymult,&\n! d2pyq(ixsym(id,jd))*ymult*yionva\n215 format('3X d2pyq: ',4i3,4(1pe12.4))\n elseif(jd.lt.jonva) then\n! if jdintrec%propointer\n! write(*,218)'3X pyq: ',associated(proprec),ymult,pyq\n218 format(a,l2,2(1pe12.4))\n! list values of pyq, dpyg, d2pyg\n! write(*,228)'3X pyq:',pyq\n! write(*,228)'3X dpy:',dpyq\n! write(*,228)'3X d2py:',d2pyq\n219 format(a,6(1pe12.4))\n!..............................\n! Here we finally calculate the interaction parameter .... SUCK\n intprop: do while(associated(proprec))\n! calculate interaction parameter, can depend on composition\n! maybe faster to zero here than inside cgint ??\n vals=zero\n dvals=zero\n d2vals=zero\n! call cgint(lokph,proprec,moded,vals,dvals,d2vals,gz,ceq)\n call cgint(lokph,proprec,moded,&\n vals,dvals,d2vals,gz,tooprec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,228)'3X val:',vals(1),(dvals(1,id),id=1,gz%nofc)\n! G parameters (ipy=1) are divided by RT inside cgint\n typty=proprec%proptype\n if(typty.ne.1) then\n! check if magnetic and wildcard ...\n if(wildmob) then\n! nowildcard(1..3) set in gtp_init in gtp3A.F90 for mobility parameters\n! typty is indicator*100 + constituent index\n do qz=1,3\n if(typty/100.eq.nowildcard(qz)) then\n write(*,*)&\n '3X mobilities must not have wildcards',lokph\n gx%bmperr=4374; goto 1000\n endif\n enddo\n endif\n! other properties than 1 (G) must be stored in different gval(*,ipy) etc\n do qz=2,lprop-1\n if(phmain%listprop(qz).eq.typty) goto 250\n enddo\n! a new property, save its typty in listprop and increment lprop\n qz=lprop\n phmain%listprop(qz)=typty\n lprop=lprop+1\n phmain%listprop(1)=lprop\n250 continue\n! here the value of ipy is set, 1 means G\n ipy=qz\n else\n ipy=1\n endif\n! note: adding to phres%gval at the end of noder4: if(....)\n noder4: if(moded.gt.0) then\n iloop3: do id=1,gz%nofc\n if(moded.gt.1) then\n! Testing using jxsym ... OK here also\n jxsym=kxsym(id,id)\n! iloop4: do jd=id+1,gz%nofc\n! This loop was constructed for normal cases when pyq has each fraction once\n! in ionic liquids Va can have a power so loop for all!\n iloop4: do jd=id,gz%nofc\n! phres%d2gval(ixsym(id,jd),ipy)= &\n! phres%d2gval(ixsym(id,jd),ipy)+ &\n! d2pyq(ixsym(id,jd))*vals(1)\n if(ixsym(id,jd).ne.jxsym) then\n write(*,*)'ISYM error 2',id,jd,&\n ixsym(id,jd),jxsym\n stop\n endif\n phres%d2gval(jxsym,ipy)= &\n phres%d2gval(jxsym,ipy)+ &\n d2pyq(jxsym)*vals(1)\n jxsym=jxsym+jd\n! write(*,251)'3X G:',id,jd,ixsym(id,jd),&\n! d2pyq(ixsym(id,jd)),vals(1)\n251 format(a,3i3,4(1pe12.4))\n enddo iloop4\n endif\n! toop7: if(associated(tooprec)) then\n! this is part of iloop3 is for all components \"id\", starting 30 lines above \n! Normally binay interactions depend only on the constituents gz%iq(1) \n! and gz%iq(2) but Toop/Kohler method depend also on other constituents! \n! Thus dvals may not be correctly updated but that is taken care here\n! write(*,'(a,i3,5(1pe12.4))')'3X toop7: ',&\n! id,pyq,dvals(1,id),phres%dgval(1,id,ipy)+pyq*dvals(1,id),&\n! (phres%dgval(1,id,ipy)-pyq*dvals(1,id))*gz%rgast\n! For those like me who forget:\n! dgval)1,j,1) is derivative of G wrt constituent j\n! dgval(2,j,1) is derivative of G wrt constituent j and T\n! dgval(3,j,1) is derivative of G wrt constituent j and P. \n! Third index is for other properties such as TC, BMAGN etc\n! write(*,'(\"3X Toop: \",i3,1pe12.4,2x,3(1pe12.4))')id,pyq,&\n! dvals(1,id),dvals(2,id),dvals(3,id)\n! do itp=1,3\n! phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)-pyq*dvals(itp,id)\n! enddo\n! I think this is already taken into account in calc_toop\n! ignore contribution to the second derivatives phres%d2gval\n! iloop3 ends just a few lines below\n! endif toop7\n do itp=1,3\n phres%dgval(itp,id,ipy)=&\n phres%dgval(itp,id,ipy)+dpyq(id)*vals(itp)\n enddo\n enddo iloop3\n! write(*,211)'3X Interactions: ',gz%iq,jonva\n211 format(a,5i3,5x,i3)\n! if(jonva.gt.0) then\n! write(*,212)jonva,phres%dgval(1,jonva,1)*rtg\n212 format('3X with va: ',i3,6(1pe12.4))\n! endif\n!...............................\n! below contribution to derivatives from composition dependent parameters\n! the values of gz%iq represent interacting constituents and are set in cgint\n cdex1: if(gz%iq(5).gt.0) then\n! gz%iq(5) is nonzero only for TOOP and similar models not implemented yet ...\n gx%bmperr=4086; goto 1000\n elseif(gz%iq(4).gt.0) then\n!...............................\n! composition dependent reciprocal parameter\n! for ionic liquid one must consider extra vacancy fractions ...\n! remember ipy is property type for this parameter, set above\n! write(*,333)'3X comp dep reciprocal:',gz%iq,pyq,vals(1)\n333 format(a,5i4,4(1pe14.6))\n if(moded.gt.0) then\n do jk=1,4\n if(moded.gt.1) then\n! contribution to second derivatives with respect to 2 const previously ignored\n! No second derivatives calculated in cgint for this case\n! no jxsym here ... to complicated\n do qz=jk,4\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)=&\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)+&\n! dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+&\n! dpyq(gz%iq(qz))*dvals(1,gz%iq(jk))\n! I do not trust optimized gfortran will eliminate 2 calls to ixsym !!!\n jxsym=ixsym(gz%iq(jk),gz%iq(qz))\n phres%d2gval(jxsym,ipy)=&\n phres%d2gval(jxsym,ipy)+&\n dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+&\n dpyq(gz%iq(qz))*dvals(1,gz%iq(jk))\n enddo\n endif\n! first derivatives, including 2nd wrt T and P\n do itp=1,3\n! itp=1 for 1st derivative, =2 for 2nd derivative also with T, =3 also with P\n phres%dgval(itp,gz%iq(jk),ipy)=&\n phres%dgval(itp,gz%iq(jk),ipy)+&\n pyq*dvals(itp,gz%iq(jk))\n enddo\n enddo\n endif\n elseif(gz%iq(3).gt.0) then !cedex1\n! composition dependent ternary interaction in same sublattice, Mats model\n! PROBABLY ERRORS HERE as no consideration of derivatives wrt other endmember\n! constituents, only to the 3 interacting\n! ALSO used to indicate derivatives wrt vacancies in ionic liquid model ??? NO!\n!...<<<<<<<...... indentation back 2 levels\n if(moded.gt.1) then\n noindent1: do jk=1,3\n do qz=jk+1,3\n! the second derivative for jk=qz calculated below as it is simpler\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)=&\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(qz)),ipy)+&\n! dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+&\n! dpyq(gz%iq(qz))*dvals(1,gz%iq(jk))\n! not trusting gfortran optimizing\n jxsym=ixsym(gz%iq(jk),gz%iq(qz))\n phres%d2gval(jxsym,ipy)=&\n phres%d2gval(jxsym,ipy)+&\n dpyq(gz%iq(jk))*dvals(1,gz%iq(qz))+&\n dpyq(gz%iq(qz))*dvals(1,gz%iq(jk))\n enddo\n enddo noindent1\n endif\n do jk=1,3\n do itp=1,3\n phres%dgval(itp,gz%iq(jk),ipy)=&\n phres%dgval(itp,gz%iq(jk),ipy)&\n +pyq*dvals(itp,gz%iq(jk))\n enddo\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)=&\n! phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)+&\n! 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk))\n! not trusing gforntran optimizing\n jxsym=ixsym(gz%iq(jk),gz%iq(jk))\n phres%d2gval(jxsym,ipy)=&\n phres%d2gval(jxsym,ipy)+&\n 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk))\n enddo\n!...>>>>>>...........indentation forward\n elseif(gz%iq(2).gt.0) then !cedex1\n! gz%iq(2) nonzero means composition dependent binary interaction parameter,\n! only RK yet.\n noder3B: if(moded.gt.1) then\n! one can maybe make this loop faster by just looping throungh endmembrs\n! but then one must handle wildcard endmembers ....\n! and there may be other bugs here anyway ....\n do ic1=1,gz%nofc\n! add1=dpyq(ic1)*dvals(1,gz%iq(1))+&\n! dpyq(gz%iq(1))*dvals(1,ic1)+&\n! pyq*d2vals(ixsym(ic1,gz%iq(1)))\n! phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)=&\n! phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)+add1\n! not trusing gfortran optimizing\n jxsym=ixsym(ic1,gz%iq(1))\n add1=dpyq(ic1)*dvals(1,gz%iq(1))+&\n dpyq(gz%iq(1))*dvals(1,ic1)+&\n pyq*d2vals(jxsym)\n phres%d2gval(jxsym,ipy)=&\n phres%d2gval(jxsym,ipy)+add1\n if(ic1.ne.gz%iq(1)) then\n! this IF to avoid that the second derivative gz%iq(1) and gz%iq(2) is\n! calculated twice. ic1 will at some time be equal to gz%iq(1) and to gz%iq(2)\n! add1=dpyq(ic1)*dvals(1,gz%iq(2))+&\n! dpyq(gz%iq(2))*dvals(1,ic1)+&\n! pyq*d2vals(ixsym(ic1,gz%iq(2)))\n! phres%d2gval(ixsym(ic1,gz%iq(2)),ipy)=add1+&\n! phres%d2gval(ixsym(ic1,gz%iq(2)),ipy)\n! not trusting gfortran optimizing\n jxsym=ixsym(ic1,gz%iq(2))\n add1=dpyq(ic1)*dvals(1,gz%iq(2))+&\n dpyq(gz%iq(2))*dvals(1,ic1)+&\n pyq*d2vals(jxsym)\n phres%d2gval(jxsym,ipy)=add1+&\n phres%d2gval(jxsym,ipy)\n endif\n enddo\n endif noder3B\n do itp=1,3\n phres%dgval(itp,gz%iq(1),ipy)=&\n phres%dgval(itp,gz%iq(1),ipy)&\n +pyq*dvals(itp,gz%iq(1))\n phres%dgval(itp,gz%iq(2),ipy)=&\n phres%dgval(itp,gz%iq(2),ipy)&\n +pyq*dvals(itp,gz%iq(2))\n! to many indentations--------------------------------------------\n catx: if(ionicliq) then\n! for ionic liquid when interactions involve cations there is a contribution\n! due to the vacancy fraction multiplied with the cations yc1*yc2*yva**2\n! we are dealing with binary RK interactions, gz%intlevel=1, check if \n! interaction is in first sublattice (between cations) and vacancy in second\n if(iliqva .and. jonva.gt.0) then\n if(gz%intlat(1).eq.1) then\n! add pyq multipled with the derivative with respect to vacancy fraction\n! This should be done for d2gval also but I skip that at present ...\n phres%dgval(itp,jonva,ipy)=&\n phres%dgval(itp,jonva,ipy)+pyq*dvals(itp,jonva)\n! write(*,*)'3X jonva:',jonva,pyq,dvals(1,jonva)\n elseif(gz%intlat(1).eq.2 .and. gz%iq(2).gt.jonva) then\n! This fixed the problem with Pd-Ru-Te in the fuel (+ fix in cgint)\n! write(*,55)'3X (C:Va,K)',iliqva,gz%intlat(1),jonva,gz%iq(1),&\n! gz%iq(2),gz%endcon(1),pyq,dvals(itp,gz%endcon(1))\n55 format(a,l2,5i3,4(1pe12.4))\n icat=gz%endcon(1)\n if(icat.gt.0) then\n phres%dgval(itp,icat,ipy)=&\n phres%dgval(itp,icat,ipy)+pyq*dvals(itp,icat)\n! else\n! wow, icat can be -99 meaning interaction between neutrals ....\n! but then just skip as the assignment above is not relevant\n! Error occured for ionic liquid with:\n! 1 2 3 4 5 6 7 8 9 10 11\n! BA+2 CE+3 CS+ GD+3 LA+3 MO+4 PD+2 PU+3 RU+4 U+4 ZR+4 : \n! I- MOO4-2 O-2 VA CEO2 CS2TE CSO2 I2 MOO3 O PUO2 TE TEO2\n! 12 13 14 15 16 17 18 19 20 21 22 23 24\n! we come here with: BA+2:VA,TE; PD+2:VA,TE; RU+4:VA,TE; *:CS2TE,TE\n! gz%intlat(1)=2 OK; jonva=15 OK; gz%iq(1)=17(Cs2Te); gz%iq(2)=23(Te); \n! gz%endcon(1)=-99\n! write(*,55)'3X Instroini:',iliqva,gz%intlat(1),jonva,&\n! gz%iq(1),gz%iq(2),gz%endcon(1),pyq\n endif\n endif\n endif\n endif catx\n! increase indendation-----------------------------------------\n enddo\n endif cdex1\n! end contribution to derivates from composition dependent parameters\n!......................\n endif noder4\n! finally add the contribution to G, G.T etc\n iloop6: do itp=1,6\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp)\n enddo iloop6\n! debug problem with mobility calculation\n! if(ipy.eq.2) then\n! write(*,172)'3X imob:',ipy,phmain%listprop(1),&\n! phmain%listprop(ipy),&\n! pyq,vals(1),pyq*vals(1),phres%gval(1,ipy)\n! endif\n proprec=>proprec%nextpr\n enddo intprop\n! write(*,*)'3X Config G 4F: ',phres%gval(1,1)*rtg\n! finished one interaction (or permutation on this level), go to higher level\n! note that ipermut is saved in lastpmq(pmq). If there are more\n! permutations on this level they will be calculated later also including \n! higher order parameters. \n!------------------------------------------------------------------\n! Take link to higher level records for current permutation\n290 continue\n intrec=>intrec%highlink\n wrong: if(chkperm .and. associated(intrec)) then\n! We must go to higher as we can have interactions with different permutations?\n jpr=intrec%order\n if(lastpmq(jpr).gt.0 .and.lastpmq(jpr).ge.maxpmq(jpr)) then\n! if we nullify here we will take next rather than higher\n! nullify(intrec)\n! write(*,155)'3X Maybe skipping higer?: ',jpr,&\n! lastpmq(jpr),maxpmq(jpr),gz%intlevel\n! if(maxpmq(jpr).lt.0) maxpmq(jpr)=intrec%noofip(2)-&\n! maxpmq(jpr)\n endif\n endif wrong\n! if intrec is associated then go to big \"interloop: do while()\" loop\n295 continue\n popint: do while(.not.associated(intrec))\n! No higher level, pop lower order interaction records, if no pop: endmember\n if(gz%intlevel.eq.0) exit interloop\n call pop_pyval(pystack,intrec,pmq,&\n pyq,dpyq,d2pyq,moded,gz%nofc)\n gz%intlevel=gz%intlevel-1\n pmq=intrec%order\n! check if we have more permutations for this record\n if(chkperm) then\n if(lastpmq(pmq).lt.maxpmq(pmq)) then\n! here we could maybe use cycle interloop ??/Bosse 2023.12.16\n goto 200\n endif\n endif\n intrec=>intrec%nextlink\n enddo popint\n! we should loop here if we found a higher order record or \n! a lower order record with a next link\n enddo interloop\n298 continue\n! write(*,*)'3X Config G 4X: ',phres%gval(1,1)*rtg\n! take next permutation of the end member fractions\n enddo empermut\n300 continue\n! take next end member\n! write(*,155)'3X endmem: ',epermut,endmemrec%noofpermut,endmemrec%antalem\n endmemrec=>endmemrec%nextem\n enddo endmemloop\n! write(*,*)'3X Config G 5: ',phres%gval(1,1)*rtg\n!------------------------------------------------------------------------\n! end loop for this fraction type, initiation for next in the beginning of loop\n! but we may have to calculate once again with same fraction type but\n! with the fractions as disordered fractions\n! write(*,*)'3X Testing nevertwice ',nevertwice\n! Jump to 400 terminates calculation for this fraction type\n! write(*,303)'3X Nevertwice: ',nevertwice,&\n! btest(phlista(lokph)%status1,phsubo),&\n! first,fractype,phres%gval(1,1)\n303 format(a,3(1x,l1),i3,4(1pe12.4))\n! write(*,623)'3X order/disorder: ',lprop,phres%gval(1,2),phres%gval(1,3)\n if(nevertwice) goto 400\n! UNIFINISHED ??\n! TEST IF WE SHOULD SUBTRACT THE ORDERED ENERGY AS DISORDERED AS IN THE\n! CURRENT IMPLEMENTATION IN THERMO-CALC. BY JUMPING TO 400 WE SKIP THAT.\n if(btest(phlista(lokph)%status1,phsubo)) then\n! write(*,*)'3X phsubo bit set'\n goto 400\n endif\n! PARTITION PROBLEM FOR ORDERED PHASES\n! goto 400\n!------------------------------------------------\n! write(*,611)'3X ftyp1:',fractype,btest(phlista(lokph)%status1,phmfs),&\n! btest(phmain%status2,csorder),first,lokph,phres%gval(1,1)\n611 format(a,i3,3(1x,L),i3,3(1pe12.4))\n disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) &\n .and. btest(phmain%status2,csorder)) then\n! Handle additions of several fraction set ?? Additions calculated\n! after both ordered and disordered fraction set calculated\n! write(*,611)'3X ftyp:',fractype,btest(phlista(lokph)%status1,phmfs),&\n! btest(phmain%status2,csorder),first,lokph,phres%gval(1,1)\n returnoradd: if(first) then\n! we have calculated for the first, now calculate for second fraction type\n! alternative method: no need to calculate with all fractions as disordered\n first=.false.\n! write(*,*)'3X: next fraction type'\n! goto 400\n! we must save phres%yfr before disorder ....\n! allocate(savey(gz%nofc))\n! this creates problem with pointers in disordery?? avoid by allocating savey??\n! savey=phres%yfr\n do j1=1,size(phres%yfr)\n savey(j1)=phres%yfr(j1)\n enddo\n!------------ code below was removed for a while but is now reinstated\n! write(*,*)'3X cg: ',phmain%phlink,phmain%disfra%varreslink\n! ??? very uncertain how to call disordery .....\n! call disordery(phmain,phmain%disfra%varreslink,ceq)\n! write(*,*)'3X At disordery: ',phmain%disfra%varreslink,&\n! cps%disfra%varreslink\n call disordery(phmain,ceq)\n! if call to disordery here no crash in disordery ...\n! if call moved to after assignment of savey there is a crash (GNU fortran)\n!----------\n! allocate(savey(gz%nofc))\n! savey=phres%yfr\n! nprop=phmain%nprop\n! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3)\n! write(*,623)'3X V0,VA 1: ',lprop,phres%gval(1,2),phres%gval(1,3)\n623 format(a,i3,6(1pe12.4))\n! we already know nprop\n allocate(saveg(6,nprop))\n allocate(savedg(3,gz%nofc,nprop))\n allocate(saved2g(nofc2,nprop))\n! write(*,*)'3X saveg allocated 3: ',size(saveg)\n saveg=phres%gval\n savedg=phres%dgval\n saved2g=phres%d2gval\n! do i1=1,gz%nofc\n! write(*,602)'3X G4y: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1)\n! enddo\n phres%gval=zero\n phres%dgval=zero\n phres%d2gval=zero\n goto 110\n else\n! We have now calculated the 4SL model both as original and disordered\n! We should now subtract the disordered from the ordered\n! this is debug output\n! do i1=1,gz%nofc\n! write(*,602)'3X G4x: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1)\n! enddo\n602 format(a,i3,6(1pe14.6))\n! Ordered part calculated with disordered fractions, subtract this\n! from the first, restore fractions and deallocate\n! THIS IS TRICKY\n! NOTE all sublattices are identical in this case with the same number \n! of constituents\n! First sum all second derivatives into tmpd2g, moded=1 means only 1st deriv\n! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3)\n! write(*,623)'3X V0,VA 2: ',lprop,phres%gval(1,2),phres%gval(1,3)\n noder6A: if(moded.gt.1) then\n nz=fracset%tnoofxfr\n! allocate(tmpd2g(nz*(nz+1)/2,nprop))\n! tmpd2g=zero\n!--------------------------------------------------------------------------\n! simplest way of correcting 2nd deruvatives, Gord(y=x) in phres%d2gval\n! phres%d2gval(i,j) = saved2g(i,j) - phres%d2gval(i,j)\n do ipy=1,lprop-1\n do i1=1,gz%nofc\n! jxsym=ixsym(i1,i1)\n jxsym=kxsym(i1,i1)\n! It should work with jxsym here \n do i2=i1,gz%nofc\n! if(ixsym(i1,i2).ne.jxsym) then\n! this ixsym test works and has run of few 1000 times, removed for speed!!\n! write(*,*)'ISYM error 3',i1,i2,ixsym(i1,i2),jxsym\n! stop\n! endif\n phres%d2gval(jxsym,ipy)=&\n saved2g(jxsym,ipy)-&\n phres%d2gval(jxsym,ipy)\n! adding i2 to jxsym here seems correct!!\n jxsym=jxsym+i2\n! phres%d2gval(ixsym(i1,i2),ipy)=&\n! saved2g(ixsym(i1,i2),ipy)-&\n! phres%d2gval(ixsym(i1,i2),ipy)\n enddo\n enddo\n enddo\n! goto 667\n! old code removed\n!667 continue\n if(allocated(tmpd2g)) deallocate(tmpd2g)\n endif noder6A\n!---------------------\n! sum all first partial derivates to first sublattice\n noder6B: if(moded.gt.0) then\n! write(*,613)'3X dG/dx: ',fracset%ndd,fracset%nooffr\n do ipy=1,lprop-1\n do ider=1,3\n do is=1,fracset%nooffr(1)\n sum=zero\n kk=is\n do ll=1,fracset%latd\n sum=sum+phres%dgval(ider,kk,ipy)\n! it is not really necessary to put phres%dgval it to zero, just for prudence\n! phres%dgval(ider,kk,ipy)=zero\n kk=kk+fracset%nooffr(1)\n enddo\n phres%dgval(ider,is,ipy)=sum\n enddo\n if(fracset%ndd.eq.2) then\n! one can have 2 sets of ordered subl like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)...\n! BUT I doubt that works ...\n ioff=fracset%nooffr(1)*fracset%latd\n do is=1,fracset%nooffr(2)\n sum=zero\n kk=ioff+is\n do ll=fracset%latd+1,phlista(lokph)%noofsubl\n sum=sum+phres%dgval(ider,kk,ipy)\n phres%dgval(ider,kk,ipy)=zero\n kk=kk+fracset%nooffr(2)\n enddo\n phres%dgval(ider,ioff+is,ipy)=sum\n enddo\n endif\n enddo\n enddo\n!-------------------------\n if(moded.gt.0) then\n do ipy=1,lprop-1\n! loop in negative direction avoid destroy the values in phres%dgval first subl\n do i1=gz%nofc,1,-1\n! all derivatives wrt same element from all sublattices is in first sublattice\n j1=fracset%y2x(i1)\n do ider=1,3\n! Finally subtract this contribution from saved values\n! phres%dgval(ider,i1,ipy)=savedg(ider,i1,ipy)-&\n xxx=savedg(ider,i1,ipy)-&\n phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1)\n! write(*,615)'3X Gy-Gx: ',ider,i1,ipy,j1,&\n! savedg(ider,i1,ipy),phres%dgval(ider,j1,ipy),&\n! fracset%dxidyj(i1),xxx\n!615 format(a,4i3,4(1pe14.6))\n phres%dgval(ider,i1,ipy)=xxx\n enddo\n enddo\n enddo\n endif\n endif noder6B\n! check for bug, phres%gval(1,1) must not be negative!!\n! write(*,617)'3X do=o-oasd: ',saveg(1,1),phres%gval(1,1),&\n! saveg(1,1)-phres%gval(1,1)\n617 format(a,6(1pe12.4))\n do ipy=1,lprop-1\n do ider=1,6\n phres%gval(ider,ipy)=saveg(ider,ipy)-&\n phres%gval(ider,ipy)\n enddo\n enddo\n! error calculating volumes for order/disorder, V0 in gval(1,2), VA in gval(1,3)\n! write(*,623)'3X V0,VA 3: ',lprop,phres%gval(1,2),phres%gval(1,3)\n! restore ordered fractions and deallocate save arrays why not allocate savey?\n! write(*,612)'3X yd: ',(phres%yfr(ipy),ipy=1,gz%nofc)\n! do ipy=1,gz%nofc\n phres%yfr=savey\n! enddo\n! write(*,612)'3X yo: ',(phres%yfr(ipy),ipy=1,gz%nofc)\n612 format(a,6(1pe11.3)/(7x,6e11.3))\n! why set to zero if I deallocate ??\n! savey=zero\n! saveg=zero\n! savedg=zero\n! saved2g=zero\n! if(ocv()) write(*,*)'3X saveg DE-allocated 1: ',size(saveg)\n! deallocate(savey)\n deallocate(saveg)\n deallocate(savedg)\n deallocate(saved2g)\n endif returnoradd\n! code above reinstated but has problems ....\n endif disord\n! WE CAN JUMP HERE WITHOUT CALCULATING THE ORDERED PART AS DISORDERED\n400 continue\n! write(*,*)'3X calcg_internal at label 400'\n enddo fractyp\n! norfc=phlista(lokph)%tnooffr\n! 4SL FCC all correct here\n! write(*,69)'3X d2G/dy2B:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc)\n69 format(a,i3,6(1pe12.4))\n!--------------------------------------------------------------\n! finished loops for all fractypes, now add together G and all\n! partial derivatives for all fractypes\n410 continue\n! cheking for properties\n! if(ocv()) then\n! write(*,411)lprop-1,(phmain%listprop(j1),j1=2,lprop)\n! write(*,412)'Val: ',(phmain%gval(1,j1),j1=1,lprop-1)\n!411 format('3X Properties: ',i3,': ',10i4)\n412 format(a,(6E12.4))\n! endif\n norfc=phlista(lokph)%tnooffr\n fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then\n!----------------------------------------------------------------\n! for disordered part of sigma we may have to multiply the disordered\n! part with fsites to have correct formula unit\n! write(*,*)'3X fsites 1: ',phmain%disfra%fsites\n fsites=phmain%disfra%fsites\n! add together contributions from different fractypes\n! phres is last calculated part, set phpart to ordered part (phmain)\n phpart=>phmain\n! loop for all second and first derivatives using chain rule\n! and coefficients from fracset%dxidyj\n! d2f1/dyidyj = d2f2/dxkdxl*dxk/dyi*dxl/dyj\n! gz%nofc are number of disordered constituents\n! norfc are number of ordered constituents\n! lprop-1 is number of properties to be summed\n! G(tot) = GD(x)+(GO(y)-GO(y=x))\n! G(tot).yj = dGD(x).dxi*dxdyj + (GO(y).yj - GO(y=x).yj)\n! configurational entropy calculated only for GO(y)\n noder7A: if(moded.gt.0) then\n do i1=1,norfc\n j1=fracset%y2x(i1)\n! second derivatives\n noder7B: if(moded.gt.1) then\n! problem using jxsym here, map13 crashed FCC 4 sublattice orering!!!\n! PAY ATTENTION TO indices!! we have both i1, i2 and j1, j2\n! jxsym=ixsym(i1,i1)\n jxsym=kxsym(i1,i1)\n do i2=i1,norfc\n! add the contributions from the disordered part\n j2=fracset%y2x(i2)\n! if(ixsym(i1,i2).ne.jxsym) then\n! this ixsym test works and has run of few 1000 times, removed for speed!!\n! write(*,*)'ISYM error 4',i1,i2,ixsym(i1,i2),jxsym\n! stop\n! endif\n do ipy=1,lprop-1\n phpart%d2gval(jxsym,ipy)=&\n phpart%d2gval(jxsym,ipy)+&\n fsites*phres%d2gval(ixsym(j1,j2),ipy)*&\n fracset%dxidyj(i1)*fracset%dxidyj(i2)\n! phpart%d2gval(ixsym(i1,i2),ipy)=&\n! phpart%d2gval(ixsym(i1,i2),ipy)+&\n! fsites*phres%d2gval(ixsym(j1,j2),ipy)*&\n! fracset%dxidyj(i1)*fracset%dxidyj(i2)\n enddo\n jxsym=jxsym+i2\n enddo\n endif noder7B\n! first derivatives\n do ipy=1,lprop-1\n! add1=phpart%dgval(1,i1,ipy)\n do ider=1,3\n! phpart%dgval(ider,i1,ipy)=phpart%dgval(ider,i1,ipy)+&\n xxx=phpart%dgval(ider,i1,ipy)+&\n fsites*phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1)\n! phres have the disordred contribution\n! write(*,413)'3X Gd+Go:',ider,i1,j1,&\n! phpart%dgval(ider,i1,ipy),fsites,&\n! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx\n! write(*,413)'3X Gd+Go:',ider,i1,j1,&\n! phmain%dgval(ider,i1,ipy),fsites,&\n! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx\n phpart%dgval(ider,i1,ipy)=xxx\n enddo\n enddo\n enddo\n endif noder7A\n413 format(a,3i3,6(1pe12.4))\n! Check Integral values, phpart%gval(1,1) is ordered-ordasdis, phres is disord\n! write(*,617)'3X g=do+d: ',phpart%gval(1,1),fsites*phres%gval(1,1),&\n! phpart%gval(1,1)+fsites*phres%gval(1,1)\n do ipy=1,lprop-1\n! add1=phpart%gval(1,ipy)\n do ider=1,6\n phpart%gval(ider,ipy)=phpart%gval(ider,ipy)+&\n fsites*phres%gval(ider,ipy)\n \n enddo\n! if(ocv()) write(*,413)'3X G:',ipy,0,0,&\n! write(*,413)'3X G:',ipy,0,0,&\n! phpart%gval(1,ipy),add1,phres%gval(1,ipy)\n enddo\n! write(*,413)'3X 413:',ipy,0,0,&\n! phpart%gval(1,ipy),add1,phres%gval(1,1)\n endif fractionsets\n! now set phres to ordered+disorded results and forget phpart\n phres=>phmain\n!................................\n! write(*,*)'3X: ioliq+saved: ',ionicliq,iliqsave,phres%gval(1,1)\n ionliqsum: if(ionicliq .and. iliqsave) then\n! For ionic liquid we may have to add gsave+Q*gval (with chain rule ...)\n! G = saveg + Q*phres%gval with 1st and 2nd derivatives\n! NOT FINISHED !!! interaction parameters above with VA must be treated\n!\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! BEWHARE: FOR IONIC_LIQUID Thermo-Calc (version S) calculates G = Q G_M \n! if there are no end-member parameters (G_M is the Gibbs energy per\n! formula unit and Q is the number of sites in second sublattice), \n! This is wrong (but all endmember parameters are never zero for a real liquid)\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n!\n! write(*,*)'3X Config G 6: ',phres%gval(1,1)*rtg\n if(moded.eq.0) goto 490\n! write(*,491)'3X ionliq: ',phlista(lokph)%i2slx,phlista(lokph)%nooffr\n491 format(a,2i3,5x,2i3)\n firstd: do i1=1,norfc\n! jxsym=ixsym(i1,i1)\n jxsym=kxsym(i1,i1)\n secondd: do i2=i1,norfc\n do ipy=1,lprop-1\n! write(*,497)'3X adding: ',i1,i2,ixsym(i1,i2),ipy\n497 format(a,10i3)\n! if(ixsym(i1,i2).ne.jxsym) then\n! this ixsym test works and has run of few 1000 times, removed for speed!!\n! write(*,*)'ISYM error 5',i1,i2,ixsym(i1,i2),jxsym\n! stop\n! endif\n phres%d2gval(jxsym,ipy)=saved2g(jxsym,ipy)+&\n phres%sites(2)*phres%d2gval(jxsym,ipy)\n! phres%d2gval(ixsym(i1,i2),ipy)=saved2g(ixsym(i1,i2),ipy)+&\n! phres%sites(2)*phres%d2gval(ixsym(i1,i2),ipy)\n add1=zero\n! IMPORTANT note dpqdy(i1) the the charge of iq, do not confuse with dpyq ...\n if(i1.le.phlista(lokph)%nooffr(1)) then\n add1=phres%dpqdy(i1)*phres%dgval(1,i2,ipy)\n endif\n if(i2.le.phlista(lokph)%nooffr(1)) then\n add1=add1+phres%dpqdy(i2)*phres%dgval(1,i1,ipy)\n endif\n phres%d2gval(jxsym,ipy)=phres%d2gval(jxsym,ipy)+add1\n! phres%d2gval(ixsym(i1,i2),ipy)=phres%d2gval(ixsym(i1,i2),ipy)+&\n! add1\n jxsym=jxsym+i2\n enddo\n enddo secondd\n! hm, when debugging here phres%dgval(1,*,1)=0 so ...\n add1=savedg(1,i1,1)\n sum=phres%dgval(1,i1,1)\n if(phres%dpqdy(i1).lt.1.0D-60) phres%dpqdy(i1)=zero\n do ipy=1,lprop-1\n do ider=1,3\n! this calculates the proper ionic liquid model, not Q times\n phres%dgval(ider,i1,ipy)=&\n savedg(ider,i1,ipy)+&\n phres%sites(2)*phres%dgval(ider,i1,ipy)\n! The contribution from the derivative of Q = \\sum_i nu_i y_i, dQ/dy_i = nu_i\n! G = G1 + Q G2 where\n! G1 = \\sum_i \\sum_j y_i y_j G_ij + config.entropy\n! G2 = y_va\\sum_i y_i G_i + Q\\sum_k y_k G_k\n! Above were added: dG/dy_i = dG1/dy_i + + Q dG2/dy_i \n! For cations we must add also dG/dy_i = dG/dy_i + nu_i G2 \n if(i1.le.phlista(lokph)%nooffr(1)) then\n! nooffr(1) is the number of constituents in first sublattice\n phres%dgval(ider,i1,ipy)=phres%dgval(ider,i1,ipy)+&\n phres%dpqdy(i1)*phres%gval(ider,ipy)\n endif\n enddo\n enddo\n! write(*,747)'3X suming: ',i1,savedg(1,i1,1)*rtg,phres%dgval(1,i1,1)*rtg,&\n! phres%dpqdy(i1),phres%gval(1,1)\n! write(*,747)'3Xx:',i1,add1,sum,phres%dgval(1,i1,1),phres%dpqdy(i1),&\n! phres%sites(2),savedg(1,i1,1)\n!747 format(a,i2,6(1pe12.4))\n enddo firstd\n! write(*,*)'3X summed: ',savedg(1,1,1)*rtg,phres%dgval(1,1,1)*rtg\n! Integral values: G = saveg + Q*phres%gval with T and P derivatives\n490 continue\n! write(*,492)'3X ionsum: ',saveg(1,1),phres%gval(1,1),&\n! (saveg(1,1)+phres%gval(1,1))*rtg*phres%sites(2)\n492 format(a,6(1pe12.4))\n! write(*,*)'3X Config G 7A: ',phres%gval(1,1)*rtg\n do ipy=1,lprop-1\n do ider=1,6\n phres%gval(ider,ipy)=saveg(ider,ipy)+&\n phres%sites(2)*phres%gval(ider,ipy)\n enddo\n enddo\n! write(*,*)'3X Config G 7B: ',phres%gval(1,1)*rtg,saveg(1,1)*rtg\n! strange bug which changes the results for a calculation with only C1\n! if the ionic liquid has been non-suspended at some previous calculation ...\n saveg=zero\n! if(ocv()) write(*,*)'3X deallocated saveg 2: ',size(saveg)\n! no need to set them zero if they will be deallocated??\n! savedg=zero\n! saved2g=zero\n deallocate(saveg)\n if(moded.gt.0) then\n deallocate(savedg)\n deallocate(saved2g)\n endif\n!499 continue\n endif ionliqsum\n!................................\n! we have now finished calculate all parameters including those \n! properties that affect the Gibbs energy indirectly like Curie T etc\n! The label here just a label, there is no explict jump here\n500 continue\n! write(*,69)'3Xa d2G/dy2C:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc)\n if(btest(phmain%status2,CSADDG)) then\n! we have an constant addition to G, at present just a constant /RT\n if(allocated(phmain%addg)) then\n xxx=phmain%addg(1)/ceq%rtn\n else\n write(*,*)'3X not allocated addg'\n xxx=zero\n endif\n! write(*,*)'Addition to G:',xxx\n! a constant addition affects G and dG/dy and d2G/dy2\n phmain%gval(1,1)=phmain%gval(1,1)+xxx\n! dgval( 1/dT/dP , i , property)\n do id=1,gz%nofc\n phmain%dgval(1,id,1)=phmain%dgval(1,id,1)+xxx\n do jd=id,gz%nofc\n! doubting gfortran optimizer ...\n jxsym=kxsym(id,jd)\n! phmain%d2gval(ixsym(id,jd),1)=phmain%d2gval(ixsym(id,jd),1)+xxx\n phmain%d2gval(jxsym,1)=phmain%d2gval(jxsym,1)+xxx\n enddo\n enddo\n endif\n! uniquac model\n uniquac: if(btest(phlista(lokph)%status1,phuniquac)) then\n! write(*,'(a,6(1pe12.4))')'3X calling uniquac: ',&\n! phmain%dgval(1,1,1),phres%dgval(1,2,1)\n call uniquac_model(moded,gz%nofc,phmain,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif uniquac\n!................................\n! calculate additions like magnetic contributions etc and add to G\n! Now also Einstein, twostate liquid, volume ...\n! if liq2state is FALSE we should add that constribution\n! using composition dependent G2 parameters\n addrec=>phlista(lokph)%additions\n! write(*,*)'3X check for first addrec: ',associated(addrec)\n additions: do while(associated(addrec))\n! Note for phases with a disordered fraction set, gz%nofc is equal to\n! the disordered number of fractions here \n gz%nofc=phlista(lokph)%tnooffr\n! moded is 0, 1 or 2 if derivatives should be calculated, phres is pointer\n! to result arrays, lokadd is the addition record, listprop is needed to\n! find where TC and BM are stored, gz%nofc are number of constituents\n! EINSTEIN\n! write(*,*)'3X addition select: ',phres%gval(1,2),gz%nofc\n! write(*,1001)'Addto: ',gx%bmperr,(phres%gval(j1,1),j1=1,4)\n call addition_selector(addrec,moded,phres,lokph,gz%nofc,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! NOTE that the addition record is not in the dynamic data structure\n! but the values calculated are returned added to phres which is dynamic\n! There is a temporary storage of results for listing only.\n addrec=>addrec%nextadd\n! write(*,*)'3X check for next addrec: ',associated(addrec)\n enddo additions\n! there are some special properties like mobilities and similar which\n! have a conmponent or constituent index like MQ&\n! ipy=typty/100+mod(typty,100)\n! if(ipy.gt.10) then\n! write(*,*)'3X Property ',typty,ipy\n! write(*,*)'3X extra 2: ',phres%gval(1,2)\n1000 continue\n! ipy=phlista(lokph)%linktocs(1)\n! write(*,*)'3X exit 1: ',lokph,ipy,ceq%phase_varres(ipy)%disfra%varreslink\n! ipy=phlista(lokph)%linktocs(2)\n! if(ipy.gt.0) &\n! write(*,*)'3X exit 2: ',lokph,ipy,ceq%phase_varres(ipy)%disfra%varreslink\n if(chkperm) then\n! wait for checking for errors ....\n! write(*,*)'3X Press return'\n! read(*,297)ch1\n!297 format(a)\n endif\n! 4SL all correct here also!\n! write(*,69)'3Xb d2G/dy2F:',norfc,(phres%d2gval(ixsym(j1,j1),1),j1=1,norfc)\n! running out of memory??\n! these are locally allocated, should be deallocated automatically\n! Segmentation fault if I do not write ... but ... reason somewhere else\n! write(*,*)'3X deallocate dpyq?',allocated(dpyq)\n if(allocated(dpyq)) deallocate(dpyq)\n! write(*,*)'3X deallocate d2pyq?',allocated(d2pyq)\n if(allocated(d2pyq)) deallocate(d2pyq)\n! write(*,*)'3X deallocate dvals?',allocated(dvals)\n if(allocated(dvals)) deallocate(dvals)\n! write(*,*)'3X deallocate d2vals?',allocated(d2vals)\n if(allocated(d2vals)) deallocate(d2vals)\n! write(*,*)'3X calcg_internal all deallocated'\n! if(size(phres%yfr).gt.2) then\n! debug cqc:\n! write(*,480)'3X dg/dt/RT: 2: ',qcmodel,phres%yfr(3),&\n! phres%gval(1,1),phres%gval(2,1)\n! endif\n! write(*,1001)'Total: ',gx%bmperr,(phres%gval(j1,1),j1=1,4)\n! write(*,1002)(phres%dgval(1,i,1),i=1,3)\n! write(*,1003)(phres%d2gval(i,1),i=1,6)\n1001 format('3X/',a,i5,4(1PE12.4))\n1002 format('3X calcg dg: ',3(1PE15.7))\n1003 format('3X calcg d2g: ',6(1PE11.3))\n return\n end subroutine calcg_internal\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\n\n!\\addtotable subroutine cgint\n!\\begin{verbatim}\n subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,tooprec,ceq)\n! calculates an excess parameter that can be composition dependent\n! gz%yfrem are the site fractions in the end member record\n! gz%yfrint are the site fractions in the interaction record(s)\n! lokpty is the property index, lokph is the phase record\n! vals, dvals, d2vals multiplied by endmember and interaction fractions outside\n! moded=0 means only G, =1 G and dG/dy, =2 all\n implicit none\n integer moded,lokph\n TYPE(gtp_property), pointer :: lokpty\n TYPE(gtp_parcalc) :: gz\n double precision vals(6),dvals(3,gz%nofc)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_tooprec), pointer :: tooprec\n!\\end{verbatim}\n! temporary data like gz%intlevel, gz%nofc etc\n double precision d2vals(gz%nofc*(gz%nofc+1)/2),valtp(6)\n double precision vv(0:2),fvv(0:2)\n integer lfun,jdeg,jint,qz,ivax,icat\n double precision rtg,dx0,dx,dx1,dx2,ct,fvs,dvax0,dvax1,dvax2,yionva\n double precision ycat0,dcat1,dcat2,dyvan1,dyvan2\n double precision, parameter :: onethird=one/3.0D0,two=2.0D0\n logical ionicliq,iliqva,iliqneut,iliq3cat\n! zeroing 5 iq, and vals, dvals and d2vals\n! write(*,*)'3X cgint 1:',gz%iq(1),gz%iq(2),gz%iq(3)\n! why zero qz%iq, it has been set before calling ...\n gz%iq=0\n! these 3 arrays are in the call and may already have some stored values \n! vals=zero\n! dvals=zero\n! d2vals=zero\n!-------------\n rtg=gz%rgast\n! to avoid warnings from -Wmaybe-uninitiated\n icat=0\n ivax=0\n dvax0=zero\n dvax1=zero\n! write(*,*)'3X in cgint',lokph\n if(lokpty%degree.eq.0) then\n!----------------------------------------------------------------------\n! Easy: no composition dependence. This applies also to Toop/Kohler parameters\n lfun=lokpty%degreelink(0)\n call eval_tpfun(lfun,gz%tpv,vals,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n if(lokpty%proptype.eq.1) then\n vals=vals/rtg\n endif\n goto 1000\n endif\n!----------------------------------------------------------------------\n! for composition dependent param set default variables for ionic liquid\n ionicliq=.FALSE.\n iliqva=.FALSE.\n iliqneut=.FALSE.\n yionva=zero\n if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! prepare for ionic liquid interactions\n! write(*,17)'3X RK: ',phlista(lokph)%i2slx(1),gz%endcon(gz%intlat(1))\n17 format(a,10i4)\n! write(*,*)'3X ionicliq set true'\n! write(*,17)'3X Const in subl: ',gz%intlat(1),gz%endcon(gz%intlat(1)),&\n! gz%endcon(2),phlista(lokph)%i2slx(1),gz%intlevel\n ionicliq=.TRUE.\n if(gz%endcon(2).eq.phlista(lokph)%i2slx(1)) then\n! VA endmember in the 2nd sublattice, this is the complicated case\n yionva=gz%yfrem(2)\n ivax=phlista(lokph)%i2slx(1)\n! write(*,64)'3X iliq with Va: ',ivax,yionva\n64 format(a,i3,6(1pe12.4))\n if(gz%intlat(1).eq.1) then\n! interaction in sublattice 1 between two cations same as substituional L_A,B\n! with each cation fraction multiplied with vacancy \n! Also set TRUE for reciprocal interactions (gz%intlevel=2)\n iliqva=.TRUE.\n else\n! interaction in sublattice 2 between Va and neutral (i.e. cation and neutral)\n! same as substitutional L_A,B with cation fraction multiplied with vacancy\n! Hm, I am not sure interactions are ordered so all interactions in first\n! sublattice comes before any in second sublattice ??\n iliqneut=.TRUE.\n endif\n! else\n! constituent in second sublattice is not vacancy, no particular action ??\n! write(*,17)'3X 2nd sublattice constituent not Va: ',gz%endcon(2)\n endif\n endif\n intlev: if(gz%intlevel.eq.1) then\n!----------------------------------------------------------------------\n! plain binary Redlich Kister or Toop/Kohler method\n! gz%endcon can be wildcard, i.e. negative\n! but for the moment give error message in that case\n! A binary wildcard excess parameter means y_A ( 1 - y_A) * L_A*\n! most naturally gz%intcon(1) would be negative\n gz%iq(1)=gz%endcon(gz%intlat(1))\n gz%iq(2)=gz%intcon(1)\n if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0) then\n! composition dependent wildcard interaction not implemented\n! y(1-y) ( L0 + (2y-1) L1 + (2y-1)**2 L2 + ....) ??\n gx%bmperr=4031; goto 1000\n endif\n if(associated(tooprec)) then\n! This is a Kohler-Toop method parameter\n! only for binary interaction parameters with Kohler or Toop models\n! if no composition dependence we never come here as we exit 50 lines above\n call calc_toop(lokph,lokpty,moded,vals,dvals,d2vals,gz,tooprec,ceq)\n! we have calculated all, skip the rest of this subroutine\n goto 1000\n endif\n! endmember fraction minus interaction fraction\n dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1)\n! ycat is one unless ionic liquid with vacancy-neutral interaction\n ycat0=one\n if(ionicliq) then\n if(iliqva) then\n! interaction between cations with vacancy on second sublattice\n! NOTE intraction fraction alreay multiplied with yionva before calling cgint\n dvax0=gz%yfrem(gz%intlat(1))-gz%yfrint(1)/yionva\n! dvax0=dx0\n dx0=yionva*dvax0\n! write(*,65)'3X Va on 2nd: ',gz%iq(2),gz%intlat(1),dvax0,dx0,&\n! gz%yfrem(gz%intlat(1)),gz%yfrint(1)\n65 format(a,2i3,6(1pe12.4))\n elseif(iliqneut) then\n! interaction between vacancy and neutral in second sublattice\n! we must know the cation (if only neutrals set to one)\n icat=gz%endcon(1)\n ycat0=gz%yfrem(1)\n! the fraction difference is between (y_cation * y_Va - y_neutral)\n dx0=gz%yfrem(1)*yionva-gz%yfrint(1)\n dvax0=ycat0\n! write(*,*)'3X dx0: ',dx0,ycat0,yionva\n endif\n endif\n vals=zero\n dx=one\n dx1=zero\n dx2=zero\n dvax1=zero\n dvax2=zero\n dyvan1=one\n dyvan2=one\n! write(*,*)'3X cgint 2:',gz%iq(1),gz%iq(2),gz%iq(3),icat\n! write(*,*)'3X c1bug: ',ionicliq,iliqva,iliqneut\n! special for ionic liquid: when two cation interacts with Va in second\n! sublattice the vacancy fraction is raised by power 2\n RK: do jdeg=0,lokpty%degree\n lfun=lokpty%degreelink(jdeg)\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n if(lokpty%proptype.eq.1) then\n! property type 1 is G and should be normalized by RT\n valtp=valtp/rtg\n endif\n! vals and valtp are arrays with 6 elements: G, G.T, G.P, G.T.T ...\n vals=vals+dx*valtp\n! write(*,11)'3X dx: ',gz%iq(1),gz%iq(2),jdeg,vals(1),dx,valtp(1)\n11 format(a,3i2,6(1pe11.3))\n! no composition derivative. if moded=0 only G, =1 G+G.Y, =2 all\n noder5: if(moded.gt.0) then\n! first derivatives, qz=1: dG/dyA dG/dyB; qz=2: d2G/dTdy; qz=3: d3G/dPdy\n! for iliqneut there should not be same -dx1 ... gz%iq(2) is neutral\n do qz=1,3\n! For interactions between Va and neutral in ionic liguid a power of yionva\n! is required for the cation derivative as we have (y_cation*yionva-y_neutral)\n! In all other cases dyvan1=unity\n dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+ycat0*dx1*valtp(qz)\n dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))-dx1*valtp(qz)\n! The handling of ionic liquid parameter derivatives can be simplified ...\n if(iliqva) then\n! derivative with respect to vacancy fraction for (yc1-yc2)*yva: yc1-yc2\n dvals(qz,ivax)=dvals(qz,ivax)+dvax1*valtp(qz)\n! if(qz.eq.1) write(*,11)'3X iliqva: ',0,0,ivax,dvax1\n elseif(iliqneut) then\n! derivative with respect to cation (yc1*yva-yn):\n! multiply with a power of y_Va\n dvals(qz,icat)=dvals(qz,icat)+yionva*dx1*valtp(qz)\n! write(*,19)'3X mess:',qz,gz%iq(1),gz%iq(2),icat,yionva,ycat0,&\n! valtp(qz),dx1\n19 format(a,4i3,6(1pe12.4))\n endif\n enddo\n! write(*,11)'3X dx1:',gz%iq(1),gz%iq(2),jdeg,dvals(1,gz%iq(1)),&\n! dvals(1,gz%iq(2)),dx1,valtp(1)\n! second derivatives, d2G/dyAdyA d2G/dyAdyB d2G/dyBdyB\n if(moded.gt.1) then\n d2vals(ixsym(gz%iq(1),gz%iq(1)))=&\n d2vals(ixsym(gz%iq(1),gz%iq(1)))+dx2*valtp(1)\n d2vals(ixsym(gz%iq(1),gz%iq(2)))=&\n d2vals(ixsym(gz%iq(1),gz%iq(2)))-dx2*valtp(1)\n d2vals(ixsym(gz%iq(2),gz%iq(2)))=&\n d2vals(ixsym(gz%iq(2),gz%iq(2)))+dx2*valtp(1)\n! if(iliqva) then\n! UNFINISHED d2G/dyvdyv d2G/dyvdyA d2G/dyvdyB interactions two cations\n! d2vals(ixsym(ivax,ivax))=&\n! d2vals(ixsym(ivax,ivax))+dvax2*valtp(1)\n! elseif(iliqneut) then\n! UNFINISHED also for interactions Va-neutral\n! continue\n! endif\n endif\n endif noder5\n! next power of dx\n if(iliqva) then\n! interaction between two cations, dx0=y_va*(y_c1 - y_c2)\n! NO CHANGE HERE WHEN FIXING ERROR FOR Va-Neutal interaction ...\n dx2=(jdeg+1)*dx1\n dvax2=(jdeg+1)*dvax1\n if(jdeg.eq.0) then\n dx1=yionva\n dvax1=dvax0\n else\n dx1=(jdeg+1)*dx1*dx0\n dvax1=(jdeg+1)*dvax1*dx0\n endif\n dx=dx*dx0\n! write(*,23)'3X iliqvb: ',jdeg,dx,dx1,dx2,dvax0,dvax1,dvax2\n23 format(a,i2,6(1pe12.4))\n elseif(iliqneut) then\n! interaction between Va and neutral a bit more complicated ... NOT TESTED\n! NOTE 2nd derivatives ignored ...\n dx2=(jdeg+1)*dx1\n dvax2=dvax1\n if(jdeg.eq.0) then\n dx1=one\n dvax1=dvax0\n else\n dx1=(jdeg+1)*dx1*dx0\n dvax1=(jdeg+1)*dvax0*dx1\n endif\n dx=dx*dx0\n else\n! normal CEF model. Note negative sign taken care of when \"added\"\n dx2=(jdeg+1)*dx1\n dx1=(jdeg+1)*dx\n dx=dx*dx0\n endif\n enddo RK\n elseif(gz%intlevel.eq.2) then !intlev\n!----------------------------------------------------------------------\n! important to set ivax=0 here as tested below if not zero\n ivax=0\n iliq3cat=.FALSE.\n! it can be a ternary interaction in same sublattice or a reciprocal parameter\n! write(*,*)'3X gz%intlat: ',gz%intlat\n! write(*,*)'3X gz%intcon: ',gz%intcon\n if(ionicliq) then\n! write(*,*)'3X Comp.dep ternary ionic liquid parameter: ',iliqva\n if(gz%intlat(1).eq.2) then\n! Both interacting constituents in second sublattice, this should handle these:\n! TAFID problem: (5):(33,37,56) is (CA+2):(ALO2-,SIO4-4,SIO2) !!!\n! TAFID problem: (12):(33,37,56) is (MG+2):(ALO2-,SIO4-4,SIO2) !!!\n! TAFID problem: (9):(38,39,41) is (Fe+2):(VA,B,C) !!\n! not tested: (Fe+2):(S-2,Va,S) or similar ... but it should be OK\n continue\n elseif(iliqva) then\n! the pair constituent in second sublattice is Va, no anions!!\n if(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.1) then\n! we have 3 cations interacting in first sublattice and Va in second\n! with composition dependence .... require treatment of extra vacancy fraction\n! TAFID not implemented: (Fe+2,Cr+2,Ni+1):(Va) for example ....\n! ternary term: y_Va*(y_Cr*L;0 +y_Fe*L;1 +y_Ni*L;2)\n! write(*,*)'3X unimplemented comp. dep. ternary cation',&\n! 'interaction in liquid'\n! gx%bmperr=4343; goto 1000\n! \n iliq3cat=.TRUE.\n ivax=gz%intcon(2)\n elseif(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.2) then\n! This is a reciprocal interaction, two cations, vacancy and neutral\n ivax=gz%endcon(2)\n endif\n elseif(gz%intcon(2).eq.phlista(lokph)%i2slx(1)) then\n! reciprocal interaction between two cations in first sublattice and\n! an anion and vacancy is the second sublattice\n! write(*,*)'3X reciprocal with 2 cations and anion and Va'\n ivax=gz%intcon(2)\n yionva=gz%yfrint(2)\n else\n! I do not know what kind of parameter this is\n! THIS ERROR OCCUR ONLY IN PARALLEL\n! write(*,28)'3X: unknown I2SL parameter on level: ',&\n! gz%intlevel,gz%endcon(1),gz%intcon(1),gz%intcon(2),&\n! gz%endcon(2),gz%iq,iliqva\n28 format(a,i2,': ',i2,',',i2,',',i2,':',i2,5x,5i3,2x,l2)\n! gx%bmperr=4342; goto 1000\n goto 1000\n endif\n! other ternary parameters in ionic liquid OK, no extra vacancy fraction\n endif\n!................................................................\n300 continue\n! ternary composition dependent interaction\n ternary: if(gz%intlat(1).eq.gz%intlat(2)) then\n! Ternary composition dependent interaction in same sublattice, Hillert form.\n! The idea is that the sum of vv is always unity even in higher order systems\n! whereas the sum of the constituent frations are not\n! If wildcard then any of the gz%iq would be negative, not allowed\n gz%iq(1)=gz%endcon(gz%intlat(1))\n gz%iq(2)=gz%intcon(1)\n gz%iq(3)=gz%intcon(2)\n if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0 .or. gz%iq(3).lt.0) then\n gx%bmperr=4031; goto 1000\n endif\n vv(0)=gz%yfrem(gz%intlat(1))\n vv(1)=gz%yfrint(1)\n vv(2)=gz%yfrint(2)\n ct=(one-vv(0)-vv(1)-vv(2))*onethird\n vv=vv+ct\n! derivatives of vv w.r.t. the 3 constituents 0, 1 and 2\n fvv(0)=two*onethird\n fvv(1)=-onethird\n fvv(2)=-onethird\n if(size(lokpty%degreelink).eq.2) then\n! KRASCH if only two degrees of ternary parameter (3 MUST BE GIVEN)\n! If only one it is composition independent!\n write(*,37)trim(phlista(lokph)%name),size(lokpty%degreelink)\n37 format('3X Database error, ternary composition dependent',&\n ' parameter in ',a/'must have 3 degrees, has only ',i2)\n write(*,38)gz%endcon(1),gz%intcon(1),gz%intcon(2)\n38 format('3X constituents: ',3i3)\n write(*,39)(lokpty%degreelink(jint),jint=0,2)\n39 format('3X degreelinks: ',3i5)\n gx%bmperr=4342; goto 1000\n endif\n terloop: do jint=0,2\n! calculate parameters, there are 3 of them, jint=0, 1 and 2\n lfun=lokpty%degreelink(jint)\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\n if(lokpty%proptype.eq.1) then\n valtp=valtp/rtg\n endif\n! function value\n if(iliq3cat) then\n! this is when there are 3 cations in ionic liquid, yionva is vacancy fraction\n! NOTE vals and valtp both have dimension 6!!\n vals=vals+yionva*vv(jint)*valtp\n! there are also a contrbution to df/dyva!, d2f/dyvadT ... calculated below\n! ivax is the index of vacancy\n! write(*,*)'3X ivax: ',ivax\n dvals(1,ivax)=dvals(1,ivax)+vv(jint)*valtp(1)\n dvals(2,ivax)=dvals(2,ivax)+vv(jint)*valtp(2)\n dvals(3,ivax)=dvals(3,ivax)+vv(jint)*valtp(3)\n else\n vals=vals+vv(jint)*valtp\n endif\n noder6: if(moded.gt.0) then\n! first derivatives, qz=2 is for T and qz=3 is for P derivatives\n do qz=1,3\n! for interaction with 3 cations and Va in 2nd sublattice\n! valtp(1) is G; valtp(2) is dG/dT; valtp(3) is dG/dP\n if(iliq3cat) then\n! the first derivatives\n dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+&\n yionva*fvv(0)*valtp(qz)\n dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))+&\n yionva*fvv(1)*valtp(qz)\n dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+&\n yionva*fvv(2)*valtp(qz)\n else\n dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+fvv(0)*valtp(qz)\n dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))+fvv(1)*valtp(qz)\n dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+fvv(2)*valtp(qz)\n endif\n enddo\n endif noder6\n if(iliq3cat) then\n! with ionic liquid and 3 cations iteraction there are 2nd derivatives\n! with respect to Va and the cation (but no T or P derivative)!\n! gz%iq(1) is\n d2vals(ixsym(ivax,gz%iq(jint+1)))=&\n d2vals(ixsym(ivax,gz%iq(jint+1)))+fvv(0)*valtp(1)\n endif\n fvs=fvv(2)\n fvv(2)=fvv(1)\n fvv(1)=fvv(0)\n fvv(0)=fvs\n enddo terloop\n else\n!.........................................................\n! composition dependent reciprocal interactions here only degree 1 and 2\n if(lokpty%degree.gt.2) then\n write(*,*)'3X Composition dependent reciprocal degree max 2'\n gx%bmperr=4078; goto 1000\n else\n! write(*,32)lokph,lokpty%degree,gz%intlat(1),gz%intlat(2),&\n! gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4)\n32 format('3X Comp.dep. rec. param: ',i3,2x,i1,2x,2i2,4i5)\n endif\n! Note the composition dependence is defined that \n! L = y'_Ay'_By\"_Cy\"_D (0L + (y\"_C-y\"_D)*1L + (y'_A-y'_B)*2L)\n! it is a bit strange that 2nd sublattice is 1L ... but that is the definition\n gz%iq(1)=gz%endcon(1)\n gz%iq(2)=gz%intcon(1)\n gz%iq(3)=gz%endcon(2)\n gz%iq(4)=gz%intcon(2)\n! degree 0 not composition dependent, vals multiplied with pyq after return\n lfun=lokpty%degreelink(0)\n if(lfun.gt.0) then\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n if(lokpty%proptype.eq.1) then\n valtp=valtp/rtg\n endif\n vals=vals+valtp\n endif\n! lokpty%degree must be 1 or 2 otherwise we would not be here\n! write(*,17)'3X composition dependent reciprocal',ivax\n lfun=lokpty%degreelink(1)\n recip1: if(lfun.gt.0) then\n! degree 2 can be empty, otherwise multiplied with gz%iq(3)-gz%iq(4)\n! no problem with ionic liquid except there may be values in dvals\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,62)'3X rp: ',valtp(1),valtp(2)\n62 format(a,6(1pe12.4))\n if(lokpty%proptype.eq.1) then\n valtp=valtp/rtg\n endif\n vals=vals+(gz%yfrem(gz%intlat(2))-gz%yfrint(2))*valtp\n! dvals(1,const) is the 1st derivative of the fun wrt const\n! dvals(2,const) is the 2nd derivative of the fun wrt const and T\n! dvals(3,const) is the 2nd derivative of the fun wrt const and P\n! one dvals(*,ivax) could have been assigned a value above (for ionic liquid)\n do qz=1,3\n! write(*,63)'3X dvals: ',qz,gz%iq(3),dvals(qz,gz%iq(3)),&\n! dvals(qz,gz%iq(4)),valtp(qz)\n dvals(qz,gz%iq(3))=dvals(qz,gz%iq(3))+valtp(qz)\n dvals(qz,gz%iq(4))=dvals(qz,gz%iq(4))-valtp(qz)\n! write(*,63)'3X dvals: ',qz,gz%iq(4),dvals(qz,gz%iq(3)),dvals(qz,gz%iq(4))\n enddo\n63 format(a,2i3,6(1pe12.4))\n endif recip1\n! degree 2 can be empty, otherwise multiplied with y(gz%iq(1))-y(gz%iq(2))\n recip2: if(lokpty%degree.gt.1) then \n lfun=lokpty%degreelink(2)\n if(lfun.gt.0) then\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\n if(gx%bmperr.ne.0) goto 1000\n if(lokpty%proptype.eq.1) then\n valtp=valtp/rtg\n endif\n if(ivax.gt.0) then\n! write(*,67)ivax,gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4),yionva\n!67 format('3X ion liq recip: ',i3,2x,4i3,1pe12.4)\n! interaction in ionic liquid with vacancy as one constituent in 2nd subl.\n vals=vals+yionva*(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp\n do qz=1,3\n dvals(qz,gz%iq(1))=+yionva*valtp(qz)\n dvals(qz,gz%iq(2))=-yionva*valtp(qz)\n enddo\n! we have to take into account extra derivatives wrt vacancies if vacancy\n! is a constituent in second sublattice\n do qz=1,3\n dvals(qz,ivax)=&\n (gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp(qz)\n enddo\n else\n! not ionic liquid .... puuuh\n vals=vals+(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp\n do qz=1,3\n dvals(qz,gz%iq(1))=+valtp(qz)\n dvals(qz,gz%iq(2))=-valtp(qz)\n enddo\n endif\n endif\n endif recip2\n endif ternary\n!----------------------------------------------------------------------\n elseif(gz%intlevel.ge.3) then !intlev\n! higher interaction levels have no composition dependence\n write(*,999)\n999 format('Composition dependence for parameters with >2 interacting ',&\n 'constituents'/'not implemented!')\n gx%bmperr=4078; goto 1000\n endif intlev\n!----------------------------------------------------------------------\n! finished finally ....\n1000 continue\n return\n end subroutine cgint\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy\n!\\begin{verbatim}\n subroutine config_entropy(moded,nsl,nkl,phvar,tval)\n! calculates CEF configurational entropy/R for phase lokph\n implicit none\n integer moded,nsl\n integer, dimension(nsl) :: nkl\n TYPE(gtp_phase_varres), pointer :: phvar\n!\\end{verbatim}\n integer ll,kk,kall,nk,jl\n double precision tval,ss,yfra,ylog\n ll=0\n kall=0\n sublatticeloop: do while (ll.lt.nsl)\n ll=ll+1\n nk=nkl(ll)\n kk=0\n ss=zero\n fractionloop: do while (kk.lt.nk)\n kk=kk+1\n kall=kall+1\n if(nk.eq.1) cycle sublatticeloop\n yfra=phvar%yfr(kall)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n ylog=log(yfra)\n! gval(1:6,1) are G and derivator wrt T and P\n! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N\n! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T\n! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P\n! d2dval(ixsym(N*(M+1)/2),1) are derivatives of G wrt fractions N and M\n! this is a symmetric matrix and index givem by ixsym(M,N)\n ss=ss+yfra*ylog\n if(moded.gt.0) then\n phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog)\n! phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra\n! kxsym same as ixsym when first index is >= second index\n phvar%d2gval(kxsym(kall,kall),1)=phvar%sites(ll)/yfra\n endif\n enddo fractionloop\n phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss\n enddo sublatticeloop\n! looking for error calculating 4 sublattice ordered FCC\n! write(*,69)kall,(phvar%d2gval(ixsym(jl,jl),1),jl=1,kall)\n69 format('3X d2G/dy2: ',i3,6(1pe12.4))\n! set temperature derivative of G and dG/dy\n phvar%gval(2,1)=phvar%gval(1,1)/tval\n if(moded.gt.0) then\n do jl=1,kall\n phvar%dgval(2,jl,1)=phvar%dgval(1,jl,1)/tval\n enddo\n endif\n1000 continue\n return\n end subroutine config_entropy\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_ssro\n!\\begin{verbatim}\n subroutine config_entropy_ssro(moded,lokph,phvar,tval)\n! test calculates SSRO configurational entropy/R for phase lokph\n implicit none\n integer moded,lokph\n double precision tval\n TYPE(gtp_phase_varres), pointer :: phvar\n!\\end{verbatim}\n! CVM tetrahedron model with ONLY SRO, no sublattices\n integer ia,ib,ic,id,jj,jk,jl,jm,ne,nc,zz,pz\n! this is multiplicities\n integer, allocatable :: mijkl(:)\n! this is mole fractions and derivatives\n double precision, allocatable :: xf(:),dxf(:,:),d2xf(:,:)\n! these are constituent fractions for entropy!!!\n double precision, allocatable :: ysro(:)\n! these are site fractions, not needed when only SRO as y^s_i=x_i\n! double precision, allocatable :: yf1(:),yf2(:),yf3(:),yf4(:)\n! double precision, allocatable :: dyf1(:,:),dyf2(:,:),dyf3(:,:),yf4(:,:)\n! these are pair fractions, same for all bonds!\n! double precision, allocatable :: p12(:,:),p13(:,:),p14(:,:),&\n! p23(:,:),p24(:,:),p34(:,:)\n! double precision, allocatable :: dp12(:,:,:),dp13(:,:,:),dp14(:,:,:),&\n! dp23(:,:,:),dp24(:,:,:),p34(:,:,:)\n double precision, allocatable :: pstij(:,:)\n double precision, allocatable :: dpstij(:,:,:),d2pstij(:,:,:)\n double precision, parameter :: f1=0.75D0, f2=0.5D0, f3=0.25D0\n! double precision, parameter :: f1=3.0D0, f2=2.0D0, f3=1.0D0\n! auxilliary\n character dummy*80\n double precision pijx,fpf,ssumy,ssump,ssumx,ylog,yfra,ycorr,yrest\n double precision pstijtest,pstijsave\n! debugging\n double precision ylog1(5),ylog2,ylog3\n double precision sylog1,sylog2,sylog3\n! These factors should be 2.0, -6.0 and 5.0 according to Kikuchi\n! I have no idea why I have to divide them by 10 ...\n double precision, parameter :: syfact=2.0D0, spfact=-6.0D0, sxfact=5.0D0\n logical sdebug\n save pstijsave\n! use phvar%volatile to initiate ycorr at first itertation\n! sdebug=.TRUE.\n sdebug=.FALSE.\n! write(*,*)'3X sdebug: ',sdebug\n if(phvar%volatile.eq.0) then\n! phvar%volatile is set to zero in matsmin: meq_calceq at first iteration\n! decrease ycorr when pstijsave constant\n phvar%volatile=phvar%volatile+1\n ycorr=0.5D0\n pstijsave=0.0D0\n endif\n yrest=1.0D0-ycorr\n! nc is number of constituent, ne is number of elements\n nc=phlista(lokph)%tnooffr\n! using empirical rule to calcuöate ne from nc\n select case(nc)\n case default\n write(*,*)'3X SRO number of constituents not implemented',nc\n case(1)\n ne=1\n write(*,*)'3X SRO entropy zero for single element'\n goto 1000\n case(5)\n! binary system\n ne=2 \n case(15) \n ne=3\n case(35) \n ne=4\n case(70) \n! without merging AAAB etc there would be 625 clusters instead of just 70\n ne=5\n case(126)\n ne=6\n case(210)\n ne=7\n case(330)\n! without merging AAAB etc there would be 4096 clusters\n ne=8\n end select\n!\n! write(*,*)'3X CVMTFS model for configurational entropy',nc,ne\n!\n allocate(mijkl(nc))\n allocate(xf(ne))\n allocate(dxf(ne,nc))\n allocate(d2xf(ne,nc))\n! allocate(yf1(ne))\n! allocate(yf2(ne))\n! allocate(yf3(ne))\n! allocate(yf4(ne))\n! allocate(dyf1(ne,nc))\n! allocate(dyf2(ne,nc))\n! allocate(dyf3(ne,nc))\n! allocate(dyf4(ne,nc))\n! jj incremented for each cluster\n jj=0\n mijkl=0\n xf=zero\n dxf=zero\n! site fractions same as mole fractions as no LRO\n! yf1=zero\n! yf2=zero\n! yf3=zero\n! yf4=zero\n! dyf1=zero\n! dyf2=zero\n! dyf3=zero\n! dyf4=zero\n! extrahera mole fractions from constituent fractions\n do ia=1,ne\n jj=jj+1\n! this is AAAA or BBBB etc\n mijkl(jj)=1\n xf(ia)=xf(ia)+phvar%yfr(jj)\n dxf(ia,jj)=1\n do ib=ia+1,ne\n jj=jj+3\n mijkl(jj-2)=4\n mijkl(jj-1)=6\n mijkl(jj)=4\n! jj-2 is A3B1, jj-1 is A2B2, jj is A1B3 including permutations in mijkl\n xf(ia)=xf(ia)+f1*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj)\n xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f1*phvar%yfr(jj)\n dxf(ia,jj-2)=f1; dxf(ia,jj-1)=f2; dxf(ia,jj)=f3;\n dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f1;\n do ic=ib+1,ne\n jj=jj+3\n mijkl(jj-2)=12\n mijkl(jj-1)=12\n mijkl(jj)=12\n! jj-2 is A2BC, jj-1 is AB2C, jj is ABC2\n xf(ia)=xf(ia)+f2*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f3*phvar%yfr(jj)\n xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj)\n xf(ic)=xf(ic)+f3*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f2*phvar%yfr(jj)\n dxf(ia,jj-2)=f2; dxf(ia,jj-1)=f3; dxf(ia,jj)=f3;\n dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f3;\n dxf(ic,jj-2)=f3; dxf(ic,jj-1)=f3; dxf(ic,jj)=f2;\n do id=ic+1,ne\n jj=jj+1\n mijkl(jj-2)=24\n! jj is ABCD\n xf(ia)=xf(ia)+f3*phvar%yfr(jj)\n xf(ib)=xf(ib)+f3*phvar%yfr(jj)\n xf(ic)=xf(ic)+f3*phvar%yfr(jj)\n xf(id)=xf(id)+f3*phvar%yfr(jj)\n dxf(ia,jj)=f3; dxf(ib,jj)=f3; dxf(ic,jj)=f3; dxf(id,jj)=f3;\n enddo\n enddo\n enddo\n enddo\n! Convergence problem, when pstij constant make rest approach 1.0\n pstijtest=zero\n do ia=1,ne\n do ib=ia+1,ne\n if(xf(ia)*xf(ib).gt.pstijtest) pstijtest=xf(ia)*xf(ib)\n enddo\n enddo\n! pstijtest is maximum pair fraction using mole fractions calculated\n! from cluster fractions provided by the minimizer\n! if almost the same as previous decrease ycorr\n if(abs(pstijtest-pstijsave).lt.1.0D-4) then\n ycorr=max(0.5D0*ycorr,1.0D-8)\n! when yrest=1 we use the fractions from the minimizer\n else\n ycorr=min(0.5d0*ycorr,0.5D0)\n endif\n yrest=1.0D0-ycorr\n if(SDEBUG) write(*,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,&\n pstijtest,pstijsave,yrest,ycorr\n! without this stupid dummy statement the calculations does not converge\n write(dummy,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,&\n pstijtest,pstijsave,yrest,ycorr\n! save pstij for next iteration\n pstijsave=pstijtest\n! IDEA\n! We have no LRO, fractions on all sublattices same and equal to molefractions\n! THUS recalculate the cluster fractions from the mole fractions ....\n allocate(ysro(jj))\n jj=0\n do ia=1,ne\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*xf(ia)**4\n do ib=ia+1,ne\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)*xf(ia)**3\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)**2*xf(ia)**2\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ib)**3*xf(ia)\n do ic=ib+1,ne\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)**2*xf(ib)*xf(ic)\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)**2*xf(ic)\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)**2\n do id=ic+1,ne\n jj=jj+1\n ysro(jj)=yrest*phvar%yfr(jj)+&\n ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)*xf(id)\n enddo\n enddo\n enddo\n enddo\n!\n if(SDEBUG) then\n write(*,'(a,12F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=1,nc)\n write(*,'(a,12F6.3)')'3X ysro:',ysro\n endif\n!\n! write(*,'(a,F5.2,10F6.3)')'3X xf2: ',fpf,(xf(ia),ia=1,ne)\n! calculate pair fractions using the site fractions\n! allocate(p12(ne,ne))\n! allocate(p13(ne,ne))\n! allocate(p14(ne,ne))\n! allocate(p23(ne,ne))\n! allocate(p24(ne,ne))\n! allocate(p34(ne,ne))\n allocate(pstij(ne,ne))\n allocate(dpstij(ne,ne,nc))\n allocate(d2pstij(ne,ne,nc*(nc+1)/2))\n pstij=zero\n dpstij=zero\n d2pstij=zero\n! calculation of pair fractions using mole fractions (same as site fractions)\n! include AA, AB, AC, BB etc pairs but exclude BA, CA ??\n do ia=1,ne\n do ib=1,ne\n! If we had LRO we should need yf1, yf2, yf3 and yf4\n! but the site fractions are the same in all sublattces when no LRO (?)\n pstij(ia,ib)=xf(ia)*xf(ib)\n do jj=1,nc\n dpstij(ia,ib,jj)=dxf(ia,jj)*xf(ib)+dxf(ib,jj)*xf(ia)\n do jk=jj,nc\n zz=ixsym(jj,jk)\n! write(*,'(a,2i4,2x,2i4,i7)')'3X d2pstij: ',ia,ib,jj,jk,zz\n! d2pstij(ia,ib,zz)=d2pstij(ia,ib,zz)+&\n! dxf(ia,jj)*dxf(ib,jk)+dxf(ib,jj)*dxf(ia,jk)\n enddo\n enddo\n enddo\n enddo\n! All necessary fractions and derivatives calculated, now the entropy\n! S = -2 \\sum_ijkl y_ijkl\\ln(y_ijkl) +\n! 6 \\sum_ij p_ij\\ln(p_ij) - 5 \\sum_j x_j\\ln(x_j)\n! As we calculate G the signs are inverse\n! constituent fraction entropy\n! entropy contribution from the constituent fractions ------------------\n! USE ysro fractions!!! not phvar%yfr or a mix ...\n ssumy=zero\n! sylog1=zero\n do jj=1,nc\n! yfra=phvar%yfr(jj)\n yfra=ysro(jj)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! yfra is divided by mijkl as it represent mijkl fractions\n ylog=log(yfra/mijkl(jj))\n! debugging\n! if(jj.le.5) ylog1(jj)=ylog\n! sylog1=sylog1+yfra*ylog\n ssumy=ssumy+syfact*yfra*ylog\n if(moded.gt.0) then\n! dgval(1,1:nc,1) are derivative of G/RT wrt fraction 1:nc\n! d2gval(ixsym(jj*(jk+1)/2,1) are 2nd derivarive of G/RT wrt fraction jj and jk\n! dgval and d2gval are zero before this loop\n! phvar%dgval(1,jj,1)=syfact*(mijkl(jj)+ylog)\n! convergence problem test\n phvar%dgval(1,jj,1)=syfact*(one+ylog)\n! ? T and y derivative\n phvar%dgval(2,jj,1)=syfact*(mijkl(jj)+ylog)/tval\n! 2nd derivative, each term depend on a single y fraction\n phvar%d2gval(kxsym(jj,jj),1)=syfact*mijkl(jj)/yfra\n endif\n! write(*,'(a,3(1pe12.4))')'3X ssumy: ',yfra,ylog,ssumy\n enddo\n phvar%gval(1,1)=ssumy\n phvar%gval(2,1)=ssumy/tval\n! No convergence just using ysro ... change the phvar%yfr ....\n do jj=1,nc\n phvar%yfr(jj)=ysro(jj)\n enddo\n! entropy contributions from the 6 pair fractions -----------------------\n ssump=zero\n! all pairs the same, no need to loop over sublattices\n fpf=spfact\n! sylog2=zero\n do ia=1,ne\n! do ib=ia+1,ne\n do ib=1,ne\n! bond between atom ia and ib\n ylog=log(pstij(ia,ib))\n! debugging\n! ylog2=ylog\n! sylog2=sylog2+pstij(ia,ib)*ylog\n! write(*,'(a,2i3,3(1pe12.4))')'3X ylogp: ',ia,ib,pstij(ia,ib),ylog,&\n! pstij(ia,ib)*ylog\n ssump=ssump+fpf*pstij(ia,ib)*ylog\n if(moded.gt.0) then\n do jl=1,nc\n! we need derivatives of pair fractions wrt constituent fractions\n phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+&\n fpf*dpstij(ia,ib,jl)*(one+ylog)\n do jm=jl,nc\n zz=ixsym(jl,jm)\n phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+&\n fpf*(d2pstij(ia,ib,zz)*(one+ylog)+&\n dpstij(ia,ib,jl)*dpstij(ia,ib,jm)/pstij(ia,ib))\n enddo\n enddo\n endif\n! write(*,'(a,2i3,4(1pe12.4))')'3X ssump: ',ia,ib,fpf,pstij(ia,ib),&\n! ylog,ssump\n enddo\n enddo\n phvar%gval(1,1)=phvar%gval(1,1)+ssump\n phvar%gval(2,1)=phvar%gval(2,1)+ssump/tval\n! entropy contributions from the mole fractions -----------------------\n ssumx=zero\n! sylog3=zero\n do ia=1,ne\n! we need derivatives of mole fractions wrt constituent fractions\n ylog=log(xf(ia))\n! debugg\n! ylog3=ylog\n! sylog3=sylog3+xf(ia)*ylog\n ssumx=ssumx+sxfact*xf(ia)*ylog\n if(moded.gt.0) then\n do jl=1,nc\n! we need derivatives of mole fractions wrt constituent fractions\n phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+&\n sxfact*dxf(ia,jl)*(ylog+one)\n do jm=jl,nc\n! note d2xf/dyidyj==0\n zz=kxsym(jl,jm)\n phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+&\n sxfact*dxf(ia,jl)*dxf(ia,jm)/xf(ia)\n enddo\n enddo\n endif\n enddo\n phvar%gval(1,1)=phvar%gval(1,1)+ssumx\n phvar%gval(2,1)=phvar%gval(2,1)+ssumx/tval\n! All done\n if(SDEBUG) then\n write(*,900)'3X xf: ',(xf(ia),ia=1,ne)\n900 format(a,6F7.3)\n write(*,910)'3X pstij: ',((pstij(ia,ib),ib=1,ne),ia=1,ne)\n910 format(a,10F7.3)\n! write(*,'(a,5(1pe12.4))')'3X sylog: ',sylog1,sylog2,sylog3\n! write(*,'(a,5(1pe12.4))')'3X ylog1: ',ylog1\n! write(*,'(a,5(1pe12.4))')'3X ylogx: ',ylog2,ylog3\n write(*,'(a,5(1pe12.4))')'3X cvmtfs: ',ssumy,ssump,ssumx,&\n phvar%gval(1,1),8.31451*phvar%gval(1,1)\n! write(*,*)'3X cvmtfs model not yet released'\n endif\n1000 continue\n return\n end subroutine config_entropy_ssro\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_cvmtfl\n!\\begin{verbatim}\n subroutine config_entropy_cvmtfl(moded,lokph,phvar,tval)\n! CVM tetrahedron model for FCC with LRO and SRO, all constituents mix\n!\n implicit none\n integer moded,lokph\n double precision tval\n TYPE(gtp_phase_varres), pointer :: phvar\n!\\end{verbatim}\n!========================================\n! Current code 230308 if same as _SSRO, only SRO ordering\n! Modified code 230311 works partially for SRO (not LRO)\n!========================================\n integer ia,ib,ic,id,jj,jk,jl,jm,ne,nc,zz,pz,ja,jb\n! this is multiplicities\n! integer, allocatable :: mijkl(:)\n! this is mole fractions and derivatives\n double precision, allocatable :: xf(:),dxf(:,:),d2xf(:,:)\n! these are constituent fractions for entropy!!!\n! double precision, allocatable :: ysro(:)\n double precision, allocatable :: ylro(:)\n! these are site fractions, needed for LRO yf(1..4,*)\n double precision, allocatable :: yf(:,:)\n double precision, allocatable :: dyf(:,:,:)\n! these are pair fractions, same for all bonds!\n double precision, allocatable :: pst(:,:,:)\n double precision, allocatable :: dpst(:,:,:,:)\n! use this dqst to relate derivatives pf pair directly to cluster fractions\n double precision, allocatable :: dqst(:,:,:,:)\n double precision, allocatable :: d2pst(:,:,:,:)\n! double precision, allocatable :: p12(:,:),p13(:,:),p14(:,:),&\n! p23(:,:),p24(:,:),p34(:,:)\n! double precision, allocatable :: dp12(:,:,:),dp13(:,:,:),dp14(:,:,:),&\n! dp23(:,:,:),dp24(:,:,:),dp34(:,:,:)\n! double precision, allocatable :: d2p12(:,:,:),d2p13(:,:,:),d2p14(:,:,:),&\n! d2p23(:,:,:),d2p24(:,:,:),d2p34(:,:,:)\n! to be removed\n! double precision, allocatable :: pstij(:,:)\n! double precision, allocatable :: dpstij(:,:,:),d2pstij(:,:,:)\n! double precision, parameter :: f1=0.75D0, f2=0.5D0, f3=0.25D0\n! auxilliary\n character dummy*80\n double precision pijx,ssumy,ssump,ssumx,ylog,yfra,pfra,ycorr,yrest,ybase\n double precision pstijtest,pstijsave\n! reduce derivatives\n double precision, parameter :: dfdy=1.0D0\n! debugging\n double precision ylog1(5),ylog2,ylog3,mass\n double precision sylog1,sylog2,sylog3\n integer ss,tt,mm,wb1,wb2,wa1,wa2,iphf\n character cluster*4, chel(2)*1, spname*24\n! Kikuchi factors, note we calculate dG/dT, not S, thus signs inverted\n! spfact -6 not used as we calculate and add 6 pair, sxfact/4 as 4 sublattices\n double precision, parameter :: syfact=2.0D0, spfact=-6.0D0, sxfact=1.250D0\n logical sdebug,s2debug\n save pstijsave\n! use phvar%volatile to initiate ycorr at first itertation\n!========================================\n write(*,*)\n write(*,*)'3X CVM tetrahedron FCC with LRO for testing only'\n! gx%bmperr=4399\n! goto 1000\n!========================================\n! sdebug=.TRUE.\n sdebug=.FALSE.\n! s2debug=.TRUE.\n s2debug=.FALSE.\n! write(*,*)'3X sdebug: ',sdebug\n if(phvar%volatile.eq.0) then\n! phvar%volatile is set to zero in matsmin: meq_calceq at first iteration\n! decrease ycorr when pstijsave constant\n phvar%volatile=phvar%volatile+1\n ycorr=0.5D0\n pstijsave=0.0D0\n endif\n yrest=1.0D0-ycorr\n! nc is number of constituent, ne is number of elements\n nc=phlista(lokph)%tnooffr\n! using empirical rule to calcuöate ne from nc\n select case(nc)\n case default\n write(*,*)'3X SRO number of constituents not implemented',nc\n case(1)\n ne=1\n write(*,*)'3X SRO entropy zero for single element'\n goto 1000\n case(16)\n! binary system 2*2*2*2=16\n ne=2 \n case(81) \n write(*,*)'3X max 2 elements!'; gx%bmperr=4399; goto 1000\n ne=3\n case(256) \n write(*,*)'3X max 2 elements!'; gx%bmperr=4399; goto 1000\n ne=4\n! case(625) \n! ne=5\n end select\n!\n! write(*,*)'3X CVMTFS model for configurational entropy',nc,ne\n!\n allocate(xf(ne))\n allocate(dxf(ne,nc))\n allocate(d2xf(ne,nc))\n allocate(yf(4,ne))\n allocate(dyf(4,ne,nc))\n allocate(dqst(6,ne,ne,nc))\n! jj incremented for each cluster\n xf=zero\n dxf=zero\n! site fractions same as mole fractions as no LRO\n yf=zero\n dyf=zero\n! derivative of pair fractions related to clusters\n dqst=zero\n! for nice debug output ...\n chel(1)='A'\n chel(2)='B'\n! phase number ... \n iphf=1\n! extrahera site fractions from cluster fractions\n! order is always AAAA, AAAB_01.._04; AABB_01.._06; ABBB_01.._04, BBBB etc\n jj=0\n ialoop: do ia=1,ne\n jj=jj+1\n! this is AAAA or BBBB etc\n do ss=1,4\n yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj)\n dyf(ss,ia,jj)=dfdy\n cluster(ss:ss)=chel(ia)\n enddo\n xf(ia)=xf(ia)+phvar%yfr(jj)\n dxf(ia,jj)=dfdy\n! call get_constituent_name(iphf,jj,spname,mass)\n! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj\n! write(*,300)(xf(ss),ss=1,ne)\n! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne)\n! write(*,*)'3X done AAAA: ',jj\n ibloop: do ib=ia+1,ne\n! handle 4 of AAAB, 6 of AABB and 4 of ABBB with elements in different order\n! In first 4 there is one atom ib in sublattice 4, 3, 2 and 1\n wb1=4\n do jj=jj+1,jj+4\n! These are 4 clusters ordered AAAB, AAABA, ABAA, BAAA\n! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj)\n do ss=1,4\n if(ss.eq.wb1) then\n yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj)\n dyf(ss,ib,jj)=dfdy\n cluster(ss:ss)=chel(ib)\n else\n yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj)\n dyf(ss,ia,jj)=dfdy\n cluster(ss:ss)=chel(ia)\n endif\n enddo\n! call get_constituent_name(iphf,jj,spname,mass)\n! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj\n wb1=wb1-1\n xf(ia)=xf(ia)+0.75D0*phvar%yfr(jj)\n dxf(ia,jj)=0.75D0*dfdy\n xf(ib)=xf(ib)+0.25D0*phvar%yfr(jj)\n dxf(ib,jj)=0.25D0*dfdy\n! derivative of pair fraction relative to cluster fractions, 3 AB bonds\n dqst(1,ia,ib,jj)=3.0d0\n enddo\n! after a loop the loop variable is one higher than max limit\n jj=jj-1\n! write(*,300)(xf(ss),ss=1,ne)\n! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne)\n! write(*,*)'3X done AAAB: ',jj\n! there are 3 clusters ordered AABB, ABAB, ABBA, always A in first\n wa1=2\n do jj=jj+1,jj+3\n! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj)\n yf(1,ia)=yf(1,ia)+phvar%yfr(jj)\n dyf(1,ia,jj)=dfdy\n cluster(1:1)=chel(ia)\n do ss=2,4\n if(ss.eq.wa1) then\n yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj)\n dyf(ss,ia,jj)=dfdy\n cluster(ss:ss)=chel(ia)\n else\n yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj)\n dyf(ss,ib,jj)=dfdy\n cluster(ss:ss)=chel(ib)\n endif\n enddo\n! call get_constituent_name(iphf,jj,spname,mass)\n! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj\n wa1=wa1+1\n xf(ia)=xf(ia)+0.5D0*phvar%yfr(jj)\n dxf(ia,jj)=0.5d0*dfdy\n xf(ib)=xf(ib)+0.5D0*phvar%yfr(jj)\n dxf(ib,jj)=0.5D0*dfdy\n! derivative of pair fraction relative to cluster fractions, 4 AB bonds\n dqst(1,ia,ib,jj)=4.0d0\n enddo\n jj=jj-1\n! write(*,300)(xf(ss),ss=1,ne)\n! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne)\n! write(*,*)'3X done first half AABB: ',jj\n! these are 3 clusters ordered BAAB, BABA, BBAA\n wb1=4\n do jj=jj+1,jj+3\n! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj)\n yf(1,ib)=yf(1,ib)+phvar%yfr(jj)\n dyf(1,ib,jj)=dfdy\n cluster(1:1)=chel(ib)\n do ss=2,4\n if(ss.eq.wb1) then\n yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj)\n dyf(ss,ib,jj)=dfdy\n cluster(ss:ss)=chel(ib)\n else\n yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj)\n dyf(ss,ia,jj)=dfdy\n cluster(ss:ss)=chel(ia)\n endif\n enddo\n! call get_constituent_name(iphf,jj,spname,mass)\n! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj\n wb1=wb1-1\n xf(ia)=xf(ia)+0.5D0*phvar%yfr(jj)\n dxf(ia,jj)=0.5D0*dfdy\n xf(ib)=xf(ib)+0.5D0*phvar%yfr(jj)\n dxf(ib,jj)=0.5D0*dfdy\n! derivative of pair fraction relative to cluster fractions, 3 AB bonds\n dqst(1,ia,ib,jj)=4.0d0\n enddo\n jj=jj-1\n! write(*,300)(xf(ss),ss=1,ne)\n! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne)\n! write(*,*)'3X done second half AABB: ',jj\n! now 4 clusters ABBB, BABB, BBAB, BBBA\n! These are 4 clusters ordered ABBB, BABB, BBAB, BBBA\n wa1=1\n do jj=jj+1,jj+4\n! write(*,*)'3X site fractions in cluster: ',jj,phvar%yfr(jj)\n do ss=1,4\n if(ss.eq.wa1) then\n yf(ss,ia)=yf(ss,ia)+phvar%yfr(jj)\n dyf(ss,ia,jj)=dfdy\n cluster(ss:ss)=chel(ia)\n else\n yf(ss,ib)=yf(ss,ib)+phvar%yfr(jj)\n dyf(ss,ib,jj)=dfdy\n cluster(ss:ss)=chel(ib)\n endif\n enddo\n! call get_constituent_name(iphf,jj,spname,mass)\n! write(*,*)'3X cluster: ',cluster,' ',trim(spname),jj\n wa1=wa1+1\n xf(ia)=xf(ia)+0.25D0*phvar%yfr(jj)\n dxf(ia,jj)=0.25D0*dfdy\n xf(ib)=xf(ib)+0.75D0*phvar%yfr(jj)\n dxf(ib,jj)=0.75D0*dfdy\n! derivative of pair fraction relative to cluster fractions, 3 AB bonds\n dqst(1,ia,ib,jj)=3.0d0\n enddo\n jj=jj-1\n! write(*,300)(xf(ss),ss=1,ne)\n! write(*,310)((yf(ss,zz),ss=1,4),zz=1,ne)\n! write(*,*)'3X done ABBB: ',jj\n! constitent list\n! 3 Q01 A1A1A1A \n! 4 Q02 A1A1A1B \n! 5 Q03 A1A1B1A \n! 6 Q04 A1B1A1A \n! 7 Q05 B1A1A1A \n! 8 Q06 A1A1B1B \n! 9 Q07 A1B1A1B \n! 10 Q08 A1B1B1A \n! 11 Q09 B1A1A1B \n! 12 Q10 B1A1B1A \n! 13 Q11 B1B1A1A \n! 14 Q12 A1B1B1B \n! 15 Q13 B1A1B1B \n! 16 Q14 B1B1A1B \n! 17 Q15 B1B1B1A \n! 18 Q16 B1B1B1B \n! loop below not active when ne=2 ==============================\n icloop: do ic=ib+1,ne\n write(*,*)'3X LRO not implemented for 3 elements'\n gx%bmperr=4399; goto 1000\n! mijkl(jj-2)=12\n! mijkl(jj-1)=12\n! mijkl(jj)=12\n! jj-2 is A2BC, jj-1 is AB2C, jj is ABC2\n! xf(ia)=xf(ia)+f2*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f3*phvar%yfr(jj)\n! xf(ib)=xf(ib)+f3*phvar%yfr(jj-2)+f2*phvar%yfr(jj-1)+f3*phvar%yfr(jj)\n! xf(ic)=xf(ic)+f3*phvar%yfr(jj-2)+f3*phvar%yfr(jj-1)+f2*phvar%yfr(jj)\n! dxf(ia,jj-2)=f2; dxf(ia,jj-1)=f3; dxf(ia,jj)=f3;\n! dxf(ib,jj-2)=f3; dxf(ib,jj-1)=f2; dxf(ib,jj)=f3;\n! dxf(ic,jj-2)=f3; dxf(ic,jj-1)=f3; dxf(ic,jj)=f2;\n idloop: do id=ic+1,ne\n jj=jj+1\n! mijkl(jj-2)=24\n! jj is ABCD\n! xf(ia)=xf(ia)+f3*phvar%yfr(jj)\n! xf(ib)=xf(ib)+f3*phvar%yfr(jj)\n! xf(ic)=xf(ic)+f3*phvar%yfr(jj)\n! xf(id)=xf(id)+f3*phvar%yfr(jj)\n! dxf(ia,jj)=f3; dxf(ib,jj)=f3; dxf(ic,jj)=f3; dxf(id,jj)=f3;\n enddo idloop\n enddo icloop\n enddo ibloop\n enddo ialoop\n! debug \n! if(sdebug) then\n write(*,300)(xf(ia),ia=1,ne)\n do ia=1,ne\n write(*,290)chel(ia),(dxf(ia,jj),jj=1,8)\n write(*,291)chel(ia),(dxf(ia,jj),jj=9,16)\n enddo\n290 format('3X dxf \"',a,'\" 1-8 : ',8F6.3)\n291 format('3X dxf \"',a,'\" 9-16: ',8F6.3)\n write(*,310)((yf(ss,ia),ss=1,4),ia=1,ne)\n! if(sdebug) then\n do ia=1,ne\n write(*,270)1,ia,(dyf(1,ia,jj),jj=1,16)\n write(*,270)2,ia,(dyf(2,ia,jj),jj=1,16)\n write(*,270)3,ia,(dyf(3,ia,jj),jj=1,16)\n write(*,270)4,ia,(dyf(4,ia,jj),jj=1,16)\n enddo\n270 format('3X dyf: ',2i2,16F4.1)\n280 format('3X dyf: ',2i2,8F6.3)\n300 format('3X xf: ',8F6.3)\n310 format('3X yf: A: ',4F6.3,' B: ',4F6.3,' C: ',4F6.3)\n! endif\n!============================================== pair fractions\n allocate(pst(6,ne,ne))\n allocate(dpst(6,ne,ne,nc))\n allocate(d2pst(6,ne,ne,nc*(nc+1)/2))\n pst=zero\n dpst=zero\n d2pst=zero\n zz=0\n ploop: do ia=1,ne\n! in ternary systems pst(ss,ia,ib) can be different from pst(ib,ia) etc\n do ib=1,ne\n! assume only SRO, all pair frations the same (in a binary)\n! pst(1,ia,ib)=xf(ia)*xf(ib)\n! pst(2,ia,ib)=pst(1,ia,ib)\n! pst(3,ia,ib)=pst(1,ia,ib)\n! pst(4,ia,ib)=pst(1,ia,ib)\n! pst(5,ia,ib)=pst(1,ia,ib)\n! pst(6,ia,ib)=pst(1,ia,ib)\n pst(1,ia,ib)=yf(1,ia)*yf(2,ib)\n pst(2,ia,ib)=yf(1,ia)*yf(3,ib)\n pst(3,ia,ib)=yf(1,ia)*yf(4,ib)\n pst(4,ia,ib)=yf(2,ia)*yf(3,ib)\n pst(5,ia,ib)=yf(2,ia)*yf(4,ib)\n pst(6,ia,ib)=yf(3,ia)*yf(4,ib)\n! Taking the average values here improve convergence. But not below 0.4 ...\n! p12(ia,ib)=0.5*(yf(1,ia)*yf(2,ib)+yf(2,ia)*yf(1,ib))\n! p13(ia,ib)=0.5*(yf(1,ia)*yf(3,ib)+yf(3,ia)*yf(1,ib))\n! p14(ia,ib)=0.5*(yf(1,ia)*yf(4,ib)+yf(4,ia)*yf(1,ib))\n! p23(ia,ib)=0.5*(yf(2,ia)*yf(3,ib)+yf(3,ia)*yf(2,ib))\n! p24(ia,ib)=0.5*(yf(2,ia)*yf(4,ib)+yf(4,ia)*yf(2,ib))\n! p34(ia,ib)=0.5*(yf(3,ia)*yf(4,ib)+yf(4,ia)*yf(3,ib))\n dploop: do jj=1,nc\n! when ignoring LRO\n! dpst(1,ia,ib,jj)=xf(ia)*dxf(ib,jj)+dxf(ia,jj)*dxf(ib,jj)\n! dpst(2,ia,ib,jj)=dpst(1,ia,ib,jj)\n! dpst(3,ia,ib,jj)=dpst(1,ia,ib,jj)\n! dpst(4,ia,ib,jj)=dpst(1,ia,ib,jj)\n! dpst(5,ia,ib,jj)=dpst(1,ia,ib,jj)\n! dpst(6,ia,ib,jj)=dpst(1,ia,ib,jj)\n! NOTE: Make use of the fact that pstij depend direcly on cluster fractions\n! Just using relations to y^s_A fauvours z_AAAA and z_BBBB, i.e. no mixing\n! IDEA: Use p_AB = 3z_AAAB + 4z_ABAB + 3z_ABBB\n! dp_AB/d_AAAB = 3 etc., calculated above when extracting yf\n dpst(1,ia,ib,jj)=yf(1,ia)*dyf(2,ib,jj)+dyf(1,ia,jj)*yf(2,ib)\n dpst(2,ia,ib,jj)=yf(1,ia)*dyf(3,ib,jj)+dyf(1,ia,jj)*yf(3,ib)\n dpst(3,ia,ib,jj)=yf(1,ia)*dyf(4,ib,jj)+dyf(1,ia,jj)*yf(4,ib)\n dpst(4,ia,ib,jj)=yf(2,ia)*dyf(3,ib,jj)+dyf(2,ia,jj)*yf(3,ib)\n dpst(5,ia,ib,jj)=yf(2,ia)*dyf(4,ib,jj)+dyf(2,ia,jj)*yf(4,ib)\n dpst(6,ia,ib,jj)=yf(3,ia)*dyf(4,ib,jj)+dyf(3,ia,jj)*yf(4,ib)\n! using average values\n! dp12(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(2,ib,jj)+dyf(1,ia,jj)*yf(2,ib)+&\n! dyf(1,ia,jj)*yf(2,ib)+yf(1,ia)*dyf(2,ib,jj))\n! dp13(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(3,ib,jj)+dyf(1,ia,jj)*yf(3,ib)+&\n! dyf(1,ia,jj)*yf(3,ib)+yf(1,ia)*dyf(3,ib,jj))\n! dp14(ia,ib,jj)=0.5D0*(yf(1,ia)*dyf(4,ib,jj)+dyf(1,ia,jj)*yf(4,ib)+&\n! dyf(1,ia,jj)*yf(4,ib)+yf(1,ia)*dyf(4,ib,jj))\n! dp23(ia,ib,jj)=0.5D0*(yf(2,ia)*dyf(3,ib,jj)+dyf(2,ia,jj)*yf(3,ib)+&\n! dyf(2,ia,jj)*yf(3,ib)+yf(2,ia)*dyf(3,ib,jj))\n! dp24(ia,ib,jj)=0.5D0*(yf(2,ia)*dyf(4,ib,jj)+dyf(2,ia,jj)*yf(4,ib)+&\n! dyf(2,ia,jj)*yf(4,ib)+yf(2,ia)*dyf(4,ib,jj))\n! dp34(ia,ib,jj)=0.5D0*(yf(3,ia)*dyf(4,ib,jj)+dyf(3,ia,jj)*yf(4,ib)+&\n! dyf(3,ia,jj)*yf(4,ib)+yf(3,ia)*dyf(4,ib,jj))\n! Hm 2nd derivatives ... should check ... kxsym requires ib>ia\n! zz=kxsym(ia,ib) 16*15/2=8*15=4*30=120\n! let second derivatives be zeo\n cycle dploop\n do mm=jj,nc\n zz=kxsym(jj,mm)\n d2pst(1,ia,ib,zz)=dyf(1,ia,jj)*dyf(2,ib,mm)+&\n dyf(1,ia,jj)*dyf(2,ib,mm)\n enddo\n enddo dploop\n enddo\n enddo ploop\n do ss=1,6\n write(*,320)'3X pst:',ss,((pst(ss,ia,ib),ia=1,ne),ib=1,ne)\n320 format(a,i2,8F7.4)\n enddo\n do ia=1,ne\n do ib=1,ne\n write(*,*)'3X pair ',chel(ia),'-',chel(ib)\n do ss=1,6\n write(*,330)'3X dpst 1-8 : ',ss,(dpst(ss,ia,ib,jj),jj=1,8)\n write(*,330)'3X dpst 9-16: ',ss,(dpst(ss,ia,ib,jj),jj=9,16)\n enddo\n enddo\n enddo\n330 format(a,i2,8F7.4)\n!\n! write(*,*)'3X calculation of pair fractions done'\n! gx%bmperr=4399; goto 1000\n!\n! Recalculate constituent fractions from the site fractions \n! Note the ordering of the constituent important !!!\n allocate(ylro(nc))\n ylro=zero\n jj=0\n do ia=1,ne\n! this is AAAA or BBBB etc\n ybase=yf(1,ia)*yf(2,ia)*yf(3,ia)*yf(4,ia)\n jj=jj+1\n write(*,*)'3X ylro_',chel(ia)//chel(ia)//chel(ia)//chel(ia),&\n ' from yf(ss,ia): ',jj,ybase\n ylro(jj)=ybase\n do ib=ia+1,ne\n do ss=4,1,-1\n jj=jj+1\n! to obtain 4 AAAB replace one yf(ss,ia) with yf(ss,ib) in sublattice ss\n! NOTE it has to be in correct order: AAAB, AABA, ABAA and BAAA\n ylro(jj)=ybase*yf(ss,ib)/yf(ss,ia)\n enddo\n! to obtain the 3 AABB in correct order: AABB, ABAB, ABBA\n jj=jj+1\n ylro(jj)=yf(1,ia)*yf(2,ia)*yf(3,ib)*yf(4,ib)\n jj=jj+1\n ylro(jj)=yf(1,ia)*yf(2,ib)*yf(3,ia)*yf(4,ib)\n jj=jj+1\n ylro(jj)=yf(1,ia)*yf(2,ib)*yf(3,ib)*yf(4,ia)\n! to obtain the 3 more variants: BAAB, BABA, BBAA\n jj=jj+1\n ylro(jj)=yf(1,ib)*yf(2,ia)*yf(3,ia)*yf(4,ib)\n jj=jj+1\n ylro(jj)=yf(1,ib)*yf(2,ia)*yf(3,ib)*yf(4,ia)\n jj=jj+1\n ylro(jj)=yf(1,ib)*yf(2,ib)*yf(3,ia)*yf(4,ia)\n! to obtain the 4 variants ABBB, similar to AAAB\n ybase=yf(1,ib)*yf(2,ib)*yf(3,ib)*yf(4,ib)\n do ss=1,4\n jj=jj+1\n! to obtain 4 ABBB replace one yf(ss,ib) with yf(ss,ia) in sublattice ss\n! NOTE it has to be in correct order: ABBB, BABB, BBAB and BBBA\n ylro(jj)=ybase*yf(ss,ia)/yf(ss,ib)\n enddo\n! element C and D ...\n! These lines not needed for binary systems ... NOT IMPLEMENTED\n do ic=ib+1,ne\n write(*,*)'3X ternary LRO not implemented'\n gx%bmperr=4399; goto 1000\n jj=jj+1\n! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)**2*xf(ib)*xf(ic)\n! jj=jj+1\n! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)**2*xf(ic)\n! jj=jj+1\n! ylro(jj)=yrest*phvar%yfr(jj)+ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)**2\n do id=ic+1,ne\n jj=jj+1\n! ylro(jj)=yrest*phvar%yfr(jj)+&\n! ycorr*mijkl(jj)*xf(ia)*xf(ib)*xf(ic)*xf(id)\n enddo\n enddo\n enddo\n enddo\n!\n! handle only SRO, set all pst same\n write(*,'(a,3F10.7)')'3X >>>>>>>>>>>>> only SRO <<<<<<<<<',xf(1),xf(2)\n do ia=1,ne\n do ib=1,ne\n do ss=1,6\n pst(ss,ia,ib)=xf(ia)*xf(ib)\n do jj=1,nc\n dpst(ss,ia,ib,jj)=dxf(ia,jj)*xf(ib)+xf(ia)*dxf(ib,jj)\n enddo\n enddo\n enddo\n enddo\n! SKIP CORRECTION, then converges with (almost) exactly ideal start values\n! pstijtest is maximum pair fraction using mole fractions calculated\n! from cluster fractions provided by the minimizer\n! if almost the same as previous decrease ycorr\n if(abs(pstijtest-pstijsave).lt.1.0D-4) then\n ycorr=max(0.5D0*ycorr,1.0D-8)\n! when yrest=1 we use the fractions from the minimizer\n else\n ycorr=min(2.0d0*ycorr,0.5D0)\n endif\n ycorr=zero\n yrest=1.0D0-ycorr\n write(*,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,&\n pstijtest,pstijsave,yrest,ycorr\n! without this stupid dummy statement the calculations does not converge SRO\n write(dummy,'(a,1x,l,1x,12F6.3)')'3X corr: ',sdebug,&\n pstijtest,pstijsave,yrest,ycorr\n! save pstij for next iteration\n pstijsave=pstijtest\n! We have LRO, fractions on sublattices can be different\n! do jj=1,nc\n! ylro(jj)=phvar%yfr(jj)\n! enddo\n!\n! if(SDEBUG) then\n write(*,'(a,8F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=1,8)\n write(*,'(a,8F7.4)')'3X ylro:',(ylro(jj),jj=1,8)\n write(*,'(a,8F7.4)')'3X yfr: ',(phvar%yfr(jj),jj=9,nc)\n write(*,'(a,8F7.4)')'3X ylro:',(ylro(jj),jj=9,16)\n! endif\n!\n! write(*,*)'3X calculation of clusters from site fractions done'\n! gx%bmperr=4399; goto 1000\n!\n! All necessary fractions and derivatives calculated, now the entropy\n! S = -2 \\sum_ijkl y_ijkl\\ln(y_ijkl) +\n! 6 \\sum_ij p_ij\\ln(p_ij) - 5 \\sum_j x_j\\ln(x_j)\n! As we calculate dG/dT the signs of Kikuchi are inverse\n! entropy contribution from the constituent fractions ------------------\n ssumy=zero\n! sylog1=zero\n do jj=1,nc\n! yfra=phvar%yfr(jj)\n! use cluster factions recalculated from site fractions\n yfra=ylro(jj)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! yfra is divided by mijkl as it represent mijkl fractions\n! ylog=log(yfra/mijkl(jj))\n ylog=log(yfra)\n! debugging\n! if(jj.le.5) ylog1(jj)=ylog\n! sylog1=sylog1+yfra*ylog\n ssumy=ssumy+syfact*yfra*ylog\n if(moded.gt.0) then\n! dgval(1,1:nc,1) are derivative of G/RT wrt fraction 1:nc\n! d2gval(ixsym(jj*(jk+1)/2,1) are 2nd derivarive of G/RT wrt fraction jj and jk\n! dgval and d2gval are zero before this loop\n phvar%dgval(1,jj,1)=syfact*(one+ylog)\n! ? T and y derivative\n! phvar%dgval(2,jj,1)=syfact*(mijkl(jj)+ylog)/tval\n phvar%dgval(2,jj,1)=syfact*(one+ylog)/tval\n! 2nd derivative, each term depend on a single y fraction\n phvar%d2gval(kxsym(jj,jj),1)=syfact/yfra\n endif\n enddo\n phvar%gval(1,1)=ssumy\n phvar%gval(2,1)=ssumy/tval\n! do jj=1,nc\n! use cluster fractions recalculated from site fractions !!!\n! phvar%yfr(jj)=ylro(jj)\n! enddo\n write(*,*)'3X calculation of cluster entropy term done',ssumy\n! gx%bmperr=4399; goto 1000\n! entropy contributions from the 6 pair fractions -----------------------\n! each can be different pst(ss,ia,ib) can be different for each ss\n ssump=zero\n do ia=1,ne\n do ib=1,ne\n ssloop: do ss=1,6\n! bond between atom ia and ib in sublattice s,t, there are 6 such paris\n! we must repeat this for all 6 pairs in each cluster\n! Note this term is negative in the Kikuchi summation !!!\n pfra=pst(ss,ia,ib)\n if(pfra.lt.bmpymin) pfra=bmpymin\n if(pfra.gt.one) pfra=one\n ylog=log(pfra)\n ssump=ssump-pfra*ylog\n if(moded.gt.0) then\n do jl=1,nc\n! we need derivatives of pair fractions wrt constituent fractions\n! Note negative sign because this is part of the 6 pln(p) term\n! NOTE: Make use of the fact that pstij depend direcly on cluster fractions\n! Just using relations to y^s_A fauvours z_AAAA and z_BBBB, i.e. no mixing\n! Use p_AB = 3z_AAAB + 4z_ABAB+3z_ABBB\n! dp_AB/d_AAAB = 3 etc.\n if(ia.eq.ib) then\n phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)-&\n dpst(ss,ia,ib,jl)*(one+ylog)\n else\n! this is derivative of AB pair related to clusters with ABBB, ABAB and ABBB\n phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)-&\n dqst(1,ia,ib,jl)*(one+ylog)\n endif\n do jm=jl,nc\n zz=ixsym(jl,jm)\n phvar%d2gval(zz,1)=phvar%d2gval(zz,1)-&\n d2pst(ss,ia,ib,zz)*(one+ylog)+&\n dpst(ss,ia,ib,jl)*dpst(ss,ia,ib,jm)/pst(ss,ia,ib)\n enddo\n enddo\n endif\n enddo ssloop\n! done all 6 pairs for ia,ib\n enddo\n enddo\n! done all pairs ia,ib\n! We have changed the sign when we calculate 6*p*ln(p) terms above\n! The derivatives have the negative sign already\n phvar%gval(1,1)=phvar%gval(1,1)+ssump\n phvar%gval(2,1)=phvar%gval(2,1)+ssump/tval\n write(*,*)'3X calculation of 6 pair fractions entropy term done',ssump\n! entropy contributions from the site fractions, factor 5/4 = 1.25\n ssumx=zero\n! sylog3=zero\n do ss=1,4\n do ia=1,ne\n! we need derivatives of mole fractions wrt constituent fractions\n pfra=yf(ss,ia)\n if(pfra.lt.bmpymin) pfra=bmpymin\n if(pfra.gt.one) pfra=one\n ylog=log(pfra)\n ssumx=ssumx+sxfact*pfra*ylog\n if(moded.gt.0) then\n do jl=1,nc\n! we need derivatives of site fractions wrt constituent fractions\n phvar%dgval(1,jl,1)=phvar%dgval(1,jl,1)+&\n sxfact*dyf(ss,ia,jl)*(ylog+one)\n do jm=jl,nc\n! note d2xf/dyidyj==0\n zz=kxsym(jl,jm)\n phvar%d2gval(zz,1)=phvar%d2gval(zz,1)+&\n sxfact*dyf(ss,ia,jl)*dyf(ss,ia,jm)/pfra\n enddo\n enddo\n endif\n enddo\n enddo\n! the sxfact +5/4 is already included above\n phvar%gval(1,1)=phvar%gval(1,1)+ssumx\n phvar%gval(2,1)=phvar%gval(2,1)+ssumx/tval\n write(*,'(a,F12.4)')'3X calculation of site fraction entropy: ',ssumx\n! write(*,*)'3X all entropy calculations made'\n! All done\n! if(SDEBUG) then\n write(*,900)'3X xf: ',(xf(ia),ia=1,ne)\n900 format(a,6F10.7)\n do ss=1,6\n write(*,320)'3X pst',ss,((pst(ss,ia,ib),ia=1,ne),ib=1,ne)\n enddo\n910 format(a,10F7.3)\n write(*,310)((yf(ss,ia),ss=1,4),ia=1,ne)\n do ia=1,ne\n write(*,270)1,ia,(dyf(1,ia,jj),jj=1,16)\n write(*,270)2,ia,(dyf(2,ia,jj),jj=1,16)\n write(*,270)3,ia,(dyf(3,ia,jj),jj=1,16)\n write(*,270)4,ia,(dyf(4,ia,jj),jj=1,16)\n enddo\n write(*,'(a,8F7.4)')'3X yfr 1-8: ',(phvar%yfr(jj),jj=1,8)\n write(*,'(a,8F7.4)')'3X ylro 1-8: ',(ylro(jj),jj=1,8)\n write(*,'(a,8F7.4)')'3X yfr 9-16:',(phvar%yfr(jj),jj=9,nc)\n write(*,'(a,8F7.4)')'3X ylro 9-16:',(ylro(jj),jj=9,16)\n write(*,'(a,5(1pe12.4))')'3X cvmtfs: ',ssumy,ssump,ssumx,&\n phvar%gval(1,1),8.31451*phvar%gval(1,1)\n! write(*,*)'3X cvmtfs model not yet released'\n! endif\n1000 continue\n return\n end subroutine config_entropy_cvmtfl\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_i2sl\n!\\begin{verbatim}\n subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval)\n! calculates configurational entropy/R for ionic liquid model\n! Always 2 sublattices, the sites depend on composition\n! P = \\sum_j (-v_j) y_j + Q y_Va\n! Q = \\sum_i v_i y_i\n! where v is the charge on the ions. P and Q calculated by set_constitution\n implicit none\n integer moded,nsl,i2slx(2)\n integer, dimension(nsl) :: nkl\n TYPE(gtp_phase_varres), pointer :: phvar\n!\\end{verbatim}\n integer ll,kk,kall,nk,j1,j2,jxsym\n double precision tval,ss,yfra,ylog,yva,spart(2)\n ll=0\n kall=0\n spart=zero\n yva=zero\n sublatticeloop: do while (ll.lt.nsl)\n ll=ll+1\n nk=nkl(ll)\n kk=0\n ss=zero\n fractionloop: do while (kk.lt.nk)\n kk=kk+1\n kall=kall+1\n! no cycle as we may need values of spart and yva ...\n! if(nk.eq.1) cycle sublatticeloop\n yfra=phvar%yfr(kall)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! save current value of vacancy fraction\n if(kall.eq.i2slx(1)) yva=yfra\n! write(*,2)'3X yva: ',kall,i2slx(1),yva,yfra\n!2 format(a,2i3,6(1pe12.4))\n ylog=log(yfra)\n! gval(1:6,1) are G and derivator wrt T and P\n! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N\n! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T\n! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P\n! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M\n! this is a symmetric matrix and index givem by ixsym(M,N)\n ss=ss+yfra*ylog\n if(moded.gt.0) then\n phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog)\n! phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra\n phvar%d2gval(kxsym(kall,kall),1)=phvar%sites(ll)/yfra\n endif\n enddo fractionloop\n phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss\n if(ll.eq.1) then\n spart(1)=ss\n else\n spart(2)=ss\n endif\n enddo sublatticeloop\n if(moded.eq.0) goto 900\n! convergence problem with ionic liquid, skip contribution to 2nd derivatuves\n! localmoded=moded\n! if(moded.eq.2) localmoded=1\n! write(*,*)'3X ionic config_entropy: ',i2slx,kall\n! additional derivatives as sublattice sites depend on composition\n! -------------------------- derivatives of config entropy\n! S = P*S1 + Q*S2\n! S1 = \\sum_i y_i*ln(y_i)\n! S2 = \\sum_j y_j*ln(y_j)+y_Va*ln(y_Va)+\\sum_k y_k*ln(Y_k))\n! P = \\sum_j (-v_j)*y_j + Q*y_Va\n! Q = \\sum_i v_i*y_i\n! term within [...] already calculated as part of normal config.entropy\n! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK\n! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK\n! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK\n! dS/dy_k = [Q*(1+ln(y_k)] ..neutral OK\n! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + \n! [P*(1/y_i1**2)] ..last term zero unless i1=i2 OK\n! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) OK\n! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) OK\n! d2S/dy_idy_k = v_i*(1+ln(y_k)) OK\n! d2S/dy_j1d_j2 = [only Q/y**2 if j1=j2] OK\n! d2S/dy_jdy_Va = zero OK\n! d2S/dy_jdy_k = zero OK\n! d2S/dy_Va2 = [only Q/y_Va**2] OK\n! d2S/dy_Vady_k = zero OK\n! d2S/dy_k1dy_k2 = [only Q/y_k1**2 if k1=k2] OK\n! ----------------------\n! the coding is not optimal for speed, all the 1/y**2 term calculated above\n! i2slx(1) is index of vacancy, i2slx(2) is index of first neutral\n! if either (or both) are missing their index is higher than last constituent\n! write(*,102)'3X va+neutral: ',i2slx\n!102 format(a,10i3)\n! dpqdy is calculated in gtp3X: set_constitution ??\n! write(*,108)'3X dpqdy: ',(phvar%dpqdy(j1),j1=1,nkl(1)+nkl(2))\n108 format(a,10F7.3)\n cation: do j1=1,nkl(1)\n! to avoid calling ixsym ...\n jxsym=kxsym(j1,j1)\n cation2: do j2=j1,nkl(1)\n! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + \n! [P*(1/y_i1**2)] ..last term already calculated OK\n if(ixsym(j1,j2).ne.jxsym) then\n! this ixsym test works and has run of few 1000 times, removed for speed!!\n write(*,*)'3X ISYM error 5',j1,j2,ixsym(j1,j2),jxsym\n stop \"3X ixsym indexing error 17\"\n endif\n! phvar%d2gval(ixsym(j1,j2),1)=phvar%d2gval(ixsym(j1,j2),1)+&\n! (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+&\n! phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1)\n phvar%d2gval(jxsym,1)=phvar%d2gval(jxsym,1)+&\n (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+&\n phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1)\n jxsym=jxsym+j2\n enddo cation2\n anion2: do kk=1,nkl(2)\n j2=nkl(1)+kk\n jxsym=kxsym(j1,j2)\n if(j2.lt.min(i2slx(1),i2slx(2))) then\n! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) ...cation+anion OK\n! phvar%d2gval(ixsym(j1,j2),1)=&\n! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+&\n! phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1)\n phvar%d2gval(jxsym,1)=&\n phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+&\n phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1)\n elseif(j2.eq.i2slx(1)) then\n! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) ...cation+Va OK\n! phvar%d2gval(ixsym(j1,j2),1)=&\n! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+&\n! phvar%dpqdy(j1)*spart(1)+&\n! phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1)\n phvar%d2gval(jxsym,1)=&\n phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+&\n phvar%dpqdy(j1)*spart(1)+&\n phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1)\n else\n! d2S/dy_idy_k = v_i*(1+ln(y_k)) ...cation+neutral OK\n! write(*,107)'3X i,va: ',j1,j2,phvar%dpqdy(j1),phvar%dgval(1,j2,1),&\n! phvar%sites(2)\n!107 format(a,2i2,6(1pe12.4))\n! phvar%d2gval(ixsym(j1,j2),1)=&\n! phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)\n phvar%d2gval(jxsym,1)=&\n phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)\n endif\n enddo anion2\n109 continue\n! this done at the end as original dgval(1,j1,1)=P*(1+ln(y_j1))/P used above\n! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK\n! write(*,19)'3X c: ',j1,phvar%dgval(1,j1,1),&\n! phvar%dpqdy(j1),spart(2),phvar%dpqdy(j1),yva,spart(1)\n!19 format(a,i3,6(1pe12.4))\n phvar%dgval(1,j1,1)=phvar%dgval(1,j1,1)+&\n phvar%dpqdy(j1)*spart(2)+phvar%dpqdy(j1)*yva*spart(1)\n enddo cation\n! this done separately as original dgval(1,j2,1)=Q*(1+ln(y_j2))/Q used above\n! kall here should be total number of constituents\n anion1: do j2=nkl(1)+1,min(i2slx(1),kall)\n if(j2.lt.min(i2slx(1),i2slx(2))) then\n! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK\n! write(*,*)'3X anion1 A: ',j2\n phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%dpqdy(j2)*spart(1)\n elseif(j2.eq.i2slx(1)) then\n! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK\n! write(*,*)'3X anion1 B: ',j2\n phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%sites(2)*spart(1)\n! else\n! dS/dy_k = nothing + [Q*(1+ln(y_k)] ..neutral OK\n endif\n! write(*,*)'3X anion1 C: ',j2\n enddo anion1\n! set temperature derivative of dG/dy\n do j1=1,kall\n phvar%dgval(2,j1,1)=phvar%dgval(1,j1,1)/tval\n enddo\n900 continue\n! phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss\n! write(*,905)'3X parts: ',phvar%gval(1,1),phvar%sites,spart\n!905 format(a,6(1pe12.4))\n! set temperature derivative of G\n phvar%gval(2,1)=phvar%gval(1,1)/tval\n1000 continue\n return\n end subroutine config_entropy_i2sl\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_qcwithlro\n!\\begin{verbatim}\n subroutine config_entropy_qcwithlro(moded,ncon,phvar,phrec,tval)\n!\n! calculates configurational entropy/R for the quasichemial liquid with LRO\n!\n! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2\n! ncon is number of constituents\n! phvar is pointer to phase_varres record\n! phrec is the phase record\n! tval is current value of T\n implicit none\n integer moded,ncon\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_phaserecord) :: phrec\n double precision tval\n!\\end{verbatim} %+\n! First A=(z/2)*(\\sum_i (y_ii*ln(y_ii) + \\sum_(j>=i) y_ij*ln(y_ij/2))\n! and calculate all x_i = y_ii + \\sum_j a/(a+b)*y_ij\n! Then calculate the SRO: q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2\n! and B=\\sum_i x_i*ln(x_i)*(1-z + \\sum_(j>i) (z/2-1)*f(q_ij))\n! -S = A+B\n integer icon,loksp,lokel,iel,nqij,kqij,jxsym,infirst,lat2,i,j\n double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2\n double precision xp,xs,gamma,x1,x2,sumx(2),gamma2\n double precision, allocatable, dimension(:) :: qij,ycluster,&\n dgamma,d2gamma\n double precision, allocatable, dimension(:,:) :: xval\n double precision, allocatable, dimension(:,:,:) :: dxval\n integer, allocatable, dimension(:,:) :: qxij\n logical iscluster\n double precision, parameter :: half=0.5D0\n!\n zhalf=half*phvar%qcbonds\n allocate(xval(noofel,2))\n allocate(dxval(noofel,ncon,2))\n! allocate(ycluster(noofel))\n xval=zero\n dxval=zero\n! write(*,*)'3X classical qc with LRO!',zhalf\n! gx%bmperr=4399; goto 1000\n!\n sbonds=zero\n nqij=0\n sumx=zero\n ally: do icon=1,ncon\n yfra=phvar%yfr(icon)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! loksp is set to the index of the constituent in the species array\n loksp=phrec%constitlist(icon)\n! if two elements it is an AB bond\n! To identify if the cluster constituent is on the first or second sublattice\n! use the alphabetical order of the species name. If first letter=i) y_ij*ln(y_ij/2))\n! and calculate all x_i = y_ii + \\sum_j a/(a+b)*y_ij\n! Then calculate the SRO: q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2\n! and B=\\sum_i x_i*ln(x_i)*(1-z + \\sum_(j>i) (z/2-1)*f(q_ij))\n! -S = A+B\n integer icon,loksp,lokel,iel,nqij,kqij,jxsym\n double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2\n double precision xp,xs,gamma,x1,x2\n double precision, allocatable, dimension(:) :: xval,qij,ycluster,&\n dgamma,d2gamma\n double precision, allocatable, dimension(:,:) :: dxval,dqij\n integer, allocatable, dimension(:,:) :: qxij\n logical iscluster\n double precision, parameter :: half=0.5D0\n!\n! qcmodel=1 is classical qc without LRO, 2 is q**2, 3 is 0.5*(1+q)*q**2\n! qcmodel=1\n!\n zhalf=half*phvar%qcbonds\n write(*,*)'3X classic cqc, zhalf: ',zhalf\n allocate(xval(noofel))\n allocate(dxval(noofel,ncon))\n! allocate(ycluster(noofel))\n xval=zero\n dxval=zero\n! write(*,*)'3X classical quasichemical!',zhalf\n!\n sbonds=zero\n nqij=0\n do icon=1,ncon\n yfra=phvar%yfr(icon)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! if set the constituent is a binary cluster\n if(btest(phvar%constat(icon),CONQCBOND)) then\n cluster=half\n iscluster=.TRUE.\n! write(*,*)'3X CQC classic 0: ',qcmodel,iscluster,yfra\n else\n cluster=one\n iscluster=.FALSE.\n endif\n! entropy is y*ln(y) for single atoms, y*ln(y/2) for clusters\n ylog=log(cluster*yfra)\n! gval(1:6,1) are G and derivator wrt T and P\n! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N\n! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T\n! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P\n! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M\n! this is a symmetric matrix and index givem by ixsym(M,N)\n sbonds=sbonds+zhalf*yfra*ylog\n if(moded.gt.0) then\n phvar%dgval(1,icon,1)=zhalf*(one+ylog)\n! phvar%d2gval(ixsym(icon,icon),1)=zhalf/(yfra)\n phvar%d2gval(kxsym(icon,icon),1)=zhalf/(yfra)\n! These should be the correct derivatives but with these it does not converge!!\n! phvar%dgval(1,icon,1)=zhalf*(one/cluster+ylog)\n! phvar%d2gval(ixsym(icon,icon),1)=zhalf/(cluster*yfra)\n! DO NOT CHANGE ANYTHING!!\n endif\n! loksp is set to the index of the species array\n loksp=phrec%constitlist(icon)\n lokel=splista(loksp)%ellinks(1)\n! if(btest(phvar%constat(icon),CONQCBOND)) then\n if(iscluster) then\n nqij=nqij+1\n! ycluster(nqij)=yfra\n! if a bond cluster there must be two elements \n! lokel is index in ellista of first element, iel is its alphabetical index\n iel=ellista(lokel)%alphaindex\n stoi1=splista(loksp)%stoichiometry(1)\n stoi2=splista(loksp)%stoichiometry(2)\n xval(iel)=xval(iel)+stoi1/(stoi1+stoi2)*yfra\n dxval(iel,icon)=stoi1/(stoi1+stoi2)\n! write(*,60)'3X qc 3A: ',iel,xval(iel),yfra\n lokel=splista(loksp)%ellinks(2)\n iel=ellista(lokel)%alphaindex\n xval(iel)=xval(iel)+stoi2/(stoi1+stoi2)*yfra\n dxval(iel,icon)=stoi2/(stoi1+stoi2)\n! write(*,60)'3X qc 3B: ',iel,xval(iel),yfra\n else\n lokel=splista(loksp)%ellinks(1)\n iel=ellista(lokel)%alphaindex\n xval(iel)=xval(iel)+yfra\n dxval(iel,icon)=one\n! write(*,60)'3X qc 3C: ',iel,xval(iel),yfra\n endif\n enddo\n!----------------------------------------\n! We do not need qij = y_ij/(2x_ix_j) - 1\n! The correction term is composition independent 1-z\n gamma=one-2.0D0*zhalf\n! Some elements may not be dissolved in this phase ??\n scorr=zero\n do iel=1,noofel\n yfra=xval(iel)\n if(yfra.le.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n ylog=log(yfra)\n scorr=scorr+yfra*ylog\n! WE MUST ALSO CALCULATE DERIVATIVES OF x_i USING CHAIN RULE\n! DO NOT CHANGE ANYTHING!!\n if(moded.gt.0) then\n do icon=1,ncon\n phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+&\n gamma*(one+ylog)*dxval(iel,icon)\n jxsym=kxsym(icon,icon)\n do loksp=icon,ncon\n! phvar%d2gval(ixsym(icon,loksp),1)=&\n! phvar%d2gval(ixsym(icon,loksp),1)+&\n! gamma*dxval(iel,icon)*dxval(iel,loksp)/yfra\n if(ixsym(icon,loksp).ne.jxsym) then\n! this ixsym test works and has run of few 1000 times, removed for speed!!\n write(*,*)'3X ISYM error 18',ixsym(icon,loksp),jxsym\n stop\n endif\n phvar%d2gval(jxsym,1)=&\n phvar%d2gval(jxsym,1)+&\n gamma*dxval(iel,icon)*dxval(iel,loksp)/yfra\n jxsym=jxsym+loksp\n enddo\n enddo\n endif\n enddo\n!- ixsym --------------- ixsym end modification\n! now all is calculated gval(1,1)=G; gval(2,1)=S etc\n! DO NOT CHANGE ANYTHING!!\n phvar%gval(1,1)=sbonds+gamma*scorr\n phvar%gval(2,1)=(sbonds+gamma*scorr)/tval\n write(*,12)'3X QC1: ',qcmodel,phvar%gval(1,1),phvar%gval(2,1),gamma,&\n zhalf,sbonds,scorr\n12 format(a,i2,6(1pe11.3))\n!\n! THIS ROUTINE NOT USED !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n!\n1000 continue\n return\n end subroutine config_entropy_cqc_classicqc\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_qchillert\n!\\begin{verbatim}\n subroutine config_entropy_qchillert(moded,ncon,phvar,phrec,tval)\n!\n! calculates configurational entropy/R for the corrected quasichemial liquid\n! Hillert-Selleby-Sundman\n! Rewritten 2019-01-12 based on cqc-classicqc which seems correct\n! test1: qcmodel=1: OK for zhalf=1 and 3\n! test2: qcmodel=2: OK!!\n! test3: qcmodel=3: OK for SRO, problmens for miscibility gap\n!\n! only question is the parameter, value of G = K*T*R/2;\n! K=-10, T=600 means G= -10*600*R/2 = -3000*R gives same curves as in paper. \n!\n! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2\n! ncon is number of constituents\n! phvar is pointer to phase_varres record\n! phrec is the phase record\n! tval is current value of T\n implicit none\n integer moded,ncon\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_phaserecord) :: phrec\n double precision tval\n!\\end{verbatim}\n! First A=(z/2)*(\\sum_i (y_ii*ln(y_ii) + \\sum_(j>=i) y_ij*ln(y_ij/2))\n! and calculate all x_i = y_ii + \\sum_j (a_i/(a_1+a_j))*y_ij\n! and calculate all x_j = y_jj + \\sum_i (a_j/(a_1+a_j))*y_ij\n! dx_i/dy_ii =1; dx_i/dy_ij = a_i/(a_i+a_j); dx_i/dy_jj =0\n! Then calculate normallized sro= q_ij=(y_ij/(x_i*x_j)-1)*(x_i+x_j)**2\n! gcmodel=1 : gamma = -(1-z)\n! gcmodel=2 : gamma = -(1-z -(z/2-1)*sro**2)\n! gamma is multiplied with B:\n! and B=\\sum_i x_i*ln(x_i)\n! -S = dG/dT = A+gamma*B\n integer icon,loksp,lokel,iel,nqij,kqij,jcon,kcon,maxc\n double precision zhalf,yfra,ylog,cluster,sbonds,scorr,stoi1,stoi2,temp1\n double precision xp,xs,gamma,x1,x2,sij,xnorm1,xnorm2,xprod\n double precision, allocatable, dimension(:) :: xval,qij,ycluster,&\n dgamma,d2gamma,sqz\n double precision, allocatable, dimension(:,:) :: dxval,dqij,d2qij\n integer, allocatable, dimension(:,:) :: qxij,jel\n integer, allocatable, dimension(:) :: jcluster\n logical iscluster\n double precision, parameter :: half=0.5D0\n!\n! qcmodel=1 is classical qc without LRO, 2 is q**2, 3 is 0.5*(1+q)*q**2\n! qcmodel=1\n! gcmodel=2\n! gcmodel=3\n!\n zhalf=half*phvar%qcbonds\n! ncon is number of constituents, noofel number of elements\n write(*,'(a,i2,F8.3,10i4)')'3X cqc6 start: ',qcmodel,zhalf,ncon,noofel\n allocate(xval(noofel))\n allocate(dxval(noofel,ncon))\n! max antal binary cluster\n maxc=ncon*(ncon-1)/2\n allocate(ycluster(maxc))\n allocate(sqz(maxc))\n allocate(jel(maxc,2))\n! this is used to indicate constituent index of a cluster\n allocate(jcluster(maxc))\n xval=zero\n dxval=zero\n sqz=zero\n! write(*,*)'3X classical quasichemical!',zhalf\n!\n! STEP 1: entropy for clusters\n sbonds=zero\n nqij=0\n scluster: do icon=1,ncon\n yfra=phvar%yfr(icon)\n if(yfra.lt.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n! if set the constituent is a binary cluster\n if(btest(phvar%constat(icon),CONQCBOND)) then\n cluster=half\n iscluster=.TRUE.\n! write(*,*)'3X CQC classic 0: ',qcmodel,iscluster,yfra\n else\n cluster=one\n iscluster=.FALSE.\n endif\n! entropy is y*ln(y) for single atoms, y*ln(y/2) for clusters\n ylog=log(cluster*yfra)\n! gval(1:6,1) are G, dG/dT, dG/dP, d2G/dT2, d2G/dTdP and d2G/dP2\n! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N\n! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T\n! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P\n! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M\n! this is a symmetric matrix and index givem by ixsym(M,N)\n sbonds=sbonds+zhalf*yfra*ylog\n if(moded.gt.0) then\n! first and second derivatives for \\sum_i y_ii\\ln(y_ii)+y_ij\\ln(y_ij/2)\n phvar%dgval(1,icon,1)=zhalf*(one+ylog)\n phvar%d2gval(ixsym(icon,icon),1)=zhalf/(yfra)\n endif\n! we have to calculate the mole fractions for the correction term\n! loksp is set to the index of the species array\n loksp=phrec%constitlist(icon)\n lokel=splista(loksp)%ellinks(1)\n! if(btest(phvar%constat(icon),CONQCBOND)) then\n if(iscluster) then\n nqij=nqij+1\n ycluster(nqij)=yfra\n jcluster(nqij)=icon\n! if a bond cluster there must be two elements \n! lokel is index in ellista of first element, iel is its alphabetical index\n iel=ellista(lokel)%alphaindex\n stoi1=splista(loksp)%stoichiometry(1)\n stoi2=splista(loksp)%stoichiometry(2)\n xval(iel)=xval(iel)+stoi1/(stoi1+stoi2)*yfra\n dxval(iel,icon)=stoi1/(stoi1+stoi2)\n! sqz=1 for equiatomic ordering\n sqz(nqij)=0.125/(stoi1*stoi2)\n jel(nqij,1)=iel\n! write(*,60)'3X qc 3A: ',iel,xval(iel),yfra\n lokel=splista(loksp)%ellinks(2)\n iel=ellista(lokel)%alphaindex\n xval(iel)=xval(iel)+stoi2/(stoi1+stoi2)*yfra\n dxval(iel,icon)=stoi2/(stoi1+stoi2)\n jel(nqij,2)=iel\n! write(*,60)'3X qc 3B: ',iel,xval(iel),yfra\n else\n lokel=splista(loksp)%ellinks(1)\n iel=ellista(lokel)%alphaindex\n xval(iel)=xval(iel)+yfra\n dxval(iel,icon)=one\n! write(*,60)'3X qc 3C: ',iel,xval(iel),yfra\n endif\n enddo scluster\n! check mole fractions sum up to unity\n xs=zero\n do icon=1,noofel\n xs=xs+xval(icon)\n enddo\n if(abs(xs-one).gt.1.0D-12) then\n write(*,*)'3X cqc6: sum of molefractions not unity: ',xs\n stop\n endif\n!----------------------------------------\n! step 2: correction factor gamma\n! NOTE sign opposite eq. 11 as this is dG/dy = -S \n if(qcmodel.eq.1) then\n! classic: composition independent gamma: 1-z\n gamma=one-2.0D0*zhalf\n else\n! write(*,*)'3X qcmodel: ',qcmodel,nqij,maxc\n! we must calculate the SRO for each cluster ij (more than one cluster!)\n! s_ij = 0.5 y_ij - x_ix_j/(x_i+x_j)**2\n! q_ij= s_ij/x_ix_j \n! and we can have ordering at other composition than equiatoic!!\n allocate(dgamma(ncon))\n allocate(d2gamma(ncon*(ncon+1)/2))\n allocate(qij(nqij))\n allocate(dqij(nqij,ncon))\n allocate(d2qij(nqij,ncon*(ncon+1)/2))\n gamma=one-2.0D0*zhalf\n! write(*,*)'3X loop to calculate gamma'\n gammaloop: do icon=1,nqij\n! jel(icon,k) is element k in cluster icon\n xnorm1=xval(jel(icon,1))/(xval(jel(icon,1))+xval(jel(icon,2)))\n xnorm2=xval(jel(icon,2))/(xval(jel(icon,1))+xval(jel(icon,2)))\n xprod=xnorm1*xnorm2\n! NOTE p_AB is 0.5y_AB\n! sij=0.5D0*ycluster(icon)/xprod\n sij=sqz(icon)*ycluster(icon)/xprod\n! This is the variable \"q\" defined by eq. 9 in the 2009 paper \n! qij(icon)=0.5D0*ycluster(icon)/xprod-one\n qij(icon)=sij-one\n do jcon=1,ncon\n! first derivatives of qij with respect to y_ij\n temp1=zero\n if(jcluster(icon).eq.jcon) temp1=sqz(icon)/xprod\n temp1=temp1-sij*(dxval(jel(icon,1),jcon)/xval(jel(icon,1))-&\n dxval(jel(icon,2),jcon)/xval(jel(icon,2)))\n dqij(icon,jcon)=temp1\n! ignore 2nd derivatives ... ???\n do kcon=jcon,ncon\n d2qij(icon,ixsym(icon,jcon))=zero\n enddo\n enddo\n if(qcmodel.eq.2) then\n! this is the correction factor\n gamma=gamma+(zhalf-one)*qij(icon)**2\n do jcon=1,ncon\n! THIS LINE WAS MISSING!!! works (almost)\n dgamma(jcon)=2.0D0*(zhalf-one)*qij(icon)*dqij(icon,jcon)\n do kcon=jcon,ncon\n! this is approximate, no d2qij....\n d2gamma(ixsym(jcon,kcon))=2.0D0*(zhalf-one)*&\n dqij(icon,kcon)*dqij(icon,jcon)\n enddo\n enddo\n elseif(qcmodel.eq.3) then\n! this is the correction factor for qcmodel=3\n gamma=gamma+0.5D0*(zhalf-one)*(qij(icon)+one)*qij(icon)**2\n! write(*,*)'3X qcmodel=3: ',icon,phvar%phtupx,qij(icon),gamma\n do jcon=1,ncon\n dgamma(jcon)=(zhalf-one)*qij(icon)*&\n (1.5D0*qij(icon)+one)*dqij(icon,jcon)\n do kcon=jcon,ncon\n! this is approximate, no d2qij....\n d2gamma(ixsym(jcon,kcon))=0.5D0*(zhalf-one)*&\n (6.0D0*qij(icon)*dqij(icon,kcon)*dqij(icon,jcon)+&\n (3*qij(icon)+one)*d2qij(icon,ixsym(jcon,kcon)))\n enddo\n enddo\n else\n write(*,*)'3X no such qcmodel: ',qcmodel\n endif\n enddo gammaloop\n endif\n! write(*,*)'3X qcmodel',qcmodel,gamma\n!----------------------------------------\n! Step 3: entropy for molefractions: scorr=\\sum_i x_i ln(x_i)\n scorr=zero\n! write(*,'(a,4(1pe12.4))')'3X loop scorr',sbonds,gamma,sqz\n smol: do iel=1,noofel\n yfra=xval(iel)\n if(yfra.le.bmpymin) yfra=bmpymin\n if(yfra.gt.one) yfra=one\n ylog=log(yfra)\n scorr=scorr+yfra*ylog\n! WE MUST ALSO CALCULATE DERIVATIVES OF x_i, dx_i/dy_j USING CHAIN RULE\n! at present ignore derivatives of gamma ....\n if(moded.gt.0) then\n do icon=1,ncon\n phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+&\n gamma*(one+ylog)*dxval(iel,icon)\n! derivative wrt T and icon\n phvar%dgval(2,icon,1)=phvar%dgval(2,icon,1)+&\n gamma*(one+ylog)*dxval(iel,icon)/tval\n do jcon=icon,ncon\n phvar%d2gval(ixsym(icon,jcon),1)=&\n phvar%d2gval(ixsym(icon,jcon),1)+&\n gamma*dxval(iel,icon)*dxval(iel,jcon)/yfra\n enddo\n enddo\n endif\n enddo smol\n! write(*,*)'3X all done, save values in phvar'\n! subtract the correction which depend on qcmodel\n! now all is calculated gval(1,1)=G; gval(2,1)=S etc\n! Second derivates for \\usm_i y_i\\ln(y_i) calculated above\n phvar%gval(1,1)=sbonds+gamma*scorr\n phvar%gval(2,1)=(sbonds+gamma*scorr)/tval\n if(qcmodel.gt.1) then\n! include derivatives of gamma\n do icon=1,ncon\n phvar%dgval(1,icon,1)=phvar%dgval(1,icon,1)+dgamma(icon)*scorr\n phvar%dgval(2,icon,1)=phvar%dgval(2,icon,1)+dgamma(icon)*scorr/tval\n do jcon=icon,ncon\n! approximate ....\n phvar%d2gval(ixsym(icon,jcon),1)=phvar%d2gval(ixsym(icon,jcon),1)+&\n d2gamma(ixsym(icon,jcon))*scorr\n enddo\n enddo\n endif\n! \n! write(*,12)'3X cqc6: ',qcmodel,sbonds,gamma,scorr,&\n! phvar%gval(1,1),phvar%gval(2,1)\n12 format(a,i2,6(1pe11.3))\n!\n1000 continue\n return\n end subroutine config_entropy_qchillert !gamma, dgamma, d2gamma\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_cvmce\n!\\begin{verbatim}\n subroutine config_entropy_cvmce(moded,ncon,phvar,phrec,tval)\n!\n! calculates the classical QC and CVM models sith LRO\n! started 2021-02-17\n!\n! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2\n! ncon is number of constituents\n! phvar is pointer to phase_varres record\n! phrec is the phase record\n! tval is current value of T\n implicit none\n integer moded,ncon\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_phaserecord) :: phrec\n double precision tval\n!\\end{verbatim}\n!---------------------------------------------------------------------------1\n write(*,*)'3X classical QC model with LRO, not implemented yet'\n! S = - \\sum_i y_i ln(y_i) + z/2 \\sum_k x_k ln(x_k)\n gx%bmperr=4399\n1000 continue\n return\n end subroutine config_entropy_cvmce\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_tisr\n!\\begin{verbatim}\n subroutine config_entropy_tisr(moded,ncon,phvar,phrec,tval)\n!\n! calculates configurational entropy/R for the Kremer liquid SRO model\n! started 2021-02-12\n!\n! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2\n! ncon is number of constituents, each cell a constituent\n! phvar is pointer to phase_varres record\n! phrec is the phase record\n! tval is current value of T\n implicit none\n integer moded,ncon\n! to obtain current fractions and store results\n TYPE(gtp_phase_varres), pointer :: phvar\n! to obtain phase and constituent inforamation\n TYPE(gtp_phaserecord) :: phrec\n double precision tval\n!\\end{verbatim}\n integer ii,loksp\n double precision rtg\n!---------------------------------------------------------------------------\n! \n! rtg is set to R*T\n rtg=globaldata%rgas*tval\n write(*,10)ncon,(trim(splista(phrec%constitlist(ii))%symbol),&\n phvar%yfr(ii),ii=1,ncon)\n10 format('3X config_entropy_tisr with ',i2,' constituents, fractions:'/&\n 10(a,1x,F7.4,', '))\n! You can enter all calculations here, nothing will be added elsewhere\n write(*,'(a,1pe16.6)')'3X TISR not implemented yet, G=',phvar%gval(1,1)\n gx%bmperr=4399\n! Values returned should be:\n! phvar%gval(1,1) Gibbs energy divided by RT (G/RT below)\n! phvar%gval(2,1) derivative of G/RT wrt T\n! phvar%dgval(1,ii,1) 1st derivative of G/RT wrt fraction ii\n! phvar%dgval(2,ii,1) 2nd derivative of G/RT wrt T amd fraction ii\n! phvar%d2gval(ixym(ii,jj),1) 2nd derivative of G/RT wrt fracton ii and jj\n! Normally sufficient to set phvar%d2gval(ixsym(ii,ii))=one/phvar%yfr(ii)\n!-----------------------------------\n1000 continue\n return\n end subroutine config_entropy_tisr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine config_entropy_srot\n!\\begin{verbatim}\n subroutine config_entropy_srot(moded,ncon,phvar,phrec,tval)\n!\n! calculates configurational entropy/R for tetrahedron SRO model\n! I DO NOT THINK THIS IS USED ??\n!\n! moded=0 only G, =1 G and dG/dy, =2 G, dG/dy and d2G/dy1/dy2\n! ncon is number of constituents, each cell a constituent\n! phvar is pointer to phase_varres record\n! phrec is the phase record\n! tval is current value of T\n implicit none\n integer moded,ncon\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_phaserecord) :: phrec\n double precision tval\n!\\end{verbatim}\n!---------------------------------------------------------------------------\n! FOR A BINARY, with 5 SRO clusters as in tetrahedron FCC \n! \n integer ia,ib,ja,jb,kk,mm,alpha,jxsym,loksp\n double precision rk,ggg,rtg\n! double precision s1,s2,s11,s12,s21,s22\n! double precision s111,s112,s121,s122,s211,s212,s221,s222\n! model constants \n double precision escale\n double precision, allocatable, dimension(:) :: pij,xx\n double precision rrk(0:4)\n! this is a scaling factor for the entropy\n escale=0.25D0\n! Coefficients to calculate the mole fractions from the clusters\n! which must be ordered A, A0.75B0.25, A.5B.5, A.25B.75, B\n kk=4; rk=0.25D0\n! Tetrahedron in fcc lattice, z=12; m=4. The factors below are equal to \n! 1/permutations of the clusters. Needed to obtain ideal ordering at high T\n rrk(0)=one; rrk(1)=0.25D0; rrk(2)=one/6.0D0; rrk(3)=0.25; rrk(4)=one\n if(ncon.ne.5) then\n! ncon should be 5 for a binary system\n write(*,*)'3X constituents must be 5!',ncon\n gx%bmperr=4399; goto 1000\n endif\n! allocations\n allocate(xx(1:2))\n allocate(pij(0:4))\n rtg=globaldata%rgas*tval\n! test without any ordering parameters, the system should be ideal ...\n!-------------------------------------------------------------------\n do alpha=0,4\n! these are the cluster fractions, for higher order systems must be identified\n pij(alpha)=phvar%yfr(alpha+1)\n enddo\n! mole fractions, note \"ia\" is the number of B atoms!!\n xx=zero\n do ia=0,4\n xx(1)=xx(1)+(kk-ia)*rk*pij(ia)\n xx(2)=xx(2)+ia*rk*pij(ia)\n enddo\n if(abs(xx(1)+xx(2)-one).gt.1.0e-8) stop '3X SROT mole fraction error'\n! xx(1) is fraction of A, xx(2) fraction of B. NOT USED!!\n ggg=zero\n! This is summing the SRO entropy part\n do ia=0,4\n ggg=ggg+escale*pij(ia)*log(pij(ia)*rrk(ia))\n enddo\n! These are the configurational G/RT and S/R\n phvar%gval(1,1)=ggg\n phvar%gval(2,1)=ggg/tval\n do ia=0,4\n! d/pij ( x1*ln(x1)+x2*log(x2)+ ...+ pij*log(pij)\n! note \"ia\" counts the B atoms\n phvar%dgval(1,ia+1,1)=escale*(one+log(pij(ia)*rrk(ia)))\n phvar%dgval(2,ia+1,1)=phvar%dgval(1,ia+1,1)/tval\n enddo\n!------------------------------------------------------\n! second derivatives, symmetric, stored only upper half\n! approximate with 1/pij\n jxsym=0\n jb=1\n phvar%d2gval=zero\n do ia=1,ncon\n phvar%d2gval(ixsym(ia,ia),1)=escale/(rrk(ia-1)*pij(ia-1))\n enddo\n!-----------------------------------\n1000 continue\n return\n end subroutine config_entropy_srot\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n \n!\\addtotable subroutine push_pyval\n!\\begin{verbatim}\n subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz)\n! push data when entering an interaction record\n implicit none\n integer pmq,moded,iz\n double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2)\n type(gtp_pystack), pointer :: pystack\n type(gtp_interaction), pointer :: intrec\n!\\end{verbatim} %+\n type(gtp_pystack), pointer :: new\n!\n if(associated(pystack)) then\n allocate(new)\n new%previous=>pystack\n pystack=>new\n else\n allocate(pystack)\n nullify(pystack%previous)\n endif\n! save data\n pystack%intrecsave=>intrec\n pystack%pmqsave=pmq\n pystack%pysave=pyq\n if(moded.ge.1) then\n! if moded 0 there are no derivatives\n allocate(pystack%dpysave(iz))\n pystack%dpysave=dpyq\n if(moded.eq.2) then\n! if moded 1 there are no second derivatives\n allocate(pystack%d2pysave(iz*(iz+1)/2))\n pystack%d2pysave=d2pyq\n endif\n endif\n1000 continue\n return\n end subroutine push_pyval\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine pop_pyval\n!\\begin{verbatim}\n subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz)\n! pop data when entering an interaction record\n implicit none\n integer iz,pmq,moded\n double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2)\n type(gtp_pystack), pointer :: pystack\n type(gtp_interaction), pointer :: intrec\n!\\end{verbatim}\n type(gtp_pystack), pointer :: old\n if(.not.associated(pystack)) then\n! write(*,*)'3X Tying to pop from an empty PY stack'\n gx%bmperr=4075; goto 1000\n endif\n! restore data\n intrec=>pystack%intrecsave\n pmq=pystack%pmqsave\n pyq=pystack%pysave\n if(moded.ge.1) then\n! if moded >0 there are derivatives\n dpyq=pystack%dpysave\n if(moded.eq.2) then\n! if moded 2 there are second derivatives\n d2pyq=pystack%d2pysave\n endif\n endif\n! release memory\n old=>pystack\n pystack=>pystack%previous\n deallocate(old)\n1000 continue\n return\n end subroutine pop_pyval\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_disfrac\n!\\begin{verbatim}\n subroutine calc_disfrac(lokph,lokcs,ceq)\n! calculate and set disordered set of fractions from sitefractions\n! The first derivatives are dxidyj. There are no second derivatives\n! TYPE(gtp_fraction_set), pointer :: disrec\n implicit none\n integer lokph,lokcs\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! TYPE(gtp_fraction_set), pointer :: disrec\n TYPE(gtp_phase_varres), pointer :: phord\n TYPE(gtp_phase_varres), pointer :: phdis\n! logical ordered\n! minimum difference in site fraction to be set as ordered\n! double precision, parameter :: yminord=1.0D-10\n integer lokdis,is\n!\n! write(*,*)'3X entering calc_disfrac',lokph,lokcs\n! this is the record with the ordered constitution\n phord=>ceq%phase_varres(lokcs)\n! disrec=phord%disfra\n! lokdis=disrec%varreslink\n! phdis=>disrec%phdapointer\n lokdis=ceq%phase_varres(lokcs)%disfra%varreslink\n phdis=>ceq%phase_varres(lokdis)\n! this is a record within the ordered constitution record for disordered fracs\n! disrec=>phord%disfra\n! to find the varres record with disordered fractions use varreslink\n! this is the index to the phase_varres record with the ordered fractions ???\n lokdis=ceq%phase_varres(lokcs)%disfra%varreslink\n! write(*,*)'3X in calc_disfrac',lokph,lokdis,&\n! associated(phord),associated(phdis)\n! write(*,*)'3X Calc disfra: ',lokph,lokcs,lokdis\n! phdis=>ceq%phase_varres(lokdis)\n! call calc_disfrac2(ceq%phase_varres(lokcs)%disfra,&\n! call calc_disfrac2(ceq%phase_varres(lokcs),ceq%phase_varres(lokdis),ceq)\n call calc_disfrac2(phord,phdis,ceq)\n1000 continue\n return\n end subroutine calc_disfrac\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_disfrac2\n!\\begin{verbatim} %-\n subroutine calc_disfrac2(phord,phdis,ceq)\n! calculate and set disordered set of fractions from sitefractions\n! The first derivatives are dxidyj. There are no second derivatives\n! TYPE(gtp_fraction_set), pointer :: disrec\n implicit none\n TYPE(gtp_phase_varres), target :: phord\n TYPE(gtp_phase_varres), pointer :: phdis\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_fraction_set), pointer :: disrec\n logical ordered\n! minimum difference in site fraction to be set as ordered\n double precision, parameter :: yminord=1.0D-10\n integer lokdis,is\n!\n! write(*,*)'3X entering calc_disfrac2'\n! disrec=phord%disfra\n! lokdis=disrec%varreslink\n! phdis=>disrec%phdapointer\n! this is the record with the ordered constitution\n! phord=>ceq%phase_varres(lokcs)\n! this is a record within the ordered constitution record for disordered fracs\n! write(*,*)'3X entering calc_disfrac2'\n disrec=>phord%disfra\n! write(*,*)'3X in calc_disfrac2 B',associated(disrec),associated(phdis)\n! to find the varres record with disordered fractions use varreslink\n! this is the index to the phase_varres record with the ordered fractions ???\n! lokdis=disrec%varreslink\n! phdis=>ceq%phase_varres(lokdis)\n! write(*,*)'3X calc_disfrac 1A'\n! check that some values are accessable\n! write(*,*)'3X calc_disfra phase index: ',phord%phlink\n! write(*,*)'3X calc_disfra disordered sublattices: ',disrec%ndd\n! write(*,*)'3X calc_disfra ordered and disordered records: ',lokcs,lokdis\n! write(*,*)'3X calc_disfra phase index via disordred record: ',phdis%phlink\n! write(*,*)'3X calc_disfrac 1B'\n! write(*,*)'3X in calc_disfra2c B1: ',associated(phdis%yfr)\n! Segmentation fault that phdis%yfr not always allocated !!!\n! write(*,*)'3X in calc_disfra2c B1: ',allocated(phdis%yfr)\n phdis%yfr=zero\n! write(*,*)'3X in calc_disfra2c A1: ',disrec%tnoofyfr\n do is=1,disrec%tnoofyfr\n phdis%yfr(disrec%y2x(is))=&\n phdis%yfr(disrec%y2x(is))+disrec%dxidyj(is)*phord%yfr(is)\n! write(*,77)'3X disfrac 2: ',is,disrec%y2x(is),phdis%yfr(disrec%y2x(is)),&\n! disrec%dxidyj(is),phord%yfr(is)\n77 format(a,2i3,3(1pe12.4))\n enddo\n! write(*,*)'3X in calc_disfrac2 A2'\n! check if phase is really ordered, meaning that the disordered fractions\n! are equal to the ordered ones\n ordered=.false.\n do is=1,disrec%tnoofyfr\n if(abs(phdis%yfr(disrec%y2x(is))-&\n phord%yfr(is)).gt.yminord) ordered=.true.\n enddo\n! write(*,*)'3X calc_disfrac2 A3'\n if(.not.ordered) then\n! if this bit set one will not calculate the ordered part of the phase\n phord%status2=ibclr(phord%status2,csorder)\n else\n! bit must be cleared as it might have been set at previous call\n phord%status2=ibset(phord%status2,csorder)\n endif\n! write(*,*)'3X in calc_disfrac2 A4: ',phord%status2\n! copy these to the phase_varres record that belongs to this fraction set\n! a derivative dGD/dyj = sum_i dGD/dxi * dxidyj\n! where dGD/dxi is dgval(1,y2x(j),1) and dxidyj is disrec%dxidyj(j)\n! because each y constituent contributes to only one disordered x fraction\n1000 continue\n return\n! G(tot) = GD(xdis)+(GO(yord)-GO(yord=xdis))\n! G(tot).yj = dGD(xdis).dxi*dxdyj + GO.yj - GO.yj ... \n end subroutine calc_disfrac2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine disordery\n!\\begin{verbatim}\n subroutine disordery(phvar,ceq)\n! sets the ordered site fractions in FCC and other order/disordered phases\n! equal to their disordered value in order to calculate and subtract this part\n! phvar is pointer to phase_varres for ordered fractions\n implicit none\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n TYPE(gtp_fraction_set), pointer :: disrec\n! TYPE(gtp_phase_varres) :: phdis\n TYPE(gtp_phase_varres), pointer :: phdis\n integer lokdcs,ii,nofc1,nofc2\n double precision xxx\n! integer lokdcs,kk,ll,is,nis,nsl\n! find disordered fractions\n! lokdcs=phvar%disfra%varreslink\n! disrec=>phvar%disfra\n! write(*,*)'3X disordery: ',disrec%latd,disrec%nooffr(1),lokdcs\n! phdis=ceq%phase_varres(lokdcs)\n! write(*,*)'3X disordery: ',ceq%xconv\n! write(*,*)'3X disordery: ',phdis%yfr(1)\n! phdis=>ceq%disrec%phdapointer\n! find disordered fractions\n disrec=>phvar%disfra\n lokdcs=phvar%disfra%varreslink\n! write(*,9)trim(phlista(phvar%phlink)%name),lokdcs\n9 format('3X diordery: ',a,i5)\n! problem that this pointer is not always ok ....???\n phdis=>ceq%phase_varres(lokdcs)\n call disordery2(lokdcs,phvar,disrec,ceq)\n! write(*,11)'3X phvary: ',(phvar%yfr(ii),ii=1,nofc1)\n! write(*,11)'3X phdisy: ',(phdis%yfr(ii),ii=1,nofc2)\n! write(*,*)'3X Done disorder'\n!\n1000 continue\n return\n end subroutine disordery\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine disordery2\n!\\begin{verbatim} %-\n subroutine disordery2(lokdcs,phvar,disrec,ceq)\n! subroutine disordery2(phdis,phvar,disrec,ceq)\n! sets the ordered site fractions in FCC and other order/disordered phases\n! equal to their disordered value in order to calculate and subtract this part\n! phvar is pointer to phase_varres for ordered fractions\n! phdis is pointer to phase_varres for disordered fractions\n implicit none\n TYPE(gtp_phase_varres), pointer :: phvar\n TYPE(gtp_fraction_set), pointer :: disrec\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokdcs,kk,ll,is,nis,nsl\n double precision xxx\n! copy fractions, loop through all ordered sublattices in phvar\n! and store fraction from lokdis\n! write(*,*)'3X dis2: 1',lokdcs\n! this was never assigned!! BOS 16.11.04\n lokdcs=disrec%varreslink\n! write(*,*)'3X lokdcs: ',ceq%eqno,lokdcs,disrec%latd,&\n! allocated(ceq%phase_varres(lokdcs)%yfr)\n! here copy: \n! y(ord,1,1)=y(dis,1); y(ord,1,2)=y(dis,2); y(ord,1,3)=y(dis,3); \n! y(ord,2,1)=y(dis,1); y(ord,2,2)=y(dis,2); y(ord,2,3)=y(dis,3); \n! write(*,*)'3X dis2: 2',disrec%latd,disrec%nooffr(1)\n! write(*,*)'3X dis2: 3',phdis%yfr(1)\n! write(*,*)'3X disordery2: ',lokdcs\n kk=0\n! latd is the number of sublattices to be added to first disordered sublattice\n do ll=1,disrec%latd\n do is=1,disrec%nooffr(1)\n! the number of constituents in first disordered sublattice same as in ordered\n kk=kk+1\n! phvar%yfr(kk)=phdis%yfr(is)\n! xxx=phdis%yfr(is)\n xxx=ceq%phase_varres(lokdcs)%yfr(is)\n! phvar is the phase_varres record of the ordered phase\n phvar%yfr(kk)=xxx\n enddo\n enddo\n! write(*,*)'3X dis2: 4',disrec%ndd\n if(disrec%ndd.eq.2) then\n! one can have 2 sets of ordered subl. like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)...\n! BUT NEVER TESTED\n nis=disrec%nooffr(1)\n nsl=size(phvar%sites)\n! write(*,*)'3X dis2: 5',nis,nsl\n! write(*,*)'3X dy: ',nis,kk,disrec%latd,nsl,disrec%nooffr(2)\n do ll=disrec%latd+1,nsl\n do is=1,disrec%nooffr(2)\n kk=kk+1\n! phvar%yfr(kk)=phdis%yfr(nis+is)\n phvar%yfr(kk)=ceq%phase_varres(lokdcs)%yfr(nis+is)\n enddo\n enddo\n endif\n1000 continue\n return\n end subroutine disordery2\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine uniquac_model\n!\\begin{verbatim}\n subroutine uniquac_model(moded,ncon,phres,ceq)\n! Calculate the Gibbs energy of the UNIQUAC model (Abrams et al 1975)\n! Modified 2018/Oct, Nov, Dec\n! It returns UNIQUAC G and first and second derivatives of G in phres%gval etc.\n! The values of q_i and r_i are be stored in species record, not identifiers\n! The residual term should be stored as a UQTAU identifier \n implicit none\n integer moded,ncon\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(gtp_phase_varres), pointer :: phres\n!\\end{verbatim}\n integer ia,ib,ic,id,ie,jj,nprop,nint,lokph,loksp,ii\n double precision, allocatable, dimension(:) :: theta,phi,qval,xfr,rval\n double precision, allocatable, dimension(:,:) :: tau,dtaudt\n double precision, allocatable, dimension(:) :: rho,kvottau\n double precision, allocatable, dimension(:) :: dgv,d2gv,sumdtaudt,d2gdydt\n double precision hzeta,gres,sumxq,sumxr,dgrdt,xxx,yyy,sumtt\n double precision gc,gr,term1,term2,dgr,dgc,d2gc,d2gr,sumxiqi\n! we must have a property index \"i\" for each tau_ji \n integer, allocatable, dimension(:) :: unqtau\n! if(moded.lt.2) then\n! if moded=/=2 then some of the 2nd derivatives needed is not present ...\n! moded=0 when calculating with the gridminimizer\n! write(*,*)'Skipping uniquac phase as no derivatives'\n! goto 1000\n! endif\n! need theta = \\sum_i q_i*x_i and Phi=\\sum_i r_i*x_i\n! write(*,*)'3X in uniquac 1'\n allocate(unqtau(ncon))\n allocate(theta(ncon))\n allocate(phi(ncon))\n allocate(qval(ncon))\n allocate(rval(ncon))\n allocate(xfr(ncon))\n allocate(dgv(ncon))\n allocate(d2gdydt(ncon))\n allocate(tau(ncon,ncon))\n allocate(dtaudt(ncon,ncon))\n allocate(rho(ncon))\n allocate(kvottau(ncon))\n allocate(sumdtaudt(ncon))\n! number of interactions\n nint=ncon*(ncon+1)/2\n allocate(d2gv(nint))\n! we need some place to store these indices if we have no addition record ...\n! UQT is a model parameter identifier with constituent index \n! tau_ji is UQT&I(LIQ,J)\n call need_propertyid('UQT ',id)\n if(gx%bmperr.ne.0) goto 1000\n nprop=phres%listprop(1)-1\n! unqq=0; unqr=0; unqt12=0; unqt21=0\n unqtau=0\n do ia=1,nprop\n if(phres%listprop(ia)/100.eq.id) then\n! listprop is 2600+constituent index\n! parameter syntax is UQT&UA(LIQUID,UB) for TAU_{UB,UA}\n ib=mod(phres%listprop(ia),100)\n unqtau(ib)=ia\n! write(*,*)'3X found tau: ',phres%listprop(ia),ib,unqtau(ib)\n endif\n enddo\n! copy mole fractions to xfr\n xfr=phres%yfr\n! extract unqq and unqr from species record\n lokph=phres%phlink\n sumxq=zero\n sumxr=zero\n do ia=1,ncon\n! values of q and r for each species is stored in species record\n loksp=phlista(lokph)%constitlist(ia)\n if(btest(splista(loksp)%status,SPUQC)) then\n qval(ia)=splista(loksp)%spextra(1)\n rval(ia)=splista(loksp)%spextra(2)\n else\n qval(ia)=one\n rval(ia)=one\n endif\n! calculate the sum of q and r\n sumxq=sumxq+xfr(ia)*qval(ia)\n sumxr=sumxr+xfr(ia)*rval(ia)\n enddo\n! extracting residual parameters complicated ... initiate to zero\n tau=one\n!\n! df/dx_k = ln(phi_k) + 1 - phi_k/x_k + \n! z/2 q_k ( ln(theta_k/phi_k) + phi_k/theta_k-1 )\n!\n! theta = UQQ = x_i*q_i(\\sum_j q_j*x_j) \n! Phi= UQR=x_i*r_i*(\\sum_i r_j*x_j)\n! write(*,*)'3 X Calculate Phi, theta and some invariants for the residual term'\n dtaudt=zero\n sumdtaudt=zero\n do ia=1,ncon\n theta(ia)=xfr(ia)*qval(ia)/sumxq\n phi(ia)=xfr(ia)*rval(ia)/sumxr\n! write(*,'(a,i4,6(F7.4))')'3X theta and phi:',ia,xfr(ia),theta(ia),phi(ia)\n!----------------- residual term tau_ji, may not be present!\n! write(*,'(a,2i3,3(1pe12.4))')'3X tau1: ',ia,unqtau(ia),&\n! phres%gval(1,unqtau(ia)),phres%dgval(1,3-ia,unqtau(ia))\n if(unqtau(ia).eq.0) then\n! OK if zero, this means no residual parameter\n continue\n else\n! there are some residual parameters, extract their values \n! MODIFIED xfr(ib)*tau_(ib,ia) stored in phres%gval(1,unqtau(ia))\n! MODIFIED xfr(ia)*tau_(ia,ib) stored in phres%gval(1,unqtau(ib))\n! By JING: here you need to be careful!!!\n tauloop2: do ib=1,ncon\n if(ib.eq.ia) cycle tauloop2\n! This is the derivative wrt xfr(ib) of UQT&IA i.e. TAU_IB,IA\n term1=phres%dgval(1,ib,unqtau(ia))\n! NOTE, default value one set above, value must be larger than zero\n if(term1.ne.zero) then\n tau(ib,ia)=term1\n! The derivative wrt T is in phres%dgval(2,ib,unqtau(ia))\n dtaudt(ib,ia)=phres%dgval(2,ib,unqtau(ia))\n endif\n! write(*,'(a,3i3,4(1pe12.4))')'3X tau2: ',ia,ib,unqtau(ia),&\n! phres%dgval(1,ib,unqtau(ia)),phres%dgval(2,ib,unqtau(ia))\n enddo tauloop2\n endif\n enddo\n!-----------------------\n! write(*,10)'3X q: ',qval,phres%gval(1,unqq)\n! write(*,10)'3X UNIQUAC theta: ',xfr,theta\n! write(*,10)'3X UNIQUAC tau: ',xfr,tau\n! default value of tau is unity\n! OK write(*,10)'3X tau: ',tau\n10 format(a,6(1pe12.4))\n! here we calculate \\sum_i \\theta_i \\tau_{ij} stored in rho\n do ia=1,ncon\n term1=zero\n term2=zero\n do ib=1,ncon\n! this is \\sum_j \\theta_j \\tau_{ji} \n term1=term1+theta(ib)*tau(ia,ib)\n term2=term2+theta(ib)*dtaudt(ia,ib)\n! OK write(*,'(a,2i3,6(1pe12.4))')'3X rho1: ',ia,ib,theta(ib),tau(ia,ib)\n enddo\n! these values are \\sum_j \\theta_j\\tau_ji (and the T-derivative)\n rho(ia)=term1\n sumdtaudt(ia)=term2\n enddo\n! OK write(*,10)'3X rho: ',rho\n! gx%bmperr=4399; goto 1000\n do ia=1,ncon\n! need for the residual derivatives \\sum_i (\\theta_i \\tau_ji)/\\rho_i\n term1=zero\n do ib=1,ncon\n! I am never sure if it should be tau(ia,ib) or tau(ib,ia) ...\n term1=term1+theta(ib)*tau(ib,ia)/rho(ib)\n enddo\n! This is \\sum_i (\\theta_i \\tau_ki)/\\rho_i where index \"ia\" is subscript \"k\" \n kvottau(ia)=term1\n enddo\n! write(*,107)'3X tau:: ',kvottau,zero,xfr(1),ceq%tpval(1)\n! gx%bmperr=4399; goto 1000\n! This is z/2\n hzeta=5.0D0\n! Here the UNIQUAC GIBBS ENERGY and derivatives are calculated. \n! phres%gval has the ideal configurational enntropy already\n! and possibly any reference energy terms!\n gc=zero; gr=zero; dgrdt=zero\n gmloop: do ia=1,ncon\n! The residual and configurational G\n! ALL OK without residual term, rho_i is rho_i in abrams1-190107.pdf\n gr=gr-xfr(ia)*qval(ia)*log(rho(ia))\n! NOTE gc=zero if all qval and rval equal for all components !!\n gc=gc+xfr(ia)*log(phi(ia)/xfr(ia))+&\n hzeta*xfr(ia)*qval(ia)*log(theta(ia)/phi(ia))\n! write(*,210)'3X gci: ',ia,xfr(ia),phi(ia),xfr(ia)*log(phi(ia)/xfr(ia)),&\n! qval(ia),theta(ia),hzeta*xfr(ia)*qval(ia)*log(theta(ia)/phi(ia))\n210 format(a,i2,6(1pe10.2))\n! The first T-derivative of residual (as in Abrams1.pdf 190105)\n dgrdt=dgrdt-xfr(ia)*qval(ia)*sumdtaudt(ia)/rho(ia)\n! The second T-derivative ... NOT USED YET!\n! d2grdt2=....\n enddo gmloop\n! write(*,211)'3X GC: ',0,gr,gc,gr+gc\n211 format(a,i2,6(1pe12.4))\n! gx%bmperr=4399; goto 1000\n dgv=zero\n d2gdydt=zero\n first: do ib=1,ncon\n! first residual derivative with respect to component \n! kvottau was calculated above \n dgr=qval(ib)*(one-log(rho(ib))-kvottau(ib))\n! derivative with respect to T and xfr(b)\n! we must sum_i theta_i/rho_i (dtau_ki/dT)\n xxx=zero; yyy=zero\n sumtt=zero\n! second derivative of residual\n do ia=1,ncon\n xxx=xxx+theta(ia)*dtaudt(ib,ia)/rho(ia)\n yyy=yyy+theta(ia)*tau(ib,ia)*sumdtaudt(ia)/rho(ia)**2\n enddo\n d2gdydt(ib)=-qval(ib)*(sumdtaudt(ib)/rho(ib)+xxx-yyy)\n! first derivative with respect to ib of configuration\n! NOTE: 1+ln(x) already calculated, thus -log(xfr(ib))\n dgc=log(phi(ib)/xfr(ib))+one-phi(ib)/xfr(ib)+&\n hzeta*qval(ib)*(log(theta(ib)/phi(ib))-one+phi(ib)/theta(ib))\n! write(*,'(a,i3,f10.6,1pe12.4)')'3X ib xfr dgc: ',ib,xfr(ib),dgc\n dgv(ib)=dgr+dgc\n! write(*,212)'3X dgr: ',ib,qval(ib),rho(ib),kvottau(ib),dgc,dgv(ib)\n212 format(a,i3,6(1pe12.4))\n second: do ic=ib,ncon\n! second derivative of configuration with respect to ib and ic\n! APPROXIMATE not corrected!!\n do ii=1,ncon\n sumtt=sumtt+theta(ii)*tau(ib,ii)*tau(ic,ii)/rho(ii)**2\n enddo\n d2gr=qval(ib)*qval(ic)/sumxq*(1-tau(ic,ib)/rho(ib)-&\n tau(ib,ic)/rho(ic)+sumtt)\n if(ic.eq.ib) then\n d2gc=-2.0D0*phi(ic)/xfr(ic)**2\n! else\n! d2gc=zero\n! d2gr=zero\n endif\n d2gv(ixsym(ib,ic))=d2gr+d2gc\n enddo second\n! VERY APPROXIMATE SECOND DERIVATIVES \n enddo first\n! write(*,300)'3X UQG: ',gr,gc,(dgv(ia),ia=1,ncon)\n! do ib=1,ncon\n! write(*,300)'3X D2UQG: ',(d2gv(ixsym(ia,ib)),ia=1,ncon)\n! enddo\n! copy results to global arrays\n! phres%gval(1,1) is Gm, %gval(2,1) is dG/dT, %gval(3,1) is dG/dP, \n! %gval(4,1) is d2G/dT2 ...\n! IMPORTANT the ideal configurational entropy is in %gval(1,1) and %gval(2,1)\n! phres%dgval(1,j,1) is dG/dx_j, phres%dgval(2,j,1) is d2G/dTdx_j ... \n! phres%d2gval(ixsym(j,k),1) is d2G/dx_jdx_k stored as upper triangle\n! all values divided by RT\n! phres%gval(2,1)= no T dependence\n! phres%gval(3,1)= no P dependence\n! phres%d2gval(ixsym(j,k),1) is d2G/dx_j/dx_k\n! write(*,300)'3X G/RT: ',phres%gval(1,1),gc,phres%gval(1,1)+gc\n! write(*,'(a,i3,5(1pe12.4))')'3X UQG: ',moded,gr,gc,phres%gval(1,1),&\n! gr+gc+phres%gval(1,1)\n phres%gval(1,1)=phres%gval(1,1)+gc+gr\n! add dgc/dT and T-dependence of gr. NOTE gr is also multiplied with RT\n phres%gval(2,1)=phres%gval(2,1)+(gc+gr)/ceq%tpval(1)+dgrdt\n term1=phres%gval(2,1)\n! write(*,'(a,i2,6(1pe12.4))')'3X dG/dT: ',phres%phtupx,term1,&\n! phres%gval(2,1),gc/ceq%tpval(1),gr/ceq%tpval(1),dgrdt\n! phres%gval(4,1)=phres%gval(2,1)+other terms T-dependent terms (Cp)\n do ia=1,ncon\n phres%dgval(1,ia,1)=phres%dgval(1,ia,1)+dgv(ia)\n! write(*,212)'3X ddy: ',ia,phres%dgval(1,ia,1),dgv(ia)\n! The T-dependence of the residual term affects d2G/dydT\n! term1=phres%dgval(2,ia,1)\n! phres%dgval(2,ia,1)=phres%dgval(2,ia,1)+d2gdydt(ia)\n! write(*,'(a,i2,6(1pe12.4))')'3X d2G/dydT: ',ia,term1,&\n! phres%dgval(2,ia,1),d2gdydt\n! 2nd derivatives ************ skip for the moment\n! do ib=ia,ncon\n! phres%d2gval(ixsym(ia,ib),1)=phres%d2gval(ixsym(ia,ib),1)+&\n! d2gv(ixsym(ia,ib))\n! write(*,'(a,2i3,6(1pe12.4))')'3X d2g:',ib,ic,d2gr,d2gc,&\n! phres%d2gval(ixsym(ib,ic),1)\n! enddo\n enddo\n! check chemical potentials\n xxx=phres%gval(1,1)-xfr(1)*phres%dgval(1,1,1)-xfr(2)*phres%dgval(1,2,1)\n! write(*,'(a,4(1pe12.4))')'3X mu: ',xxx,xxx+phres%dgval(1,1,1),&\n! xxx+phres%dgval(1,2,1)\n! write(*,300)'3X Gm, dG/dx: ',phres%gval(1,1),(phres%dgval(1,ia,1),ia=1,ncon)\n300 format(a,6(1pe12.4))\n! do ia=1,ncon\n! write(*,300)'3X d2G/dx2: ',(phres%d2gval(ixsym(ia,ib),1),ib=1,ncon)\n! enddo\n1000 continue\n return\n end subroutine uniquac_model\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine set_driving_force\n!\\begin{verbatim}\n subroutine set_driving_force(iph,ics,dgm,ceq)\n! set the driving force of a phase explicitly\n implicit none\n type(gtp_equilibrium_data), pointer :: ceq\n integer iph,ics\n double precision dgm\n!\\end{verbatim}\n integer lokph,lokcs\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n ceq%phase_varres(lokcs)%dgm=dgm\n1000 continue\n return\n end subroutine set_driving_force\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine extract_massbalcond\n!\\begin{verbatim}\n subroutine extract_massbalcond(tpval,xknown,antot,ceq)\n! extract T, P, mol fractions of all components and total number of moles\n! for use when minimizing G for a closed system. Probably redundant\n implicit none\n double precision, dimension(*) :: tpval,xknown\n double precision antot\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! This routine MUST return error 4143 or 4144 (too few or too many conditions)\n! if that is the fact. Other error codes can be returned if there are\n! conditions which does not allow the grid minimizer.\n integer, dimension(4) :: indices\n double precision, dimension(maxel) :: ani,abi,xset,wset\n double precision mass,h298,s298,xxx,xsum,wsum\n double precision sumwdivm,anisum,abisum,restmass,divisor,dividend,abtot\n TYPE(gtp_condition), pointer :: current,last\n character encoded*16,actual_arg(1)*16,elsym*2,elname*16,refstat*16\n integer nox,now,nc,jl,iref,iunit,ip,idf,ie,more,numberest,istv,localerr,zz\n logical allmassbal\n!\n do ie=1,noel()\n xknown(ie)=zero\n enddo\n! write(*,*)'3X in extract_massbal'\n ani=zero; abi=zero; xset=zero; wset=zero\n antot=zero; abtot=zero\n xsum=zero; wsum=zero\n anisum=zero; abisum=zero\n nox=0; now=0\n localerr=0\n!\n! write(*,*)\"3X in extract massbalace 1\"\n last=>ceq%lastcondition\n if(.not.associated(last)) then\n gx%bmperr=4143; goto 1000\n endif\n! write(*,*)\"3X in extract massbalace 2\"\n current=>last\n nc=0\n allmassbal=.TRUE.\n100 continue\n current=>current%next\n! ignore inactive conditions\n if(current%active.ne.0) goto 300\n! if a conditions has several terms we cannot calculate x\n if(current%noofterms.gt.1) then\n! write(*,*)'3X Grid minimizer cannot be used with expressions'\n localerr=4179\n endif\n! for debugging\n istv=current%statev\n do jl=1,4\n indices(jl)=current%indices(jl,1)\n enddo\n iref=current%iref\n iunit=current%iunit\n ip=1\n encoded=' '\n actual_arg=' '\n if(current%symlink1.gt.0) then\n! the value is a symbol, the node to the expression is in\n! svflista(current%symlink1)%linkpnode\n! NOTE THIS IS NOT THE SAME AS meq_evaluate_svfun but OK as no derivative\n! BUT WE HAVE TO BE CAREFUL IF THIS MUST NOT BE EVALUATED!!\n if(btest(svflista(current%symlink1)%status,SVFVAL)) then\n xxx=ceq%svfunres(current%symlink1)\n else\n xxx=evaluate_svfun_old(current%symlink1,actual_arg,1,ceq)\n endif\n else\n xxx=current%prescribed\n endif\n! write(*,17)'3X massbal: ',encoded,istv,indices,iunit,iref,xxx\n17 format(a,2x,a,2x,i3,2x,4i3,2x,2i3,1PE15.7)\n! extract values of T, P, N, B, X and W\n if(current%statev.eq.1) then\n! this is the temperature\n tpval(1)=xxx\n nc=nc+1\n elseif(current%statev.eq.2) then\n! this is the pressure\n tpval(2)=xxx\n nc=nc+1\n elseif(current%statev.eq.110) then\n! this is N=value or N(element)=value\n if(indices(2).gt.0) then\n! this should mean the number of moles of a component in a phase, illegal here\n! write(*,*)'3X N with 2 indices illegal in this case'\n localerr=4179\n elseif(indices(1).gt.0) then\n! N(i)=xxx\n ani(indices(1))=xxx\n anisum=anisum+xxx\n else\n! N=xxx\n antot=xxx\n endif\n nc=nc+1\n elseif(current%statev.eq.111) then\n if(indices(2).gt.0) then\n localerr=4179; goto 1000\n endif\n! this is X(index1)=value, CHECK UNIT if %!!!\n if(iunit.eq.100) xxx=1.0D-2*xxx\n xset(current%indices(1,1))=xxx\n xsum=xsum+xxx\n nc=nc+1\n nox=nox+1\n elseif(current%statev.eq.120) then\n! this is B=value or B(i)=value\n if(indices(2).gt.0) then\n! this should mean the mass of a component in a phase, illegal here\n write(*,*)'3X B with 2 indices illegal'\n localerr=4179\n elseif(indices(1).gt.0) then\n! B(i)=xxx\n abi(indices(1))=xxx\n abisum=abisum+xxx\n else\n! B=xxx\n abtot=xxx\n endif\n nc=nc+1\n elseif(current%statev.eq.122) then\n if(indices(2).gt.0) then\n localerr=4179\n endif\n! this is W(index1)=value, CHECK UNIT if %!!! end x2\n if(iunit.eq.100) xxx=1.0D-2*xxx\n wset(current%indices(1,1))=xxx\n wsum=wsum+xxx\n nc=nc+1\n now=now+1\n else\n! this is not a massbalance condition but continue just to check how many cond\n allmassbal=.FALSE.\n nc=nc+1\n endif\n! take next condition if we have not done all\n300 continue\n if(ocv()) write(*,310)'3X massbal: ',current%prescribed,last%prescribed\n310 format(a,6(1pe12.4))\n if(.not.associated(current,last)) goto 100\n!--------------------------------------\n! check if correct number of conditions found\n500 continue\n idf=noofel+2-nc\n if(idf.ne.0) then\n! if idf is not zero there are not enough conditions\n gx%bmperr=4144; goto 1000\n elseif(.not.allmassbal) then\n! some conditions are not massbalance\n localerr=4151\n endif\n! write(*,*)'3X extract_massbal: ',localerr\n! We have correct number of conditions but if localerr set we do not have\n! all as massbalance conditions. Return with that code set\n if(localerr.ne.0) then\n gx%bmperr=localerr; goto 1000\n endif\n! we have extracted all conditions N, B, X, W\n! check that only one value per component\n do ie=1,noel()\n if(xset(ie).gt.zero) then\n if(wset(ie).gt.zero) goto 1100\n if(ani(ie).gt.zero) goto 1100\n if(abi(ie).gt.zero) goto 1100\n elseif(wset(ie).gt.zero) then\n if(ani(ie).gt.zero) goto 1100\n if(abi(ie).gt.zero) goto 1100\n elseif(ani(ie).gt.zero) then\n if(abi(ie).gt.zero) goto 1100\n elseif(abi(ie).le.zero) then\n! this can be \"the rest\"\n! write(*,*)'3X massbal',ie,abi(ie),antot,abtot\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\n if(antot.eq.zero .and. abtot.eq.zero) goto 1105\n! else\n! write(*,*)'3X Other components then elements 1'\n endif\n endif\n enddo\n! write(*,510)'N: ',(ani(i),i=1,noel())\n! write(*,510)'B: ',(abi(i),i=1,noel())\n! write(*,510)'x: ',(xset(i),i=1,noel())\n! write(*,510)'w: ',(wset(i),i=1,noel())\n510 format(a,7F9.6)\n bigif: if(antot.gt.zero) then\n! we have a value for total number of moles, N, there must not be one for B\n if(abtot.ne.zero) goto 1110\n more=0\n numberest=0\n sumwdivm=zero\n! convert as much as possible to N(i). Sum also some data needed if there\n! are conditions on mass fractions\n do ie=1,noel()\n call get_element_data(ie,elsym,elname,refstat,mass,h298,s298)\n if(xset(ie).gt.zero) then\n ani(ie)=antot*xset(ie)\n anisum=anisum+ani(ie)\n abisum=abisum+mass*ani(ie)\n elseif(abi(ie).gt.zero) then\n ani(ie)=abi(ie)/mass\n anisum=anisum+ani(ie)\n abisum=abisum+mass*ani(ie)\n elseif(wset(ie).gt.zero) then\n sumwdivm=sumwdivm+wset(ie)/mass\n more=1\n elseif(ani(ie).eq.zero) then\n if(numberest.gt.0) then\n! write(*,*)'3X Missing condition for two elements.'\n! ?? gx%bmperr=0; goto 1000\n gx%bmperr=4151; goto 1000\n endif\n restmass=mass\n numberest=ie\n endif\n enddo\n if(numberest.eq.0) then\n write(*,*)'3X Error - condition on all elements and N??'\n gx%bmperr=0; goto 1000\n endif\n if(more.gt.0) then\n! there are some mass fractions, we have to calculate B\n! but first we must determine the number of moles of \"the rest\" element\n divisor=antot-anisum-abisum/(one-wsum)*sumwdivm\n dividend=one+restmass/(one-wsum)*sumwdivm\n ani(numberest)=divisor/dividend\n abi(numberest)=restmass*ani(numberest)\n abisum=abisum+abi(numberest)\n! now calculate B\n abtot=abisum/(one-wsum)\n! write(*,520)'3X nrest: ',numberest,divisor,dividend,ani(numberest),&\n! abi(numberest),abtot\n520 format(a,i3,6(1pe12.4))\n! now calculate moles of elements with massfractions\n do ie=1,noel()\n if(wset(ie).gt.zero) then\n abi(ie)=abtot*wset(ie)\n call get_element_data(ie,elsym,elname,refstat,mass,h298,s298)\n ani(ie)=abi(ie)/mass\n endif\n enddo\n else\n! all conditions are mole fractions, just set \"the rest\"\n ani(numberest)=antot-anisum\n endif\n do ie=1,noel()\n xset(ie)=ani(ie)/antot\n enddo\n elseif(abtot.gt.zero) then\n! we have a value for total mass, B, not common and too complicated\n! write(*,*)'3X Cannot handle condition on total mass'\n gx%bmperr=4180\n elseif(xsum.eq.zero .and. wsum.eq.zero) then\n! just N(i)= and B(i)=, no N= nor B= and no X nor W, No rest element\n! write(*,520)'3X N(i): ',0,anisum,(ani(j),j=1,noel())\n do ie=1,noel()\n if(abi(ie).gt.zero) then\n call get_element_data(ie,elsym,elname,refstat,mass,h298,s298)\n ani(ie)=abi(ie)/mass\n anisum=anisum+ani(ie)\n endif\n enddo\n antot=anisum\n do ie=1,noel()\n xset(ie)=ani(ie)/antot\n if(xset(ie).le.zero) then\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\n! when other components than elements the mole fractions can be <0 or > 1\n write(*,*)'3X mass balance error: ',ie\n gx%bmperr=4181; goto 1000\n! else\n! write(*,*)'3X Other components than elements 2'\n endif\n endif\n enddo\n else\n! any other combination of conditions ....\n write(*,*)'3X Cannot handle these massbalance conditions'\n gx%bmperr=4182\n endif bigif\n! copy fractions to arguments\n900 continue\n do ie=1,noel()\n xknown(ie)=xset(ie)\n enddo\n1000 continue\n return\n! errors\n1100 continue\n write(*,*)'3X Two mass balance conditions for same element',ie\n gx%bmperr=4183; goto 1000\n1105 continue\n write(*,*)'3X One component without condition'\n gx%bmperr=4181; goto 1000\n1110 continue\n write(*,*)'3X Both N and B cannot be set'\n gx%bmperr=4184; goto 1000\n!\n end subroutine extract_massbalcond\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine save_constitutions\n!\\begin{verbatim}\n subroutine save_constitutions(ceq,copyofconst)\n! copy the current phase amounts and constituitions to be restored\n! if calculations fails during step/map\n! DANGEROUS IF NEW COMPOSITION SETS CREATED\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n double precision, allocatable, dimension(:) :: copyofconst\n!\\end{verbatim} %+\n integer varresx,nz,ij,syfr,allsize\n! calculate dimension of copyofconst\n nz=0\n! skippa varres with index 1, that is the reference phase\n! do varresx=2,csfree-1\n do varresx=2,highcs\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n! NOTE size( ... ) can return reasonable value even if not allocated !!!\n! BUT why is phas_varres(varresx)%yfr it not allocated ???\n! evidently the composition set for varresx is created ... maybe removed??\n syfr=size(ceq%phase_varres(varresx)%yfr)+1\n else\n syfr=1\n endif\n! write(*,12)'3X Varres record and size: ',varresx,1+syfr,nz\n12 format(a,3i5)\n nz=nz+2+syfr\n enddo\n allsize=nz+1\n! write(*,*)'3X In save_constitution',highcs,allsize\n allocate(copyofconst(allsize))\n! modification due to problems, save allocated size in first word\n copyofconst(1)=allsize\n nz=2\n! do varresx=2,csfree-1\n do varresx=2,highcs\n! save 1+syfr values for each composition set\n! segmentation fault in this loop for stepbug (>20 elements COST507)\n! crash happends when higher composition sets are stored ...\n! SAVE also the amount of the phase, DGM and the size of yfr!!\n copyofconst(nz)=ceq%phase_varres(varresx)%amfu\n copyofconst(nz+1)=ceq%phase_varres(varresx)%dgm\n! varresx is 1 higher than phase index\n! if(copyofconst(nz).gt.zero) &\n! write(*,*)'3X saving amount: ',varresx-1,nz,copyofconst(nz)\n nz=nz+1\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n syfr=size(ceq%phase_varres(varresx)%yfr)\n else\n! write(*,*)'3X no fractions for: ',varresx-1,nz+1\n syfr=0\n endif\n! write(*,16)'3X Storing varres record: ',varresx,syfr,size(copyofconst),nz\n16 format(a,5i5)\n! the segmentation fault seems not to be the allocation of copyofconst but\n! rather that we cannot access the yfr in ceq%phase_varres(varresx)\n! for the extra composition sets created by gridmin\n copyofconst(nz+1)=syfr\n nz=nz+1\n do ij=1,syfr\n copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij)\n enddo\n nz=nz+1+syfr\n enddo\n! write(*,*)'3x saved size in word 1: ',highcs,allsize,nz-1\n1000 continue\n return\n end subroutine save_constitutions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine restore_constitutions\n!\\begin{verbatim} %-\n subroutine restore_constitutions(ceq,copyofconst)\n! restore the phase amounts and constitutions from copyofconst\n! if calculations fails during step/map\n! DANGEROUS IF NEW COMPOSITION SETS CREATED\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n double precision copyofconst(*)\n!\\end{verbatim}\n integer nz,varresx,ij,syfr,savedsyfr,sizeofcopy\n! size of copyofconst in first word\n! segmentation fault from smp2A running step-epz.OCM\n sizeofcopy=int(copyofconst(1))\n! write(*,*)'3X restoring constitution: ',highcs,sizeofcopy\n! skippa varres with index 1, that is the reference phase\n! do varresx=2,csfree-1\n nz=2\n do varresx=2,highcs\n! note varresx is index of phase_varres, always 1 bigger than phase index\n! if(copyofconst(nz).gt.zero) &\n! write(*,*)'3X restore amount: ',varresx-1,nz,copyofconst(nz)\n ceq%phase_varres(varresx)%amfu=copyofconst(nz)\n ceq%phase_varres(varresx)%dgm=copyofconst(nz+1)\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n syfr=size(ceq%phase_varres(varresx)%yfr)\n else\n syfr=0\n endif\n! fraction records may have been allocated!! use saved syfr\n nz=nz+2\n savedsyfr=int(copyofconst(nz))\n if(savedsyfr.eq.0 .or. savedsyfr.ne.syfr) then\n ceq%phase_varres(varresx)%dgm=-one\n! write(*,12)'Restore saved size for phase: ',varresx-1,nz-2,syfr,&\n! int(copyofconst(nz)),copyofconst(nz-2),&\n! ceq%phase_varres(varresx)%dgm\n12 format(a,4i5,2(1pe12.4))\n syfr=savedsyfr\n endif\n do ij=1,syfr\n ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij)\n enddo\n! write(*,17)varresx-1,nz,syfr,ceq%phase_varres(varresx)%amfu,&\n! (ceq%phase_varres(varresx)%yfr(ij),ij=1,syfr)\n17 format('3X r:',i2,2i3,6(1pe12.4))\n nz=nz+1+syfr\n if(nz-1.gt.sizeofcopy) write(*,*)'3X problem restore:',varresx,nz\n enddo\n1000 continue\n! gx%bmperr=4399\n return\n end subroutine restore_constitutions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine save_phase_constitutions\n!\\begin{verbatim}\n subroutine save_phase_constitutions(rw,ceq,copyofconst)\n! copy the current phase amounts and constituitions to be restored\n! trying to fix problems with saving invariants \n! compared to reoutines above here abnorm is also saved ...\n! rw=0 if save, 1 if restore\n! NOTE different ceq may be used for save and restore!\n implicit none\n integer rw\n TYPE(gtp_equilibrium_data), pointer :: ceq\n double precision, allocatable, dimension(:) :: copyofconst\n!\\end{verbatim} %+\n integer varresx,nz,ij,syfr,allsize,savedsyfr,sizeofcopy\n if(rw.eq.0) then\n! calculate dimension of copyofconst\n nz=0\n! Calculate space needed\n! All phases saved idependent of status\n! skippa varres with index 1, that is the reference phase\n do varresx=2,highcs\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n syfr=size(ceq%phase_varres(varresx)%yfr)+1\n else\n syfr=1\n endif\n! ionic liquid model require more data saved (see set_constitution)\n ij=ceq%phase_varres(varresx)%phlink\n if(btest(phlista(ij)%status1,PHIONLIQ)) then\n write(*,*)'3X cannot save ionic liquid constitutions'\n gx%bmperr=4399; goto 1000\n endif\n! we should save 5 reals in addition to the fractions\n nz=nz+5+syfr\n enddo\n allsize=nz+2\n allocate(copyofconst(allsize))\n! modification due to problems, save allocated size in first word\n copyofconst(1)=allsize\n copyofconst(2)=highcs\n nz=3\n do varresx=2,highcs\n! save 1+syfr values for each composition set\n! SAVE also the amount of the phase, DGM and the size of yfr!!\n copyofconst(nz)=ceq%phase_varres(varresx)%amfu\n copyofconst(nz+1)=ceq%phase_varres(varresx)%abnorm(1)\n copyofconst(nz+2)=ceq%phase_varres(varresx)%abnorm(2)\n copyofconst(nz+3)=ceq%phase_varres(varresx)%abnorm(3)\n copyofconst(nz+4)=ceq%phase_varres(varresx)%dgm\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n syfr=size(ceq%phase_varres(varresx)%yfr)\n else\n syfr=0\n endif\n copyofconst(nz+5)=syfr\n nz=nz+5\n do ij=1,syfr\n copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij)\n enddo\n nz=nz+syfr+1\n enddo\n write(*,*)'3X saved constitution: ',allsize,nz\n else\n! restore saved amounts and fractions \n if(.not.allocated(copyofconst)) then\n write(*,*)'3X no constitutions saved!'\n gx%bmperr=4399; goto 1000\n endif\n sizeofcopy=int(copyofconst(1))\n if(copyofconst(2).ne.highcs) then\n write(*,*)'3X number of phase tuples not the same'\n gx%bmperr=4399; goto 1000\n endif\n nz=3\n do varresx=2,highcs\n! note varresx is index of phase_varres, always 1 bigger than phase index\n ceq%phase_varres(varresx)%amfu=copyofconst(nz)\n ceq%phase_varres(varresx)%abnorm(1)=copyofconst(nz+1)\n ceq%phase_varres(varresx)%abnorm(2)=copyofconst(nz+2)\n ceq%phase_varres(varresx)%abnorm(3)=copyofconst(nz+3)\n ceq%phase_varres(varresx)%dgm=copyofconst(nz+4)\n if(allocated(ceq%phase_varres(varresx)%yfr)) then\n syfr=size(ceq%phase_varres(varresx)%yfr)\n else\n syfr=0\n endif\n! fraction records may have been allocated!! use saved syfr\n nz=nz+5\n savedsyfr=int(copyofconst(nz))\n if(savedsyfr.eq.0 .or. savedsyfr.ne.syfr) then\n write(*,*)'3X phase with zero saved fractions'\n ceq%phase_varres(varresx)%dgm=-one\n syfr=savedsyfr\n endif\n do ij=1,syfr\n ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij)\n enddo\n nz=nz+1+syfr\n enddo\n if(nz-1.gt.sizeofcopy) write(*,*)'3X problem restore:',sizeofcopy,nz\n endif\n1000 continue\n return\n end subroutine save_phase_constitutions\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine calc_eec_gibbsenergy\n!\\begin{verbatim}\n subroutine calc_eec_gibbsenergy(phres,ceq)\n! calculate an ideal Gibbs energy with just configurational entropy\n! phres is pointer to phase_varres record for the phase\n! for a solid phase with higher entropy than the liquid\n! G = RT \\sum_s a_s \\sum_i y_si \\ln(y_si)\n! dG/dy_si = RT a_s (1+ln(y_si))\n! d2G/dy_si^2 = RT a_s/y_si all other 2nd derivatives zero \n implicit none\n TYPE(gtp_phase_varres), pointer :: phres\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer lokph,sl,i1,i2,kk\n double precision sconf,tval,as\n! this is the index of the phase in phlista with phase structure\n lokph=phres%phlink\n! zero all second derivatives of G, the diagonal added below\n kk=phlista(lokph)%tnooffr*(phlista(lokph)%tnooffr+1)/2\n do i1=1,kk\n phres%d2gval(1,i1)=zero\n enddo\n kk=0\n sconf=zero\n tval=ceq%tpval(1)\n do sl=1,phlista(lokph)%noofsubl\n as=phres%sites(sl)\n do i1=1,phlista(lokph)%nooffr(sl)\n kk=kk+1\n sconf=sconf+as*phres%yfr(kk)\n phres%dgval(1,kk,1)=as*(one+log(phres%yfr(kk)))\n phres%dgval(2,kk,1)=phres%dgval(2,kk,1)/tval\n phres%d2gval(kxsym(kk,kk),1)=as/phres%yfr(kk)\n enddo\n enddo\n! return values divided by RT\n phres%gval(1,1)=sconf\n1000 continue\n end subroutine calc_eec_gibbsenergy\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine setendmemarr\n!\\begin{verbatim}\n subroutine setendmemarr(lokph,ceq)\n! stores the pointers to all ordered and disordered endmemners in arrays\n! intended to allow parallel calculation of parameters\n! UNUSED ??\n implicit none\n integer lokph\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ll,nz,noemr\n TYPE(gtp_endmember), pointer :: emrec\n TYPE(gtp_fraction_set), pointer :: disfraset\n if(allocated(phlista(lokph)%oendmemarr)) then\n deallocate(phlista(lokph)%oendmemarr)\n! allways allocate place for maximum endmembers (product of constituents)\n nz=1\n do ll=1,phlista(lokph)%noofsubl\n nz=nz*phlista(lokph)%nooffr(ll)\n enddo\n allocate(phlista(lokph)%oendmemarr(nz))\n noemr=0\n emrec=>phlista(lokph)%ordered\n do while(associated(emrec))\n noemr=noemr+1\n phlista(lokph)%oendmemarr(noemr)%p1=>emrec\n emrec=>emrec%nextem\n enddo\n phlista(lokph)%noemr=noemr\n endif\n! same for disordered endmembers (if any)\n! Data for this is stored in phase_varres record, same index as phlista !!!\n if(allocated(phlista(lokph)%dendmemarr)) then\n deallocate(phlista(lokph)%dendmemarr)\n! allways allocate place for maximum endmembers (product of constituents)\n disfraset=>ceq%phase_varres(lokph)%disfra\n nz=1\n do ll=1,disfraset%ndd\n nz=nz*disfraset%nooffr(ll)\n enddo\n allocate(phlista(lokph)%dendmemarr(nz))\n noemr=0\n emrec=>phlista(lokph)%disordered\n do while(associated(emrec))\n noemr=noemr+1\n phlista(lokph)%dendmemarr(noemr)%P1=>emrec\n emrec=>emrec%nextem\n enddo\n phlista(lokph)%ndemr=noemr\n endif\n1000 continue\n return\n end subroutine setendmemarr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tabder\n!\\begin{verbatim}\n subroutine tabder(iph,ics,times,ceq)\n! tabulate derivatives of phase iph with current constitution and T and P\n implicit none\n integer iph,ics,times\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character name*24\n double precision kappa,napfu,t,p,rtg,g,v,s,h,u,f,cp,alpha,cpu1,cpu2\n integer tnk,lokph,nsl,lokres,lokcs,ll,ll2,kk1,kk2,kk3,kk4,loksp\n!\n! For time measurements\n! lokph=len(name)\n lokph=phases(iph)\n nsl=phlista(lokph)%noofsubl\n! calculate G and derivatives, lokres returns index of phase_varres\n call cpu_time(cpu1)\n do loksp=1,times\n call calcg(iph,ics,2,lokres,ceq)\n if(gx%bmperr.ne.0) then\n goto 1000\n endif\n enddo\n call cpu_time(cpu2)\n! number of moles of atoms per formula unit\n napfu=ceq%phase_varres(lokres)%abnorm(1)\n T=ceq%tpval(1)\n P=ceq%tpval(2)\n rtg=globaldata%rgas*T\n lokcs=lokres\n! returned values: G, G.T=-S, G.P=V, G.T.T=-Cp/T G.T.P=V*alpha, G.P.P=-V*kappa\n! all divided by RT and per mole formula unit of phase\n! G=H-TS, F=U-TS, H=U+PV, S=-G.T, V=G.P\n! H=G+TS=G-T*G.T, U=H-PV=(G-T*G.T)-P*G.P, CP=-T*G.T.T\n! alpha= 1/V*V.T = G.T.P/V, kappa = -1/V*V.P = -G.P.P/V\n G=rtg*ceq%phase_varres(lokcs)%gval(1,1)\n! write(*,5)'3X tabder 2: ',rtg,G\n S=-rtg*ceq%phase_varres(lokcs)%gval(2,1)\n V=rtg*ceq%phase_varres(lokcs)%gval(3,1)\n H=G+T*S\n U=H-P*V\n F=U-T*S\n CP=-T*rtg*ceq%phase_varres(lokcs)%gval(4,1)\n if(V.ne.zero) then\n alpha=rtg*ceq%phase_varres(lokcs)%gval(5,1)/V\n kappa=rtg*ceq%phase_varres(lokcs)%gval(6,1)/V\n else\n alpha=zero\n kappa=zero\n endif\n write(kou,100)napfu,rtg,T,P,G,G/rtg\n100 format(/'Per mole FORMULA UNIT of the phase, ',1pe12.4,' atoms/F.U., RT=',&\n 1pe15.7/&\n 'at T= ',0pF8.2,' K and P= ',1PE13.6,' Pa',8x,'SI units',9x,'/RT'/ &\n 'Gibbs energy J/FU ',28('.'),1Pe16.8,e16.7)\n write(kou,102)F,F/rtg,H,H/rtg,U,U/rtg,S,S/rtg,V,V/rtg,&\n CP,CP/rtg,alpha,alpha/rtg,kappa,kappa/rtg\n102 format('Helmholtz energy J/FU ',24('.'),1PE16.8,e16.7 &\n /'Enthalpy J/FU ',32('.'),1PE16.8,e16.7 &\n /'Internal energy J/FU ',25('.'),1PE16.8,e16.7 &\n /'Entropy J/FU/K ',31('.'),1PE16.8,e16.7 &\n /'Volume m3/FU ',34('.'),1PE16.8,e16.7 &\n /'Heat capacity J/FU/K ',25('.'),1PE16.8,e16.7 &\n /'Thermal expansion 1/K ',25('.'),1PE16.8,e16.7 &\n /'Bulk modulus m2/N ',29('.'),1PE16.8,e16.7)\n tnk=phlista(lokph)%tnooffr\n ll=1\n kk1=0\n kk2=phlista(lokph)%nooffr(ll)\n dy1loop: do while(kk1.le.tnk)\n kk1=kk1+1\n if(kk1.gt.kk2) then\n! write(*,11)'3X tabder 2: ',kk1,kk2,ll,tnk,nsl\n!11 format(a,10i3)\n ll=ll+1\n if(ll.gt.nsl) exit\n kk2=kk2+phlista(lokph)%nooffr(ll)\n endif\n if(phlista(lokph)%nooffr(ll).eq.1) then\n! write(*,*)'3X tabder 1: ',kk1,kk2,ll,tnk\n ll=ll+1\n if(ll.gt.nsl) exit\n kk2=kk2+phlista(lokph)%nooffr(ll)\n cycle\n endif\n loksp=phlista(lokph)%constitlist(kk1)\n name=splista(loksp)%symbol\n write(kou,110)name(1:len_trim(name)),ll\n110 format('First partial derivative with respect to ',a,&\n ' in sublattice ',i2,' of')\n write(kou,120)rtg*ceq%phase_varres(lokcs)%dgval(1,kk1,1),&\n ceq%phase_varres(lokcs)%dgval(1,kk1,1),&\n rtg*(ceq%phase_varres(lokcs)%dgval(1,kk1,1)-&\n T*ceq%phase_varres(lokcs)%dgval(2,kk1,1)),&\n ceq%phase_varres(lokcs)%dgval(1,kk1,1)-&\n T*ceq%phase_varres(lokcs)%dgval(2,kk1,1),&\n rtg*ceq%phase_varres(lokcs)%dgval(2,kk1,1),&\n ceq%phase_varres(lokcs)%dgval(2,kk1,1),&\n rtg*ceq%phase_varres(lokcs)%dgval(3,kk1,1),&\n ceq%phase_varres(lokcs)%dgval(3,kk1,1)\n120 format(5x,'G ',40('.'),1PE16.8,e16.7, &\n /5x,'H ',40('.'),1PE16.8,e16.7, &\n /5x,'G.T ',38('.'),1PE16.8,e16.7, &\n /5x,'G.P ',38('.'),1PE16.8,e16.7)\n kk3=kk1\n kk4=kk2\n ll2=ll\n write(kou,150)\n150 format(5x,'Second partial derivative of Gibbs energy with respect to also')\n dy2loop: do while(kk3.le.tnk)\n if(phlista(lokph)%nooffr(ll2).gt.1) then\n! write(kou,160)name(1:len_trim(name)),ll2, &\n write(kou,160)name,ll2, &\n rtg*ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1),&\n ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1)\n160 format(10x,a,' in ',i2,5('.'),1PE16.8,e16.7)\n endif\n kk3=kk3+1\n if(kk3.le.tnk) then\n loksp=phlista(lokph)%constitlist(kk3)\n name=splista(loksp)%symbol\n endif\n if(kk3.gt.kk4) then\n ll2=ll2+1\n if(ll2.gt.nsl) exit\n kk4=kk4+phlista(lokph)%nooffr(ll2)\n endif\n enddo dy2loop\n! write(*,*)'3X tabder 7A: ',kk1,kk2\n enddo dy1loop\n900 continue\n if(times.gt.1) then\n write(*,11)times,cpu2-cpu1,1.0D6*(cpu2-cpu1)/dble(times)\n11 format('CPU times for ',i6,' calculations: ',1pe15.7,' s, ',1pe15.7,' ms')\n endif\n! write(*,*)'3X tabder 7B: ',kk2\n! write(*,*)'3X tabder: ',rtg,rtg*phase_varres(lokcs)%gval(1,1)\n1000 continue\n return\n end subroutine tabder\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\n\n" }, { "path": "src/models/gtp3XQ.F90", "content": "!\r\n! gtp3XQ for for MQMQA\r\n!\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n!> 15B. Section: calculate G and other things for MQMQA and Toop/Kohler\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n! removed debug output\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine config_entropy_mqmqa\r\n!\\begin{verbatim}\r\n subroutine config_entropy_mqmqa1(phvar,moded,lokph,tval)\r\n! dummy\r\n implicit none\r\n type(gtp_phase_varres), pointer :: phvar\r\n integer moded,lokph\r\n double precision tval\r\n! modified arguments for call\r\n integer ncon\r\n type(gtp_species) :: sprec\r\n! fq is max number of quads\r\n! fz max number of constituents on a sublattice\r\n! f1s dimension for other arrays ceff1 etc\r\n! integer, parameter :: fq=99, fz=20, f1=50\r\n integer, parameter :: fq=20, fz=10, f1s=50\r\n! max allower error in sum ceqf1=1 and ceqf2=1\r\n double precision, parameter :: ceqferr=1.0D-7\r\n! number of pairs and sublattice fractions\r\n integer noofpair,ncons1,ncons2\r\n! not needed ....\r\n! integer loksp,nspel,ielno(10),nextra,ncation\r\n! these are used to as index of species on sublatte 1 (ee,ff) and 2 (gg,hh)\r\n integer ee,ff,gg,hh\r\n! loop variables\r\n integer s1,s2,s3,s4,em,c1\r\n! pointer? to mqmqaf record with all fraction records\r\n! site fractions and amounts\r\n! double precision yy1(fz),yy2(fz),nn1(fz),nn2(fz)\r\n double precision yy1(fz),yy2(fz)\r\n! fractions in sublattices\r\n double precision sum1,sum2,sum3,sum4,half\r\n! contyp(1-4,i) specify sublattice +/- of element and if alone or mixing 2/1\r\n! contyp(5,i) is is the pair index for a quadrupols that is a pair\r\n! contyp(6-7,i) for a pair are species index\r\n! contyp(8-9,i) for a pair are ZERO\r\n! contyp(6-9,i) for other quadrupols are pair indices (2 or 4 indicies)\r\n! contyp(10,i) should be i ... just as a check\r\n! contyp(11,i) for a pair is constituent index in sublattice 1\r\n! contyp(12,i) for a pair is constituent index in sublattice 1\r\n! contyp(11-12,i) for other quadrupoles are zero\r\n integer em1,em2,em3,em4,mpj\r\n! %pinq(pair) is index in %contyp for a pair\r\n! cridx(pair_index) is the index of corresponding quad %contyp(5,q) is pair\r\n! integer cridx(f1) REDUNDANT\r\n! Index to the 2-4 sublattice fractions associated with a quad\r\n! integer fyqix(2,fq),fyqix2(2,fq)\r\n! pair and coord.equiv fractions for pairs in a quad\r\n double precision pair(fq),ceqf1(fq),ceqf2(fq)\r\n! test correct way to calculate pair fraction\r\n double precision cpair(fq),dcpair(fq,fq),cpairsum,dcpairsum(fq),dp(fq,fq)\r\n double precision spair(fq)\r\n! various factors\r\n double precision sm1,term,fffy,fff1,fff2\r\n double precision ffem,ffceq1,ffceq2,once1,once2\r\n! indicate which species that are involved in a quadrupole\r\n! integer involved(noofsp),stoix1,stoix2\r\n! species in sublatice 1 and 2\r\n integer nspin(2),eesub,ggsub\r\n! first and second derivatives wrt constituents ...\r\n! double precision dma1 is coefficent of site fraction in subl 1 for quad \r\n! double precision dms1 is sum of coefficents in subl 1 for a quad i\r\n! sum each part separately\r\n double precision tsub,dvvv(fq,fq),lsub(fq),tend\r\n double precision ssub,dssub(fq),send,dsend(fq),squad,dsquad(fq)\r\n double precision d2ssub(fq*(fq+1)/2)\r\n! first index is sublattice constituent, second is quad index\r\n double precision b1iA(fz,fq),b2iX(fz,fq),b1iAB(fq),b2iXY(fq),sum1AB,sum2XY\r\n! this should give stoichiometry of (species,quad) on the two sublattices\r\n double precision dmy1(fz,fq),dmy2(fz,fq)\r\n! second derivatives d2xx of site fractions ...\r\n double precision d2yy1(fz,fq*(fq+1)/2),d2yy2(fz,fq*(fq+1)/2)\r\n double precision dpair(f1s,fq),dceqf(f1s,fq),yfrac,dummy1,dq1,dq2,dq3\r\n double precision dyy1(fz,fq),dyy2(fz,fq),dceqf1(f1s,fq),dceqf2(f1s,fq)\r\n double precision dsm1(fq),d2sm1(fq*(fq-1)/2),dterm(fq),ojoj,alone1,alone2\r\n character conname*24,endname*24,spname1*24,spname2*24,connames(fq)*24\r\n double precision endkvot(fq),dendkvot(fq,fq),d2endkvot(fq,fq*(fq+1)/2)\r\n double precision mulceq(f1s),dmulceq(f1s,fq*(fq+1)/2),divisor\r\n! this is a scaling with total amount of atoms\r\n double precision invnorm,fqq,pairceq\r\n! quad entropy rewritten ...\r\n integer pair1,pair2,pair3,pair4,e2,f2,g2,h2\r\n! save here the indices of constituents in sublattices of pairs\r\n! needed for the charge equivalent fractions, ceqf1 and ceqf2\r\n! MAYBE NOT NEEDED when %contyp(11..12,quad) have constituent indices?\r\n integer eij(2,fq),nomix,all2,q1,s7,s8\r\n! modfied AB/XY loop requires, pq is pair indices, subcon is sublattices indices\r\n! pqq is pair index in %contyp ...\r\n! fq is index in corresponding %constoi\r\n integer pq(4),pqq(4),sq1(2),sq2(2),fq1(2),fq2(2)\r\n! test of indexing problem\r\n integer line757\r\n! to avoid adding quadrupols twice\r\n logical done,ddebug\r\n!\r\n! This is a maybe a reasonable place to initiate csumx for excess parameters?\r\n! if(allocated(mqmqa_data%csumx)) then\r\n! this is used in calc_mqmqa to skip excess terms with very small fractions.\r\n! write(*,*)'3XQ Maybe initiating csumx to FALSE'\r\n! initiating here leads to failed convergece, initiated now in calcg_internal\r\n! mqmqa_data%csumx=.FALSE.\r\n! endif\r\n ncon=phlista(lokph)%tnooffr\r\n ddebug=.FALSE.\r\n! ddebug=.TRUE.\r\n if(ddebug) write(*,*)'3X in config_entropy_mqmqa1',lokph,moded,ncon\r\n! phrec=phlista(lokph)\r\n invnorm=phvar%abnorm(1)\r\n! invnorm=one\r\n! phvar%abnorm(1)=one\r\n! phvar%abnorm(1)=one\r\n! We should probably update abnorm(2) and (3) also ...\r\n! phvar%abnorm(2)=invnorm*phvar%abnorm(2)\r\n! phvar%abnorm(3)=invnorm*phvar%abnorm(3)\r\n!\r\n! write(*,'(a,i3,1pe12.3)')'3X in MQMQA, version 5: ',ncon,one/invnorm\r\n!\r\n if(.not.allocated(mqmqa_data%contyp)) then\r\n write(*,*)'3X MQMQA missing constituent information'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n if(ncon.ne.mqmqa_data%nconst) then\r\n write(*,*)'3Xncon, %nconst: ',ncon,mqmqa_data%nconst\r\n stop '3X constituent problems in mqmqa ...'\r\n endif\r\n11 format(a,4(F5.2,2x))\r\n! write(*,*)'3X error return as unfinished'\r\n! gx%bmperr=4399; goto 1000\r\n! if(.not.allocated(phvar%mqmqaf%yy1)) then\r\n! THIS MOVED BELOW BUT SHOULD EVENTUALLY BE HERE\r\n! allocating fraction arrayes for use in entropy an excess calculations\r\n! write(*,*)'3X allocating phase_varres%mqmqaf arrays'\r\n! allocate(phvar%mqmqaf%yy1(20))\r\n! allocate(phvar%mqmqaf%yy2(20))\r\n!... add more ...\r\n! endif\r\n! to avoid typing too much (should mqmqaf be a target? no compiler error)\r\n! problem allocating arrays to this pointer !!!\r\n! mqf=>phvar%mqmqaf\r\n do s1=1,ncon\r\n! wow, using phase constituent order to find quad name !! Keep it at present\r\n! conname=splista(phrec%constitlist(mqmqa_data%contyp(10,s1)))%symbol\r\n conname=splista(phlista(lokph)%constitlist(mqmqa_data%contyp(10,s1)))%symbol\r\n connames(s1)=conname\r\n if(ddebug) write(*,3)s1,(mqmqa_data%contyp(s2,s1),s2=1,14),&\r\n (mqmqa_data%constoi(s2,s1),s2=1,4),phvar%yfr(s1),trim(conname)\r\n3 format('3X mq:',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3,4F5.1,F5.2,1x,a)\r\n enddo\r\n if(ddebug) then\r\n do s1=1,ncon\r\n write(*,4)s1,(mqmqa_data%pp(s2,s1),s2=1,4),trim(connames(s1))\r\n4 format('3X pp:',i2,4(F8.5),2x,a)\r\n enddo\r\n endif\r\n! write(*,'(a,20i3)')'3X pinq: ',(mqmqa_data%pinq(s1),s1=1,mqmqa_data%npair)\r\n! write(*,6)phvar%yfr\r\n6 format('3X y: ',9F7.4)\r\n! maybe use mqf variables? Need allocation\r\n! local variables can be replaced by those stored in phvar\r\n! local fraction variables and derivatives\r\n yy1=zero; yy2=zero; pair=zero; ceqf1=zero; ceqf2=zero;\r\n b1iA=zero; b2iX=zero; dpair=zero; dceqf1=zero; dceqf2=zero\r\n b1iAB=zero; b2iXY=zero; dmy1=zero; dmy2=zero\r\n cpair=zero; dcpair=zero\r\n! write(*,431)'3X d2S/Rx:',((phvar%d2gval(ixsym(s2,s3),1),s3=s2,ncon),s2=1,ncon)\r\n! any species used below is indicated by a 1 or 2 depending on sublattice\r\n! do s1=1,ncon\r\n! if(mqmqa_data%contyp(5,s1).ne.s1) then\r\n! write(*,*)'3X *** Warning %contyp index 10 not correct'\r\n! endif\r\n! enddo\r\n! these count the sum of element and pair stoichiometries for a quad\r\n! fyp=zero\r\n!----------------------------------------------------\r\n! the array species in each sublattice will have missing values\r\n!----------------------------------------------------\r\n! we must calculate a number of auxilliary fraction variables from the\r\n! site fractions using mqmqa_data%contyp\r\n! do s1=1,ncon\r\n! write(*,14)'3X %%contyp: ',s1,(mqmqa_data%contyp(s7,s1),s7=1,14),&\r\n! trim(connames(s1))\r\n14 format(a,i3,1x,4i2,1x,i3,1x,4i3,1x,i3,1x,4i3,1x,a)\r\n! enddo\r\n mpj=mqmqa_data%npair\r\n if(ddebug) write(*,15)'3X pinq: ',mpj,(mqmqa_data%pinq(s1),s1=1,mpj)\r\n15 format(a,i3,2x,20i4)\r\n nspin(1)=mqmqa_data%ncon1\r\n nspin(2)=mqmqa_data%ncon2\r\n! noofpair=mqmqa_data%npair\r\n! write(*,'(a,2i3,2x,i3)')'3X subl const and pairs: ',nspin,mpj\r\n noofpair=0\r\n! BIG LOOP OVER ALL QUADS, calculating fracions of pairs, sublattices etc\r\n sumfrac: do s1=1,ncon\r\n conname=connames(s1)\r\n if(mqmqa_data%contyp(10,s1).ne.s1) then\r\n write(*,212)s1,mqmqa_data%contyp(10,s1)\r\n212 format('3XQ Warning: mqmqa_data%contyp(10,s1) =/= s1:',2i4)\r\n! emergecy fix 17/12 2025 does not work \r\n! mqmqa_data%contyp(10,s1)=s1\r\n endif\r\n s3=mqmqa_data%contyp(5,s1)\r\n typ: if(s3.gt.0) then\r\n! AN PAIR quadrupol AA:XX, increment the pair counter\r\n! the index of the quadrupole fraction is in ALSO in contyp(10,s1) \r\n! yfrac=phvar%yfr(mqmqa_data%contyp(10,s1))\r\n yfrac=phvar%yfr(s1)\r\n! Pair fractions has to be normallized later, here multiply with %pp\r\n noofpair=noofpair+1\r\n pair(s3)=pair(s3)+yfrac\r\n dpair(s3,s1)=one\r\n cpair(s3)=cpair(s3)+yfrac*mqmqa_data%pp(1,s1)\r\n! dcpair( pairindex, quadindex )\r\n dcpair(s3,s1)=mqmqa_data%pp(1,s1)\r\n! Calculating pairs\r\n! write(*,'(a,2i3,7F8.4)')'3X pair1: ',s1,s3,one,yfrac,pair(s3),&\r\n! mqmqa_data%pp(1,s1),cpair(s3),dcpair(s3,s1),dpair(s3,s1)\r\n! all second derivatives of pair is zero\r\n! the index of constituent in first sublattice is in %contyp(11,s1)\r\n! ee is species index, eesub is index of species in sublattice\r\n ee=mqmqa_data%contyp(6,s1)\r\n eesub=mqmqa_data%contyp(11,s1)\r\n eij(1,noofpair)=eesub\r\n! the index of constituent in second sublattice is in %contyp(12,s1)\r\n gg=mqmqa_data%contyp(7,s1)\r\n ggsub=mqmqa_data%contyp(12,s1)\r\n eij(2,noofpair)=ggsub\r\n! ee and gg are pair indices, eesub and ggsub sublatice const. indices\r\n! write(*,50)'3X decode1: ',s1,ee,gg,eesub,ggsub\r\n50 format(a,i3,5x,2i4,5x,2i4)\r\n spname1=splista(ee)%symbol\r\n spname2=splista(gg)%symbol\r\n! remember which species that are used by marking them (only needed for pairs)\r\n! this is the stoichiometric factors of the species in the pair\r\n fff1=2.0d0/mqmqa_data%constoi(1,s1)\r\n fff2=2.0d0/mqmqa_data%constoi(2,s1)\r\n! else\r\n! write(*,*)'3X contyp error 1: ',mqmqa_data%contyp(1,s1)\r\n! gx%bmperr=4399; goto 1000\r\n! endif\r\n! SAVE the location in sublattice array of species eesub in quad s1\r\n! eesub and ggsub are sublattice indices\r\n! >>>>>>>>>>>>>>>>>>>>>>> .............. EQUATION B15 part 1\r\n \r\n yy1(eesub)=yy1(eesub)+fff1*yfrac\r\n b1iA(eesub,s1)=fff1\r\n! write(*,12)'3X yy1 add1:',s1,eesub,1,yy1(eesub),fff1,yfrac\r\n12 format(a,3i3,5F10.6)\r\n! there is a single contribution from this quad to the site fractions\r\n b1iAB(s1)=fff1\r\n yy2(-ggsub)=yy2(-ggsub)+fff2*yfrac\r\n b2iX(-ggsub,s1)=fff2\r\n b2iXY(s1)=fff2\r\n! write(*,12)'3X yy2 add1:',s1,ggsub,2,yy2(-ggsub),fff2,yfrac\r\n! equivalent sublattice fraction for the sublattice constituents\r\n! >>>>>>>>>>>>>>>>>>>>>>>> .............. EQUATION B19 part 1\r\n ceqf1(eesub)=ceqf1(eesub)+yfrac\r\n ceqf2(-ggsub)=ceqf2(-ggsub)+yfrac\r\n dceqf1(eesub,s1)=one\r\n dceqf2(-ggsub,s1)=one\r\n! Calculating ceq\r\n! write(*,333)'3X ceqf1e:',s1,0,0,1,eesub,ceqf1(eesub),&\r\n! yfrac,one,1,trim(spname1),trim(connames(s1))\r\n! write(*,333)'3X ceqf2e:',s1,0,0,2,ggsub,ceqf2(-ggsub),&\r\n! yfrac,one,2,trim(spname2),trim(connames(s1))\r\n333 format(a,1x,5i3,3F10.6,' ceq',i1,'(',a,') ',a)\r\n! end of pair summations\r\n else\r\n!--------------------------------------------------------------\r\n! this is a quadrupol AB:XY consisting of 2 or 4 pairs typ A:X and B:Y\r\n! the pair indices in %contyp are indicated in contyp(6..9,s1)\r\n! IT IS A BIT INVOLVED AND CAN (certainly) BE SIMPLIFIED ....\r\n ffem=0.5D0\r\n fffy=one\r\n yfrac=phvar%yfr(s1)\r\n if(mqmqa_data%contyp(9,s1).gt.0) then\r\n! contyp(9,s1) nonzero for quadrupoles with 4 pairs A:X, A:Y, B:X, B:Y\r\n! set ffem=0.25 if 4 pairs\r\n ffem=0.25D0\r\n! set fffy=0.5 to avoid adding same fraction twice\r\n fffy=0.5D0\r\n endif\r\n! these refer to constituent species, ff, gg in first; gg hh in second\r\n! ee=0; ff=0; gg=0; hh=0\r\n! s2 loops over the species involved in the quadrupol, it can be 3 or 4\r\n! in %contyp(1..4,s1) is indicated if same species twice (2) or not (1)\r\n! in %constoi(1..4,s1) is the coordination number\r\n! s2 loops positions 1..4 in contyp and constoi\r\n! these are used to find correct stoichimetry index\r\n! which constoi to use? AA:XY should have (1,2) and (1,3) for AA:XX and AA:YY\r\n! which constoi to use? AB:XX should have (1,3) and (2,3) for AA:XX and BB:XX\r\n! which constoi to use? AB:XY should have (1,3), (1,4), (2,3) and (2,4) for ...\r\n! position 6, 7, 8, 9 are indices to pairs, s2 incremented at loop end\r\n! in the pairs %contyp(11,pairindex) and %contyp(12,pairindex) and subl index\r\n once1=one; once2=one; alone1=2.0d0; alone2=2.0d0\r\n ffceq1=0.5D0; ffceq2=0.5D0\r\n pq=0; sq1=0; sq2=0\r\n! pq are the pair indices, 2 or 4\r\n! but below we use pq as indices to mqmqa_data ... we need pinq(pq(j))\r\n pq(1)=mqmqa_data%contyp(6,s1)\r\n pq(2)=mqmqa_data%contyp(7,s1)\r\n pqq(1)=mqmqa_data%pinq(pq(2))\r\n pqq(2)=mqmqa_data%pinq(pq(2))\r\n! here we saved A and X assuming mixing in first sublattice\r\n! we must also save the stoichiometric factors of the sublattice species\r\n sq1(1)=mqmqa_data%contyp(11,pqq(1))\r\n! fq1 this is index to %constoi for this sublattice constituent\r\n fq1(1)=1\r\n sq2(1)=mqmqa_data%contyp(12,pqq(1))\r\n fq2(1)=3\r\n if((mqmqa_data%contyp(1,s1).eq.2)) then\r\n! quadruplet AA:XY, pairs AA:XX and AA:YY\r\n! Same constituents in first sublattice, indices in %contyp(11, %contyp(6,s1))\r\n! and %contyp(12, %contyp(7,s1))\r\n! mixing in second sublattice, same constituent twice in first\r\n sq1(2)=sq1(1)\r\n fq1(2)=fq1(1)\r\n! replace stoichiometric factor\r\n fq2(1)=2\r\n sq2(2)=mqmqa_data%contyp(12,pqq(2))\r\n fq2(2)=3\r\n alone2=one\r\n nomix=1\r\n! write(*,'(a,2i3,2x,2i3)')'3X mixing in 2: ',sq1,sq2\r\n elseif(abs(mqmqa_data%contyp(3,s1)).eq.2) then\r\n! quadrupole AB:XX, first pair AA:XX, second BB:XX\r\n! Same constituents in second sublattice, indices in %contyp(11, %contyp(6,s1))\r\n! and %contyp(12, %contyp(7,s1))\r\n! mixing in first sublattice, same constituent twice in second\r\n sq2(2)=sq2(1)\r\n fq2(2)=fq2(1)\r\n! add second sublattice constituent twice\r\n sq1(2)=mqmqa_data%contyp(11,pqq(2))\r\n fq1(2)=2\r\n alone1=one\r\n nomix=2\r\n! write(*,'(a,2i3,2x,2i3)')'3X mixing in 1: ',sq1,sq2\r\n else\r\n! quadupole AB:XY, 4 pairs used, AA:XX; AA:YY; BB:XX BB:YY\r\n! 4 pairs, we have to add 2 more\r\n pq(3)=mqmqa_data%contyp(8,s1)\r\n pq(4)=mqmqa_data%contyp(9,s1)\r\n pqq(3)=mqmqa_data%pinq(pq(3))\r\n pqq(4)=mqmqa_data%pinq(pq(4))\r\n sq1(2)=mqmqa_data%contyp(11,pqq(3))\r\n! \r\n fq1(2)=2\r\n fq2(2)=4\r\n! I am not sure how the pairs are arranged \r\n! but testing 3 pairs the sublattice constituent must be different\r\n if(sq1(2).eq.sq1(1)) sq1(2)=mqmqa_data%contyp(11,pqq(2))\r\n sq2(2)=mqmqa_data%contyp(12,pqq(2))\r\n if(sq2(2).eq.sq2(1)) sq2(2)=mqmqa_data%contyp(12,pqq(2))\r\n alone1=one; alone2=one\r\n nomix=4\r\n! write(*,*)'3X reciprocal cluster',mqmqa_data%contyp(2,s1)\r\n endif\r\n! write(*,313)'3X pq mm: ',s1,pq,pqq,sq1,sq2,fq1,fq2\r\n313 format(a,i3,2x,4i2,2x,4i2,4x,2i2,2x,2i2,4x,2i2,2x,2i2)\r\n! contribution from all pairs included in this quadruple, nonzero pq\r\n pqloop: do s2=1,4\r\n! write(*,'(a,2i3)')'3x pqloop: ',s2,pq(s2)\r\n if(pq(s2).eq.0) exit pqloop\r\n pair(pq(s2))=pair(pq(s2))+ffem*yfrac\r\n dpair(pq(s2),s1)=ffem\r\n! EMERGENCY, how to know which %pp to use for each pair???\r\n! modified in gtp3B to ensure that pairs are correlated with %constoi ??\r\n! s2 is assumed to be %pp index, pq(s2) constittuent index ...\r\n cpair(pq(s2))=cpair(pq(s2))+yfrac*mqmqa_data%pp(s2,s1)\r\n! dcpair( pairindex, quadindex )\r\n dcpair(pq(s2),s1)=mqmqa_data%pp(s2,s1)\r\n! write(*,'(a,3i3,2F10.7)')'3X dcpair2: ',pq(s2),s1,s2,&\r\n! yfrac,dcpair(pq(s2),s1)\r\n! Calculating pairs in SNN\r\n! write(*,'(a,3i3,6F10.6)')'3X pair2: ',s1,s2,pq(s2),ffem,yfrac,&\r\n! pair(pq(s2)),mqmqa_data%pp(s2,s1),cpair(pq(s2)),&\r\n! dcpair(pq(s2),s1)\r\n enddo pqloop\r\n! write(*,'(a,i3,2x,2i3,2x,2i3)')'3X sqi: ',s1,sq1,sq2\r\n s7=0\r\n subloop: do s2=1,2\r\n! For the site fractions and equivalent fraction ceqfi we have to\r\n! extract all constituent species of the quadrupol s1 using the pair s3\r\n! divided by with the coordination factor in s2 for quadrupol s1\r\n! the species in first sublattice of the pair\r\n if(sq1(s2).le.0) then\r\n write(*,*)'3X no constituent in first sublattice!!!',s1,s2,sq1\r\n stop\r\n else\r\n! We have to use the correct sublattice index and coordination factor !!\r\n! eesub should be in mqmqa_data%contyp(10+s2,s1) ?? What is sq1(s2)?\r\n eesub=sq1(s2)\r\n eesub=mqmqa_data%contyp(10+s2,s1)\r\n! write(*,'(a,3i3,F8.3)')'3X sublattice index: ',&\r\n! eesub,sq1(s2),fq1(s2),mqmqa_data%constoi(s2,s1)\r\n! SAVE the sublattice location of species eesub for quad s1\r\n fff1=fffy*alone1/mqmqa_data%constoi(fq1(s2),s1)\r\n yy1(eesub)=yy1(eesub)+fff1*yfrac\r\n b1iA(eesub,s1)=fff1\r\n! write(*,13)'3X yy1 add2:',s1,s2,eesub,yy1(eesub),fff1*yfrac,&\r\n! fff1,yfrac,fffy,alone1,mqmqa_data%constoi(fq1(s2),s1)\r\n13 format(a,3i3,3F10.6,5(F6.3))\r\n! there can be more than one contribution to site fraction from this quad\r\n! nomix=1 if single in 1\r\n if(nomix.ne.1) then\r\n b1iAB(s1)=b1iAB(s1)+fff1\r\n else\r\n b1iAB(s1)=fff1\r\n endif\r\n ceqf1(eesub)=ceqf1(eesub)+fffy*ffceq1*yfrac\r\n dceqf1(eesub,s1)=fffy*ffceq1\r\n endif\r\n!---------- second sublattice\r\n if(sq2(s2).gt.0) then\r\n! constituent index is negative in second sublattice!!\r\n write(*,*)'3X no constituent in second sublattice!!!',s1,s2,sq2\r\n write(*,14)'3X %contyp: ',s1,(mqmqa_data%contyp(s7,s1),s7=1,14)\r\n gx%bmperr=4399; goto 1000\r\n else\r\n! NOW the species in second sublattice of the pair NOTE negative\r\n ggsub=sq2(s2)\r\n! SAVE the sublattice location of species eesub and ggsub for quad s1\r\n! fq1(s2) specify stoichiometry index of const. in 1st sublattice in AB/XY\r\n! the species indexing in %contyp(11..14) is the same as for %constoi(1..4)\r\n! fq2(s2) specify stoichiometry index of const. in 2nd sublattice in AB/XY\r\n fff2=fffy*alone2/mqmqa_data%constoi(fq2(s2),s1)\r\n yy2(-ggsub)=yy2(-ggsub)+fff2*yfrac\r\n! write(*,13)'3X yy2 add2:',s1,ggsub,s2,yy2(-ggsub),fff2,yfrac,&\r\n! fffy,alone2,mqmqa_data%constoi(fq2(s2),s1)\r\n52 format(a,i3,5F8.5)\r\n b2iX(-ggsub,s1)=fff2\r\n! nomix=2 if single in sublattice 2\r\n if(nomix.ne.2) then\r\n b2iXY(s1)=b2iXY(s1)+fff2\r\n else\r\n b2iXY(s1)=fff2\r\n endif\r\n331 format('3Xq n(',a2,'): ',3i3,2i3,4F7.4,2x,a)\r\n! equivalent site fraction, each mixing element will be counted twice\r\n! for quadrupole with 4 pairs fffy=0.25; otherwice 0.5\r\n! >>>>>>>>>>>>>>>>>>> ................ EQUATION B17 part 2\r\n ceqf2(-ggsub)=ceqf2(-ggsub)+fffy*ffceq2*yfrac\r\n dceqf2(-ggsub,s1)=fffy*ffceq2\r\n! write(*,333)'3X ceqf1q:',s1,0,s3,1,eesub,ceqf1(eesub),&\r\n! yfrac,fffy*ffceq1,1,trim(spname1),trim(connames(s1))\r\n! write(*,333)'3X ceqf2q:',s1,0,s3,2,ggsub,ceqf2(-ggsub),&\r\n! yfrac,fffy*ffceq2,2,trim(spname2),trim(connames(s1))\r\n! increment s2 for next pair in quadrupole s1\r\n endif\r\n enddo subloop\r\n endif typ\r\n! problem with pair fractions ...\r\n! do s3=1,mpj\r\n! write(*,'(a,2i3,5F10.7)')'3X loop:',s1,s3,(dpair(s3,s2),s2=1,ncon)\r\n! write(*,'(a,2i3,5F10.7)')'3X loop:',s1,s3,(dcpair(s3,s2),s2=1,ncon)\r\n! enddo\r\n enddo sumfrac\r\n! write(*,*)'3X sumfrac done'\r\n!\r\n!------------------------------ end BIG LOOP over all quads\r\n! do s3=1,nspin(1)\r\n! write(*,342)'3X b1iA(m,n):',s3,s1,(b1iA(s3,s4),s4=1,ncon)\r\n! enddo\r\n! write(*,341)'3X b1iAB(n) :',s1,(b1iAB(s4),s4=1,ncon)\r\n! do s3=1,nspin(2)\r\n! write(*,342)'3X b2iX(m,n):',s3,s1,(b2iX(s3,s4),s4=1,ncon)\r\n! enddo\r\n! write(*,341)'3X b2iXY(n) :',s1,(b2iXY(s4),s4=1,ncon)\r\n! write(*,340)'3X yy1: ',(yy1(s4),s4=1,3)\r\n! write(*,340)'3X yy2: ',(yy2(s4),s4=1,3)\r\n340 format(a,7F10.7)\r\n342 format(a,2i2,7F7.4)\r\n720 format(a,i3,4(4I3,2x))\r\n\r\n! debug listings:\r\n! write(*,*)'3X summed all amounts, next normallize'\r\n! write(*,720)'3X contyp: ',0,((mqmqa_data%contyp(s2,s1),s2=11,14),s1=1,ncon)\r\n! write(*,200)'3X p_AB/XY:',(phvar%yfr(s1),s1=1,ncon)\r\n! write(*,200)'3X n1 :',(yy1(s1),s1=1,nspin(1))\r\n! write(*,200)'3X n2 :',(yy2(s1),s1=1,nspin(2))\r\n! write(*,200)'3X pairs :',(pair(s1),s1=1,noofpair)\r\n! write(*,200)'3X cpairs :',(cpair(s1),s1=1,noofpair)\r\n! do s1=1,noofpair\r\n! write(*,200)'3X dcpairs:',(dcpair(s1,s2),s2=1,ncon)\r\n! enddo\r\n! write(*,200)'3X ceqf1 :',(ceqf1(s1),s1=1,nspin(1))\r\n! write(*,200)'3X ceqf2 :',(ceqf2(s1),s1=1,nspin(2))\r\n! stop\r\n! do s3=1,nspin(1)\r\n! write(*,342)'3X b1iA(m,n):',s3,s1,(b1iA(s3,s4),s4=1,ncon)\r\n! enddo\r\n! write(*,341)'3X b1iAB(n) :',s1,(b1iAB(s4),s4=1,ncon)\r\n! do s3=1,nspin(2)\r\n! write(*,342)'3X b2iX(m,n):',s3,s1,(b2iX(s3,s4),s4=1,ncon)\r\n! enddo\r\n! write(*,341)'3X b2iXY(n) :',s1,(b2iXY(s4),s4=1,ncon)\r\n341 format(a,i2,7F10.7)\r\n!-------------- we have extracted all comp.variables and their deriv wrt quads\r\n! Now sum amounts and normallize\r\n!\r\n! NOTE in b1iA and b1iA the first index is subl.const, second is quad \r\n! sometimes I mix them up ...\r\n!\r\n! write(*,*)'Sublattice fractions and detivatives:\r\n! first sublattice\r\n sum1AB=zero\r\n! write(*,*)'3X nspin: ',nspin\r\n do s1=1,nspin(1)\r\n sum1AB=sum1AB+yy1(s1)\r\n! write(*,88)'3X subl: ',s1,yy1(s1),(b1iA(s1,s2),s2=1,ncon)\r\n enddo\r\n88 format(a,i2,F7.3,2x,9(F8.4))\r\n! write(*,'(a,F7.3,a)')'3X sum1AB: ',sum1AB\r\n do s1=1,nspin(1)\r\n yy1(s1)=yy1(s1)/sum1AB\r\n enddo\r\n! second sublattice\r\n sum2XY=zero\r\n do s1=1,nspin(2)\r\n sum2XY=sum2XY+yy2(s1)\r\n! write(*,88)'3X sub2: ',s1,yy2(s1),(b2iX(s1,s2),s2=1,ncon)\r\n enddo\r\n do s1=1,nspin(2)\r\n yy2(s1)=yy2(s1)/sum2XY\r\n enddo\r\n! write(*,*)'3X nspin2: ',nspin\r\n! derivatives of sublattice fractions wrt quads\r\n all2=ncon*(ncon+1)/2\r\n d2yy1=zero\r\n dummy1=one/sum1AB**2\r\n! ixsym finds the sequential storage place of (i,j) in a symmetrical array\r\n! write(*,538)ncon,ixsym(ncon,ncon),ixsym(5,3),nspin\r\n538 format('3XQ entropy: ',3i5,' nspin: ',20i3)\r\n!\r\n! write(*,*)'3X d2yy1 size: ',fz,fq*(fq+1)/2,fz*fq*(fq+1)/2,all2\r\n yder1: do s1=1,nspin(1)\r\n do s2=1,ncon\r\n! b1iAB may contain contributions from two constituents in same quad\r\n dyy1(s1,s2)=(b1iA(s1,s2)-yy1(s1)*b1iAB(s2))/sum1AB\r\n! cycle yder1\r\n! this gives phase matrix singuler\r\n do s3=1,ncon\r\n d2yy1(s1,ixsym(s2,s3))=&\r\n (-b1iA(s1,s2)*b1iAB(s3)-b1iA(s1,s3)*b1iAB(s2)+&\r\n 2.0D0*yy1(s1)*b1iAB(s2)*b1iAB(s3))*dummy1\r\n! write(*,19)'3X dyy: ',s1,s2,s3,b1iA(s1,s2),b1iAB(s3),&\r\n! b1iA(s1,s3),b1iAB(s2),2.0D0*yy1(s1),d2yy1(s1,ixsym(s2,s3))\r\n19 format(a,3i2,6(1pe10.2))\r\n enddo\r\n! try ... gives also phase matrix singular ...\r\n! d2yy1(s1,s1)=one/yy1(s1)\r\n enddo\r\n enddo yder1\r\n! debug\r\n! do s1=1,nspin(1)\r\n! do s3=s1,all2\r\n! s8=ixsym(s3,s1)\r\n! write(*,'(a,4i4,1pe12.4)')'3X mqmqa d2yy1: ',s1,s3,s8,all2,d2yy1(s1,s8)\r\n! write(*,87)'3X d2yyj: ',1,s1,(d2yy1(s1,s2),s2=1,all2)\r\n! enddo\r\n! enddo\r\n87 format(a,2i3,6(1pe10.2))\r\n d2yy2=zero\r\n dummy1=one/sum1AB**2\r\n yder2: do s1=1,nspin(2)\r\n! the line below works when there are no SRO quads (species)\r\n! dyy2(s1,s1)=one; cycle yder2\r\n! below needed when yy2 calculated from quads\r\n do s2=1,ncon\r\n! b2iXY may contain contributions from two constituents in same quads\r\n dyy2(s1,s2)=(b2iX(s1,s2)-yy2(s1)*b2iXY(s2))/sum2XY\r\n cycle yder2\r\n do s3=1,ncon\r\n if(nspin(2).eq.1) then\r\n! single sublattice fractions should not have any second derivaties ??\r\n d2yy2(s1,ixsym(s2,s3))=zero\r\n else\r\n! appoximate ...\r\n d2yy2(s1,ixsym(s2,s3))=&\r\n (-b2iX(s1,s2)*b2iXY(s3)-b2iX(s1,s3)*b2iXY(s2)+&\r\n 2.0D0*yy2(s1)*b2iXY(s2)*b2iXY(s3))*dummy1\r\n endif\r\n enddo\r\n enddo\r\n enddo yder2\r\n! do s1=1,nspin(2)\r\n! write(*,87)'3X d2yyj: ',2,s1,(d2yy2(s1,s2),s2=1,all2)\r\n! enddo\r\n! ------------------------------------------\r\n! calculate sublattice sites related to formula units\r\n! dummy1=invnorm/(sum1AB+sum2XY)\r\n! sum1AB=sum1AB*dummy1\r\n! sum2XY=sum2XY*dummy1\r\n! sum1AB=invnorm*sum1AB\r\n! sum2XY=invnorm*sum2XY\r\n! We have to sum and normalize cpair\r\n cpairsum=zero\r\n dcpairsum=zero\r\n dp=zero\r\n do s1=1,noofpair\r\n spair(s1)=cpair(s1)\r\n cpairsum=cpairsum+cpair(s1)\r\n do s2=1,ncon\r\n dcpairsum(s2)=dcpairsum(s2)+dcpair(s1,s2)\r\n dp(s1,s2)=dcpair(s1,s2)\r\n enddo\r\n enddo\r\n! write(*,'(a,F10.6,2x,10(F8.4))')'3X cpsum:',cpairsum,&\r\n! (dcpairsum(s2),s2=1,ncon)\r\n do s1=1,noofpair\r\n cpair(s1)=cpair(s1)/cpairsum\r\n do s2=1,ncon\r\n dcpair(s1,s2)=(cpairsum*dp(s1,s2)-spair(s1)*dcpairsum(s2))/cpairsum**2\r\n enddo\r\n! replacing pair here creates problems .... do it later\r\n! pair(s1)=cpair(s1)\r\n! Calculate derivatives of pairs wrt quads, NEEDED FOR REFERENCE STATE\r\n enddo\r\n! do s1=1,noofpair\r\n! write(*,119)'3X cpair: ',s1,cpair(s1),(dcpair(s1,s2),s2=1,ncon)\r\n! enddo\r\n119 format(a,i2,F10.7,2x,8F10.6)\r\n!\r\n! check pairs are unity ... this pair fraction is wrong anyway ...\r\n! write(*,*)'3X pair fractions and derivatives:'\r\n dummy1=zero\r\n! loop over all pairs\r\n do s1=1,noofpair\r\n! Check sum is unity\r\n dummy1=dummy1+pair(s1)\r\n! write(*,120)s1,pair(s1),(dpair(s1,s2),s2=1,ncon)\r\n enddo\r\n120 format('3X pairs:',i3,F7.4,1x,10F6.3)\r\n if(abs(dummy1-one).gt.1.0D-12) then\r\n write(*,*)'3X pair fractions does not add up to unity',dummy1\r\n write(*,'(a,10F7.4)')'3X pf: ',(pair(s1),s1=1,noofpair)\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n!\r\n! NOW list the Charge Equivalent Fractions, related to sublattices\r\n! write(*,*)'3X Charge Equivalent fractions and derivatives:'\r\n dummy1=zero\r\n do s1=1,nspin(1)\r\n! Check sum is unity\r\n dummy1=dummy1+ceqf1(s1)\r\n! write(*,81)'3X ceqf:',1,ceqf1(s1),(dceqf1(s1,s2),s2=1,ncon)\r\n enddo\r\n if(abs(dummy1-one).gt.ceqferr) then\r\n write(*,*)'3X Sum of charge equivalent fractions on subl 1 not 1:',dummy1\r\n write(*,'(a,7(F10.7))')'3X ceqf1: ',(ceqf1(s2),s2=1,nspin(1))\r\n! assume this will be the fixed when converged ....\r\n! gx%bmperr=4399; goto 1000\r\n endif\r\n dummy1=zero\r\n do s1=1,nspin(2)\r\n! Check sum is unity\r\n dummy1=dummy1+ceqf2(s1)\r\n! write(*,81)'3X ceqf:',2,ceqf2(s1),(dceqf2(s1,s2),s2=1,ncon)\r\n enddo\r\n if(abs(dummy1-one).gt.ceqferr) then\r\n write(*,*)'3X Sum of charge equivalent fractions on subl 2 not 1',dummy1\r\n write(*,'(a,7(F10.7))')'3X ceqf2: ',(ceqf2(s2),s2=1,nspin(2))\r\n! assume this will be the fixed when converged ....\r\n! gx%bmperr=4399; goto 1000\r\n endif\r\n81 format(a,i2,F7.4,1x,(10F7.4))\r\n! write(*,*)'3X all normallized fractions calculated'\r\n! write(*,*)'3X error return as unfinished'\r\n! gx%bmperr=4399\r\n! goto 1000\r\n!---------------------------------------------------------------------------\r\n! 2021.08.24 derivatives of site fractions wrt quadrupoles??\r\n!---------------------------------------------------------------------------\r\n! write(*,*)'3X quitting as not finished below'\r\n! gx%bmperr=4399\r\n! goto 1000\r\n! fraction listings\r\n! write(*,200)'3X p_AB/XY:',(phvar%yfr(s1),s1=1,ncon)\r\n! write(*,200)'3X sites/FU :',sum1AB,sum2XY\r\n! write(*,200)'3X y1 :',(yy1(s1),s1=1,nspin(1))\r\n! write(*,200)'3X y2 :',(yy2(s1),s1=1,nspin(2))\r\n! do s1=1,nspin(1)\r\n! write(*,202)'3X dy1/dpi:',s1,(dyy1(s1,s2),s2=1,ncon)\r\n! enddo\r\n! do s1=1,nspin(2)\r\n! write(*,202)'3X dy2/dpi:',s1,(dyy2(s1,s2),s2=1,ncon)\r\n! enddo\r\n! same as above\r\n! write(*,200)'3X x_A/B :',(pair(s1),s1=1,noofpair)\r\n! write(*,200)'3X ceqf1 :',(ceqf1(s1),s1=1,nspin(1))\r\n! write(*,200)'3X ceqf2 :',(ceqf2(s1),s1=1,nspin(2))\r\n200 format(a,(10F7.4))\r\n202 format(a,i2,(10F7.4))\r\n! write(*,*)'3X now the entropy: >>>>>>>>>>>>>'\r\n!--------------------------------------------------------------------------\r\n! Problems here!!\r\n! COPY ALL FRACTIONS VARIABLES AND DERIVATIVES TO MQMQAF for use in parameters\r\n! allocate all arrays\r\n if(.not.allocated(phvar%mqmqaf%yy1)) then\r\n! allocate first time only!!\r\n! mqf is phvar%mqmqaf\r\n phvar%mqmqaf%nquad=ncon; phvar%mqmqaf%npair=noofpair; \r\n phvar%mqmqaf%ns1=nspin(1); phvar%mqmqaf%ns2=nspin(2)\r\n! write(*,207)nspin(1),nspin(2),ncon,noofpair\r\n207 format('3XQ allocating phvar%mqmqaf arrays',2i3,4i5)\r\n allocate(phvar%mqmqaf%yy1(nspin(1)))\r\n allocate(phvar%mqmqaf%yy2(nspin(2)))\r\n allocate(phvar%mqmqaf%dyy1(nspin(1),ncon))\r\n allocate(phvar%mqmqaf%dyy2(nspin(2),ncon))\r\n allocate(phvar%mqmqaf%d2yy1(nspin(1),ncon*(ncon+1)/2))\r\n allocate(phvar%mqmqaf%d2yy2(nspin(2),ncon*(ncon+1)/2))\r\n allocate(phvar%mqmqaf%ceqf1(nspin(1)))\r\n allocate(phvar%mqmqaf%ceqf2(nspin(2)))\r\n allocate(phvar%mqmqaf%dceqf1(nspin(1),ncon))\r\n allocate(phvar%mqmqaf%dceqf2(nspin(2),ncon))\r\n allocate(phvar%mqmqaf%pair(noofpair))\r\n allocate(phvar%mqmqaf%dpair(noofpair,ncon))\r\n! write(*,*)'3XQ allocation of d2yy2:',size(phvar%mqmqaf%d2yy2)\r\n! else\r\n! write(*,*)'3X copying data to phvar%mqmqaf arrays'\r\n endif\r\n! write(*,*)'3X mqf arrays allocated'\r\n! mqf=>phvar%mqmqaf\r\n!\r\n! write(*,*)'3X d2yy1: ',nspin(1),all2,size(phvar%mqmqaf%d2yy1)\r\n! write(*,*)'3X d2yy1: ',nspin(1),all2,nspin(1)*all2\r\n phvar%mqmqaf%yy1(1)=yy1(1)\r\n do s1=1,nspin(1)\r\n phvar%mqmqaf%yy1(s1)=yy1(s1)\r\n phvar%mqmqaf%ceqf1(s1)=ceqf1(s1)\r\n do s2=1,ncon\r\n phvar%mqmqaf%dyy1(s1,s2)=dyy1(s1,s2)\r\n phvar%mqmqaf%dceqf1(s1,s2)=dceqf1(s1,s2)\r\n enddo\r\n do s3=s1,ncon\r\n s8=ixsym(s3,s1)\r\n! write(*,'(a,2i3,3i4)')'3X mqmqa: ',s1,s3,s8,ncon*(ncon+1)/2,all2\r\n! phvar%mqmqaf%d2yy1(s1,ixsym(s3,s2))=d2yy1(s1,ixsym(s3,s2))\r\n! This statement kills whole subroutine\r\n phvar%mqmqaf%d2yy1(s1,s8)=d2yy1(s1,s8)\r\n enddo\r\n enddo\r\n!\r\n! write(*,771)nspin(1),nspin(2),ncon\r\n do s1=1,nspin(2)\r\n phvar%mqmqaf%yy2(s1)=yy2(s1)\r\n phvar%mqmqaf%ceqf2(s1)=ceqf2(s1)\r\n do s2=1,ncon\r\n phvar%mqmqaf%dyy2(s1,s2)=dyy2(s1,s2)\r\n phvar%mqmqaf%dceqf2(s1,s2)=dceqf2(s1,s2)\r\n enddo\r\n!****************************************************************\r\n! write(*,*)'3XQ line 757 skipping a 2nd derivative'\r\n!****************************************************************\r\n do s3=s1,ncon\r\n s8=ixsym(s3,s1)\r\n! large dimension problem here ixsym is a function to access a symetric array\r\n! write(*,671)s1,s3,s8,ixsym(s1,s8),size(d2yy2)\r\n671 format('3XQ accessing d2yy2: ',3i4,2i7)\r\n! phvar%mqmqaf%d2yy2(s1,s8)=d2yy2(s1,ixsym(s1,s8))\r\n line757=max(line757,s1*ixsym(s1,s8))\r\n enddo\r\n enddo\r\n! write(*,*)'3XQ line 771: ',line757,s1*ixsym(s1,s8)\r\n! do s1=1,noofpair\r\n! this will later be replaced by cpair!! for entropy the old pair works better\r\n! phvar%mqmqaf%pair(s1)=pair(s1)\r\n! do s2=1,ncon\r\n! phvar%mqmqaf%dpair(s1,s2)=dcpair(s1,s2)\r\n! try using dpair ....\r\n! phvar%mqmqaf%dpair=dpair(s1,s2)\r\n! enddo\r\n! enddo\r\n! write(*,777)'3X mqf sub1 1 copied:',(phvar%mqmqaf%yy1(s1),s1=1,nspin(1))\r\n! write(*,777)'3X mqf sub1 2 copied:',(phvar%mqmqaf%yy2(s1),s1=1,nspin(2))\r\n! write(*,777)'3X mqf pair copied:',(phvar%mqmqaf%pair(s1),s1=1,noofpair)\r\n! do s1=1,noofpair\r\n! write(*,777)'3X mqf dpair:',phvar%mqmqaf%pair(s1),&\r\n! (phvar%mqmqaf%dpair(s1,s2),s2=1,ncon)\r\n! enddo\r\n777 format(a,F10.7,2x,5(F10.6),(/5x,6F10.6))\r\n!---------------------------------------------------------------------------\r\n! ENTROPY CALCULATION\r\n!---------------------------------------------------------------------------\r\n! separate documentation, i,j in first subl, k,l in second subl\r\n! p_ijkl is cluster fraction; x_i site fraction; v_ik pair fraction\r\n! w_i coordination equivalent site fraction;\r\n! \\sum_i y'_i ln(y'_i) + \\sum_j y\"_j ln(y\"_j)+ subattice fractions\r\n!\r\n! \\sum_i\\sum_k v_ik ln(v_ik/(w_i w_k))+ pair fractions\r\n!\r\n! \\sum_i\\sum_k p_iikk ln(p_iikk/((v^4_ik/(w^2_i w^2_k)))+ \r\n! \\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)))+ \r\n! \\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)))+\r\n! \\sum_i\\sum_j\\sum_k\\sum_l p_ijkl ln(\r\n! p_ijkl/(4(v_ik v_il v_jk v_jl)/(w_i w_j w_k w_l)))\r\n!---------------------------------------------------------------------------\r\n! Discovered 21/10/20 with help by Mac Poschmann:\r\n! The entropy is distributed on the quads, dS/dquad is the sum of\r\n! the entropy contribution from sublattices, pairs and the quads\r\n! is related to each separate quad! Use the dyy1(*,quadindex) etc\r\n!-----------------------------------------------------------------\r\n! Here we calculate for one formula unit (FU) of the phase\r\n! at the end we multiply with current number of atomes/FU\r\n!-----------------------------------------------------------------\r\n!\r\n ssub=zero; dssub=zero\r\n dvvv=zero\r\n! write(*,'(a,6(1pe12.4))')'3X quads: ',(phvar%yfr(q1),q1=1,ncon)\r\n! NEW CODE, loop over all quads\r\n qsub: do q1=1,ncon\r\n! Entropy from sublattices\r\n tsub=zero\r\n! replace dsub with dvvv\r\n s7=0\r\n quady: do s1=1,4\r\n! Entropy contribution from sublattice constituents for the quad\r\n s7=s7+1\r\n s2=mqmqa_data%contyp(10+s1,q1)\r\n fqq=one\r\n if(s2.gt.0) then\r\n! Specie in first sublattice >0, if a single species fqq=2\r\n if(mqmqa_data%contyp(1,q1).eq.2) fqq=2.0d0\r\n tsub=tsub+fqq*log(yy1(s2))/mqmqa_data%constoi(s7,q1)\r\n! write(*,700)'3X ssub1: ',q1,s1,s2,s7,tsub,&\r\n! fqq*log(yy1(s2))/mqmqa_data%constoi(s7,q1),fqq,yy1(s2),&\r\n! mqmqa_data%constoi(s7,q1)\r\n700 format(a,4i3,2(1pe12.4),4(0PF10.6))\r\n! the derivative of fqq*log(yy1(s2))/mqmqa_data%constoi wrt all quads!\r\n do s3=1,ncon\r\n dvvv(s3,q1)=dvvv(s3,q1)+&\r\n fqq*dyy1(s2,s3)/(yy1(s2)*mqmqa_data%constoi(s7,q1))\r\n! write(*,706)'3X dvvv1: ',q1,s2,s3,dvvv(s3,q1)\r\n706 format(a,3i3,4(1pe12.4))\r\n enddo\r\n elseif(s2.lt.0) then\r\n! if a single species in second sublattice fqq=2\r\n if(mqmqa_data%contyp(s1,q1).eq.2) fqq=2.0d0\r\n tsub=tsub+log(yy2(-s2))/mqmqa_data%constoi(s7,q1)\r\n! the derivative of fqq*log(yy2(s2))/mqmqa_data%constoi wrt all quads!\r\n do s3=1,ncon\r\n dvvv(s3,q1)=dvvv(s3,q1)+&\r\n fqq*dyy2(-s2,s3)/(yy2(-s2)*mqmqa_data%constoi(s7,q1))\r\n! write(*,706)'3X dvvv2: ',q1,s2,s3,dvvv(s3,q1)\r\n enddo\r\n else\r\n! no more sublattice constituents\r\n exit quady\r\n endif\r\n! exit if this is a pair\r\n if(mqmqa_data%contyp(5,q1).gt.0) exit quady\r\n enddo quady\r\n! first derivatives, dSsub/dquad\r\n lsub(q1)=tsub\r\n ssub=ssub+phvar%yfr(q1)*tsub\r\n! write(*,702)'3X ssub2: ',q1,ssub,phvar%yfr(q1),tsub\r\n702 format(a,i3,5(1pe12.4))\r\n enddo qsub\r\n! correct first derivatives with respect to quads using dvvv\r\n! do q1=1,ncon\r\n! write(*,701)'3X dvvv: ',(dvvv(s1,q1),s1=1,ncon)\r\n! enddo\r\n do q1=1,ncon\r\n dssub(q1)=lsub(q1)\r\n! add on all derivatives wrt q1 from other entropy terms \r\n do s1=1,ncon\r\n dssub(q1)=dssub(q1)+phvar%yfr(s1)*dvvv(s1,q1)\r\n enddo\r\n enddo\r\n! OK here\r\n! write(*,701)'3X dssub: ',(dssub(q1),q1=1,ncon)\r\n! write(*,701)'3X SSUB:',ssub,ssub*phvar%amfu,phvar%amfu,phvar%abnorm(1),&\r\n! phvar%amfu*phvar%abnorm(1)\r\n701 format(a,6(1pe12.4))\r\n! stop\r\n600 format(a,1pe12.4,2x,6(1pe10.2))\r\n!===============\r\n! skip the pair and quad contributions\r\n! write(*,*)'3X Done sublattice entropy, skipping rest',squad\r\n! goto 900\r\n!\r\n!-------------------------------------------------------\r\n! pair entropy\r\n send=zero; dsend=zero\r\n quadcef: do q1=1,ncon\r\n tend=zero\r\n! loop of all pairs of this quad\r\n s1=5\r\n! allpairs: do while(.TRUE. .and. s1.lt.10)\r\n allpairs: do while(.TRUE. .and. s1.lt.9)\r\n! mqmqa_data%contyp(5,q1) is nonzero if the quad is a pair\r\n s2=mqmqa_data%contyp(s1,q1)\r\n if(s1.eq.5 .and. s2.ne.0) then\r\n! the quad q1 is a pair with index s2, only one calculation with s2=q1\r\n fqq=4.0D0\r\n s1=10\r\n else\r\n s1=s1+1\r\n s2=mqmqa_data%contyp(s1,q1)\r\n! s2 is now the index a pair in this SNN quad is in %contyp(6..9,q1) \r\n! exit here ifthere is no pair\r\n if(s2.eq.0) exit allpairs\r\n! fqq depends on q1\r\n fqq=1.0D0\r\n if(mqmqa_data%contyp(1,q1).eq.2) then\r\n fqq=2.0D0\r\n elseif(mqmqa_data%contyp(3,q1).eq.-2) then\r\n fqq=2.0D0\r\n endif\r\n endif\r\n! Here s2 is a pair of the quadrupole q1. The pair fraction is pair(s2)\r\n! which should be divided by ceqf1(1,s2)*ceqf2(2,s2)\r\n! The logarithm should be multiplied by qfnnsnn for the pair. no more??\r\n! Entropy: quadfrac*\\sum_s2 fqq*ln( pair(s2)/v_s2k/(w_i w_k))/%qfnnsnn(s2)\r\n! MAYBE save values of \"pair/(ceqf1*ceqf2)\" and derivaties for later use??\r\n! REMEMBER ceqf1 is equivalent sublattice fraction ... what is eij(1,s2)??\r\n! eij(1..2,s2) are species in first and second sublattice of the pair\r\n! BUT they are now in %contype(11,s2) and %contyp(12,s2) ???\r\n! KEEP eij as it is used as link from pair to sublattice constituents\r\n! write(*,'(a,i3,2x,2i3,2x,2i3)')'3X keep eij?: ',s2,eij(1,s2),&\r\n! eij(2,s2),mqmqa_data%contyp(11,s2),mqmqa_data%contyp(12,s2)\r\n ee=eij(1,s2); gg=-eij(2,s2)\r\n dq1=ceqf1(ee)*ceqf2(gg)\r\n mulceq(s2)=dq1\r\n endkvot(s2)=pair(s2)/dq1\r\n fqq=fqq/mqmqa_data%qfnnsnn(s2)\r\n! >>>>>>>>>>>>>>>> ............. EQUATION B21 2nd line first half\r\n! This is the entropy contribution from a pair of this quad\r\n! %qfnnsnn is read from database\r\n! %dfnnsnn can be different for different pairs, composition dependence???\r\n! But it should be a sum? or is that taken care of by the sum over p_AB/XY ??\r\n tend=tend+fqq*log(endkvot(s2))\r\n! write(*,421)'3X pairs: ',q1,s1,s2,tend,endkvot(s2),&\r\n! fqq/mqmqa_data%qfnnsnn(s2),fqq,mqmqa_data%qfnnsnn(s2)\r\n421 format(a,3i3,5(1pe11.3))\r\n! first derivatives, note multiplied by p_AB/XY ....\r\n do s3=1,ncon\r\n if(s3.eq.q1) dsend(s3)=dsend(s3)+fqq*log(endkvot(s2))\r\n dsend(s3)=dsend(s3)+fqq/endkvot(s2)*(&\r\n dpair(s2,q1)/(mulceq(s2))**2-&\r\n 2.0d0*pair(s2)/mulceq(s2)**4*(&\r\n ceqf1(ee)*dceqf2(gg,q1)+dceqf1(ee,q1)*ceqf2(gg)))\r\n! skip 2nd derivatives ...\r\n enddo\r\n enddo allpairs\r\n! Finally we must multiply the tend with the quad fraction\r\n send=send+phvar%yfr(q1)*tend\r\n! derivatives of send wrt quad\r\n enddo quadcef\r\n!\r\n! ternary error before this\r\n! write(*,600)'3X SEND: ',send,(dsend(s1),s1=1,ncon)\r\n!========================================================================\r\n! skip quad entropies\r\n! write(*,*)'3X done pair entropies'\r\n! write(*,*)'3X skipping quad entropies'\r\n! goto 900\r\n!========================== begin loop for all quads\r\n! write(*,*)'3X quadropole entropies:'\r\n! do s1=1,noofpair\r\n! write(*,440)'3X dpair/dq: ',q1,(dpair(s1,s2),s2=1,ncon)\r\n! enddo\r\n440 format(a,i2,6(1pe10.2),(/20x,6e10.2))\r\n squad=zero; dsquad=zero\r\n! replaced s1 by q1\r\n quadloop: do q1=1,ncon\r\n if(q1.ne.mqmqa_data%contyp(10,q1)) then\r\n! TEST: the value in contyp(10,q1) should be q1 ... 260111/BoS WHY??\r\n write(*,441)q1,mqmqa_data%contyp(10,q1),mqmqa_data%contyp(14,q1)\r\n441 format('3X problems in %contyp with quad indexing:',3i5)\r\n! gx%bmperr=4399; goto 1000\r\n endif\r\n lsub=zero\r\n! New code for the general case\r\n! p_i\r\n! p_i * log( ------------------------------------)\r\n! xi_A/X*xi_B/X*xi_B/X*xi_B/Y\r\n! ---------------------------\r\n! w_A * w_B * w_X * w_Y\r\n!\r\n s1=mqmqa_data%contyp(5,q1)\r\n if(s1.gt.0) then\r\n! this is a pair\r\n pair1=s1\r\n pair2=pair1\r\n pair3=pair1\r\n pair4=pair1\r\n ee=eij(1,pair1)\r\n ff=ee\r\n gg=-eij(2,pair1)\r\n hh=gg\r\n! before adding this write statement hh was sometines not same as gg\r\n! as it should be SUCK\r\n! write(*,*)'3X gg hh: ',gg,hh,ceqf2(gg),ceqf2(hh)\r\n fqq=one\r\n! write(*,'(a,10i3)')'3X quad1: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh\r\n elseif(mqmqa_data%contyp(9,q1).eq.0) then\r\n! here either ee=ff or gg=hh\r\n pair1=mqmqa_data%contyp(6,q1)\r\n pair2=pair1\r\n ee=eij(1,pair1)\r\n gg=-eij(2,pair1)\r\n pair3=mqmqa_data%contyp(7,q1)\r\n pair4=pair3\r\n ff=eij(1,pair3)\r\n hh=-eij(2,pair3)\r\n fqq=2.0d0\r\n! write(*,'(a,10i3)')'3X quad2: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh\r\n else\r\n! all ee, ff, gg, hh should be different, not certain if they are\r\n pair1=mqmqa_data%contyp(6,q1)\r\n ee=eij(1,pair1)\r\n gg=-eij(2,pair1)\r\n pair2=mqmqa_data%contyp(7,q1)\r\n ff=eij(1,pair2)\r\n hh=-eij(2,pair2)\r\n pair3=mqmqa_data%contyp(8,q1)\r\n if(ee.eq.ff) ff=eij(1,pair3)\r\n if(gg.eq.hh) hh=-eij(2,pair3)\r\n pair4=mqmqa_data%contyp(9,q1)\r\n fqq=4.0D0\r\n! write(*,'(a,10i3)')'3X quad4: ',q1,pair1,pair2,pair3,pair4,ee,ff,gg,hh\r\n endif\r\n!\r\n! write(*,'(a,8F8.4)')'3X quadx: ',pair(pair1),ceqf1(ee),&\r\n! pair(pair2),ceqf1(ff),pair(pair3),ceqf2(gg),pair(pair4),ceqf2(hh)\r\n pairceq=fqq*pair(pair1)/ceqf1(ee)*pair(pair2)/ceqf1(ff)*&\r\n pair(pair3)/ceqf2(gg)*pair(pair4)/ceqf2(hh)\r\n! write(*,'(a,9i3,1pe12.4)')'3X quadx: ',q1,pair1,pair2,pair3,pair4,&\r\n! ee,ff,gg,hh,pairceq\r\n!\r\n squad=squad+phvar%yfr(q1)*log(phvar%yfr(q1)/pairceq)\r\n! write(*,440)'3X squad: ',q1,squad,phvar%yfr(q1),pairceq\r\n!\r\n! New code for the general case\r\n! p_i\r\n! p_i * log( ------------------------------------)\r\n! xi_A/X*xi_B/X*xi_B/X*xi_B/Y\r\n! ---------------------------\r\n! w_A * w_B * w_X * w_Y\r\n!\r\n! loop for derivatives\r\n do s1=1,ncon\r\n if(s1.eq.q1) lsub(s1)=log(phvar%yfr(q1)/pairceq)+one\r\n if(s1.eq.q1) dsquad(s1)=dsquad(s1)+log(phvar%yfr(q1)/pairceq)+one\r\n! derivative for just q1 is OK\r\n lsub(s1)=lsub(s1)-phvar%yfr(q1)*&\r\n (dpair(pair1,s1)/pair(pair1)+dpair(pair2,s1)/pair(pair2)+&\r\n dpair(pair3,s1)/pair(pair3)+dpair(pair4,s1)/pair(pair4)-&\r\n dceqf1(ee,s1)/ceqf1(ee)-dceqf1(ff,s1)/ceqf1(ff)-&\r\n dceqf2(gg,s1)/ceqf2(gg)-dceqf2(hh,s1)/ceqf2(hh))\r\n! Skipping this means I ignore effect of variable fracrion on pair and ceqf\r\n! dsquad(s1)=dsquad(s1)-phvar%yfr(q1)*&\r\n! (dpair(pair1,s1)/pair(pair1)+dpair(pair2,s1)/pair(pair2)+&\r\n! dpair(pair3,s1)/pair(pair3)+dpair(pair4,s1)/pair(pair4)-&\r\n! dceqf1(ee,s1)/ceqf1(ee)-dceqf1(ff,s1)/ceqf1(ff)-&\r\n! dceqf2(gg,s1)/ceqf2(gg)-dceqf2(hh,s1)/ceqf2(hh))\r\n! skip 2nd derivatives\r\n! write(*,440)'3X lsub: ',s1,(lsub(s2),s2=1,ncon)\r\n enddo\r\n! write(*,440)'3X SQUAD: ',q1,squad,(dsquad(s1),s1=1,ncon)\r\n enddo quadloop\r\n!\r\n! write(*,600)'3X SQUAD: ',squad,(dsquad(s1),s1=1,ncon)\r\n! first derivatives are wrong ....\r\n! dsquad=zero\r\n! write(*,*)'3X done quad derivatives'\r\n! goto 900\r\n!\r\n!***********************************************************************\r\n900 continue\r\n! we have multiplied with amounts above, (?) set invnorm=one\r\n! write(*,*)'3X second derivatives are approximate. Atoms/FU: ',invnorm\r\n! Values should be per formula unit!\r\n invnorm=one\r\n! store results in appropriate places, values divided by RT\r\n! This is G/RT\r\n phvar%gval(1,1)=phvar%gval(1,1)+invnorm*(ssub+send+squad)\r\n! derivative of G wrt T, i.e. -S/R\r\n phvar%gval(2,1)=phvar%gval(2,1)+invnorm*(ssub+send+squad)/tval\r\n if(moded.gt.0) then\r\n! This is if first derivatives are requested (must be exact)\r\n! write(*,*)'3X start quad loop'\r\n do s1=1,ncon\r\n phvar%dgval(1,s1,1)=phvar%dgval(1,s1,1)+&\r\n invnorm*(dssub(s1)+dsend(s1)+dsquad(s1))\r\n phvar%dgval(2,s1,1)=phvar%dgval(2,s1,1)+&\r\n invnorm*(dssub(s1)+dsend(s1)+dsquad(s1))/tval\r\n if(moded.gt.1) then\r\n! this is if second derivatives are requested\r\n! do s2=s1,ncon\r\n! phvar%d2gval(ixsym(s1,s2),1)=phvar%d2gval(ixsym(s1,s2),1)+&\r\n! invnorm*d2sm1(ixsym(s1,s2))\r\n! enddo\r\n! We just set 1/quad\r\n dummy1=phvar%yfr(s1)\r\n if(dummy1.lt.1.0D-12) dummy1=1.0D-12\r\n phvar%d2gval(ixsym(s1,s1),1)=one/dummy1\r\n endif\r\n enddo\r\n! write(*,*)'3X done quad loop'\r\n! write(*,431)'3X dS/Rq :',(phvar%dgval(1,s1,1),s1=1,ncon)\r\n! write(*,431)'3X d2S/Rq2:',(phvar%d2gval(s1,1),s1=1,all2)\r\n431 format(a,6(1pe12.4),(/6x,6e12.4))\r\n endif\r\n! mqf=>phvar%mqmqaf ??\r\n! write(*,*)'3X pair do loop npair: ',phvar%mqmqaf%npair\r\n! write(*,*)'3X pair do loop mqf%pair: ',allocated(phvar%mqmqaf%pair)\r\n! write(*,'(a,3(1pe14.6))')'3X MQMQA:',phvar%gval(1,1),&\r\n! phvar%gval(1,1)*8.31451,phvar%gval(1,1)*8.31451*phvar%amfu\r\n! replace pair by cpair to handle endmembers\r\n! Creates problems calculating the entropy in this routine ... SUCK\r\n! write(*,*)'3X pair do loop mqf%dpair: ',allocated(phvar%mqmqaf%dpair)\r\n do s1=1,phvar%mqmqaf%npair\r\n phvar%mqmqaf%pair(s1)=cpair(s1)\r\n do s2=1,ncon\r\n phvar%mqmqaf%dpair(s1,s2)=dcpair(s1,s2)\r\n! converge problems, maybe use dp?\r\n! mqf%dpair(s1,s2)=dp(s1,s2)\r\n enddo\r\n enddo\r\n if(ddebug) write(*,*)'3X Done MQMQA configurational entropy'\r\n! TEST temporary fix\r\n! do s1=1,mqf%npair\r\n! write(*,'(a,F9.6,2x,10F10.6)')'3X cpair: ',mqf%pair(s1),&\r\n! (mqf%dpair(s1,s2),s2=1,mqf%nquad)\r\n! enddo\r\n!\r\n1000 continue\r\n return\r\n end subroutine config_entropy_mqmqa1\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n \r\n!\\addtotable subroutine calc_mqmqa\r\n!\\begin{verbatim}\r\n subroutine calc_mqmqa(lokph,phres,ceq)\r\n! Called from calcg_internal to calculate nonconfig G for the mqmqa phase\r\n! another subroutine calculates the entropy using all data in phres%mqf\r\n implicit none\r\n integer lokph\r\n type(gtp_phase_varres), pointer :: phres\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n! Most variables here are the same as in calcg_internal ...\r\n integer, parameter :: f1=50\r\n integer mqmqj,kend,s1,s2,s3,id,nofc2,ipy,lokfun,typty,itp,zp,nrealem,mqendx\r\n double precision vals(6),pyq,rtg,aff\r\n double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:)\r\n double precision, dimension(:,:), allocatable :: dvals(:,:),affarr(:)\r\n! for saving FNN reference energies\r\n double precision refg(f1,f1)\r\n double precision dummy1,dummy2\r\n! for MQMQA minimal fractions\r\n double precision, parameter :: MINMQMQA=1.0D-5\r\n TYPE(gtp_parcalc) :: gz\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_endmember), pointer :: endmemrec\r\n TYPE(gtp_interaction), pointer :: intrec\r\n TYPE(gtp_pystack), pointer :: pystack\r\n TYPE(gtp_phase_add), pointer :: addrec\r\n TYPE(gtp_mqmqa_var), pointer :: mqf\r\n TYPE(gtp_tooprec), pointer :: tooprec\r\n! for handling excess parameters, just binary, use no mqmqa_data ksi arrays\r\n integer ij,jd,jq,qq1,qq2,ass,mpow,isumx,tsize,tch,iiz,mqmqcon,mqmqjy\r\n integer noofex,nqx,ncv,icv,dd\r\n double precision ksi,sumx,dsumx\r\n double precision dksi(3),d2ksi(3)\r\n! logical calc_alldvkij\r\n! logical ddebug\r\n logical :: oldmqmqa_model = .true.\r\n! save oldmqmqa_model\r\n!------------------------------------- \r\n! tch is level of debug output, 0=none, 3=max\r\n tch=0\r\n noofex=0\r\n! calc_alldvkij=.TRUE.\r\n! ddebug=.FALSE.\r\n! ddebug=.TRUE.\r\n if(tch.ge.1) write(*,*)'3XQ in calc_mqmqa nonconfig G'\r\n gz%nofc=phlista(lokph)%tnooffr\r\n nofc2=gz%nofc*(gz%nofc+1)/2\r\n! write(*,*)'3X allocating:',gz%nofc,nofc2\r\n allocate(dpyq(gz%nofc))\r\n allocate(d2pyq(nofc2))\r\n allocate(dvals(3,gz%nofc))\r\n allocate(d2vals(nofc2))\r\n! this shortcut may be bad - but it works ---------------------------------\r\n! write(*,*)'3XQ assigning mqf pointer'\r\n mqf=>phres%mqmqaf\r\n! write(*,*)'3XQ assigning mqf pointer OK'\r\n!-------------------\r\n allocate(affarr(mqf%npair))\r\n affarr=zero\r\n nullify(pystack)\r\n rtg=globaldata%rgas*ceq%tpval(1)\r\n! do s1=1,mqmqa_data%nconst\r\n! write(*,599)s1,(mqmqa_data%contyp(s2,s1),s2=1,14)\r\n!599 format('3XQ contyp 7: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3)\r\n! enddo\r\n nrealem=0\r\n! refg=zero\r\n dummy2=zero\r\n! list %pp\r\n! %pp( quad , FNN index )\r\n! do mqmqj=1,mqmqa_data%nconst\r\n! write(*,17)'3XQ %pp: ',mqmqj,(mqmqa_data%pp(s1,mqmqj),s1=1,4)\r\n! enddo\r\n!17 format(a,i3,4(1pe12.4))\r\n!--------------------------------------\r\n! Trying to understand the data structure. List all species and some data\r\n! do mqmqj=1,noofsp\r\n! write(*,13)mqmqj,splista(mqmqj)%symbol,splista(mqmqj)%alphaindex,&\r\n! splista(mqmqj)%quadindex\r\n!13 format('3XQ specie: ',i3,2x,a,2x,5i5)\r\n! enddo\r\n!--------------------------------------\r\n! debug output of varkappa mm moved to beginning of calc_mqmqa\r\n if(mqmqxcess .and. btest(phlista(lokph)%status1,PHMQMQX)) then\r\n write(*,*)'3XQ Debug output of quads, \\varkappa_ij, \\xi_ij and y_i/k'\r\n!\r\n! these variables are in the TYPE GTP_MQMQA_VAR\r\n nqx=mqmqa_data%nquad\r\n write(*,82)nqx\r\n82 format('3XQ Quad fractions:',i3)\r\n write(*,84)(mqf%xquad(icv),icv=1,nqx)\r\n84 format((8F8.5))\r\n ncv=size(mqf%compvar)\r\n write(*,78)ncv\r\n78 format('3XQ varkappa_ij varkappa_ji xi_ij xi_ji',i12)\r\n! 123456789.123456123456789.123456.....123456789.123456123456789.123456\r\n do icv=1,ncv\r\n write(*,80)mqf%compvar(icv)%vk_ij,mqf%compvar(icv)%vk_ji,&\r\n mqf%compvar(icv)%xi_ij,mqf%compvar(icv)%xi_ji\r\n80 format(2x,2(1pe16.8),5x,2(1pe16.8))\r\n enddo\r\n! write(*,86)mqmqa_data%ncat,(mqf%y_ik(icv),icv=1,mqmqa_data%ncat)\r\n!86 format(/'3XQ y_i/k ',i2,': ',(7F9.6))\r\n! do icv=1,ncv\r\n! write(*,80)mqf%compvar(icv)%vk_ij,mqf%compvar(icv)%vk_ji,&\r\n! mqf%compvar(icv)%xi_ij,mqf%compvar(icv)%xi_ji\r\n!80 format(2x,2(1pe16.8),5x,2(1pe16.8))\r\n! enddo\r\n! \r\n if(mqmqder) then\r\n write(*,*)'3XQ 2215 Derivatives of vk_ij relative to quads',ncv\r\n do icv=1,ncv\r\n write(*,79)'ij',(mqf%compvar(icv)%dvk_ij(dd),dd=1,nqx)\r\n write(*,79)'ji',(mqf%compvar(icv)%dvk_ji(dd),dd=1,nqx)\r\n79 format('3XQ dvk',a,10(1pe12.4))\r\n enddo\r\n write(*,86)mqmqa_data%ncat,(mqf%y_ik(icv),icv=1,mqmqa_data%ncat)\r\n86 format(/'3XQ y_i/k:',i2,3x,7F9.6)\r\n endif\r\n endif\r\n!--------------------------------------\r\n! first loop over ALL endmembers\r\n mqmqj=0\r\n endmemrec=>phlista(lokph)%ordered\r\n! This should be number of atoms for scaling G\r\n! dummy1=phres%abnorm(1)/rtg this was OK before ...\r\n dummy1=one/rtg\r\n! %amfu * %abnorm(1) is number of moles in the liquid\r\n! in the test case we have 6 atoms in the liquid phase\r\n! dummy1=6.0D0/rtg\r\n! dummy1=one/(phres%abnorm(1)*rtg)\r\n! write(*,'(a,3(1pe14.6))')'3XQ mqmqa scaling: ',dummy1,&\r\n! phres%amfu,phres%abnorm(1)\r\n! This first loop: all endmember parameters\r\n! this can give SRO contribution and excess from SNN parameters\r\n! or it makes it possible to calculate the G for the FNN parameters\r\n endmemloop1: do while(associated(endmemrec))\r\n mqmqj=mqmqj+1\r\n if(mqmqj.gt.mqmqa_data%nconst) exit endmemloop1\r\n! We do not know if mqmqj is associated with this endmember!!\r\n! there can be gaps in the endmember list?? \r\n! we must take kend from the endmember record, it is sored in %antalem\r\n mqendx=endmemrec%antalem\r\n kend=mqmqa_data%contyp(5,mqendx)\r\n! write(*,*)'3XQ endmemloop1A: ',mqmqj,mqendx,kend,nrealem\r\n if(kend.le.0) then\r\n! This is an SNN parameter we calculate and add SNN energy and interactions ...\r\n! write(*,*)'3XQ SNN endmember record found',mqmqj\r\n proprec=>endmemrec%propointer\r\n mqsnn: do while(associated(proprec))\r\n! This loop is not really necessay, in mqmqa the only property is G at present\r\n typty=proprec%proptype\r\n if(typty.ne.1) stop '3XQ illegal typty in mqmqa model'\r\n ipy=1\r\n lokfun=proprec%degreelink(0)\r\n call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,'(a,2i3,2(1pe12.4))')'3XQ SNN endmember',mqmqj,kend,&\r\n! pyq,vals(1)\r\n! write(*,'(a,6(1Pe12.4))')'3XQ vals1:',vals\r\n if(ipy.eq.1) then\r\n vals=vals*dummy1\r\n! This is an SNN ordering parameter, reference state addel in second loop\r\n endif\r\n pyq=phres%yfr(mqmqj)\r\n! Should I use any factor??\r\n! aff=mqmqa_data%pp(1,mqmqj)\r\n aff=one\r\n! NOTE the reference state contribution to this SNN added in next loop\r\n! for all quads!!\r\n do itp=1,3\r\n phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+vals(itp)\r\n enddo\r\n! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation\r\n! ipy is property, ipy=1 means G, ipy=2 means Curie T etc.\r\n! %gval(1,1) is total G, %gval(2,1) is total dG/dT etc.\r\n do itp=1,6\r\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp)\r\n enddo\r\n! write(*,210)'3XQ SRO G, dG/dqi: ',mqmqj,mqmqj,pyq,aff,&\r\n! phres%gval(1,1),(phres%dgval(1,s1,1),s1=1,gz%nofc)\r\n proprec=>proprec%nextpr\r\n enddo mqsnn\r\n!600 continue\r\n! write(*,*)'3XQ any excess parameters will be handled in 3rd loop'\r\n endmemrec=>endmemrec%nextem\r\n cycle endmemloop1\r\n endif\r\n! This is an FNN parameter, we calculate and save the value for later use\r\n nrealem=nrealem+1\r\n! write(*,*)'3XQ endmemloop1B: ',mqmqj,kend,nrealem\r\n proprec=>endmemrec%propointer\r\n aff=one/mqmqa_data%pp(1,mqmqj)\r\n mq1: do while(associated(proprec))\r\n typty=proprec%proptype\r\n if(typty.ne.1) stop 'illegal typty in mqmqa model'\r\n ipy=1\r\n lokfun=proprec%degreelink(0)\r\n call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! write(*,'(a,i3,F7.4,3(1Pe10.2))')'3XQ refg:',mqmqj,aff,vals(1),vals(2)\r\n! we should divide this by the aff of this pair and we will multiply this\r\n! FNN same aff but SNN fractions linking to this pair use another aff\r\n! write(*,'(a,2i3,2(1pe12.4))')'3XQ FNN endmember',mqmqj,kend,&\r\n! pyq,vals(1)\r\n if(ipy.eq.1) then\r\n vals=vals*dummy1*aff\r\n! save values of reference state for use with SNN parameters ??\r\n! kend is FNN (pair) index \r\n do s1=1,6\r\n refg(kend,s1)=vals(s1)\r\n enddo\r\n endif\r\n! next property record (should not be any ...)\r\n proprec=>proprec%nextpr\r\n if(associated(proprec)) then\r\n write(*,*)'3XQ Warning: ignoring second mqmqa property recotd!'\r\n endif\r\n! write(*,200)'3XQ FNN G, dG/dqi: ',phres%gval(1,1),&\r\n! (phres%dgval(1,s1,1),s1=1,gz%nofc)\r\n200 format(a,1pe12.4,2x,6(1pe12.4))\r\n enddo mq1\r\n endmemrec=>endmemrec%nextem\r\n enddo endmemloop1\r\n! write(*,*)'3XQ finished endmemloop1'\r\n!--------------------------------------------------- end first endmember loop\r\n! All endmembers with a single element in each sublattice must have a parameter\r\n! these are counted above in endmemloop1\r\n! write(*,'(a,3i3)')'3XQ number of sublattice constituents and FNN: ',&\r\n! mqf%ns1,mqf%ns2,nrealem\r\n if(nrealem.ne.mqf%ns1*mqf%ns2) then\r\n! This test is not foolproof one can enter an interaction parameter\r\n! which creates an empty endmember record but that seems crazy\r\n write(*,216)mqf%ns1*mqf%ns2,nrealem\r\n216 format('Some FNN constituents (A/X) have no parameter!, should be',&\r\n i3,' found only ',i3)\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! second loop over all constutents (quads), ignore FNN endmember records\r\n! but add reference state parameters to all SNN and reciprocal constituents\r\n ipy=1\r\n if(tch.ge.3) write(*,*)'3XQ adding reference to SNN endmembers'\r\n qloop: do mqmqj=1,gz%nofc\r\n! this is quad fraction, multiply with all FNN reference energies\r\n pyq=phres%yfr(mqmqj)\r\n zp=mqmqa_data%contyp(5,mqmqj)\r\n pair: if(zp.gt.0) then\r\n! this is an FNN pair, reference energy in refg(zp,1..6), only one y derivative\r\n! %pp(1..4,mqmqj) is stoichiometric factor for the pair\r\n aff=mqmqa_data%pp(1,mqmqj)\r\n do itp=1,3\r\n phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+&\r\n aff*refg(zp,itp)\r\n enddo\r\n! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation\r\n do itp=1,6\r\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*aff*refg(zp,itp)\r\n enddo\r\n! write(*,205)'3XQ FNN: qix, FNN, aff, pyq, fun, DG: ',mqmqj,zp,aff,&\r\n! pyq,refg(zp,1),pyq*aff*refg(zp,1)\r\n205 format(a,2i3,F8.5,2x,3(1pe12.4))\r\n if(tch.ge.3) &\r\n write(*,210)'3XQ FNN G: ',mqmqj,mqmqj,pyq,aff,pyq,phres%gval(1,1)\r\n210 format(a,2i3,2F8.5,1pe12.4,2x,6(1pe10.2))\r\n else\r\n! this is an SNN with two or more pairs\r\n! For each SNN pair add the contribution to the FNN reference state\r\n! %contyp(1..4,mqmqj) is index of FNN reference energy\r\n if(tch.ge.3) write(*,'(a,i3,1x,4i3,4F8.5)')'3XQ pp2: ',mqmqj,&\r\n (mqmqa_data%contyp(s1,mqmqj),s1=6,9),&\r\n (mqmqa_data%pp(s1,mqmqj),s1=1,4)\r\n snnloop: do s1=6,9\r\n! zp is index to an FNN record, there can be 2 or 4 FNN records\r\n zp=mqmqa_data%contyp(s1,mqmqj)\r\n if(zp.eq.0) exit snnloop\r\n! %pp(1..4,mqmqj) is stoichiometric factor for the pair\r\n aff=mqmqa_data%pp(s1-5,mqmqj)\r\n! write(*,211)1,mqmqj,ipy,phres%dgval(1,mqmqj,ipy)\r\n211 format('3XQ SNN dG/dy:',3i3,1(1pe12.4))\r\n do itp=1,3\r\n phres%dgval(itp,mqmqj,ipy)=phres%dgval(itp,mqmqj,ipy)+&\r\n aff*refg(zp,itp)\r\n enddo\r\n! write(*,212)zp,mqmqj,ipy,phres%dgval(1,mqmqj,ipy),aff,aff*refg(zp,1)\r\n212 format('3XQ SNN dG/dy reference added:',3i3,3(1pe12.4))\r\n! Initially ignore 2nd derivatives, d2G/dy2=1/y set by entropy calculation\r\n if(tch.ge.3) write(*,213)s1,zp,mqmqj,ipy,pyq,aff,phres%gval(1,ipy)\r\n213 format('3XQ SNN G ref:',4i3,2F10.5,1pe12.4)\r\n do itp=1,6\r\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*aff*refg(zp,itp)\r\n enddo\r\n! write(*,214)zp,mqmqj,ipy,phres%gval(1,ipy),pyq,aff,aff*refg(zp,1)\r\n! write(*,214)zp,mqmqj,ipy,phres%gval(1,ipy),pyq,aff,refg(zp,1)*rtg\r\n214 format('3XQ SNN G ref added:',3i3,4(1pe12.4))\r\n! write(*,205)'3XQ SNN: qix, FNN, aff, pyq, fun, DG: ',mqmqj,zp,aff,&\r\n! pyq,refg(zp,1),pyq*aff*refg(zp,1)\r\n! (phres%dgval(1,s2,1),s2=1,gz%nofc)\r\n enddo snnloop\r\n endif pair\r\n enddo qloop\r\n if(tch.ge.3) write(*,*)'3XQ finished loop for endmembers'\r\n! if this goto then excess is ignored and result correct\r\n! write(kou,299)\r\n299 format('3QX endmember energy and entropy calculated, excess to be done')\r\n! goto 800\r\n!---------------------------------------------------------------------\r\n! code below needed for excess parameters ONLY, all SNN FNN endmembers done\r\n! NOTE some of them may not have a reference energy parameter\r\n! This is to allocate csumx for handling quads with small fractions.\r\n isumx=0\r\n! debug output of G for check of excess\r\n if(mqmqxcess) then\r\n write(*,288)(phres%gval(itp,1),itp=1,4)\r\n288 format(/'3XQ line 1439 before excess:'/'G, dG/dT dG/dP d2G/dT2:',&\r\n 4(1pe14.6))\r\n endif\r\n!\r\n mqmqj=0\r\n endmemrec=>phlista(lokph)%ordered\r\n endmemloop2: do while(associated(endmemrec))\r\n if(mqmqj.gt.0) endmemrec=>endmemrec%nextem\r\n mqmqj=mqmqj+1\r\n if(tch.ge.3) write(*,*)'3XQ endmemloop2:',&\r\n mqmqj,mqmqa_data%nconst,associated(endmemrec)\r\n if(mqmqj.gt.mqmqa_data%nconst .or. .not.associated(endmemrec)) then\r\n exit endmemloop2\r\n endif\r\n kend=mqmqa_data%contyp(5,mqmqj)\r\n if(tch.ge.3) write(*,311)mqmqj,mqmqa_data%nconst,kend,&\r\n associated(endmemrec%intpointer)\r\n311 format(/'3XQ in loop for excess parameters: ',3i5,l2)\r\n intrec=>endmemrec%intpointer\r\n! interaction parameters are NOT linked from SNN endmembers ?? really?\r\n! They are stored in alphabetical order of the constituents\r\n! write(*,*)'3XQ Check interaction parameters 1',associated(endmemrec),&\r\n! associated(intrec),mqmqj,kend\r\n! if we cycle here the results are the same as without excess parameters\r\n! cycle endmemloop2\r\n!\r\n if(.not.associated(intrec)) then\r\n cycle endmemloop2\r\n endif \r\n if(.not.btest(phlista(lokph)%status1,PHMQMQX)) then\r\n! this is the first MQMQA implementation with correct reference energy and\r\n! configurational entropy but very messy Toop/Kohler implementation\r\n goto 499\r\n endif\r\n!\r\n! THIS IS NEW EXCESS MQMQA CODE\r\n!\r\n! if(mqmqxcess) then\r\n! if parameter errors in interactions below these are the endmemberquads A/X\r\n! write(*,313)(mqmqa_data%emquad(iiz),iiz=1,mqmqa_data%ncat)\r\n313 format('3XQ endmember quads: ',15i3)\r\n! endif\r\n! \r\n! mqmqj is NOT the mqmqa constituent index, it is just an endmember counter\r\n! look for the constituent in fraction record, sublattice 1, constituent 1\r\n! WOW !!!! it does not crash\r\n mqmqjy=endmemrec%fraclinks(1,1)\r\n!\r\n! we must find its position in the quad list \r\n! write(*,314)mqmqj,mqmqjy,size(phlista(lokph)%constitlist)\r\n! associated(endmemrec%oendmemarr),associated(endmemrec%dendmemarr)\r\n314 format(/'3XQ endmember data: ',3i3)\r\n! write(*,315)phlista(lokph)%constitlist\r\n315 format('3XQ constituents: ',20i3)\r\n! \r\n if(mqmqxcess) write(*,318)phres%gval(1,ipy),&\r\n (phres%dgval(1,jq,ipy),jq=1,gz%nofc)\r\n!\r\n! if(calc_alldvkij) then\r\n! calculate partial derivatives of all vk_ij etc\r\n! call calc_newdvkij_values(phres,ceq)\r\n! calc_alldvkij=.FALSE.\r\n! endif\r\n!\r\n noofex=noofex+1\r\n if(mqmqxcess) write(*,*)'3XQ excess with endmember constituent: ',&\r\n mqmqjy,ipy\r\n! write(*,316)mqmqjy,ipy\r\n call new_mqmqa_excess(lokph,intrec,mqmqjy,vals,dvals,d2vals,gz,ceq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n!------------- important --------------------\r\n! vals, dvals and d2vals is the SUM OF ALL EXCESS parameters for this endmember\r\n! gz is pointer to gtp_parcalc .... for phases with parameter permutations\r\n!------------- important --------------------\r\n if(mqmqxcess) write(*,316)mqmqjy,ipy,vals(1)\r\n316 format('3XQ endmember excess: ', 2i5,' calculated: ',1pe12.4)\r\n! intrec is nullified inside new_mqmqa_excess\r\n! if(mqmqxcess) write(*,*)'3XQ back with excess from endmember ',mqmqjy,&\r\n! associated(endmemrec)\r\n! if(mqmqxcess) write(*,317)gz%nofc,vals(1),vals(2),&\r\n! write(*,317)gz%nofc,rtg*vals(1),rtg*vals(2),&\r\n! (rtg*dvals(1,jq),jq=1,gz%nofc)\r\n317 format('3XQ Back from new_mqmqa: ',i3,2(1pe12.4)/6(1pe12.4))\r\n!\r\n!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \r\n! BIG STEP ... add vals, dvals to G and dG/dy\r\n! what about aff?\r\n!\r\n! what is ipy? It is the property 1 is G, 2 is BMAGN or something else\r\n ipy=1\r\n if(mqmqxcess) write(*,318)phres%gval(1,ipy),&\r\n (phres%dgval(1,jq,ipy),jq=1,gz%nofc)\r\n318 format('3XQ G & G.y: ',1pe12.4/6(1pe12.4))\r\n! dvals(1,jq=1,gz%nofc) set here\r\n! write(*,3181)gz%nofc,(dvals(1,jq),jq=1,gz%nofc)\r\n3181 format('3XQ dex: ',i3,25(1pe12.4))\r\n do itp=1,6\r\n! loop for G, G.T, G.P, G.T.T, G.T.P, G.P.P to add excess contribution\r\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+vals(itp)\r\n enddo\r\n! TEMPORARILY REMOVED SOME LOOPS\r\n if(mqmqder) write(*,3183)gz%nofc,(dvals(1,jq),jq=1,gz%nofc)\r\n3183 format('3XQ dvals: ',i3,20(1pe12.4))\r\n do jq=1,gz%nofc\r\n! skip loop for dG/dy, d2G/dydT, d2G/dydP, only for constituents\r\n! do itp=1,3 this skips 2nd derivative wrt T ?? ipy=1 is G\r\n if(mqmqder .and. abs(dvals(1,jq)).gt.1.0D-3) then\r\n! this line is strange, supress it temporarily\r\n write(*,3182)jq,dvals(1,jq),phres%dgval(1,jq,1)\r\n endif\r\n do itp=1,3\r\n phres%dgval(itp,jq,ipy)=phres%dgval(itp,jq,ipy)+dvals(itp,jq)\r\n enddo\r\n! write(*,3182)jq,dvals(1,jq),phres%dgval(1,jq,1)\r\n enddo\r\n3182 format('3XQ line 1567 addexcess: ',i3,2(1pe12.4))\r\n! \r\n! ignore 2nd derivatives as not calculated for excess\r\n!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \r\n!\r\n! write(*,289)(phres%gval(itp,1),itp=1,4)\r\n289 format('3XQ line 1532 after excess:'/'G, dG/dT dG/dP d2G/dT2:',4(1pe14.6))\r\n if(.not.associated(intrec)) cycle endmemloop2\r\n!\r\n!*************** remove all code below when excess code above OK *******\r\n!******************* new code above should replace code below *******\r\n!\r\n! There are excess parameters, any Tooprecords?\r\n!\r\n! THIS IS OLD CODE WHISH SHOULD NO LONGER BE USED\r\n!\r\n!******************* new code above should replace code below *******\r\n499 continue\r\n if(oldmqmqa_model) then\r\n write(*,319)\r\n319 format(/'3XQ *** this is the old mqmqa excess model **'/)\r\n! stop \"gtp3XQ line 1542\"\r\n endif\r\n!\r\n if(associated(intrec%tooprec)) then\r\n! the allocatable arrays Toop1, Toop2 and Kohler have all same size\r\n! equal to the number of binary combination of constituents\r\n!\r\n tooprec=>intrec%tooprec\r\n if(tch.ge.3) then\r\n write(*,'(a,2i3,l2)')'3XQ A Toop/Kohler record, id:',&\r\n tooprec%toopid,tooprec%endmemel,associated(tooprec%binint)\r\n if(allocated(tooprec%toop1)) then\r\n tsize=size(tooprec%toop1)\r\n write(*,320)'Toop1 ',(tooprec%toop1(jd),jd=1,tsize)\r\n write(*,320)'Toop2 ',(tooprec%toop1(jd),jd=1,tsize)\r\n write(*,320)'Kohler ',(tooprec%kohler(jd),jd=1,tsize)\r\n320 format('3XQ ',a,': ',10i3)\r\n endif\r\n endif\r\n! this is an excess parameter with possible excess parameters\r\n! write(*,'(a,2i3)')'3XQ endmember with excess parameter:',mqmqj\r\n! just excess parameters, we must calculate product of fractions\r\n! BRANCH for intrec%highlink and intrec%nexlink\r\n! write(*,'(a,i2,F10.6,6(1pe12.4))')'3XQ SNN df/dy: ',id,pyq,&\r\n! (dpyq(itp),itp=1,gz%nofc)\r\n!-------------------------------------\r\n! content of %contyp and %pinq\r\n! do jd=1,mqmqa_data%nconst\r\n! write(*,599)jd,(mqmqa_data%contyp(id,jd),id=1,14)\r\n!599 format('3XQ contyp: ',i2,1x,4i2,1x,i3,1x,4i2,1x,i2,4i3)\r\n! enddo\r\n! write(*,*)'3XQ pinq: ',mqmqa_data%pinq\r\n! extract fractions from the endmember and check if AB/X or A/XY or A/X \r\n end if\r\n!-------------------------------------- code below ignore Toop/Kohler\r\n id=endmemrec%fraclinks(1,1)\r\n! jump back here for next interaction record (if any)\r\n600 continue\r\n! Note it is arbitrary if the cluster is endmember or interaction\r\n jd=intrec%fraclink(1)\r\n! We must keep track of which endmember is separate!!!\r\n if(mqmqa_data%contyp(5,id).eq.0) then\r\n! id is a cluster, jd is separate fraction, jq is additional salt OK\r\n ass=id\r\n! %contyp(6,..9) are index of FNN, pairs, FNN pairs index in cintyp in PINQ\r\n jq=mqmqa_data%pinq(mqmqa_data%contyp(6,ass))\r\n if(jq.eq.jd) jq=mqmqa_data%pinq(mqmqa_data%contyp(7,ass))\r\n qq1=jd\r\n qq2=jq\r\n! write(*,'(a,6i3)')'3XQ ass, sep, sum 1:',ass,qq1,qq2\r\n elseif(mqmqa_data%contyp(5,jd).eq.0) then\r\n! jd is the cluster, id is interaction endmember WRONG\r\n ass=jd\r\n jq=mqmqa_data%pinq(mqmqa_data%contyp(6,ass))\r\n if(jq.eq.id) jq=mqmqa_data%pinq(mqmqa_data%contyp(7,ass))\r\n qq1=id\r\n qq2=jq\r\n! write(*,'(a,6i3)')'3XQ ass, sep, sum 2:',ass,qq1,qq2\r\n else\r\n! Interactions are only between clusters AB/X and endmembers A/X or B/X\r\n write(*,*)'3XQ interaction between two endmembers illegal'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! write(*,428)phres%yfr\r\n428 format('3XQ all yfr: ',20(1x,F8.6))\r\n if(tch.ge.3) write(*,430)id,jd,jq,qq1,qq2,ass,&\r\n phres%yfr(id),phres%yfr(jd),phres%yfr(jq)\r\n430 format('3XQ interaction: ',3i3,3x,3i3,3x,3(1x,F8.6))\r\n!------------------------------------- extract parameter value\r\n proprec=>intrec%propointer\r\n typty=proprec%proptype\r\n if(typty.ne.1) stop 'illegal typty in mqmqa model'\r\n ipy=1\r\n! several powers we must loop here -------------- not yet done\r\n if(proprec%degree.gt.0) write(*,*)'3XQ degree: ',proprec%degree\r\n mpow=0\r\n700 continue\r\n! first power is in link 0\r\n lokfun=proprec%degreelink(mpow)\r\n mpow=mpow+1\r\n if(mpow.gt.9) then\r\n write(*,*)'3XQ too high interaction power'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! some powers may not have a parameter, max 9. If no function loop\r\n if(lokfun.le.0) goto 700\r\n call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(tch.ge.3) write(*,'(a,3i4/4x,6(1Pe12.4))')'3XQ excess1:',&\r\n lokfun,mqmqj,mpow,vals(1)\r\n if(ipy.eq.1) then\r\n! Nath has implemented this half in the converter\r\n! vals=0.5D0*vals/rtg\r\n vals=vals/rtg\r\n endif\r\n! skip excess 1\r\n! cycle endmemloop2\r\n!----------------------- multiply with fractions\r\n! the parameter should be multiplied with cluster fractions and\r\n! the separate endmember qq1 fraction normalized \r\n isumx=isumx+1\r\n sumx=phres%yfr(qq1)+phres%yfr(qq2)+phres%yfr(ass)\r\n ksi=phres%yfr(qq1)/sumx\r\n if(mpow.eq.1) then\r\n pyq=phres%yfr(ass)*ksi\r\n! most of the derivatives of pyq is zero\r\n dpyq=zero\r\n dsumx=-sumx**(-2)\r\n! only those involving id, jd and jq are nonzero.\r\n! the species qq1, qq2 and ass has one more term, qq2 is only in the sumx\r\n! dpyq(qq1)=pyq*dsumx+phres%yfr(ass)/sumx\r\n! dpyq(qq2)=pyq*dsumx\r\n! dpyq(ass)=pyq*dsumx+ksi\r\n! corrected derivatives ...\r\n dpyq(qq1)=(phres%yfr(ass)-pyq)/sumx\r\n dpyq(ass)=(phres%yfr(qq1)-pyq)/sumx\r\n dpyq(qq2)=-pyq/sumx\r\n else\r\n! NOT CORRECTED THESE ... suck\r\n pyq=phres%yfr(ass)*(ksi**mpow)\r\n dpyq=zero\r\n dsumx=-mpow*sumx**(-mpow-1)\r\n dpyq(qq1)=pyq*dsumx+mpow*phres%yfr(ass)*ksi**(mpow-1)\r\n dpyq(qq2)=pyq*dsumx\r\n dpyq(ass)=pyq*dsumx+ksi*mpow\r\n endif\r\n! here the fraction product is calculated\r\n! write(*,650)ass,qq1,qq2,mpow,ksi,phres%yfr(ass),pyq,sumx,vals(1)*rtg\r\n650 format('3XQ excess: ',4i3,4(1x,F8.6),1pe12.4)\r\n! write(*,'(a,2(1pe14.6))')'3XQ excess G:',pyq,pyq*vals(1)\r\n! skip excess 2\r\n! cycle endmemloop2\r\n!\r\n! ---------------------------------\r\n! add to G and first derivatives of G, ipy is property, ipy=1 is G\r\n! 2nd derivatives ignored\r\n! ---------------------------------\r\n do s1=1,gz%nofc\r\n do itp=1,3\r\n phres%dgval(itp,s1,ipy)=phres%dgval(itp,s1,ipy)+&\r\n dpyq(s1)*vals(itp)\r\n enddo\r\n enddo\r\n do itp=1,6\r\n phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp)\r\n enddo\r\n! maybe several fraction powers of this property\r\n! write(*,*)'3XQ several powers? ',mpow,proprec%degree\r\n if(mpow.lt.proprec%degree) goto 700\r\n!------------- next property for same interaction,\r\n! each property can have different number of powers ... not implemented\r\n proprec=>proprec%nextpr\r\n if(associated(proprec)) then\r\n! more than one property ... not implemented\r\n write(*,*)'3XQ MQMQA parameter with several properties!',mqmqj\r\n endif\r\n if(associated(intrec%highlink)) then\r\n! a higher interaction ... not allowed\r\n write(*,*)'3XQ ternary MQMQA parameters not implemented',mqmqj\r\n endif\r\n! there can be more interactions on this level\r\n intrec=>intrec%nextlink\r\n if(associated(intrec)) then\r\n! There can be more than one interaction linked from an endmember\r\n if(tch.ge.3) write(*,*)'3XQ more interaction for an endmember',mqmqj\r\n goto 600\r\n endif\r\n! write(*,*)'3XQ done excess for endmember',mqmqj\r\n! next endmember .... is set at the beginning\r\n\r\n enddo endmemloop2\r\n!----------------------------------------------------- end SNN loop\r\n800 continue\r\n! write(*,990)'3XQ exit calc_mqmqa G:',phres%gval(1,1),&\r\n! (phres%dgval(1,s1,1),s1=1,gz%nofc)\r\n! write(*,990)'3XQ exit calc_mqmqa G:',rtg*phres%gval(1,1),rtg*vals(1)\r\n! (phres%dgval(1,s1,1),s1=1,gz%nofc)\r\n990 format(a,5(1pe14.6))\r\n1000 continue\r\n return\r\n end subroutine calc_mqmqa\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine calc_toop\r\n! called from cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq)\r\n!\\begin{verbatim}\r\n subroutine calc_toop(lokph,lokpty,moded,vals,dvals,d2vals,gz,TOOPX,ceq)\r\n! NOT USED FOR MQMQA liquid model ... done in calc_mqmqa\r\n! This routine replaces all calculations inside cgint for Toop/Kohler excess\r\n! binary interaction parameter with Toop or Kohler extrapolation\r\n! toopx is the pointer to the kohler-Toop record\r\n! toopx%binint is pointer back to calling subroutine\r\n! A single composition dependent binary parameter is calculated\r\n! But in the Toop/Kohler we can have additional fraction variables\r\n implicit none\r\n integer moded,lokph\r\n TYPE(gtp_property), pointer :: lokpty\r\n TYPE(gtp_parcalc) :: gz\r\n! all fraction variable can be involved in derivatives of vals ...\r\n double precision vals(6),dvals(3,gz%nofc)\r\n double precision d2vals(gz%nofc*(gz%nofc+1)/2)\r\n TYPE(gtp_tooprec), pointer :: toopx\r\n TYPE(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n! we use this to save the pointer from toopx\r\n TYPE(gtp_phase_varres), pointer :: phres\r\n! fraction values to be used in RK series\r\n double precision x12,x21,sigma,dxrk,dxrk0\r\n double precision, allocatable, dimension(:) :: dsigma, dx12, dx21\r\n! ternary fraction index\r\n integer jj(3),j1,j2,j3,link,count,toopconst,limit,jdeg,lfun,nyfr,tkdeb\r\n! loop veriables \r\n integer qz,ic,cc\r\n! to avoid calculating derivatives if no constituents in toop1, toop2 or kohler\r\n logical not1,not2,nok\r\n! for the RK calculation with Toop/Kohler fractions!\r\n double precision valtp(6)\r\n double precision dx,dx0,dx1,dx2,dxi,dxj,fff,rtg\r\n! The first part here is to modify the fractions to be used in the RK series\r\n! the gz record has information which elements involved\r\n! gz%iq(1) and gz%iq(2) are index of the binary constituents\r\n! We must also handle first and second derivatives wrt all fractions.\r\n! as the binary fractions are modified by adding or subtractions\r\n! we come here from a binary interaction record will only deal with this\r\n!\r\n! These are UNUSED arrays with additional fractions to calculate derivatives\r\n integer dtoop1(5),dtoop2(5),dkohler(10),ntp1,ntp2,nkh\r\n! These are arrays to eliminate cases with duplicate fractions in Toop1/2/Kohler\r\n integer, allocatable, dimension(:) :: ctoop1,ctoop2,ckohler\r\n integer nz\r\n!\r\n! Use the phres passed on via toopx%phres if there are more toopx records\r\n! this link to phres is copied to toopx%phres before the call.\r\n! In gtp3X, subroutine calcg_internal around line 858.\r\n! This makes it possible to have several composition sets (I hope)\r\n if(associated(toopx%phres)) then\r\n phres=>toopx%phres\r\n else\r\n write(*,*)'3QX phres pointer is not assigned entering calc_toop'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! debug level 0 nothing, 1 minimum, 2 Toop, 5 all\r\n tkdeb=2\r\n if(tkdeb.ge.2) write(*,*)'3XQ in calc_toop ',lokpty%degreelink(0)\r\n! NOTE vals, dvals and d2vals set to zero in calcg before calling this routine\r\n rtg=gz%rgast\r\n if(lokpty%degree.eq.0) then\r\n! quick exit if no composition dependence\r\n lfun=lokpty%degreelink(0)\r\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(lokpty%proptype.eq.1) then\r\n valtp=valtp/rtg\r\n endif\r\n! this is multiplied with y_i y_j (and their derivatives) at the return\r\n vals=vals+valtp\r\n goto 1000\r\n endif\r\n! we come here if there are RK terms >0\r\n if(tkdeb.gt.0) then\r\n write(*,10)gz%iq(1),gz%iq(2),lokpty%degree\r\n10 format(/'3XQ in calc_toop & Kohler with binary;',2i3,' degrees: ',i2)\r\n endif\r\n! do nz=1,3\r\n! it seems that dvals are not properly initiatiad to zero?\r\n! write(*,7)nz,(dvals(nz,ic),ic=1,gz%nofc)\r\n!7 format('3XQ initial dvals: ',i2,10(1pe12.4))\r\n! enddo\r\n! We have to calculate the reduced fractions, it can involve many fractions\r\n nyfr=size(phres%yfr)\r\n allocate(dsigma(nyfr))\r\n allocate(dx12(nyfr))\r\n allocate(dx21(nyfr))\r\n! default value of sigma is unity\r\n sigma=one\r\n! these are default zero, i.e. derivatives with respect to no extra fractions\r\n dx12=zero\r\n dx21=zero\r\n dsigma=zero\r\n! constituents are ordered alphabetically, x12 is the first in the endmember\r\n x12=gz%yfrem(gz%intlat(1))\r\n x21=gz%yfrint(1)\r\n if(tkdeb.ge.2) write(*,15)x12,x21,gz%iq(1),gz%iq(2)\r\n15 format('3XQ initial fractions: ',2f8.4,2i5)\r\n! We have a binary excess parameter which depend on x_A and x_B\r\n! and a Redlich-Kister polynom (x_A -x_B)/sigma\r\n! When the data for the system was entered some ternaries were\r\n! specified as Toop or Kohler and the toopx record created with the\r\n! information needed for the calculations below\r\n! For all ternaries A-B-K where the composition of B is constant (Toop)\r\n! the fraction of K should be added to A, i.e. x12\r\n if(phlista(lokph)%toopfirst%endmemel.ne.0) then\r\n! CHECK FOR DUPLICATE FRACTION INDICES, an add ternary may add same fraction!!\r\n! phlista(lokph)%firsttoop%free=-1 in add_ternary... (in gtp3H.F90)\r\n! if phlista(lokph)%firsttoop%free=-1 check and remove redundant fractions!!\r\n! This phlista(lokph)%firsttoop%free=0 at the end of gcalc (in gtp3X.F90)\r\n if(tkdeb.ge.1) write(*,16)phlista(lokph)%toopfirst%endmemel\r\n16 format('3XQ Checking duplicates as phlista(lokph)%toopfirst%endmemel:',i2)\r\n! The check made only once, this value is zeroed at end of calcg subroutine\r\n allocate(ctoop1(phlista(lokph)%toopfirst%free))\r\n allocate(ctoop2(phlista(lokph)%toopfirst%free))\r\n allocate(ckohler(phlista(lokph)%toopfirst%free))\r\n endif\r\n not1=.TRUE.\r\n if(tkdeb.ge.2) then\r\n write(*,8)toopx%free,nyfr\r\n8 format('3XQ Number of Toop/Kohler ternaries: ',i3,&\r\n ' Total number of fractions: ',i3)\r\n write(*,12)phres%yfr\r\n12 format('3XQ All yfr: ',20F7.4)\r\n endif\r\n! toopx%free is last used index in %Toop1, %Toop2 and %Kohler\r\n not1=.TRUE.; not2=.TRUE.; nok=.TRUE.\r\n allcorr: do ic=1,toopx%free\r\n if(tkdeb.ge.2) &\r\n write(*,33)ic,toopx%toop1(ic),toopx%toop2(ic),toopx%kohler(ic)\r\n33 format('3XQ List of Toop/Kohler constituents: ',i2,2x,3i3)\r\n!------------ Toop1\r\n cc=toopx%toop1(ic)\r\n if(allocated(ctoop1)) then\r\n! if ctoop1 allocated then check to eliminate duplicates\r\n if(tkdeb.ge.1) write(*,'(a)')'3XQ Check for duplicated fractions'\r\n do nz=1,ic-1\r\n if(cc.gt.0 .and. cc.eq.toopx%toop1(nz)) then\r\n jdeg=toopx%toop1(ic); toopx%toop1(ic)=0; cc=0\r\n write(*,69)'Toop1',nz,jdeg\r\n69 format('3XQ eliminated duplicate ',a,' fraction',2i4)\r\n endif\r\n enddo\r\n endif\r\n if(cc.gt.0) then\r\n! In this binary i-j with ternary k where i (endmember) is constant (Toop)\r\n! Add the fraction of x_k to x_i\r\n x12=x12+phres%yfr(cc); dx12(cc)=one; not1=.FALSE.\r\n if(tkdeb.ge.2) &\r\n write(*,34)'x12 ',ic,cc,toopx%toop1(ic),phres%yfr(cc),x12\r\n34 format('3XQ Added fraction to ',a,3i3,2E15.7)\r\n endif\r\n!------------ Toop2\r\n cc=toopx%toop2(ic)\r\n if(allocated(ctoop2)) then\r\n! if ctoop2 allocated check to eliminate duplicates\r\n do nz=1,ic-1\r\n if(cc.gt.0 .and. cc.eq.toopx%toop2(nz)) then\r\n jdeg=toopx%toop2(ic); toopx%toop2(ic)=0; cc=0\r\n write(*,69)'Toop2',nz,jdeg\r\n endif\r\n enddo\r\n endif\r\n if(cc.gt.0) then\r\n! In this binary i-j with ternary k where i (interaction) is constant (Toop)\r\n! Add the fraction of x_k to x_j\r\n x21=x21+phres%yfr(cc); dx21(cc)=one; not2=.FALSE.\r\n if(tkdeb.ge.2) &\r\n write(*,34)'x21 ',ic,cc,toopx%toop2(ic),phres%yfr(cc),x21\r\n endif\r\n!------------ Kohler\r\n cc=toopx%Kohler(ic)\r\n if(allocated(ckohler)) then\r\n! if ckohler allocated check to eliminate duplicates\r\n do nz=1,ic-1\r\n if(cc.lt.0 .and. cc.eq.toopx%kohler(nz)) then\r\n jdeg=toopx%kohler(ic); toopx%kohler(ic)=0; cc=0\r\n write(*,69)'3Kohler',nz,jdeg\r\n endif\r\n enddo\r\n endif\r\n if(cc.lt.0) then\r\n! In this ternary i-j-k the i-j extrapolates as Kohler\r\n! the composition of k should be subtracted from sigma (initiated to 1.0 above)\r\n sigma=sigma-phres%yfr(-cc); dsigma(-cc)=-one; nok=.FALSE.\r\n if(tkdeb.ge.2) write(*,35)ic,cc,toopx%kohler(ic),phres%yfr(-cc),sigma\r\n35 format('3XQ subtracted fraction for sigma ',3i3,2E15.7)\r\n endif\r\n enddo allcorr\r\n if(x12.ge.one) then\r\n write(*,*)'3XQ Error: x12 larger than 1.0 in Toop/Kohler extrapolation!'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n if(x21.ge.one) then\r\n write(*,*)'3XQ Error: x21 larger than 1.0 in Toop/Kohler extrapolation!'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n if(sigma.le.zero) then\r\n write(*,*)'3XQ Error: negative sigma in Toop/Kohler extrapolation!'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n! This is the RK fraction difference, sigma is the Kohler divisor\r\n dxrk0=(x12-x21)/sigma\r\n! dxrk is the Tredlich-Kister term, it is raised to powers jdeg=0...n\r\n! The derivative of dxrk**n is:\r\n! n*dxrk**((m-1)*[ (dx12-dx21)/sigma - (x12-x21)*dsigma/sigma**2 ]\r\n! where dx12, dx21 be 0 or 1 and dsigma 0 or -1 for several fraction variables\r\n! were set above. \r\n!\r\n! dxrk=1.0 for jdeg=0\r\n dxrk=one\r\n if(tkdeb.ge.2) then\r\n write(*,17)'3XQ x12: ', x12,', dx12: ',dx12,dxrk0\r\n write(*,17)'3XQ x21: ', x21,', dx21: ',dx21\r\n write(*,17)'3XQ sigma: ', sigma,', dsigma: ',dsigma\r\n17 format(a,F8.6,a,10F7.3)!\r\n endif\r\n!-----------------------------------------------------------------\r\n! No documentation of code below (at present), see paper by Pelton 2001\r\n!-----------------------------------------------------------------\r\n! in toopx there are 3 arrays\r\n! toop1 with toop constitunents to be added to iq(1)\r\n! toop2 with toop constitunents to be added to iq(2)\r\n! Kohler with constitunents to be subtracted from sigma\r\n! Calculate the corrected the binary fractions x12 and x21 and sigma\r\n if(tkdeb.gt.0) write(*,20)x12,x21,sigma,dxrk,moded\r\n20 format('3XQ fractions: ',2F8.4,' sigma,dxrk: ',2F8.4,' moded: ',i1)\r\n! gz%iq(1) is first constitution, gz%iq(2) in interaction\r\n dx12(gz%iq(1))=one/sigma\r\n dx21(gz%iq(2))=one/sigma\r\n RK: do jdeg=0,lokpty%degree\r\n lfun=lokpty%degreelink(jdeg)\r\n call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(lokpty%proptype.eq.1) then\r\n valtp=valtp/rtg\r\n endif\r\n vals=vals+dxrk*valtp\r\n if(tkdeb.ge.2) write(*,9)'3XQ vals1: ',jdeg,dxrk,valtp(1),rtg*valtp(1),&\r\n vals(1),rtg*vals(1)\r\n9 format(a,i2,5(1PE13.5))\r\n noder5: if(moded.gt.0) then\r\n! moded=0 no derivative, =1 first, =2 second; gz%iq(1) is endmember\r\n! derivatives with respect to original x12 and x12\r\n! qz=1 is parameter value, qz=2 is parameter derivative wrt T, qz(3) wrt P\r\n do qz=1,3\r\n dvals(qz,gz%iq(1))=dvals(qz,gz%iq(1))+dx12(gz%iq(1))*valtp(qz)\r\n dvals(qz,gz%iq(2))=dvals(qz,gz%iq(2))-dx21(gz%iq(2))*valtp(qz)\r\n enddo\r\n! derivatives wrt Toop1 constintuents, use dx12, dx21 and dsigma\r\n! all approximate ....... negative sign of dx21 taken care of when \"added\"\r\n! NOTE dx12, dx21 and sigma are arrays as any constituent can be involved\r\n dx12(gz%iq(1))=(jdeg+1)*dxrk\r\n dx21(gz%iq(2))=(jdeg+1)*dxrk\r\n! This part takes care of derivatives wrt fractions \"k\" in x12, x21 and sigma\r\n! They have dx12(k)=dx21(k)=1 and dsigma)k)=-1\r\n! dxrk**n * valtp is the Redlich-Kister term, valtp(1,2,3) is the parameter\r\n! The derivative of dxrk**n * valtp is:\r\n! n*dxrk**((n-1)*valtp*[ dx12/sigma -dx21/sigma -(x12-x21)*dsigma/sigma**2 ]\r\n! valtp(1) is parameter value, valtp(2,3) is derivative wrt T and P respectivly\r\n! where dx12, dx21 are 0 or 1 and dsigma is 0 or -1 for the fraction variables\r\n! The fractions \"k\" involved have nonzero %toop1(ic), %toop2 or %kohler indices\r\n extraderivatives: do ic=1,toopx%free\r\n! the arrays %toop1, %toop2 and %kohler have the same dimensions\r\n! they have fraction indices in toop1, toop2 or kohler (most of which is 0)\r\n! -------------------- derivatives for toop1\r\n cc=toopx%toop1(ic)\r\n ltoop1: if(.not.not1) then\r\n! there is a fraction added to x12, fraction index in toopx%toop1(ic)\r\n if(cc.gt.0) then\r\n do qz=1,3\r\n! this fraction is added to x12, dx12=1 but we have to divide with sigma\r\n dvals(qz,cc)=dvals(qz,cc)+(jdeg+1)*dxrk*valtp(qz)/sigma\r\n enddo\r\n if(tkdeb.ge.2) write(*,44)'Toop1 ',cc,dvals(1,cc)\r\n44 format('3XQ ',a,' derivative: ',i2,1pe14.6)\r\n! Any second derivatives is ignored (it may slow down convergence)\r\n endif\r\n endif ltoop1\r\n!--------------------- derivatives for Toop2\r\n cc=toopx%toop2(ic)\r\n ltoop2: if(.not.not2) then\r\n! there is a fraction added to x21, fraction index in toopx%toop2(ic)\r\n if(cc.gt.0) then\r\n do qz=1,3\r\n! dx21(ic) is unity here but divide with sigma. OBS negative sign\r\n dvals(qz,cc)=dvals(qz,cc)-(jdeg+1)*dxrk*valtp(qz)/sigma\r\n enddo\r\n if(tkdeb.ge.2) write(*,44)'Toop2 ',cc,dvals(1,cc)\r\n! Any second derivatives ignored (it may slow down convergence)\r\n endif\r\n endif ltoop2\r\n!---------------------- derivatives for Kohler, negative index of fraction!!!\r\n cc=toopx%kohler(ic)\r\n lkohler: if(.not.nok) then\r\n! there is a fraction subtracted from sigma, fraction -index in toopx%kohler(ic)\r\n if(cc.lt.0) then\r\n if(tkdeb.ge.2) write(*,54)cc,jdeg,dvals(1,-cc),&\r\n (jdeg+1)*dxrk*valtp(1)*(x12-x21)/sigma**2,&\r\n dxrk,valtp(1),(x12-x21),sigma\r\n54 format('3XQ Kohler derivative: ',2i2,2(1pe12.4)/4x,4(1pe12.4))\r\n do qz=1,3\r\n! dxrk**n * valtp is the Redlich-Kister term, valtp is the parameter\r\n! n*dxrk**((n-1)*valtp*[ dx12/sigma -dx21/sigma -(x12-x21)*dsigma/sigma**2 ]\r\n! dsigma is unity here but divide with sigma**2\r\n dvals(qz,-cc)=dvals(qz,-cc)-&\r\n (jdeg+1)*dxrk*valtp(qz)*(x12-x21)/sigma**2\r\n enddo\r\n! Any second derivatives ignored (it may slow down convergence)\r\n endif\r\n endif lkohler\r\n enddo extraderivatives\r\n! dxrk has one more power for next term\r\n dxrk=dxrk*dxrk0\r\n endif noder5\r\n enddo RK\r\n!--------- maybe almost finished ???\r\n!\r\n! if(tkdeb.ge.1) write(*,30)'3XQ vals2: ',vals(1),rtg*vals(1),&\r\n! gz%iq(1),gz%iq(2),rtg*dvals(1,gz%iq(1)),rtg*dvals(1,gz%iq(2))\r\n30 format(a,2F12.4,2i2,2F12.4)\r\n1000 continue\r\n!------------------------------------------------------------------\r\n! this calculates the whole \\sum_i (\\xi_A - \\xi_B)/sigma_AB)^i iL_AB\r\n! and derivatives ....\r\n!------------------------------------------------------------------\r\n! The result is multiplied with the fractions x_A'x_B in the calling routine\r\n if(tkdeb.gt.0) write(*,'(a,2i3,F12.4)')'3XQ RT*vals: ',&\r\n gz%iq(1),gz%iq(2),rtg*vals(1)\r\n! if(tkdeb.gt.0) write(*,'(a,i3,2x,5F8.5)')'3XQ dxrk mm:',&\r\n! jdeg,rtg*vals(1),dxrk0,dxrk\r\n return\r\n end subroutine calc_toop\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n!\r\n! new MQMQA excess subroutines below\r\n! using a separate data structury for asymmetries\r\n!\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine new_mqmqa_excess\r\n! called from calc_mqmqa line 1429. CALCULATES MQMQA excess\r\n!\\begin{verbatim}\r\n! subroutine new_mqmqa_excess(lokph,intrecin,mqmqj,vals,dvals,d2vals,gz,ceq)\r\n subroutine new_mqmqa_excess(lokph,intrecin,mqmqj,vals,dvals,d2vals,gz,ceq)\r\n! vals(1..6) are G, dG.T, dG.P, d2G.T.T, d2G.T.P and d2G.P.P for parameter\r\n! dvals(1,i) are first derivatives wrt fracton and 2nd wrt fraction, T or P\r\n! dvals(1,i) is dG.yi, dval2(2,i) is d2G.yi.T, dvals(3,i) is d2G.yi.P\r\n! d2vals(i,j) are second derivatives to 2 fractions, IGNORED HERE\r\n! gz%nofc is number of fraction variables multiplied with this parameter(?)\r\n!\r\n! written using the gtp_allinone data structure for asymmetric excess\r\n implicit none\r\n! mqmqj is index of first constituent in endmemberrecord\r\n integer lokph,mqmqj\r\n! type(gtp_property), pointer :: lokpty\r\n type(gtp_parcalc) :: gz\r\n type(gtp_phase_varres), pointer :: phres\r\n TYPE(gtp_mqmqa_var), pointer :: mqf\r\n! dvals(1,x) is derivative wrt constituent x, dvals(2,x) is d2G/dTdx .....\r\n! dvals(3,x) is derivative wrt d2G/dPdx\r\n double precision vals(6),dvals(3,gz%nofc)\r\n! **** d2vals NOT USED\r\n double precision d2vals(gz%nofc*(gz%nofc+1)/2)\r\n! pointer to first interaction record from an endmember\r\n! intrecin is copied to intrec and then nullified. intrec may be updated below,\r\n TYPE(gtp_interaction), pointer :: intrecin,intrec,intrecfirst\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n! needed locally?\r\n TYPE(gtp_intstack), dimension(:), allocatable :: savedint\r\n TYPE(gtp_pystack), pointer :: pystack\r\n TYPE(gtp_phase_add), pointer :: addrec\r\n TYPE(gtp_terdata), pointer :: ternaries\r\n TYPE(gtp_property), pointer :: proprec\r\n TYPE(gtp_interaction), pointer :: ternaryexcess\r\n! type(gtp_allinone), pointer :: compvar\r\n!\r\n character*120 text\r\n double precision :: rtg\r\n logical :: once=.true.\r\n integer ppow,qpow,rpow,intlev,iiz,jj,pairquad,jp\r\n integer, save :: proprecno=0\r\n integer parquad(4),nprr,nfr,dd\r\n integer :: nex=0\r\n integer, dimension(:), allocatable :: ylinks,qlinks\r\n integer ncv,icv,nqx,lokcs,lokfun,xq,cxq,mm\r\n double precision compprod,nomin,ternary,tpfun(6)\r\n!\r\n logical, save :: ternaryonce=.true.\r\n!\r\n! composition derivatives are only relative to quads !!!!!!!\r\n! the composition variables for a parameters are expressions using asymmetric\r\n! y_ik, \\xi or \\varkappa which depend on quads\r\n! we have to sort out how this affects the derivatives\r\n! dy_ik are factors for y_ik relative to quads, can be 1 or less\r\n! dxi_ij and dx_ji and dvk_ij and dvk_ji are 1 or less\r\n! A parameter P multiplied with vk_ij(ij) has several contributions to the\r\n! derivatives dP(zz), dvk_ij(ij,zz),zz=1,nquad\r\n integer idyix(5,mqmqa_data%nquad)\r\n integer zkij,nvkappa,ijx,nexrec,nooftps\r\n double precision term1,term2,dterm1,dterm2,dsum\r\n double precision haha,one1,dnomin,ddivisor,dternary\r\n double precision dyix(5,mqmqa_data%nquad),values(6)\r\n double precision dvalxq(mqmqa_data%nquad)\r\n! pder(nquad) is the derivative of parameter wrt to each quad ij\r\n! double precision pder(mqmqa_data%nquad*(mqmqa_data%nquad-1)/2\r\n double precision debugder(mqmqa_data%nquad) ! for debug only\r\n! dvkijz(1,*) are dvk_ij/dxquad and dvkijz(2,*) are dvk_ji/dxquad\r\n double precision dvkijz(2,mqmqa_data%nquad)\r\n! These are short for the values of vk_ij and vk_ji\r\n double precision vk_ij,vk_ji\r\n! partial derivative for one parameter contribution\r\n double precision d1vals(mqmqa_data%nquad)\r\n double precision dtvals(mqmqa_data%nquad)\r\n! FactSage Factor\r\n! double precision :: FSF=1.0d0\r\n!\r\n character*1 ptyp1\r\n! The previous MQMQA excess implementation arrive here\r\n! If mqmqa_data%exlevel is zero we should return and old code will still work.\r\n! write(*,*)'3XQ in new_mqmqa_excess',mqmqa_data%exlevel\r\n if(mqmqder) write(*,*)'3XQ in new_mqmqa_excess',mqmqa_data%exlevel\r\n if(mqmqa_data%exlevel.eq.0) then\r\n! if(once) write(*,6)mqmqa_data%exlevel\r\n6 format('3XQ *** this system use the old excess model ***',i5)\r\n goto 1000\r\n endif\r\n!--------------------------------------------------------------\r\n! we are here because this endmember has an intercation link\r\n! if(mqmqxcess .and. associated(intrecin)) write(*,5)mqmqj\r\n if(mqmqxcess) write(*,5)mqmqj\r\n! write(*,5)mqmqj\r\n5 format(/'3XQ in new_mqmqa_excess ',i3,' with intreraction record')\r\n! initiate ylinks for this tree with the endmember fraction\r\n intrecfirst=>intrecin\r\n intrec=>intrecin\r\n! this is needed to move to next endmemeber\r\n nullify(intrecin)\r\n!\r\n! below divide values with rtg?\r\n rtg=globaldata%rgas*ceq%tpval(1)\r\n!---------------------------------\r\n! not more than 10 interactions ....\r\n allocate(savedint(10))\r\n allocate(ylinks(10))\r\n allocate(qlinks(10))\r\n! this is the endmember constituent\r\n nfr=1\r\n ylinks(1)=mqmqj\r\n! there can only a one quad with two cations (pair) in an interaction\r\n pairquad=0\r\n! ifem: do jj=1,mqmqa_data%ncat\r\n! if(ylinks(1).eq.mqmqa_data%emquad(jj)) goto 17\r\n! enddo ifem\r\n! this quad is evidently a pair AB/X\r\n! pairquad=ylinks(1)\r\n17 continue\r\n!\r\n! THIS IS THE EXCESS CALCULATION ROUTINE WITH extensive DEBUG LISTING ADDED\r\n!\r\n! loop here until all excess records from this endmember calculated\r\n! The new excess model implementation using allinone etc below\r\n! The quad fractions and related composition variables such as\r\n! quadfractions and asymmetrical variables have been set by set_constitution\r\n!\r\n! ceq%phase_varres(lokcs)%mqmqaf%compvar(icv)%vi_ij etc\r\n! access to composition variables\r\n!\r\n lokcs=phlista(lokph)%linktocs(1)\r\n mqf=>ceq%phase_varres(lokcs)%mqmqaf\r\n!\r\n! when we are here intrec must be associated\r\n! All interaction records from a single endmember record will be calculated\r\n nexrec=0\r\n intlev=0\r\n nooftps=0\r\n! if no parameters return zero\r\n! otherwise vals and dvals sums up all excess parameters for this endmember\r\n! write(*,*)'3XQ line 2218: zero excess contribution'\r\n! mqmqx_deltag=0.0d0\r\n! These values return sum of all excess parameters for this endmember\r\n vals=zero\r\n! dvals has dimension dvals(3,mqmqa_data%nquad) dG/dy_i, d2G/dTdy_i, d2G/dPdy_i\r\n dvals=zero\r\n! summing partial derivatives for each separate parameter, no P derivative\r\n! d1vals=zero\r\n! dtvals=zero\r\n!\r\n intloop: do while(associated(intrec))\r\n!\r\n! intrec must be associated here, nexrec just counts interaction records\r\n nexrec=nexrec+1\r\n!\r\n! there is a single set of sites, save constituent first index\r\n! We may come back here for another interaction with same endmember\r\n! Set ylinks to be indices of the OC fractions\r\n! write(*,88)intlev,associated(intrec%propointer),intrec%fraclink\r\n88 format('3XQ Starting intloop with component ',i3,l2,5i4)\r\n! save name of interacting constituent even if no property\r\n nfr=nfr+1\r\n ylinks(nfr)=intrec%fraclink(1)\r\n proprec=>intrec%propointer\r\n! loop for all property records for same set of constituents\r\n proplist: do while(associated(proprec))\r\n! we have found an excess parameter !!!\r\n lokfun=proprec%degreelink(0)\r\n if(lokfun.gt.0) nooftps=nooftps+1\r\n call eval_tpfun(lokfun,ceq%tpval,tpfun,ceq%eq_tpres)\r\n if(gx%bmperr.ne.0) goto 1000\r\n if(mqmqxcess) then\r\n write(*,114)ptyp1,lokfun,rtg,tpfun(1),tpfun(2)\r\n114 format('3XQ tpfun: ',a,i4,6(1pe12.4))\r\n endif\r\n if(tpfun(1).eq.0.0d0) then\r\n! skip if there is no TP function (no TPFUN used during testing)\r\n proprec=>proprec%nextpr\r\n nex=nex+1\r\n cycle proplist\r\n endif\r\n! divide all parameter values with rtg!!\r\n tpfun=tpfun/rtg\r\n! calculate all d(varkappa_ij)/dx_kl\r\n nvkappa=size(mqf%compvar)\r\n! there can be several property record for the same set of constituents\r\n proprecno=proprecno+1\r\n if(proprec%proptype.eq.34) ptyp1='G'\r\n if(proprec%proptype.eq.35) ptyp1='Q'\r\n if(proprec%proptype.eq.36) ptyp1='B'\r\n!\r\n ternary=1.0D0\r\n ppow=proprec%asymdata%ppow\r\n qpow=proprec%asymdata%qpow\r\n rpow=proprec%asymdata%rpow\r\n if(mqmqxcess) then\r\n! LIST PARAMETER helps to understand what the parameter it is ....\r\n jp=1\r\n text=' '\r\n call mqmqa_excesspar_name(lokph,intlev,nfr,ylinks,text,jp)\r\n text(jp-1:)=';'//ptyp1//','//char(ichar('0')+ppow)//&\r\n ','//char(ichar('0')+qpow)//','//char(ichar('0')+rpow)//')'\r\n write(*,115)trim(text),ppow,qpow,rpow\r\n115 format(/'3XQ param: ',a,', pqr:',3i2)\r\n! extract the quad pointers\r\n endif\r\n!\r\n! lokfun=proprec%degreelink(0)\r\n! can xq be zero here ??????\r\n xq=proprec%asymdata%quad\r\n! cxq transforms the quad index to an index in compvar (which as not diagonal)\r\n cxq=mqmqa_data%quad2compvar(xq)\r\n vk_ij=mqf%compvar(cxq)%vk_ij\r\n vk_ji=mqf%compvar(cxq)%vk_ji\r\n! write(*,1160)xq,mqf%xquad(xq),vk_ij,vk_ji,mqf%compvar(cxq)%denominator\r\n1160 format('3XQ xq etc: ',i3,4(1pe14.6))\r\n!------------------------------------------------------------- ternary\r\n ternary=one\r\n par3: if(nfr.gt.3) then\r\n! if(ternaryonce) write(*,116)\r\n write(*,116)\r\n116 format(/'3XQ *** ternary parameters to be implemented ***'/)\r\n! ternaryonce=.false.\r\n! goto 1000\r\n! this is a dummy call\r\n call ternary_factor(xq,mqf%compvar(cxq)%cat1,mqf%compvar(cxq)%cat2,&\r\n ylinks,mm,ternary,proprec)\r\n if(gx%bmperr.ne.0) goto 1000\r\n endif par3\r\n!------------------------------------------------------------- end ternary\r\n! Maybe a scaling difference with FactSage, multiply tpfun by FSF\r\n! FSF=1.5D0\r\n! write(*,*)'3XQ Scaling with ',FSF\r\n! tpfun(1)=FSF*tpfun(1)\r\n!\r\n!--------------------------------------------------------------------\r\n! multiply the parameter with the composition variables\r\n ptyp: if(ptyp1.eq.'G') then\r\n! ppow is for varkappa_ij, qpow is for varkappa_ji, term1 and term2 used below\r\n! vk_ij and vk_ji are (sum of quands)/(sum of quads)\r\n term1=1.0d0\r\n term2=1.0d0\r\n! if ppow or qpow is zero the term is unity\r\n if(ppow.gt.0) term1=vk_ij**ppow\r\n if(qpow.gt.0) term2=vk_ji**qpow\r\n nomin=term1*term2\r\n! ternary = 1.00, rtg=R*T\r\n compprod=mqf%xquad(xq)*nomin*ternary\r\n! vals(1) is the sum of all excess parameters linked from this endmember\r\n vals(1)=vals(1)+compprod*tpfun(1)\r\n! list 2 indices, 2 powers, 3 constitutions, tpfun, constituents*tpfun, vals\r\n if(xq.gt.0) then\r\n! list value of excess parameter\r\n if(mqmqxcess) then\r\n write(*,991)xq,nexrec,ppow,qpow,&\r\n! mqf%xquad(xq),vk_ij,vk_ji,&\r\n mqf%xquad(xq),term1,term2,&\r\n rtg*tpfun(1),compprod*tpfun(1),vals(1)\r\n991 format('3XQ line 2357:',i3,3i2,3F7.4,3(1pE12.4))\r\n endif\r\n else\r\n write(*,*)'3XQ no quad index!'\r\n stop\r\n endif\r\n!--------------------------------------------------------------------\r\n! BEGIN calculate partial derivatives ...........\r\n! any quad can be involved in compvar(cxq)%vk_ij\r\n if(mqmqder) then\r\n write(*,992)xq,cxq,mqf%compvar(cxq)%cat1,mqf%compvar(cxq)%cat2\r\n992 format('3XQ derivatives of quad: ',i2,', and vk_ij and vk_ji: ',&\r\n i3,2x,2i3)\r\n write(*,*)'3XQ calling dvkij_dzijkl for varkappa: ',cxq\r\n endif\r\n nqx=mqmqa_data%nquad\r\n ncv=size(mqf%compvar)\r\n! \r\n! cxq is varkappa involved with this parameter\r\n! calculate all partial derivatives of this wrt nqx quad fractions\r\n! The vk_ij/vk_ji are used for several parameters and their derivatives\r\n! should calculated only once\r\n! dvkijz(1, 1..nqx) are derivatives of vk_ij: dvk_ij/dxz\r\n! dvkijz(2, 1..nqx) are derivatives of vk_ji: dvk_ji/dxz\r\n call dvkij_dzijk(mqf,cxq,dvkijz)\r\n if(gx%bmperr.ne.0) goto 1000\r\n!\r\n! loop for derivatives of parameter for all quads\r\n zkijloop: do zkij=1,nqx\r\n!\r\n! EG = xq * (vk_ij**pp) * (vk_ji**qq) * param\r\n!\r\n! dEG/dxz = xq * pp*(vk_ij**(pp-1))*dvk_ij/dxz * (vk_ji**qq) * param +\r\n! xq * (vk_ij**pp) * qq*(vk_ji**(qq-1))*dvk_ji/dxz * param +\r\n! dxq/dxz * (vk_ij**pp) * (vk_ji**qq) * param \r\n!\r\n if(ppow.eq.0) then\r\n dterm1=term2\r\n elseif(ppow.eq.1) then\r\n dterm1=dvkijz(1,zkij) * term2\r\n else\r\n dterm1=ppow*vk_ij**(ppow-1)*dvkijz(1,zkij)*term2\r\n endif\r\n! dvkijz(1,zkij) is dvk_ij/dxz and \r\n! dvkijz(2,zkij) is dvk_ji/dxz\r\n if(qpow.eq.0) then\r\n dterm2=term1\r\n elseif(qpow.eq.1) then\r\n dterm2=term1*dvkijz(2,zkij)\r\n else\r\n dterm2=term1*qpow*vk_ji**(qpow-1)*dvkijz(2,zkij)\r\n endif\r\n if(zkij.eq.xq) then\r\n dsum=(dterm1+dterm2)*mqf%xquad(xq)+term1*term2\r\n else\r\n dsum=(dterm1+dterm2)*mqf%xquad(xq)\r\n endif\r\n! dvkijz are the derivative of EG with respect to xqz\r\n! dvals(1,...) is dG/dy, \r\n dvals(1,zkij)=dvals(1,zkij)+dsum*tpfun(1)\r\n! dvals(2,...) is d2G/dydT, dvals(3,...) is d2G/dydP\r\n dvals(2,zkij)=dvals(2,zkij)+dsum*tpfun(2)\r\n! this is just for debug output below\r\n debugder(zkij)=dsum\r\n enddo zkijloop\r\n! debug output of all fraction product derivatives\r\n! rtg&tpfun(1) and vals(1) listed at line 2357\r\n! write(*,997)rtg*tpfun(1),vals(1),(debugder(zkij),zkij=1,nqx)\r\n! write(*,997)(debugder(zkij),zkij=1,nqx)\r\n997 format('3XQ df/dx:',20(1pe11.3))\r\n! partial derivative end >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\r\n if(mqmqder) write(*,122)(dvals(1,zkij),zkij=1,nqx)\r\n122 format('3XQ dEG/dxz ',20(1pe11.3))\r\n elseif(ptyp1.eq.'Q') then\r\n!\r\n write(*,*)'3XQ the Q parameter not implemented yet',ptyp1\r\n stop\r\n else\r\n write(*,*)'3XQ the B parameter not implemented: ',ptyp1\r\n stop\r\n endif ptyp\r\n if(mqmqxcess) write(*,*)'3XQ end of a parameter: ',ptyp1,lokfun,nexrec\r\n!\r\n800 continue\r\n if(mqmqxcess .and. associated(proprec)) write(*,96)' more ',vals(1)\r\n96 format('3XQ ',a,' Current Excess G: ',1pe12.4)\r\n proprec=>proprec%nextpr\r\n nex=nex+1\r\n enddo proplist\r\n!\r\n! we have calculated all property records for one excess parameter\r\n! there can be a ternary or more binary parameters\r\n!\r\n ternaryexcess=>intrec%highlink\r\n! All mqmqa parameters are \"ternary\" or higher\r\n! write(*,811)associated(ternaryexcess)\r\n811 format('3XQ is there a link to higher excess?',l2)\r\n! if(ternaryexcess) then\r\n! write(*,*)'3XQ this must be an error, not implemeneted'\r\n! nullify(ternaryexcess)\r\n! endif\r\n push_ornext: if(associated(intrec%highlink)) then\r\n! go to higher level of interaction but save link to next for other parameters\r\n intlev=intlev+1\r\n if(associated(intrec%nextlink)) then\r\n if(mqmqxcess) write(*,97)intlev,intrec%nextlink%fraclink\r\n97 format('3XQ saved nextlink at intlev: ',2i3)\r\n if(intlev.gt.9) then\r\n write(*,*)'Interaction level record overflow',intlev\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n savedint(intlev)%saved=>intrec%nextlink\r\n else\r\n nullify(savedint(intlev)%saved)\r\n endif\r\n intrec=>intrec%highlink\r\n else\r\n if(mqmqxcess) write(*,*)'3XQ any more excess on level?',intlev,nexrec\r\n intrec=>intrec%nextlink\r\n! too many constituents ...\r\n nfr=nfr-1\r\n pop: do while(.not.associated(intrec))\r\n! write(*,*)'3XQ pop stack',intlev,nfr\r\n if(intlev.gt.0) then\r\n intrec=>savedint(intlev)%saved\r\n intlev=intlev-1\r\n nfr=nfr-1\r\n else\r\n exit intloop\r\n endif\r\n! if(associated(intrec)) &\r\n! write(*,*)'3XQ take nextlink ',intrec%fraclink(1)\r\n enddo pop\r\n if(.not.associated(intrec)) exit intloop\r\n! why cycle?\r\n! cycle intloop\r\n endif push_ornext\r\n enddo intloop\r\n!\r\n!------------ return to next endmember\r\n1000 continue\r\n if(mqmqxcess) then\r\n if(associated(intrecfirst)) then\r\n proprec=>intrecfirst%propointer\r\n write(*,1001)nexrec,vals(1) ! ,(dvals(1,mm),mm=1,mqmqa_data%nquad)\r\n1001 format('3XQ exit new_mqmqa_excess, excess records: ',i5,2x,1pe12.4)\r\n endif\r\n endif\r\n! write(*,1099)vals(1),nexrec,nooftps\r\n! if(mqmqxcess) write(*,1099)vals(1),nexrec,nooftps\r\n1099 format('3XQ exit new_mqmqa_excess with G=',1pe12.4,&\r\n ', ',i3,' parameters and ',i3,' TPFUNs')\r\n return\r\n end subroutine new_mqmqa_excess\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine dvkij_dzijk\r\n!\\begin{verbatim}\r\n subroutine dvkij_dzijk(mqf,cxq,dvkijk)\r\n! calculates all partial derivatives of a parameter multiplied with\r\n! xquad * varkappa**ppow * varkappa**qpow\r\n implicit none\r\n! type(gtp_phase_varres), pointer :: phres\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n type(gtp_allinone), pointer :: box\r\n integer cxq\r\n! there are mqmqa_data%nquad variable and derivatives \r\n double precision dvkijk(2,mqmqa_data%nquad)\r\n! cxq is the varkappa index\r\n! dvkijk is the the 2D array with derivatives of vk_ij and vk_ji with respect\r\n! to all quad fractions. Many of them will be zero\r\n!\\end{verbatim}\r\n!\r\n! Looking for errors in ternaries, suspect missing derivative wrt\r\n! derivatives of quad fraction in denominator _kvk not included !!!???\r\n! df/dx = -nominator/denominator**2 = -g/h**2\r\n!\r\n integer ijkl,vkix,vkdenom,kk,mxq,dgij,dgji,dijk,cat1,cat2\r\n double precision sumi, sumj, sumk, dvkij, dvkji, dvkdenom\r\n logical skip,dksum\r\n! integer, allocatable :: qdone(:)\r\n! integer, allocatable :: indenom\r\n integer denomx,qq,ii\r\n!\r\n! derivative of a quotient d(g/h) = 1/h*dg/dx - (g/h**2)*dh/dx =\r\n! (h*dg/dx - g*dh/dx)/h**2\r\n! dgij=0 if no derivative of vkij\r\n! dgji=0 if no derivative of vkji\r\n! dijk=0 if no derivative of kvkall ?\r\n! NOTE both vkij and vkji has the same denominator, specified by kvkijk !!!\r\n!\r\n! This routine calculates both d(vk_ij)/dx and d(vk_ji)/dx \r\n! with respect to all quadrupole fractions\r\n! \r\n dvkijk=0.0d0\r\n!\r\n mxq=mqmqa_data%nquad\r\n box=>mqf%compvar(cxq)\r\n denomx=size(box%all_ijk)\r\n cat1=box%cat1\r\n cat2=box%cat2\r\n! initiate done with all quad indices\r\n! allocate(qdone(denomx))\r\n! qdone=mqf%compvar(cxq)%all_ijk\r\n! write(*,7)size(dvkijk),qdone\r\n7 format('3XQ *** enter dvkij_dzijk, qdone: ',i5,2x,20i3)\r\n! write(*,8)dvkijk\r\n8 format('3XQ dvkijk:',6(1pe10.2))\r\n!\r\n! set all partical derivatives to zero as default return\r\n if(mqmqder) then\r\n write(*,*)'3XQ *** entering dvkij_dzijkl',cxq,mxq\r\n! write(*,*)'3XQ in dvkij_dzijkl',cxq,mxq\r\n! write(*,10)mqf%compvar(cxq)%ivk_ij\r\n! write(*,20)mqf%compvar(cxq)%jvk_ji\r\n! write(*,30)mqf%compvar(cxq)%kvk_ijk\r\n! write(*,30)mqf%compvar(cxq)%all_ijk\r\n write(*,10)box%ivk_ij\r\n write(*,20)box%jvk_ji\r\n write(*,30)box%kvk_ijk\r\n write(*,40)box%all_ijk\r\n10 format('3XQ ivk_ij: ',10i3)\r\n20 format('3XQ jvk_ji: ',10i3)\r\n30 format('3XQ kvk_ijk:',10i3)\r\n40 format('3XQ kvk_all:',10i3)\r\n endif\r\n! initiate all partial derivaties to zero\r\n dksum=.true.\r\n sumi=zero\r\n sumj=zero\r\n!\r\n! vk_ij = \\sum_i xquad(ivk_ij) / (\\sum_k xquad(kvk_ijk)+\\sum_k xquad(ivk_ij))\r\n! vk_ji = \\sum_i xquad(jvk_ji) / (\\sum_k xquad(kvk_ijk)+\\sum_k xquad(jvk_ji))\r\n!\r\n! This routine calculates derivatives of variables vk_ij does not depend on!\r\n!\r\n! quadloop: do ijkl=1,mxq\r\n! The loop for ksum needed only once ....................\r\n! do_dksum: if(dksum) then\r\n! if derivative of sum_k xquad(kvk_ijk), if zero all derivatives zero\r\n! the sumk include sum of all fractions in \\sum_i and \\sum_j\r\n! sumk=zero\r\n! derivative of denominator is zero or one\r\n! dgij=0\r\n! dgji=0\r\n! dijk=0\r\n! skip=.true.\r\n!\r\n sumk=0.0d0\r\n denominator: do kk=1,size(box%all_ijk)\r\n! a quad fraction term can only apper once\r\n vkix=box%all_ijk(kk)\r\n sumk=sumk+mqf%xquad(vkix)\r\n! listing of derivative calculations\r\n! 3XQ kloop for mqf%compvar( 1)%all_ijk( 1) 1 sum 3.5933E-02 1 1 1\r\n! 3XQ kloop for mqf%compvar( 1)%all_ijk( 2) 1 sum 6.7187E-01 1 3 1\r\n! 3XQ kloop for mqf%compvar( 1)%all_ijk( 3) 1 sum 1.0000E+00 1 2 1\r\n! 3XQ iloop for mqf%compvar( 1)%ivk_ij( 1) 1 sum 3.5933E-02 1 1 1\r\n! 3XQ jloop for mqf%compvar( 1)%jvk_ji( 1) 1 sum 6.3593E-01 0 3 1\r\n! 3XQ dvk: 1 1 0 3.5933E-02 6.3593E-01 1.0000E+00 9.6407E-01 -6.3593E-01\r\n! 3XQ kloop for mqf%compvar( 1)%all_ijk( 1) 2 sum 3.5933E-02 1 1 1\r\n! 1 2 3 4 \r\n! if(mqmqder) write(*,50)'k',cxq, ')%all_ijk(', kk,') ',&\r\n! ijkl,'k',sumk,1,vkix,ijkl\r\n! 5 6 7 8 9 10\r\n!\r\n! 1 2 3 4 \r\n!50 format('3XQ ',a,'loop for mqf%compvar(',i2, a, i2,a,&\r\n! i4,' sum',a,': ',1pe12.4,2x,3i2)\r\n! 5 6 7 8-10\r\n! mqf%compvar(cxq)%all_ijk(kk),ijkl, sumk \r\n!\r\n! skip=.false.\r\n! write(*,*)'3XQ ********* ',kk,vkix,ijkl\r\n! dijk=1\r\n! endif\r\n enddo denominator\r\n! write(*,51)size(box%all_ijk),sumk,box%all_ijk\r\n51 format('3XQ Summed ',i2,' quads in kvk_ijk ',1pe12.4,10i3)\r\n \r\n! if sumk is zero there are no derivatives with respect to this quad\r\n! this is not an error, just a message\r\n! write(*,54)cxq,ijkl\r\n!54 format('3XQ vk(',i2,') does not depend on quad ',i2)\r\n!\r\n! below only if the vk_ij and vk_ji do not depend on ijkl\r\n!\r\n! The loop above summed all fraction variables of denominator, needed below\r\n! We have to take care of the nominators if varkappa_ij and varkappa_ji \r\n! sumi=zero\r\n!\r\n sumi=0.0d0\r\n nominator1: do kk=1,size(box%ivk_ij)\r\n! dgij=0\r\n vkix=box%ivk_ij(kk)\r\n sumi=sumi+mqf%xquad(vkix)\r\n! if(mqf%compvar(cxq)%ivk_ij(kk).eq.ijkl) then \r\n! if(box%ivk_ij(kk).eq.ijkl) then\r\n! if(vkix.eq.ijkl) then\r\n! dgij=1\r\n! endif\r\n! 1 2 3 4 \r\n! if(mqmqder) write(*,50)'i',cxq, ')%vk_ij(', kk,') ',&\r\n! ijkl,'i',sumi,1,vkix,ijkl\r\n! 5 6 7 8 9 10\r\n enddo nominator1\r\n! write(*,55)size(box%ivk_ij),sumi,box%ivk_ij\r\n55 format('3XQ Summed ',i2,' quads in ivk_ij',1pe12.4,10i3)\r\n!\r\n! note sumi and/or sumj can be zero\r\n!\r\n sumj=0.0d0\r\n nominator2: do kk=1,size(box%jvk_ji)\r\n! dgji=0\r\n vkix=box%jvk_ji(kk)\r\n sumj=sumj+mqf%xquad(vkix)\r\n! if(mqf%compvar(cxq)%jvk_ji(kk).eq.ijkl) then\r\n! if(box%jvk_ji(kk).eq.ijkl) then\r\n! if(vkix.eq.ijkl) then\r\n! dgji=1\r\n! endif\r\n! 1 2 3 4 \r\n! if(mqmqder) write(*,50)'j',cxq, ')%vk_ji(', kk,') ',&\r\n! ijkl,'j',sumj,1,vkix,ijkl\r\n! 5 6 7 8 9 10\r\n enddo nominator2\r\n! write(*,56)size(box%jvk_ji),sumj,box%jvk_ji\r\n56 format('3XQ Summed ',i2,' quads in jvk_ji',1pe12.4,10i3)\r\n!\r\n! derivative of a quotient d(g/h) = (1/h)*dg/dx - (g/h**2)*dh/dx = \r\n! = (h*dg/dx - g*dh/dx)/h**2\r\n!\r\n! the derivarive value g=sumi/sumk; h=sumj/sumk; di and dj can be zero \r\n! the derivarive value dj*sumi-di*sumj\r\n! \r\n if(sumk.eq.zero) then\r\n write(*,*)'3XQ line 2691, division by zero, check source code!!!'\r\n sumk=1.0d0\r\n endif\r\n! Attempt 2026.03.29 to fix problem derivatives wrt fractions in denomonator\r\n!\r\n! the derivatives are calculated here, dg/dx and dh/dx is 0 or 1\r\n! derivative of a quotient d(g/h) = 1/h*(dg/dx) - (g/h**2)*dh/dx\r\n!\r\n! the denominatorof a vk_ij contains all quads\r\n dijk=1.0d0\r\n loopdenom: do kk=1,size(box%all_ijk)\r\n! all quads in the vk are present in the denominator\r\n ijkl=box%all_ijk(kk)\r\n checknom1: do ii=1,size(box%ivk_ij)\r\n if(box%ivk_ij(ii).eq.ijkl) then\r\n dvkijk(1,ijkl)=(sumk - sumi*dijk)/sumk**2\r\n else\r\n dvkijk(1,ijkl)= -sumi*dijk/sumk**2\r\n endif\r\n enddo checknom1\r\n checknom2: do ii=1,size(box%jvk_ji)\r\n! do not use dgij and dgji are 0 or 1 depending on quads in vk_ij or vk_ji\r\n if(box%jvk_ji(ii).eq.ijkl) then\r\n dvkijk(2,ijkl)=(sumk - sumj*dijk)/sumk**2\r\n else\r\n dvkijk(2,ijkl)= - sumj*dijk/sumk**2\r\n endif\r\n enddo checknom2\r\n!\r\n! write(*,69)cxq,ijkl,dvkijk(1,ijkl),dvkijk(2,ijkl)\r\n69 format('3XQ dvk(',i2,')_ij&_ji/dq(',i2,') = ',2(1pe12.4))\r\n enddo loopdenom\r\n if(mqmqder) then\r\n write(*,70)ijkl,sumi,sumj,sumk,&\r\n dvkijk(1,ijkl),dvkijk(2,ijkl)\r\n70 format('3XQ dvk2: ',i2,3(1pe12.4),1x,2(1pe12.4))\r\n endif\r\n!---------------------------------------------------------\r\n! return derivatives of dvarkappa(ceq)/dxquad for all quads\r\n!\r\n1000 continue\r\n if(mqmqder) then\r\n write(*,1090)cat1,cat2,(dvkijk(1,ijkl),ijkl=1,mxq)\r\n write(*,1090)cat2,cat1,(dvkijk(2,ijkl),ijkl=1,mxq)\r\n1090 format('3XQ dvk(',i1,',',i1,')/dq: ',20(1pe10.2))\r\n write(*,*)'3XQ *** exit dvkij_dzijk'\r\n endif\r\n return\r\n end subroutine dvkij_dzijk\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine calc_newdvkij_values(phres,ceq)\r\n!\\begin{verbatim}\r\n subroutine calc_newdvkij_values(phres,ceq)\r\n! calculates all partial derivatives of vk_ij wrt x_ij for use in excess param\r\n! f_ij = xquad(xq) * vk_ij(vk)**ppow * vk_ji(vk)**qpow with terms as\r\n! df_ij/dx_lm = ...ppow*vk_ij(vk)**(ppow-)*DVKIJ(ij,lm) ...\r\n!\r\n implicit none\r\n type(gtp_phase_varres), pointer :: phres\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n!\r\n! dvk_ij(ij,lm) is derivative of vk_ij with respect to x_lm\r\n! using ivk_ij, jvk_ji and kvk_ijk\r\n! and current values of x_ij\r\n! values stored in local arrays ??\r\n! simplification: NO SECOND DERIVATIVES !!!!!!!! not even d2(prod * dL/dT)\r\n!!\\end{verbatim}\r\n! For the excess we need to calculate many derivatives of\r\n!\r\n! f_ij = x_ij * vk_ij(x_kl)**ppow * vk_ji(x_kl)**qpow * L\r\n! \r\n! which requires values of d(vk_ij(x_kl))/dx_mn\r\n! many times. Calculate all now and store in mqf%compvar(ij)%dvk_ij(mn)\r\n!\r\n! mqf%compvar(ij)%vk_ij array of values of vk(ij) for current quad fractions\r\n! mqf%compvar(ij)%vk_ji \" values of vk(ji)\r\n! mqf%compvar(ij)%ivk_ij \" of quad indices for nominator of vk_ij (fixed)\r\n! mqf%compvar(ij)%jvk_ji \" indices for nominator of vk_ji\r\n! mqf%compvar(ij)%kvk_ijk \" indices for denominator of both\r\n! mqf%compvar(ij)%dvk_ij \" of derivatives of vk_ij for current quad fractions\r\n! mqf%compvar(ij)%dvk_ji \" of derivatives of vk_ij for current quad fractions\r\n!\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n integer ij,nquad,nvk\r\n!-----------------------------------------------------------------\r\n! Calculate all derivatives of vk_ij with resp to all quadruplet x_ij\r\n!\r\n! vk_ij = ivk_ij / kvk_ijk = \\sum_kl x_kl / \\sum_mn x_mn\r\n! vk_ji = jvk_ji / kvk_ijk = \\sum_kl x_kl / \\sum_mn x_mn\r\n!\r\n! ivk, jvk and kvk are stored in DVK_ij DVK_JI calculated where ???\r\n!\r\n! divk, djvk and dkvk are note stored\r\n!\r\n! dvk_klm = d(ivk) * kvk - ivk * d(kvk) / kvk**2\r\n!\r\n!\r\n! NOTE j>i in x_ij but vk_ij can depend on all x_ii, etc.\r\n!\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n mqf=>phres%mqmqaf\r\n! \r\n! do ij=1,mqf%npair\r\n! mqf%compvar(ij)%dvk_ij=zero\r\n! mqf%compvar(ij)%dvk_ji=zero\r\n! enddo\r\n!\r\n write(*,*)'3XQ remove any call to one_newdvkij_values'\r\n stop\r\n return\r\n end subroutine calc_newdvkij_values\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine convert_y2quadx\r\n!\\begin{verbatim}\r\n subroutine mqmqa_excesspar_name(lokph,intlev,nfr,ylinks,text,jp)\r\n!\r\n integer lokph,intlev,nfr\r\n integer ylinks(*),jp\r\n character text*(*)\r\n! write the set of constituents, complex as ylinks are quadindex\r\n! and ylinks are constiuent order (which may be the same but not always)\r\n!\\end{verbatim}\r\n integer ii,jj,kk\r\n character*24, dimension(10) :: const\r\n! strange intlev is 1 here, it is 0 in calling routine ... only endmember quad\r\n! write(*,10)nfr,(ylinks(ii),ii=1,nfr)\r\n!10 format('3XQ *** no of const: ',i2,', ylinks: ',10i3)\r\n! write(*,20)phlista(lokph)%constitlist\r\n!20 format('3XQ *** phase const: ',25i3)\r\n! phlista(lokph)%constitlist is index in splista <<<<<<<<<<<<<<<\r\n! write(*,30)trim(splista(phlista(lokph)%constitlist(1))%symbol)\r\n!30 format('3XQ *** phase const names: ',a)\r\n!\r\n! A useful excersize to remember how data in OC are stored!!!\r\n!\r\n text='G(MSCL,'; jp=8\r\n do jj=1,nfr\r\n text(jp:)=trim(splista(phlista(lokph)%constitlist(ylinks(jj)))%symbol)//','\r\n jp=len_trim(text)+1\r\n enddo\r\n! write(*,40)(trim(splista(phlista(lokph)%constitlist(ylinks(jj)))%symbol),&\r\n! jj=1,intlev)\r\n! trim(splista(phlista(lokph)%constitlist(ylinks(3)))%symbol)\r\n!40 format('3XQ *** phase const name: ',10(a,','))\r\n!\r\n return\r\n end subroutine mqmqa_excesspar_name\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine ternary_factor\r\n!\\begin{verbatim}\r\n subroutine ternary_factor(xq,cat1,cat2,ylinks,mm,hejhopp,proprec)\r\n! calculates the ternary factor of a parameter\r\n integer xq,cat1,cat2,mm,ylinks(*)\r\n double precision hejhopp\r\n type(gtp_property), pointer :: proprec\r\n!\\end{verbatim}\r\n! xq is the AB/X quad index\r\n! cxq in the index in compvar which gives 2 quad indices for A/X and B/X\r\n! ylinks are the OC fraction indices\r\n! mm is the unknown 4th quad\r\n! hejhopp is the value to return, possibly 1.0D0\r\n integer ii\r\n write(*,'(a,3i3,2x,10i3)')'3XQ trying to find mm',xq,cat1,cat2,&\r\n (ylinks(ii),ii=1,4)\r\n! but ylinks are OC fraction indices, not necessarily same as quad indices\r\n! BUT at present, check which one of the last 2 in ylinks that is an A/X quad\r\n do ii=1,size(mqmqa_data%emquad)\r\n if(ylinks(3).eq.mqmqa_data%emquad(ii)) goto 100\r\n enddo\r\n do ii=1,size(mqmqa_data%emquad)\r\n if(ylinks(4).eq.mqmqa_data%emquad(ii)) goto 100\r\n enddo\r\n write(*,*)'3XQ cannot find the ternary C/X quad'\r\n gx%bmperr=4399; goto 1000\r\n! return the index of the cation in the C/X quad\r\n100 mm=ii\r\n1000 continue\r\n write(*,*)'3XQ leaving ternary_factor',mm\r\n return\r\n end subroutine ternary_factor\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine convert_y2quadx\r\n!\\begin{verbatim}\r\n subroutine convert_y2quadx(sem,nint,jord,pquad)\r\n! This is to fix the constitution variables for an MQMQX excess parameter.\r\n! It has one AB/X quad index and 2 A/X and B/X quads and possibly a C/X one\r\n! convert y fraction indexed in sem and jord to quad indices in parquad\r\n!\r\n! I am really really fedup with this model\r\n!\r\n implicit none\r\n integer sem,nint,jord(2,*),pquad(*)\r\n!\\end{verbatim}\r\n integer ii,jj,nq3,kk,pair,qorder(4),lowa,highb,temp(4),nbx\r\n!\r\n! input data from database\r\n! write(*,*)'3XQ *** fixing MQMQA parameter composition variables',&\r\n! size(mqmqa_data%emquad),size(mqmqa_data%con2quad)\r\n! write(*,5)sem,jord(2,1:nint)\r\n5 format('3XQ fixing MQMQA parameter composition variables',10i3)\r\n! write(*,20)'emquad',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n! write(*,20)'con2quad',(mqmqa_data%con2quad(jj),jj=1,mqmqa_data%nquad)\r\n20 format('3XQ ',a,21i3)\r\n! pquad(1) should be the pair quad AB/X among sem, jord(2,1..nint)\r\n temp(1)=mqmqa_data%con2quad(sem)\r\n! pquad(2) should be the alphabetically first in quad AB/X, i.e A/X\r\n! pquad(3) should be the alphabetically second in quad AB/X, i.e B/X\r\n! pquad(4) should be the 4th quand, not including A or B \r\n temp(2)=mqmqa_data%con2quad(jord(2,1))\r\n! one may have jord(2,2)=0 here if vacancies\r\n if(jord(2,2).eq.0) then\r\n write(*,*)'3XQ Vacancy not allowed in MQMQA quad'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n temp(3)=mqmqa_data%con2quad(jord(2,2))\r\n! the quad index related to temp(2) and temp(3) should be temp(1) ???\r\n! check:\r\n! emquad have the quad indices of all A/X quads, there are ncat of them.\r\n! The index of a quad (i,j) where j>i is emquad(i)+j-i \r\n! write(*,*)'3XQ values temp: ',temp(1),temp(2),temp(3)\r\n if(temp(2).gt.temp(3)) then\r\n write(*,*)'3XQ parameter has wrong order of A/X and B/X quads'\r\n stop 76\r\n! else\r\n! ii=mqmqa_data%emquad(temp(2))+temp(3)-temp(2)\r\n! write(*,*)'3XQ values of mixed quad index: ',temp(1),temp(2),temp(3),ii\r\n! if(temp(1).ne.ii) then\r\n! write(*,*)'3XQ problems with quad indices'\r\n! stop 77\r\n! endif\r\n endif\r\n nq3=3\r\n if(nint.eq.3) then\r\n nq3=4; temp(4)=mqmqa_data%con2quad(jord(2,3))\r\n endif\r\n! write(*,10)'first',(temp(ii),pquad(ii),ii=1,nq3)\r\n10 format('3XQ ',a,' quads ',2i3,', first ',2i3,', second ',2i3,', maybe ',2i3)\r\n! find the AB/X quad and the arrange the others\r\n! all but one of the quads in temp(1..nq3) should be A/X quads\r\n! and temp(2) should have the lowest index of the AB/x quad and temp(3)\r\n! the highest. Any temp(4) quad should not be A/X or B/X\r\n! this code is horrible\r\n!\r\n pair=0; lowa=0\r\n loop4: do ii=1,nq3\r\n pquad(ii)=temp(ii)\r\n qorder(ii)=ii\r\n!\r\n! qx is quad\r\n! Calculate: quad(temp(1)*\\xi(temp(3),temp(2)**ppow\r\n! write(*,*)'3XQ is this the pair?',pquad(ii),qorder(ii)\r\n loopax: do jj=1,mqmqa_data%ncat\r\n!\r\n! cycle loop4 if temp(ii) is an A/X quad\r\n!\r\n if(temp(ii).eq.mqmqa_data%emquad(jj)) cycle loop4\r\n enddo loopax\r\n! if we arrive here temp(ii) is a AB/X quad\r\n if(pair.eq.0) then\r\n! do not exit as we want to check there is not a second pair\r\n! pair=ii; lowa=jj-1\r\n! ERROR: we have to loop mequad again to find jj! Or program smarter\r\n pair=ii\r\n! write(*,*)'3XQ loop to find the A/X quad index'\r\n notneeded: do jj=1,mqmqa_data%ncat\r\n if(temp(ii).lt.mqmqa_data%emquad(jj)) exit notneeded\r\n! if(temp(ii).gt.mqmqa_data%emquad(jj)) then\r\n! lowa=jj-1\r\n! exit notneeded\r\n! endif\r\n enddo notneeded\r\n lowa=jj-1\r\n! lowa saves the quad index of the A/X quad for the AB/X quad\r\n! write(*,*)'3XQ the pair is quad ',ii,lowa\r\n else\r\n write(*,*)'3XQ convert_y2quads found two pair fractions in a parameter'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n enddo loop4\r\n! if lowa=0 we have not found the AB/X quad\r\n if(lowa.eq.0) then\r\n write(*,*)'3XQ cannot find the AB/X quad',(temp(ii),ii=1,nq3),&\r\n ', among ',(mqmqa_data%emquad(ii),ii=1,mqmqa_data%ncat)\r\n stop\r\n endif\r\n! set the pair as first quad in pquad; maybe change qorder\r\n! write(*,30)pair,lowa,(qorder(ii),ii=1,nq3)\r\n30 format('3XQ we found the pair: ',i3,', lowa:',i3,', qorder:',15i3)\r\n! write(*,40)'3XQ pquad before:',(pquad(ii),ii=1,nq3)\r\n! write(*,40)'3XQ qorder before',(qorder(ii),ii=1,nq3)\r\n if(pair.ne.1) then\r\n! shift positions\r\n jj=pquad(1); kk=qorder(1)\r\n pquad(1)=pquad(pair); qorder(1)=qorder(pair)\r\n pquad(pair)=jj; qorder(pair)=kk\r\n endif\r\n! write(*,40)'3XQ pquad after:',(pquad(ii),ii=1,nq3)\r\n! write(*,40)'3XQ qorder after',(qorder(ii),ii=1,nq3)\r\n40 format(a,4i3)\r\n! it seems OK here ..................\r\n! now pquad(1) is the pair AB/X. make pquad(2) to be A/X and pquad(3) as B/X\r\n! Probably there is a smart way but I am just fed up with this\r\n! All other constituents must be single cations: A/X, B/X or C/X\r\n! write(*,*)'3XQ value of nq3',nq3\r\n if(nq3.eq.3) then\r\n! It should be sufficient that temp(2) < temp(3)\r\n! But if there is a 4th quad one has to eliminate the quad without A and B\r\n if(pquad(2).gt.pquad(3)) then\r\n if(pquad(3).ne.lowa) then\r\n write(*,*)'3XQ problems finding A/X quad',lowa,pquad(2)\r\n jj=pquad(2); pquad(2)=pquad(3); pquad(3)=jj\r\n endif\r\n endif\r\n! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3)\r\n else\r\n! lowa must be the A/X quad because AB/X must be after A/X\r\n! the difference between quad AB/X and A/X must be related to the B/X\r\n! pquad(1) is the index of AB/X quad, the A/X quad is lowa\r\n! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n highb=pquad(1)-mqmqa_data%emquad(lowa)\r\n! write(*,*)'3XQ value of highb',pquad(1),mqmqa_data%emquad(lowa),highb\r\n! the B/X quad should be highb indices in emquad higher than lowa\r\n nbx=mqmqa_data%emquad(lowa+highb)\r\n! write(*,*)'3XQ tables are turning:',pquad(3),pquad(4),nbx\r\n if(pquad(3).ne.nbx) then\r\n if(pquad(4).ne.nbx) then\r\n write(*,*)'3XQ circles are square'\r\n stop\r\n endif\r\n jj=pquad(4); pquad(4)=jj; pquad(3)=jj\r\n endif\r\n! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3)\r\n endif\r\n! list everything\r\n! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n! write(*,10)'final',(temp(ii),pquad(ii),ii=1,nq3)\r\n! write(*,666)(pquad(ii),ii=1,nq3)\r\n666 format('3XQ fixed MQMQA parameter, quad is ',i3,', asymmetrical: ',10i3)\r\n! write(*,*)'3XQ hit return to handle next parameter'\r\n! read(*,*)\r\n!\r\n1000 continue\r\n return\r\n end subroutine convert_y2quadx\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine convert_y2quadx_old\r\n!\\begin{verbatim}\r\n subroutine convert_y2quadx_old(sem,nint,jord,pquad)\r\n! This is to fix the constitution variables for an MQMQX excess parameter.\r\n! It has one AB/X quad index and 2 A/X and B/X quads and possibly a C/X one\r\n! convert y fraction indexed in sem and jord to quad indices in parquad\r\n!\r\n! I am really really fedup with this model\r\n!\r\n implicit none\r\n integer sem,nint,jord(2,*),pquad(*)\r\n!\\end{verbatim}\r\n integer ii,jj,nq3,kk,pair,qorder(4),lowa,highb,temp(4),nbx\r\n!\r\n! input data from database\r\n! write(*,*)'3XQ *** fixing MQMQA parameter composition variables',&\r\n! size(mqmqa_data%emquad),size(mqmqa_data%con2quad)\r\n! write(*,5)sem,jord(2,1:nint)\r\n5 format('3XQ fixing MQMQA parameter composition variables',10i3)\r\n! write(*,20)'emquad',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n! write(*,20)'con2quad',(mqmqa_data%con2quad(jj),jj=1,mqmqa_data%nquad)\r\n20 format('3XQ ',a,21i3)\r\n! pquad(1) should be the pair quad AB/X among sem, jord(2,1..nint)\r\n temp(1)=mqmqa_data%con2quad(sem)\r\n! pquad(2) should be the alphabetically first in quad AB/X, i.e A/X\r\n! pquad(3) should be the alphabetically second in quad AB/X, i.e B/X\r\n! pquad(4) should be the 4th quand, not including A or B \r\n temp(2)=mqmqa_data%con2quad(jord(2,1))\r\n temp(3)=mqmqa_data%con2quad(jord(2,2))\r\n! the quad index related to temp(2) and temp(3) should be temp(1) ???\r\n! check:\r\n! emquad have the quad indices of all A/X quads, there are ncat of them.\r\n! The index of a quad (i,j) where j>i is emquad(i)+j-i \r\n write(*,*)'3XQ values temp: ',temp(1),temp(2),temp(3)\r\n if(temp(2).gt.temp(3)) then\r\n write(*,*)'3XQ parameter has wrong order of A/X and B/X quads'\r\n stop 76\r\n else\r\n ii=mqmqa_data%emquad(temp(2))+temp(3)-temp(2)\r\n write(*,*)'3XQ values of mixed quad index: ',temp(1),temp(2),temp(3),ii\r\n if(temp(1).ne.ii) then\r\n write(*,*)'3XQ problems with quad indices'\r\n stop 77\r\n endif\r\n endif\r\n nq3=3\r\n if(nint.eq.3) then\r\n nq3=4; temp(4)=mqmqa_data%con2quad(jord(2,3))\r\n endif\r\n! write(*,10)'first',(temp(ii),pquad(ii),ii=1,nq3)\r\n10 format('3XQ ',a,' quads ',2i3,', first ',2i3,', second ',2i3,', maybe ',2i3)\r\n! find the AB/X quad and the arrange the others\r\n! all but one of the quads in temp(1..nq3) should be A/X quads\r\n! and temp(2) should have the lowest index of the AB/x quad and temp(3)\r\n! the highest. Any temp(4) quad should not be A/X or B/X\r\n! this code is horrible\r\n!\r\n pair=0; lowa=0\r\n loop4: do ii=1,nq3\r\n pquad(ii)=temp(ii)\r\n qorder(ii)=ii\r\n!\r\n! qx is quad\r\n! Calculate: quad(temp(1)*\\xi(temp(3),temp(2)**ppow\r\n! write(*,*)'3XQ is this the pair?',pquad(ii),qorder(ii)\r\n loopax: do jj=1,mqmqa_data%ncat\r\n!\r\n! cycle loop4 if temp(ii) is an A/X quad\r\n!\r\n if(temp(ii).eq.mqmqa_data%emquad(jj)) cycle loop4\r\n enddo loopax\r\n! if we arrive here temp(ii) is a AB/X quad\r\n if(pair.eq.0) then\r\n! do not exit as we want to check there is not a second pair\r\n! pair=ii; lowa=jj-1\r\n! ERROR: we have to loop mequad again to find jj! Or program smarter\r\n pair=ii\r\n! write(*,*)'3XQ loop to find the A/X quad index'\r\n notneeded: do jj=1,mqmqa_data%ncat\r\n if(temp(ii).lt.mqmqa_data%emquad(jj)) exit notneeded\r\n! if(temp(ii).gt.mqmqa_data%emquad(jj)) then\r\n! lowa=jj-1\r\n! exit notneeded\r\n! endif\r\n enddo notneeded\r\n lowa=jj-1\r\n! lowa saves the quad index of the A/X quad for the AB/X quad\r\n! write(*,*)'3XQ the pair is quad ',ii,lowa\r\n else\r\n write(*,*)'3XQ convert_y2quads found two pair fractions in a parameter'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n enddo loop4\r\n! if lowa=0 we have not found the AB/X quad\r\n if(lowa.eq.0) then\r\n write(*,*)'3XQ cannot find the AB/X quad',(temp(ii),ii=1,nq3),&\r\n ', among ',(mqmqa_data%emquad(ii),ii=1,mqmqa_data%ncat)\r\n stop\r\n endif\r\n! set the pair as first quad in pquad; maybe change qorder\r\n! write(*,30)pair,lowa,(qorder(ii),ii=1,nq3)\r\n30 format('3XQ we found the pair: ',i3,', lowa:',i3,', qorder:',15i3)\r\n! write(*,40)'3XQ pquad before:',(pquad(ii),ii=1,nq3)\r\n! write(*,40)'3XQ qorder before',(qorder(ii),ii=1,nq3)\r\n if(pair.ne.1) then\r\n! shift positions\r\n jj=pquad(1); kk=qorder(1)\r\n pquad(1)=pquad(pair); qorder(1)=qorder(pair)\r\n pquad(pair)=jj; qorder(pair)=kk\r\n endif\r\n! write(*,40)'3XQ pquad after:',(pquad(ii),ii=1,nq3)\r\n! write(*,40)'3XQ qorder after',(qorder(ii),ii=1,nq3)\r\n40 format(a,4i3)\r\n! it seems OK here ..................\r\n! now pquad(1) is the pair AB/X. make pquad(2) to be A/X and pquad(3) as B/X\r\n! Probably there is a smart way but I am just fed up with this\r\n! All other constituents must be single cations: A/X, B/X or C/X\r\n! write(*,*)'3XQ value of nq3',nq3\r\n if(nq3.eq.3) then\r\n! It should be sufficient that temp(2) < temp(3)\r\n! But if there is a 4th quad one has to eliminate the quad without A and B\r\n if(pquad(2).gt.pquad(3)) then\r\n if(pquad(3).ne.lowa) then\r\n write(*,*)'3XQ problems finding A/X quad',lowa,pquad(2)\r\n jj=pquad(2); pquad(2)=pquad(3); pquad(3)=jj\r\n endif\r\n endif\r\n! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3)\r\n else\r\n! lowa must be the A/X quad because AB/X must be after A/X\r\n! the difference between quad AB/X and A/X must be related to the B/X\r\n! pquad(1) is the index of AB/X quad, the A/X quad is lowa\r\n! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n highb=pquad(1)-mqmqa_data%emquad(lowa)\r\n write(*,*)'3XQ value of highb',pquad(1),mqmqa_data%emquad(lowa),highb\r\n! the B/X quad should be highb indices in emquad higher than lowa\r\n nbx=mqmqa_data%emquad(lowa+highb)\r\n! write(*,*)'3XQ tables are turning:',pquad(3),pquad(4),nbx\r\n if(pquad(3).ne.nbx) then\r\n if(pquad(4).ne.nbx) then\r\n write(*,*)'3XQ circles are square'\r\n stop\r\n endif\r\n jj=pquad(4); pquad(4)=jj; pquad(3)=jj\r\n endif\r\n! write(*,*)'3XQ order of pquad:',(pquad(kk),kk=1,nq3)\r\n endif\r\n! list everything\r\n! write(*,20)'emquad again',(mqmqa_data%emquad(jj),jj=1,mqmqa_data%ncat)\r\n! write(*,10)'final',(temp(ii),pquad(ii),ii=1,nq3)\r\n! write(*,666)(pquad(ii),ii=1,nq3)\r\n666 format('3XQ fixed MQMQA parameter, quad is ',i3,', asymmetrical: ',10i3)\r\n! write(*,*)'3XQ hit return to handle next parameter'\r\n! read(*,*)\r\n!\r\n1000 continue\r\n return\r\n end subroutine convert_y2quadx_old\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine set_quadfractions(phres,verbose,yfr)\r\n!\\begin{verbatim}\r\n subroutine set_quadfractions(phres,verbose,yfra)\r\n! copy values from yfr to xquad, y_ik etc using con2quad\r\n! mqmqa_data%initaties phase variables for new mqmqa excess model\r\n! the normal fractions, used by the config entropy, already set\r\n implicit none\r\n type(gtp_phase_varres), pointer :: phres\r\n type(gtp_mqmqa_var), pointer :: mqmqaf\r\n double precision yfra(*)\r\n logical verbose\r\n! type(gtp_equilibrium_data), pointer :: ceq\r\n!\\end{verbatim}\r\n integer ia,iq\r\n! write(*,10)\r\n10 format('3XQ in set_quadfractions, use con2quad for yfr to xquad'/&\r\n 'then call calcasymvar to set \\varkappa, \\xi and Y_ik.',&\r\n ' Latt som en platt')\r\n mqmqaf=>phres%mqmqaf\r\n if(.not.associated(mqmqaf)) then\r\n write(*,*)'3XQ there is no mqmqaf record for this phase'\r\n stop\r\n end if\r\n if(verbose) write(*,20)size(mqmqa_data%con2quad),&\r\n (mqmqa_data%con2quad(ia),ia=1,mqmqa_data%nquad)\r\n20 format('3XQ mqmqaf%con2quad: ',i3,2x,20i3)\r\n do ia=1,mqmqa_data%nquad\r\n iq=mqmqa_data%con2quad(ia)\r\n! I am not sure how to copy from yfr to mqmqaf%xquad\r\n mqmqaf%xquad(ia)=phres%yfr(iq)\r\n if(verbose) write(*,26)ia,phres%yfr(ia),iq,mqmqaf%xquad(iq)\r\n26 format('3XQ the OC fraction: ',i3,1pe14.6,&\r\n ' is set to MQMQA quad: ',i3,1pe14.6)\r\n enddo\r\n! if(verbose) write(*,*)'3XQ calling calcasymvar for \\varkappa_ij, \\xi_ij etc.'\r\n call calcasymvar(phres)\r\n! if(verbose) write(*,*)'3XQ back from calcasymvar'\r\n!\r\n1000 continue\r\n return\r\n end subroutine set_quadfractions\r\n \r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine init_excess_asymm\r\n!\\begin{verbatim}\r\n subroutine init_excess_asymm(lokph)\r\n! subroutine init_excess_asymm(lokph,ic,ia)\r\n! initaties phase variables for new mqmqa excess model\r\n! called from gtp3B create_asymmetry\r\n! number of independent quads, ic cations, ia anions (max 1)\r\n implicit none\r\n! ic is number of cations, ia number of anions, there are also avalable globally\r\n integer ic,ia,lokph\r\n! type(gtp_phase_record), pointer :: phase\r\n type(gtp_ternary_asymmetry), pointer :: asym3rec\r\n! there is a global mqmqa_data record to use!! <<<<<<<<<<<<<<<<<<,\r\n!\\end{verbatim}\r\n integer i,j,k,nseq,mm,apos,nbinsys,ntercat\r\n! integer i,j,k,nseq,mm,apos,lcat,lnan,nbinsys,ntercat\r\n! how to create xquad mm when we need a pointer to gtp_phase_varres?\r\n type(gtp_equilibrium_data), pointer :: ceq\r\n type(gtp_phase_varres), pointer :: phres\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n character*6 defasym\r\n! Many properties are symmetric, for example xquad which has a single index\r\n! and is indexed by ijkl(i,j,k,l) where ijkl(i,j,k,l)=ijkl(j,i,k,l)\r\n! but other are unsymmetric such as varkappa and xi\r\n!\r\n! write(*,*)'3QX In init_excess_asymm <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'\r\n!\r\n ceq=>firsteq\r\n! I have forgotten how OC works. When entering phases one can creat\r\n! data structures in gtp_equilibrium_data (record pointer ceq)\r\n! and these will be copied when new equilibrium records created\r\n! (for example parallel calculations). When a second gtp_equilibium_data\r\n! has been created one is not allowed to change this data_structure\r\n! the line below creates a pointer to the gtp_mqmqa_var data inside ceq\r\n! maybe problem with the array here ...\r\n i=1\r\n5 continue\r\n i=i+1\r\n! this is very clumsy, but I have no better way\r\n phres=>ceq%phase_varres(i)\r\n! write(*,*)'loop: ',i,lokph,phres%phlink\r\n if(phres%phlink.ne.lokph) goto 5\r\n!\r\n! write(*,*)'Found phase_varres!',i\r\n mqf=>phres%mqmqaf\r\n! xquad is declared globally in OC BUT maybe better if\r\n! xquad is declared within the gtp3_phase_varres mqmqaf record ??????/\r\n! The mqf below is part of gtp_phase_varres \r\n! initiate with equal amount\r\n! The xquads in a sequental array and used ONLY to calculate excess parameters \r\n! number of binary cation combination, in a binary 11-12-22\r\n! in xquad the order is sequential in the cation order\r\n! 1 2 3 4 .. n ! n+1 n+2 .. 2n-1 ! 2n 2n+1 .. ! ... ! n(n+1)/2\r\n! 1/1 1/2 1/3 1/4 1/n ! 2/2 2/3 .. 2/n ! 3/3 3/4 .. ! ... ! n/n \r\n! the function ijklx(i,j,k,l) calculates the sequential index\r\n! we have to inititate con2quad below with the corresponding cation indices\r\n! now we can create the xquad array and other things in mqf \r\n if(.not.allocated(mqf%xquad)) then\r\n! write(*,*)'3XQ allocating xquad',mqmqa_data%nquad,mqmqa_data%nconst\r\n allocate(mqf%xquad(mqmqa_data%nquad))\r\n mqf%xquad=1.0d0/mqmqa_data%nquad\r\n endif\r\n!\r\n! write(*,*)'3XQ *** Creation of cross indices for fractions and quads below'\r\n!\r\n! ncat=ic\r\n! nan=ia\r\n! write(*,10)trim(phlista(lokph)%name),mqmqa_data%ncat,mqmqa_data%nan\r\n10 format(/'3XQ Initiating mqmqa model for ',a,' with ',i3,' cations and ',&\r\n i2,' anion')\r\n! initiate also values in mqmqa_data\r\n! write(*,*)'3XQ init_excess check:',mqmqa_data%ncon1,mqmqa_data%ncat,&\r\n! mqmqa_data%ncon2,mqmqa_data%nan,mqmqa_data%lcat\r\n! mqmqa_data%ncon1=ncat\r\n! mqmqa_data%ncon2=nan\r\n! mqmqa_data%lcat=ncat*(ncat+1)/2\r\n! FNN/SNN ratio same for all pairs ... in first work: qfnnsnn\r\n! allocate(mqmqa_data%etafs(ncat*nan))\r\n! mqmqa_data%etafs=2.4D0\r\n! same as qfnnsnn\r\n! the molefration xquad(1,2) is the same as xquad(2,1) and xquad\r\n! lcat=ncat*(ncat+1)/2\r\n! lnan=1 if only one anion\r\n! write(*,*)'3xq value of lnan: ',mqmqa_data%lnan\r\n! lnan=nan*(nan+1)/2\r\n! total number of quads, \r\n!>>>>>>> nquad, ncat, nan, lcat and lnan are global variables !!!!!!!!!!\r\n! CHANGE TO USE VALUES IN MQMQA_DATA!!!\r\n! write(*,11)mqmqa_data%ncat,mqmqa_data%nan,mqmqa_data%nquad,&\r\n! mqmqa_data%ncon1,mqmqa_data%ncon2\r\n11 format('3XQ mqmqa_data: ',10i4)\r\n! if(mqmqa_data%ncat.gt.1 .and. mqmqa%data%nan.gt.1) then\r\n! cations 1 and 2 form quads 1/1 1/2 2/2 but xquad(2,1) same as xquad(1,2)\r\n! 11, 12, 22 are separate quad fractions\r\n! nquad=ncat*(ncat+1)/2*nan*(nan+1)/2\r\n! elseif(nan.eq.1) then\r\n! frequantly there will be a single anion\r\n! nquad=ncat*(ncat+1)/2\r\n! endif\r\n!!\r\n!-------------------------------------------\r\n! now initate record with asymmetries\r\n! write(*,*)'Allocating asymmetries',mqmqa_data%ncat\r\n nseq=0\r\n if(mqmqa_data%nan.eq.1) then\r\n if(mqmqa_data%ncat.gt.1) then\r\n nbinsys=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2\r\n!...allocate ternary structure with asymmetry data\r\n if(mqmqa_data%ncat.gt.2) then\r\n ntercat=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqa_data%ncat-2)/6\r\n allocate(tersys(ntercat))\r\n! insert element indices\r\n mm=0\r\n do i=1,mqmqa_data%ncat-2\r\n do j=i+1,mqmqa_data%ncat-1\r\n do k=j+1,mqmqa_data%ncat\r\n! initiate all ternaries as symmetrical el(1) < el(2) < el(3)\r\n mm=mm+1\r\n if(mm.gt.ntercat) then\r\n write(*,*)'wrong allocation of ntercat',mm,ntercat\r\n stop\r\n endif\r\n tersys(mm)%seq=mm\r\n tersys(mm)%el(1)=i\r\n tersys(mm)%el(2)=j\r\n tersys(mm)%el(3)=k\r\n tersys(mm)%asymm='KKK'\r\n tersys(mm)%isasym=0\r\n enddo\r\n enddo\r\n enddo\r\n! write(*,17)mm\r\n17 format('init_excess_ asymm allocated ternary structures ',i3)\r\n if(mm.ne.ntercat) then\r\n stop 'ternary allocation error'\r\n endif\r\n! else\r\n! write(*,*)'3XQ No ternary data structures needed'\r\n endif\r\n else\r\n write(*,*)'A liquid with a single cation and anion not implemented'\r\n stop\r\n endif\r\n else\r\n write(*,*)'Systems with multiple anions not implemented'\r\n stop\r\n endif\r\n! varkappa and xi_ijis now part of allinone\r\n!\r\n! if(mqmqa_data%ncat.eq.2) goto 80\r\n! write(*,67)mqmqa_data%ncat*(mqmqa_data%ncat-1)*mqmqa_data%nan/2\r\n67 format('3XQ init_excess_asymm allocating asymmetrical compvar array: ',i5)\r\n! we have to intitiate several variables in each compvar\r\n! allocate(compvar(ncat*(ncat-1)*nan/2))\r\n!\r\n allocate(mqf%compvar(mqmqa_data%ncat*(mqmqa_data%ncat-1)/2*mqmqa_data%nan))\r\n! write(*,*)'3QX, initiating compvar for excess model variables',&\r\n! mqmqa_data%ncat,size(mqf%compvar)\r\n if(allocated(mqmqa_data%el2ancat)) then\r\n! write(*,69)\r\n69 format('Heureca! el2ancat allocated')\r\n! write(*,70)size(mqmqa_data%el2ancat),mqmqa_data%ncat,mqmqa_data%el2ancat\r\n70 format('3XQ el2ancat: ',2i3,5x,20i3)\r\n else \r\n write(*,*)'3XQ line 2168: The array mqmqa_data%el2ancat not allocated!'\r\n write(*,*)'3XQ should have been done in correlate_const_and_quads'\r\n gx%bmperr=4399; goto 1000\r\n endif\r\n!\r\n nseq=0\r\n mm=0\r\n! it would have been better allocate compvar as this ...\r\n allocate(mqmqa_data%quad2compvar(mqmqa_data%ncat*(mqmqa_data%ncat+1)/2))\r\n dum1: do i=1,mqmqa_data%ncat\r\n dum2: do j=i,mqmqa_data%ncat\r\n nseq=nseq+1\r\n if(i.ne.j) then\r\n mm=mm+1\r\n mqmqa_data%quad2compvar(nseq)=mm\r\n else\r\n mqmqa_data%quad2compvar(nseq)=10000\r\n endif\r\n enddo dum2\r\n enddo dum1\r\n! write(*,71)mqmqa_data%quad2compvar\r\n71 format('3XQ check quad2compvar',50i3)\r\n!\r\n nseq=0\r\n first: do i=1,mqmqa_data%ncat-1\r\n second: do j=i+1,mqmqa_data%ncat\r\n! initiallize allinone record, allocated as compvar array\r\n nseq=nseq+1\r\n mqf%compvar(nseq)%seq=nseq\r\n! these indices are from 1 to n-1 ignoring anions\r\n mqf%compvar(nseq)%cat1=i\r\n mqf%compvar(nseq)%cat2=j\r\n! these are the element indices in OC\r\n if(i.gt.mqmqa_data%xanionalpha) mqf%compvar(nseq)%elcat1=i+1\r\n if(j.gt.mqmqa_data%xanionalpha) mqf%compvar(nseq)%elcat2=j+1\r\n! note it is negative of element alphabetical index\r\n mqf%compvar(nseq)%elan=-mqmqa_data%xanionalpha\r\n mqf%compvar(nseq)%anion=1\r\n mqf%compvar(nseq)%lastupdate=-1\r\n! ivk_ij, jvi_ji, kvk_ijk, xi_ij etc allocated at each calculation\r\n! NOTE vk_ij, xi_ij are single variables in each box, no need to allocate\r\n mqf%compvar(nseq)%vk_ij=0.0d0\r\n mqf%compvar(nseq)%vk_ji=0.0d0\r\n mqf%compvar(nseq)%xi_ij=0.0d0\r\n mqf%compvar(nseq)%xi_ji=0.0d0\r\n! For identifying m used in eq.25 or 26 in Max paper for ternary excess\r\n! in varkappa1 allocate arrays for which quad fractions vk and xi depend\r\n! they can be different for each compvar\r\n! %dvk_ij and %vdk_ji are single variables, arrays for derivatives\r\n! %dvkx_ij and %vdkx_ji are type(zquad) ??, alternative arrays for derivatives\r\n! allocated at first calculation\r\n allocate(mqf%compvar(nseq)%dxi_ij(mqmqa_data%nquad)) ! dxi_ij/dquad_k\r\n allocate(mqf%compvar(nseq)%dxi_ji(mqmqa_data%nquad)) ! dxi_ji/dquad_k\r\n! The arrays dxi_ij are allocated here but xi_ij are single values in compvar\r\n mqf%compvar(nseq)%dxi_ij=0.0d0\r\n mqf%compvar(nseq)%dxi_ji=0.0d0\r\n! write(*,77)nseq,i,j\r\n77 format(i4,2i5)\r\n enddo second\r\n enddo first\r\n80 continue\r\n\r\n! initiate newXupdate, there is a newupdate I do not know where it is declared\r\n! write(*,*)'3XQ newXupdate for varkappa and xi ',newXupdate\r\n! write(*,*)' *** Where is newupdate declared? ',newupdate\r\n newXupdate=0\r\n! allocate quadz with zi_ijkl, for a single anion\r\n! There are some data for Zv_ij/kl declared in mqmqa_data, use that!!\r\n! write(*,79)ncat*(ncat+1)/2\r\n79 format('Allocating ',i3,' quadz array, for zv_ijkl data')\r\n! allocate(quadz(ncat*(ncat+1)/2))\r\n! create crossreferences beween OC datastructure and MQMQX asymmetric\r\n! write(*,*)'3qx **** init_excess_asymm calls correlate_const_and_quads'\r\n!\r\n! THIS ROUTINE CALLS THIS ONE call correlate_const_and_quads(lokph)\r\n! if(gx%bmperr.ne.0) goto 1000\r\n!\r\n! write(*,90)mqmqa_data%ncat*mqmqa_data%nan\r\n90 format('Allocating pair fraction array y_i/k: ',i4)\r\n! y_ik varies with the current constitution\r\n allocate(mqf%y_ik(mqmqa_data%ncat*mqmqa_data%nan))\r\n! with multiple anion derivatives add dimension nan also\r\n! its content is set in varkappa1\r\n! write(*,*)'3XQ allocating mqf%dy_ik: ',ncat,nan,nquad, assume nan=1\r\n! dy_ik is a structure information, independent of current constitution\r\n allocate(mqmqa_data%dy_ik(mqmqa_data%ncat,mqmqa_data%nquad))\r\n call pairfracs(.false.,mqf)\r\n!\r\n1000 continue\r\n!\r\n! REMOVE ncat from global data structure\r\n write(*,99)mqmqa_data%ncat,mqmqa_data%nquad,size(phres%yfr),size(mqf%compvar)\r\n99 format(/'3QX **** leaving init_excess_asym : ',10i4/)\r\n!\r\n return\r\n end subroutine init_excess_asymm\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine pairfracs\r\n!\\begin{verbatim}\r\n subroutine pairfracs(list,mqf)\r\n! calculate all pair fractions from a set of quad fractions\r\n! pair fractions are y_v/x = \\sum_ik/kl x_ij/kl*(delta_iv+delta_jv)/etafs\r\n! if there is a single anion\r\n implicit none\r\n logical list\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n!\\end{verbatim}\r\n integer i,j,v,dd,seq\r\n! double precision sum,nofs(ncat),yfs(ncat),sum1,sum2,zz\r\n double precision sum,sum1,sum2,zz\r\n double precision nofs(mqmqa_data%ncat)\r\n double precision yfs(mqmqa_data%ncat)\r\n! how to move variables in the mqmqa_var record ??\r\n! mqf is a pointer!!\r\n!\r\n seq=0\r\n if(.not.allocated(mqf%xquad)) then\r\n write(*,*)'xquad not allocated'\r\n stop\r\n endif\r\n! write(*,*)'3XQ In pairfracts ncat and nan: ',ncat,nan\r\n if(list) write(*,6)\r\n6 format(/'Calculating pair fractions'/&\r\n 6x,'seq i j sum sum2 1 2 3 4 5 6')\r\n sum1=0.0d0\r\n sum2=0.0d0\r\n do i=1,mqmqa_data%ncat\r\n! loop will count each quad once including 11, 22 etc.\r\n do j=i,mqmqa_data%ncat\r\n if(mqmqa_data%nan.ne.1) then\r\n write(*,*)'Cannot calculate pair fractions with 2 or more anions'\r\n stop\r\n endif\r\n seq=seq+1\r\n zz=0.5d0*mqf%xquad(ijklx(i,j,1,1))\r\n if(seq.ne.ijklx(i,j,1,1)) then\r\n! test for bugs ...\r\n write(*,*)'In pairfracs, ijklx and seq does not agree',seq\r\n stop\r\n endif\r\n! if i=j they are added here\r\n nofs(i)=nofs(i)+zz\r\n nofs(j)=nofs(j)+zz\r\n! y_ik(i) is the sum of all quads fractions with element i divided by /etafs\r\n! dy_ik(i,z) is 0.5/etafs(i) for quad z\r\n yfs(i)=yfs(i)+zz/mqmqa_data%qfnnsnn(i)\r\n yfs(j)=yfs(j)+zz/mqmqa_data%qfnnsnn(j)\r\n! These are constants, only calculate once, seq is the quad index\r\n! dy_ik(i,seq)=0.5d0/etafs(i)\r\n! dy_ik(j,seq)=0.5d0/etafs(j)\r\n! ignore etafs ... but we must take stoichiometry Zv_ijkl into account!\r\n if(i.eq.j) then\r\n mqmqa_data%dy_ik(i,seq)=1.0d0\r\n else\r\n mqmqa_data%dy_ik(i,seq)=0.5d0\r\n mqmqa_data%dy_ik(j,seq)=0.5d0\r\n endif\r\n!\r\n sum1=sum1+2*zz\r\n sum2=sum2+zz/mqmqa_data%qfnnsnn(i)+zz/mqmqa_data%qfnnsnn(j)\r\n if(list) then\r\n write(*,7)seq,i,j,sum1,sum2,nofs\r\n7 format('y_ik: ',i3,2x,2i3,2F6.3,2x,(10F6.3/))\r\n endif\r\n enddo\r\n enddo\r\n! a lot of trouble but it seems to work now ....\r\n! These y_ik are for symmetrical systems ....unsure if this fnnsnn used ???\r\n do i=1,mqmqa_data%ncat\r\n mqf%y_ik(i)=yfs(i)/sum2\r\n enddo\r\n! write(*,*)'3XQ line 3179 Calculated y_i/k from quad fractions',mqf%y_ik(1)\r\n if(list) then\r\n write(*,10)'\\etafs ',mqmqa_data%qfnnsnn,sum2\r\n write(*,10)'y_i/k: ',mqf%y_ik,sum1\r\n10 format(a,10F7.4)\r\n do i=1,mqmqa_data%ncat\r\n write(*,12)i,(mqmqa_data%dy_ik(i,dd),dd=1,mqmqa_data%nquad)\r\n12 format('dy_ik/dq: ',i2,12F6.3)\r\n enddo\r\n endif\r\n end subroutine pairfracs\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable function ijklx(i,j,k,l)\r\n!\\begin{verbatim}\r\n integer function ijklx(i,j,k,l)\r\n! i and j are cations, the order irrelevant\r\n! k and l are anions, the order irrelevant\r\n! always use the lowest value of i and j as first index below\r\n! always use the lowest value of k and lj as first index below\r\n implicit none\r\n integer i,j,k,l\r\n!\\end{verbatim}\r\n integer iquad,kquad,a,b,x,y\r\n!\r\n iquad=0\r\n! Important order!!!\r\n! Note i,j same as j,i and k,l same as l,k, lowest index always first\r\n! Index order: \r\n! 1 2 ncat ncat+1 ncat+2\r\n! (1,1,1,1), (1,2,1,1), ... (1,ncat,1,1), (2,2,1,1) (2,3,1,1) ... \r\n! (2,ncat,1,1), (3,3,1,1), ... (3,ncat,1,1), (4,4,1,1) ... (ncat,ncat,1,1)\r\n! (1,1,1,2), (1,2,1,2), ... (1,ncat,1,2), ... (ncat,ncat,1,2), \r\n! (1,1,2,2), (1,2,2,2), ... (ncat,ncat,2,2), (1,1,3,3), (1,2,3,3), ... \r\n! (ncat,ncat,nan,nan)\r\n! indices (2,1,1,1) is same as (1,2,1,1) !\r\n!------------------------------\r\n! confusion where ncat,nan etc are stored\r\n! write(*,*)'Calling ijklx with: ',i,j,k,l\r\n! write(*,5)mqmqa_data%ncon1,mqmqa_data%ncon2,mqmqa_data%nconst,&\r\n! mqmqa_data%npair,mqmqa_data%lcat\r\n!5 format('ijklx fixed values',2i4,2x,5i4)\r\n! The cation index i,j order i<=j to find (i-1)*ncat-i*(i-1)/2+j\r\n! The anion index k,l order k<=l to find (k-1)*nan-k*(k-1)/2+l\r\n! For each set of anion indices there are lcat=ncat*(ncat+1)/2 cation fractions\r\n if(i.le.0 .or. i.gt.mqmqa_data%ncon1 .or. &\r\n j.le.0 .or. j.gt.mqmqa_data%ncon1) goto 2000\r\n if(k.le.0 .or. k.gt.mqmqa_data%ncon2 .or. &\r\n l.le.0 .or. l.gt.mqmqa_data%ncon2) goto 2000\r\n!\r\n if(l.lt.k) then\r\n kquad=(l-1)*mqmqa_data%ncon2-l*(l-1)/2+k-1\r\n! write(*,10)l,k,mqmqa_data%ncon2,kquad\r\n else\r\n kquad=(k-1)*mqmqa_data%ncon2-k*(k-1)/2+l-1\r\n! write(*,10)k,l,mqmqa_data%ncon2,kquad\r\n endif\r\n10 format('Anion index in ijklx: ',2i3,2i10)\r\n! \r\n if(j.lt.i) then\r\n iquad=(j-1)*mqmqa_data%ncon1-j*(j-1)/2+i\r\n! write(*,20)j,i,mqmqa_data%ncon1,kquad\r\n else\r\n iquad=(i-1)*mqmqa_data%ncon1-i*(i-1)/2+j\r\n! write(*,20)i,j,mqmqa_data%ncon1,kquad\r\n endif\r\n20 format('Cation index in ijklx: ',2i3,2i10)\r\n iquad=kquad*mqmqa_data%lcat+iquad\r\n! write(*,30)iquad,kquad,lcat,i,j,k,l\r\n30 format('Index in xquad: ',i5,5x,3i5,5x,2i5)\r\n if(iquad.gt.mqmqa_data%nconst) goto 1000\r\n ijklx=iquad\r\n! write(*,*)'Return from ijklx with:',iquad\r\n!\r\n77 continue\r\n return\r\n! errors \r\n1000 write(*,1010)i,j,k,l,mqmqa_data%ncon1,mqmqa_data%ncon2,mqmqa_data%lcat,&\r\n kquad,iquad\r\n1010 format(' *** Indexing error in ijklx',4i4,2x,7i5,/'Stop!!!!')\r\n gx%bmperr=4399\r\n goto 77\r\n! \r\n2000 continue\r\n write(*,2010)i,j,k,l,mqmqa_data%ncon1,mqmqa_data%ncon2\r\n2010 format('3XQ Quad indices outside limits',4i3,5x,2i3)\r\n gx%bmperr=4399\r\n goto 77\r\n end function ijklx\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine binsym\r\n! calculates sequential index of a binary system\r\n!\\begin{verbatim}\r\n integer function binsym(i,j)\r\n! SEPARATE FOR CATIONS AND ANION BINARIES, maybe merge with gtp_allinone?\r\n! The binary systems form a symmetric matrix where (i,j) is the same as (j,i)\r\n! and data for this system is stored as a linear array where where i > j always\r\n! This function return the sequantial index for the binary (i,j)\r\n! it is essentially the same as ijklx but only one set of indices\r\n! The dimension of the binary cation matrix is the global variable ncat ...\r\n!\r\n! i/j 1 2 3 4 5 6 end of previous row ncat*(ncat-1)/2 = 6*5/2\r\n! 1 0 1 2 3 4 5 0 (ncat-j)*(ncat-j-1)/2 10 4*5/2 = 10\r\n! 2 1 - 6 7 8 9 5 15 - (6-2)*(6-1)/2 = 15-4*5/2 = 5\r\n! 3 2 6 - 10 11 12 9 15 - (6-3)*(6-2)/2 = 15-3*4/2 = 9\r\n! 4 3 7 10 - 13 14 12 15 - (6-4)*(6-3)/2 = 15-2*3/2 = 12\r\n! 5 4 8 11 13 - 15 14 15 - (6-5)*(6-4)/2 = 15-1 =14\r\n! 6 5 9 12 14 15 - note (6,6) is not a binary!!!\r\n implicit none\r\n integer i,j\r\n!\\end{verbatim}\r\n!\r\n integer ix,iy\r\n if(i.le.0 .or. i.gt.mqmqa_data%ncat) goto 1100\r\n if(j.le.0 .or. j.gt.mqmqa_data%ncat) goto 1100\r\n ix=0\r\n if(j.lt.i) then\r\n if(j.gt.1) then\r\n ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 -&\r\n (mqmqa_data%ncat-j)*(mqmqa_data%ncat-j+1)/2\r\n endif\r\n iy=ix+i-j\r\n else\r\n! j > i\r\n if(i.gt.1) then\r\n ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)/2 - &\r\n (mqmqa_data%ncat-i+1)*(mqmqa_data%ncat-i)/2\r\n endif\r\n iy=ix+j-i\r\n endif\r\n binsym=iy\r\n1000 continue\r\n return\r\n1100 write(*,*)'Indexing error in binsym ',i,j,iy\r\n iy=-1\r\n goto 1000\r\n end function binsym\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine order3\r\n!\\begin{verbatim}\r\n subroutine order3(i,j,v,a,b,c)\r\n! subroutine to rearrange i, j, v in increasing order in a, b, c\r\n implicit none\r\n integer i,j,k,a,b,c,v\r\n!\\end{verbatim}\r\n! Return i, j, k ordered in a= j and v > j thus j is smallest\r\n a=j\r\n if(i.lt.v) then \r\n b=i; c=v\r\n elseif(v.lt.i) then\r\n b=v; c=i\r\n else\r\n write(*,10)'3: i=v',i,j,v\r\n goto 1100\r\n endif\r\n elseif(v.lt.j) then\r\n! here when i>j and j>v\r\n a=v; b=j; c=i\r\n else !\r\n! two or more numbers equal\r\n goto 1100\r\n endif\r\n return\r\n! \r\n1100 continue\r\n write(*,*)' *** Error in call to order3: ',i,j,v\r\n a=-1\r\n end subroutine order3\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine order3KKK\r\n!\\begin{verbatim}\r\n subroutine order3KKK(i,j,v,a,b,c,kkk)\r\n! subroutine to rearrange i, j, v in increasing order in a, b, c\r\n implicit none\r\n integer i,j,k,a,b,c,v,jj\r\n character kkk*3,kopia*3,ch1*1\r\n!\\end{verbatim}\r\n! Return i, j, v ordered in a= j and v > j thus j is smallest\r\n a=j\r\n if(i.lt.v) then \r\n b=i; c=v\r\n elseif(v.lt.i) then\r\n b=v; c=i\r\n else\r\n write(*,10)'3: i=v',i,j,v\r\n goto 1100\r\n endif\r\n elseif(v.lt.j) then\r\n! here when i>j and j>v\r\n a=v; b=j; c=i\r\n else \r\n! two or more numbers equal\r\n goto 1100\r\n endif\r\n1000 continue\r\n! rearrange kkk to the new order of cations. \r\n! KTK means the Toop element should be the second, TKK third and KKT first.\r\n! programming this makes me sick Just for a single Toop element\r\n fix: do jj=1,3\r\n ch1=kopia(jj:jj)\r\n if(ch1.ne.'T') cycle fix\r\n if(jj.eq.1) then\r\n! Txx: the Toop element was originally third\r\n if(c.eq.v) then\r\n! and still is, no change\r\n exit fix\r\n elseif(a.eq.v) then\r\n! the first element is now the Toop element, change to xxT\r\n kkk='KKT'; exit fix\r\n else\r\n! the Toop element must now be the second element\r\n kkk='KTK'; exit fix\r\n endif\r\n elseif(jj.eq.2) then\r\n! xTx: the Toop element was the second \r\n if(a.eq.j) then\r\n! the first element is now the Toop element, change to xxT\r\n kkk='KKT'; exit fix\r\n elseif(b.eq.j) then\r\n! no change\r\n exit fix\r\n else\r\n! it must be the third element\r\n kkk='TKK'; exit fix\r\n endif\r\n else\r\n! xxT: the Toop element was the first ... exit if it still is\r\n if(a.eq.i) exit fix\r\n if(a.eq.j) then\r\n! it is now the second\r\n kkk='KTK'\r\n else\r\n! or finally it is now the third\r\n kkk='TKK'\r\n endif\r\n endif\r\n enddo fix\r\n! \r\n! write(*,3)kkk,kopia,a,b,c\r\n3 format('3XQ rearranged? \"',a,'\" original \"',a,'\" ',3i3)\r\n return\r\n! \r\n1100 continue\r\n write(*,*)' *** Error in call to order3: ',i,j,v\r\n a=-1\r\n goto 1000\r\n end subroutine order3KKK\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable function terind\r\n!\\begin{verbatim}\r\n integer function terind(i,j,v)\r\n! integer function terind(i,j,v,ncat)\r\n! find sequential index of ternary system i, j, k\r\n! simplified version, SEPARATE FOR CATIONS AND ANION mixing\r\n! The ternary systems form a symmetric matrix where (i,j,k) is same as (j,k,i)\r\n! and data for the ternary is stored as a linear array where where i=1, ix is number of skipped ternary systems\r\n ix=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqa_data%ncat-2)/6 - &\r\n (mqmqa_data%ncat-a+1)*(mqmqa_data%ncat-a)*(mqmqa_data%ncat-a-1)/6\r\n! we now have a binary matrix for i,v with dimension bin, indexed by (bp,cp)\r\n bin=mqmqa_data%ncat-a\r\n bp=b-a\r\n cp=c-a\r\n iy=bin*(bin-1)/2-(bin-bp+1)*(bin-bp)/2+cp-bp\r\n iz=ix+iy\r\n! write(*,10)a,b,c,mqmqa_data%ncat,ix,bin,bp,cp,iy,iz\r\n10 format('terind: ',4i4,8i6)\r\n1000 continue\r\n terind=iz\r\n return\r\n1100 write(*,*)'Indexing error in terind ',i,j,v\r\n iz=-1\r\n goto 1000\r\n end function terind\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine test_asymm\r\n!\\begin{verbatim}\r\n integer function test_asymm(t,i,j,v)\r\n! The ternary specified by t has 3 elements i-j-v. v is redundant ... ?\r\n! return 0 if neither element i nor j are asymmetric elements in this ternary\r\n! return 1 if element i is an asymmetric element\r\n! return 2 if element j is an asymmetric element\r\n! return 3 if element both i and j are asymmetric elements\r\n implicit none\r\n integer t,i,j,v\r\n!\\end{verbatim}\r\n integer asymmetric1,asymmetric2,hejhopp\r\n! EXAMPLE: a single ternary 1-2-3 with 2 as Toop\r\n! Call i j v\r\n! 1 1 2 1 \r\n! 2 1 2 2\r\n! 3 2 3 3\r\n integer a,selectij\r\n! default\r\n hejhopp=0\r\n! we have to check %asymm, if %asymm(1:1) is not 'T' return 0\r\n if(tersys(t)%asymm(1:1).eq.'T') then\r\n! The asymmetry in tersys(t) is stored as 'Tx ' where x is 1, 2 or 3\r\n! very very clumsy but my brain rotates still ......\r\n asymmetric1=ichar(tersys(t)%asymm(2:2))-ichar('0')\r\n! asymmetric1 is 1, 2 or 3; change to the quad index in that position\r\n! asymmetric2=tersys(t)%el(asymmetric1)\r\n! write(*,8)t,tersys(t)%el,tersys(t)%isasym,asymmetric1\r\n8 format('3XQ bug: ter: ',i3,' quads: ',3i3,', isasym: ',3i3,' asym: ',i3)\r\n asymmetric2=tersys(t)%el(asymmetric1)\r\n! write(*,10)t,tersys(t)%isasym,i,j\r\n10 format('3XQ In asymm: ternary ',i3,' asymmetry: ',3i3,' binary ',2i3,' OK')\r\n! The i-j are the quads in the varkappa variable\r\n! if i = asymmetric2 return 1\r\n! if j = asymmetric2 return 2\r\n if(i.eq.asymmetric2) hejhopp=1\r\n if(j.eq.asymmetric2) hejhopp=2\r\n endif\r\n if(hejhopp.ne.0) then\r\n! write(*,90)t,i,j,v,asymmetric1,asymmetric2,hejhopp\r\n90 format('3XQ testasym: ',i3,3x,2i3,3x,i3,5x,2i3,5x,i3)\r\n endif\r\n test_asymm=hejhopp\r\n100 continue\r\n return\r\n end function test_asymm\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine calcasymvar\r\n!\\begin{verbatim}\r\n subroutine calcasymvar(phres)\r\n! subroutine calcasymvar(mqmqavar)\r\n! This must be called whenever the quad fractions has changed\r\n! It updates varkappaij, xiij etc for the whole system\r\n! and stores them in compvar(bin) datastructure\r\n! Currently programmed ONLY for a single anion\r\n implicit none\r\n type(gtp_phase_varres), pointer :: phres\r\n! type(gtp_mqmqa_var), pointer :: mqmqavar\r\n! type(gtp_mqmqa_var), pointer :: mqmqavar\r\n!\\end{verbatim}\r\n integer i,j,ia,seq,k,l,m,ny,abrakadabra\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n character*3 asymmetry\r\n! how to create xquad mm when we need a pointer to gtp_phase_varres?\r\n! type(gtp_equilibrium_data), pointer :: ceq\r\n! type(gtp_phase_varres), pointer :: phres\r\n! type(gtp_mqmqa_var), pointer :: mqf\r\n type(gtp_allinone), pointer :: box\r\n! attempt to move mqmqa variables into the mqmqa_var record\r\n! phres=>ceq%phase_varres(lokvar)\r\n! mqf=>phres%mqmqaf\r\n!\r\n! if(.not.allocated(mqmqavar%xquad)) then\r\n! write(*,*)'3XQ No xquad array allocated'\r\n! goto 1000\r\n! endif\r\n! if(.not.allocated(mqmqavar%compvar)) then\r\n! write(*,*)'3XQ No compvar array allocated'\r\n! goto 1000\r\n! endif\r\n!\r\n ia=1\r\n! if(allocated(phres%mqmqaf%compvar)) then\r\n! write(*,*)'3XQ in calcasym: compvar: ',size(phres%mqmqaf%compvar)\r\n! else\r\n! write(*,*)'3XQ in calasym: phres%mqmqaf%compvar not allocated'\r\n! endif\r\n! the separate array of binaries redundant?\r\n! when a change of ternary asymmetries is made the newXupdate is incremented\r\n seq=0\r\n! initiate all asymmetry 0, earlier in init_excess_asymm, line 3134\r\n! we set tersys(*)%isasym=0\r\n do i=1,mqmqa_data%ncat-1\r\n do j=i+1,mqmqa_data%ncat\r\n! seq specifies a binary set of elements\r\n! results are stored in compvar(seq) for use in Gibbs energy calculations\r\n seq=seq+1\r\n! write(*,*)'Calling varkappa1 ',i,j,seq\r\n! call varkappa1(mqmqavar%compvar(seq))\r\n! call varkappa1(seq,mqmqavar)\r\n! call varkappa1(seq,mqf)\r\n! asymmetry is KKK or Tx where x=1, 2 or 3\r\n if(mqmqder) write(*,*)'3XQ calcasymvar call varkappa1'\r\n! write(*,*)'3XQ call varkappa1',seq\r\n! the argument 0 means no asymmetry change or set all symmetrical\r\n call varkappa1(seq,phres,0)\r\n enddo\r\n enddo\r\n! inside varkappa1 one adds quads to vk_ij and vk_ji and \r\n! if one has ijklx(vz1,vz1,ia,ia) in vk_ij and ijklx(vz2,vz2,ia,ia) in vk_ij\r\n! then the %kvk_ij needs an additional ijkl(vz1,vz2,ia,ia)\r\n! Check that here .... (this is due to bad initial programming)\r\n! write(*,790)1\r\n790 format('3XQ **** DOUBLE CHECK KVK_IJK',i3)\r\n! mqf=>phres%mqmqaf\r\n! box%lastupdate=-1\r\n! write(*,*)'3XQ box%lastupdate: ',box%lastupdate\r\n! write(*,790)\r\n! if(box%lastupdate.ne.newXupdate) then\r\n! box%lastupdate=newXupdate\r\n! write(*,1001)box%seq,box%lastupdate,newXupdate\r\n!1001 format('3XQ allinone record ',i3,' updated to new asymmetries ',i5)\r\n! else\r\n! write(*,*)'3XQ line 3707: mixed asymmetries added'\r\n! endif\r\n!\r\n! write(*,*)'3XQ code below skipped as moved to varkappa1'\r\n goto 1000\r\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\r\n! Code below moved to varkappa1 ... but some problems persist ...\r\n write(*,790)2\r\n write(*,791)mqmqa_data%emquad\r\n791 format('3XQ THIS CODE SHOULD NOT BE USED: ',25i3)\r\n stop 'THIS CODE SHOULD NOT BE USED'\r\n!\r\n do i=1,size(mqf%compvar)\r\n! if in vk_ij one has added (vz1,vz1,ia,ia)\r\n! and in vk_ji added (vz2,vz2,ia,ia)\r\n! one must add (vz1,vz2,ia,ia) to the kvk_ij (now done in calling routine)\r\n! BUT this quad may already be present !!!!!!!!!!!\r\n box=>mqf%compvar(i)\r\n write(*,792)box%seq,box%lastupdate,newXupdate\r\n792 format('3XQ newXupdate: ',i3,2i5)\r\n! write(*,800)i,box%cat1,box%cat2\r\n! write(*,805)'ivk_ij ',box%ivk_ij\r\n! write(*,805)'jvk_ij ',box%jvk_ji\r\n! write(*,805)'kvk_ijk ',box%kvk_ijk\r\n do j=2,size(box%ivk_ij)\r\n do k=1,size(mqmqa_data%emquad)\r\n if(box%ivk_ij(j).eq.mqmqa_data%emquad(k)) then\r\n! we have an endmember quad in ivk_ij (in addition to the first)\r\n! Check if we have another endmember quad in jvk_ji\r\n do l=1,size(box%jvk_ji)\r\n neverending: do m=1,size(mqmqa_data%emquad)\r\n if(box%jvk_ji(l).eq.mqmqa_data%emquad(m)) then\r\n if(k.ne.m) then\r\n! we have 2 different endmember quads in ivk_ij and jvk_ji, \r\n! if the mixed quad is not alreay present add it\r\n ny=ijklx(k,m,ia,ia)\r\n do abrakadabra=1,size(box%kvk_ijk)\r\n! check if this quad not already in box_kvk_ijk\r\n\r\n enddo\r\n! add this quad !!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(k,m,ia,ia)]\r\n write(*,806)i,k,m,ijklx(k,m,ia,ia)\r\n write(*,805)'kvk_ijk ',box%kvk_ijk\r\n endif\r\n endif\r\n enddo neverending\r\n enddo\r\n endif\r\n enddo\r\n enddo\r\n! a quad representing a vz,vz,ia,ia quad is part of emquad\r\n box%lastupdate=newXupdate\r\n enddo\r\n800 format('3XQ compvar: ',i3,2x,2i3)\r\n805 format(a,20i3)\r\n806 format('3XQ adding mixed quad to kvk_ijk',i3,2x,2i3,2x,i3)\r\n!\r\n1000 continue\r\n return\r\n end subroutine calcasymvar\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine varkappa1\r\n!\\begin{verbatim}\r\n! subroutine varkappa1(seq,phres,asymter)\r\n subroutine varkappa1(seq,phres,asymter)\r\n! seq is the index of varkappa in mqf%compvar array of all varkappa\r\n! phres is pointer to gtp_phase_varres for the mqmqa phase\r\n! should phres it be a pointer? Does it matter? It seems to work\r\n! *** phres is called parres in calling routine\r\n! asymter is the index of integer array, if zero set all symmetrical\r\n! if nonzero the asymmetric constituent ins already set in %asymm\r\n! %asymm is 'Tx ' where x is 1, 2 or for the assymmetric constituent\r\n! in varkappa the cations are ordered (1,1) (1,2) ... (2,2) ... (n,n)\r\n! in tersys the cations are ordered (1,2,3) (1,2,4) ... (2,3,4) ... (n-2,n-1,n)\r\n! box is a record of the type(gtp_allinone)\r\n! tersym is a structure with all combination of 3 cations for the asymmetries\r\n! tersym(tt)%el(1) %el(2) and %el(3) are cation indices in the ternary\r\n! tersym(tt)%isasym(1) %isasym(2) %isasym(3) is 0 or asymmetric cation index\r\n! tersym(tt)%asymm is a 3 character variable of asymmetry DO NOT USE\r\n! this routine may initiate, calculate and store varkappa_ij, varkappa_ji, and\r\n! xi_ij and xi_ji for symmetric and asymmetric systems with Kohler/Toop\r\n! It is programmed for a single anion and just for the MQMQX phase!\r\n!\r\n! It will inintiate all data in box if box%lastupdate neq newXupdate\r\n!\r\n! I do not think updating asymmetry of one ternary will change all varkappa?\r\n!\r\n implicit none\r\n integer seq,asymter\r\n! integer seq,asymter,new_toop\r\n type(gtp_phase_varres), pointer :: phres\r\n! type(gtp_mqmqa_var), pointer :: \r\n!\\end{verbatim}\r\n!\r\n! replaced original i and j by icat and jcat below!! integer i,j,ia,bin\r\n!\r\n! these are quad indices of i,i, i,j abd j,j\r\n integer mii,mij,mjj,ia\r\n type(gtp_allinone), pointer :: box\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n!\r\n! ia represent the single anion\r\n! varkappa_ij and varkappa_ji are the 2 composition variables to be multiplied\r\n! with a binary i-j parameter or ternary. \r\n! It is modified depending on the types of\r\n! extrapolations for each ternary it is involved: Kohler or Toop.\r\n! initially varkappaij=x_ii and varkappaji=x_jj and sum=x_ij \r\n! for the Kohler (Muggianu not implemented)\r\n! and nugamma is set to zero\r\n! - if element i is Toop in j-i-v the x_iv is added to nugamma\r\n! - if element j is Toop in i-j-v the x_jv is added to nugamma\r\n! for those involved in asymmetric ternaries the divison must include \\nu\\gamma\r\n! At the end both varkappaij and varkappaji are divided by sum where\r\n! sum = sum+varkappaij+varkappaji+\\nu\\gamma\r\n! CHECK if \\nu\\gamma already included in sum ...\r\n!\r\n integer i,ii,vz,v,w,vv,ternary,ll,lasthope,di,icat,jcat,nnn\r\n double precision varkappaij,varkappaji,sum,initialij,initialji,nugamma\r\n double precision xi_ij,xi_ji,sum1,sum2\r\n logical asymmetric\r\n! added nov 3/2025. See this date below\r\n! in mixnugamma all vz that have asymmetric ternary with icat or jcat are saved\r\n! because their mixed quad fractions should be added to kvk_ijk\r\n integer, dimension(:), allocatable :: mixnugamma\r\n integer selectij,qz1,qz2\r\n! mixed update\r\n integer j,k,l,m,ny,abrakadabra\r\n! If a binary i-j is part of 2 or more asymmetric ternaries i-j-\\nu, i-j-\\gamma\r\n! the quad fraction x_\\nu\\gamma should be added to kvk_ijk (the denomonator)\r\n! of kvk_ijk\r\n! saving multiple asymmetrical cations for a binary\r\n! integer, dimension(:), allocatable :: savevz\r\n integer, dimension(:), allocatable :: savenu\r\n integer, dimension(:), allocatable :: savegamma\r\n! debug output\r\n integer nn1,nn2,nn3,nn4,nn5,nn6,nn7,gg,thisasym\r\n logical nysym\r\n! character*3 nyasym\r\n! local variables used for updating quad indices for iasymm, jasymm, etc\r\n! integer, dimension(:), allocatable :: vk_ij,vk_ji,vk_ijk,xi_ij,xi_ji\r\n! all asymmetric quad indices needed are stored in each separate gtp_allinone\r\n! integer nvk_ij,nvk_ji,nvk_ijk,nxi_ij,nxi_ji\r\n!\r\n! how to create xquad mm when we need a pointer to gtp_phase_varres?\r\n! type(gtp_equilibrium_data), pointer :: ceq\r\n! type(gtp_phase_varres), pointer :: phres\r\n! type(gtp_mqmqa_var), pointer :: mqf\r\n! attempt to move mqmqa variables into the mqmqa_var record\r\n! ceq=>firsteq\r\n!\r\n! Check if y_ik set ...!!!!\r\n if(asymter.ne.0) then\r\n if(mqmqder) write(*,2)asymter\r\n2 format(/'3XQ in varkappa1, updating asymmetries: ',2i5)\r\n! else\r\n! write(*,1)\r\n1 format('3XQ initiating varkappa 1')\r\n endif\r\n mqf=>phres%mqmqaf\r\n if(mqmqder) &\r\n write(*,*)'3XQ line 4462 vk_ij, xi_ij and y_ik with new quad fracs'\r\n! write(*,10)'3XQ old',(mqf%y_ik(v),v=1,mqmqa_data%ncat)\r\n10 format(a,15(f8.5))\r\n do v=1,mqmqa_data%ncat\r\n mqf%y_ik(v)=0.0d0\r\n! write(*,20)'3XQ dy_ik',(mqmqa_data%dy_ik(v,w),w=1,mqmqa_data%nquad)\r\n20 format(a,(20F5.2))\r\n do w=1,mqmqa_data%nquad\r\n mqf%y_ik(v)=mqf%y_ik(v)+mqmqa_data%dy_ik(v,w)*mqf%xquad(w)\r\n enddo\r\n enddo\r\n!\r\n! 2026.04.08: When a ternary asymmetry is changed, all varkappa must be updated\r\n! A ternary asymmetri can be KKK, TKK, KTK or KKT where the asymmetric\r\n! constituent is the first, second or third constituent.\r\n! I do not remember how this is indicated in the loop below \r\n! But obviously there is some error as KTK and KKT is not registered correctly\r\n! I do not remember how one identifies the asymmetric constituent below\r\n!\r\n! write(*,10)'3XQ line 3731 y_ik:',(mqf%y_ik(v),v=1,mqmqa_data%ncat)\r\n!\r\n if(.not.allocated(mqf%compvar)) then\r\n write(*,*)'3XQ line 3076 in varkappa: compvar not allocated, problems'\r\n gx%bmperr=4399; goto 1000\r\n! else\r\n! write(*,*)'3XQ varkappa allocated OK'\r\n endif\r\n box=>mqf%compvar(seq)\r\n! icat and jcat represent cations ... duplicated here (and many other places)\r\n icat=box%cat1\r\n jcat=box%cat2\r\n ia=box%anion\r\n! write(*,'(a,4i4,5x,a)')'3XQ varkappa1 line 4267: ',seq,icat,jcat,ia\r\n! the xquad values i,j and j,i are the same but for varkappa they are different\r\n if(icat.gt.jcat) then\r\n write(*,3)icat,jcat\r\n3 format(/'In varkappa1: wrong order of elements ',2i4)\r\n stop\r\n endif\r\n! set default quads\r\n mii=ijklx(icat,icat,ia,ia)\r\n mij=ijklx(icat,jcat,ia,ia)\r\n mjj=ijklx(jcat,jcat,ia,ia)\r\n! how to deallocate box%asymm_nu and box%asymm_gamma?\r\n! deallocate(box%asymm_nu)\r\n! deallocate(box%asymm_gamma)\r\n!\r\n nysym=.false.\r\n! deafult is 0, to update set box%lastupdate to -1\r\n!\r\n! below is code to update asymmetry\r\n! and after that the code to calculate varkappa for current molefractions\r\n if(box%lastupdate.ne.newXupdate) then\r\n if(asymter.eq.0) then\r\n! write(*,4)\r\n4 format('3XQ initiating varkappa 2')\r\n else\r\n! write(*,5)box%lastupdate,newXupdate\r\n if(mqmqder) write(*,5)box%lastupdate,newXupdate\r\n5 format('3XQ *** Updating allinone record from ',i5,' to ',i5,' new: ',2i5)\r\n endif\r\n endif\r\n vzloopupdate:if(newXupdate.gt.box%lastupdate) then\r\n! *** this if ... endif code part needed only when new asymmetries defined\r\n! Below the arrays below are allocated, the initial 0 is overwritten if used\r\n! This makes use of the new Fortran 2003 facility using [ ]\r\n! Setting an allocatable array to single value means previous values deleted\r\n! box%ivk_ij=[0]; box%jvk_ji=[0]; box%kvk_ijk=[0]\r\n!\r\n! new asymmetry defined\r\n! if(asymter.lt.0 .or. asymter.gt.size(tersys)) then\r\n! write(*,*)'Illegal ternary ',asymter\r\n! goto 1000\r\n! else\r\n if(asymter.gt.0) then\r\n! write(*,77)asymter,tersys(asymter)%isasym,tersys(asymter)%asymm\r\n77 format('3XQ new asymmetry: ',i3,3x,3i2,5x,a)\r\n! else\r\n! write(*,*)'3XQ sorry may not work'\r\n! tersys(asymter)%asymm='KKK'\r\n endif\r\n! write(*,*)'3XQ varkappa1 new asymmetry in ternary: ',asymter\r\n! repeating Max equations for vakappa_AB in ternary A-B-C\r\n! -----------if A is asymmetric, \\gamma in documentation\r\n! v_AB x_AA \r\n! v_BA x_BB+x_BC+x_CC\r\n! denom= x_AA+x_BB+x_AB+x_BC+x_AC+x_CC (=1 if only one ternary)\r\n! ----------- if B is asymmetric, \\nu in documentation \r\n! v_AB x_AA+x_AC+x_CC\r\n! v_BA x_BB\r\n! denom= x_AA+x_BB+x_AB+x_BC+x_AC+x_CC (=1 if only one ternary)\r\n!------------ if C is asymmetric .........ignore\r\n! if A and B are asymmetric in several ternaries the v_AB and v_BA \r\n! can include more quadruplets. One has to update all ternary asymmetries\r\n! at the same time because it is complicated to remove things in the [ ... ]\r\n!\r\n! if(allocated(savevz)) deallocate(savevz)\r\n box%lastupdate=newXupdate\r\n! default nyasym is KKK, no asymmetry\r\n! if(asymter.gt.0) write(*,381)asymter,new_toop\r\n!381 format('3XQ in varkappa1 new asymmetry: ',i2)\r\n if(allocated(savenu)) deallocate(savenu)\r\n if(allocated(savegamma)) deallocate(savegamma)\r\n! vk derivatives are quad indices, also denominator (same vk_ij and vk_ji)\r\n! the statements below allocate and assign initial quad index\r\n box%ivk_ij=[mii]; box%jvk_ji=[mjj]; box%kvk_ijk=[mij]\r\n! to simplify handling derivatives the denominator is summed separately\r\n box%all_ijk=[mii, mjj, mij]\r\n! xi are the Y_i/k fractions, for derivatives save quad indices in dxi_ij\r\n!\r\n do di=1,mqmqa_data%nquad\r\n! the derivatives of xi_ relative to quad index di\r\n! The derivatives involves several quads, given by dy_ik(icat)\r\n box%dxi_ij(di)=mqmqa_data%dy_ik(icat,di)\r\n box%dxi_ji(di)=mqmqa_data%dy_ik(jcat,di)\r\n enddo\r\n! calculate xi_ ... why??\r\n box%xi_ij=0.0d0; box%xi_ji=0.0d0\r\n do di=1,mqmqa_data%nquad\r\n box%xi_ij=box%xi_ij+box%dxi_ij(di)*mqf%xquad(di)\r\n box%xi_ji=box%xi_ji+box%dxi_ji(di)*mqf%xquad(di)\r\n enddo\r\n! *** end of symmetric initialization of vk_ij, vk_ji, xi_ij and xi_ji\r\n!\r\n! if in vk_ij one has added (vz1,vz1,ia,ia)\r\n! and in vk_ji added (vz2,vz2,ia,ia)\r\n! Now take care of asymmetries and update for later use\r\n! Asymmetric vk and xi are updated in the vz loop AND at the end of the loop\r\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\r\n!\r\n if(mqmqder) write(*,*)'3XQ in varkappa1',icat,jcat\r\n!\r\n! below vz loops through all ternaries ...\r\n! and below that\r\n! \r\n! write(*,*)'3XQ with asymmetric cation ',thisasym\r\n! this subroutine is called with the sequentially ordered box%icat,box%jcat\r\n! it must create the basic Kohler model and possibly Toop asymmetries\r\n!\r\n! write(*,*)'3XQ unfinished varkappa1 code around line 4384'\r\n! \r\n! The loop below is for all pairs of varkappa records identifying Toop cations\r\n! in ternaries i-j-vz\r\n! and adjusting the expression to calculate varkappa_ij and varkappa_ji\r\n!\r\n vzloop: do vz=1,mqmqa_data%ncat\r\n! loop for all ternary systems to find those with asymmetric i-j-vz and j-i-vz\r\n! write(*,403)icat,jcat,vz,thisasym\r\n403 format('3XQ in vzloop A: ',2i3,2x,i3,2x,i3,2x,5i3)\r\n! if vz is icat or jcat it is not a ternary\r\n if(vz.eq.icat .or. vz.eq.jcat) cycle vzloop\r\n! find the sequential order of the ternary icat-jcat-vz \r\n ternary=terind(icat,jcat,vz)\r\n! write(*,402)'3XQ in vzloop B: ',icat,jcat,vz,thisasym,ternary\r\n402 format(a,2i3,2x,i3,2x,i3,2x,5i3)\r\n! error if ternary not >0\r\n if(ternary.le.0) goto 1100\r\n! if icat is Toop in this ternary add quadfractions of x_ivz to varkappa_ij\r\n! if jcat is Toop in this ternary add quadfractions of x_jvz to varkappa_ji\r\n! ********* selectij=0 means no asymmetry in this ternary***************\r\n selectij=test_asymm(ternary,icat,jcat,vz)\r\n! if(vz.eq.thisasym) then\r\n!\r\n! write(*,404)icat,jcat,vz,thisasym,ternary,selectij\r\n404 format('3XQ in vzloop C: ',2i3,2x,i3,2x,i3,2x,5i3)\r\n! ********* selectij=0 means no asymmetry in this ternary***************\r\n! asymm returns 1 if icat is an asymmetric element in icat-jcat-vz (gamma)\r\n! asymm returns 2 if jcat is an asymmetric element in icat-jcat-vz (nu)\r\n! asymm returns 3 if both icat and jcat are asymmetric in icat-jcat-vz\r\n! to be considered: asymmetric i-j-nu and i-j-gamma requires x_\\nu\\gamma\r\n! in the denominator. For this the savenu/gamma is used\r\n!\r\n! cycle vzloop\r\n if(selectij.eq.0) cycle vzloop\r\n! if(.not.asymmetric) then\r\n! the asymmetric logical is to just for debug output of initial varkappa values\r\n! asymmetric=.true.\r\n! endif\r\n! write(*,*)'An asymmetric ternary, how to handle it?'\r\n! write(*,*)'We must also set tersys(ternary)%asymm'\r\n! write(*,*)'Only icat asymmetry found above'\r\n!\r\n!\r\n!******************** asymmetric ternary *****************************\r\n! write(*,420)selectij,icat,jcat,vz\r\n420 format('3XQ set varkappa ternary asymmetry typ:',i2,' cations: ',3i3)\r\n asymmetry: select case(selectij)\r\n!\r\n case default\r\n write(*,*)'Illegal asymmetry ',selectij\r\n stop\r\n!-------------------------------------------------------------------\r\n case(1) ! *************************************************\r\n! vz is asymmetric, save in jvk_ij and in savenu\r\n! icat is asymmetric, save in jvk_ij and in savenu\r\n! an elegant Fortran assignment of an additional items in an allocatable\r\n box%jvk_ji=[box%jvk_ji, ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! Below quad fractions added to jvk_ij added to denominator, add ijklx(icat,vz\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(icat,vz,ia,ia)]\r\n box%all_ijk=[box%all_ijk, ijklx(jcat,vz,ia,ia), &\r\n ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! savenu is related to ij, savegamma to ji\r\n if(allocated(savenu)) then\r\n! write(*,373)'case 1 use \\nu',size(savenu),savenu\r\n373 format('3XQ ',a,' mixed asymmetry terms',i3,': ',10i3)\r\n374 format(a,' x_',2i1)\r\n do gg=1,size(savenu)\r\n! the mixed terms with \\nu should should be added to jvk_ji\r\n box%all_ijk=[box%all_ijk, ijklx(vz,savenu(gg),ia,ia)]\r\n! write(*,374)'3XQ added ji',savenu(gg),vz\r\n! write(*,375)'jvk_ji ',box%jvk_ji\r\n375 format('3XQ ',a,'=',10i4)\r\n enddo\r\n savenu=[savenu, vz ]\r\n else\r\n! otherwize just add vz to savenu\r\n savenu=[vz]\r\n! write(*,373)'3XQ line 4377 savednu i ',size(savenu),savenu\r\n endif\r\n! savegamma is related to ji, maybe add denominator terms\r\n if(allocated(savegamma)) then\r\n! write(*,373)'case 1 use \\gamma',size(savegamma),savegamma\r\n do gg=1,size(savegamma)\r\n! the mixed terms with \\gamma should should be added to kvk_ijk\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(vz,savegamma(gg),ia,ia)]\r\n box%all_ijk=[box%all_ijk, ijklx(vz,savegamma(gg),ia,ia)]\r\n! write(*,374)'3XQ added kvk_ijk',savegamma(gg),vz\r\n! write(*,375)'kvk_ji ',box%kvk_ijk\r\n enddo\r\n! do not save vz as it does no relates to ij\r\n! savegamma=[savegamma, vz ]\r\n! else\r\n! and we must add vz to savegamma\r\n! savegamma=[vz]\r\n! write(*,373)'saved i ',size(savevz),savevz\r\n endif\r\n! The asymmetric xi is depend on y_ik update dxi_ij and dxi_ji\r\n do nnn=1,mqmqa_data%nquad\r\n! box%dxi_ij(nnn)=box%dxi_ij(nnn)+dy_ik(icat,nnn)\r\n box%dxi_ji(nnn)=box%dxi_ji(nnn)+mqmqa_data%dy_ik(vz,nnn)\r\n enddo\r\n!\r\n!---------------------------------------------------------------------\r\n case(2) ! ***************************************************\r\n! jcat is asymmetric, same as for icat just change icat to jcat!!!!\r\n! and save in jvk_ji ...\r\n box%ivk_ij=[box%ivk_ij, ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! Nath noted missing ijklx(vz1,vz2,ia,ia) if icat and jcat are asymmetrical\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(jcat,vz,ia,ia)]\r\n box%all_ijk=[box%all_ijk, ijklx(icat,vz,ia,ia), &\r\n ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! if savegamma allocated we must add terms to jvk_ijk\r\n if(allocated(savegamma)) then\r\n! write(*,373)'case 2 use \\gamma',size(savegamma),savegamma\r\n do gg=1,size(savegamma)\r\n box%ivk_ij=[box%ivk_ij, ijklx(vz,savegamma(gg),ia,ia)]\r\n box%all_ijk=[box%all_ijk, ijklx(vz,savegamma(gg),ia,ia)]\r\n! write(*,374)'3XQ added ij',savegamma(gg),vz\r\n! write(*,375)'ivk_ij ',box%ivk_ij\r\n enddo\r\n savegamma=[savegamma, vz ]\r\n else\r\n! and we must add vz to savevz\r\n savegamma=[ vz ]\r\n! write(*,373)'savedgamma j ',size(savegamma),savegamma\r\n endif\r\n! savenu is related to ij, maybe add denominator terms\r\n if(allocated(savenu)) then\r\n! write(*,373)'case 2 use \\nu',size(savenu),savenu\r\n do gg=1,size(savegamma)\r\n! the mixed terms with \\nu should should be added to kvk_ijk\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(vz,savenu(gg),ia,ia)]\r\n box%all_ijk=[box%all_ijk, ijklx(vz,savenu(gg),ia,ia)]\r\n! write(*,374)'3XQ added kvk_ijk',savenu(gg),vz\r\n! write(*,375)'jvk_ji ',box%kvk_ijk\r\n enddo\r\n endif\r\n! The asymmetric xi is depend on y_ik update dxi_ij and dxi_ji\r\n do nnn=1,mqmqa_data%nquad\r\n! box%dxi_ij(nnn)=box%dxi_ij(nnn)+dy_ik(jcat,nnn)\r\n box%dxi_ij(nnn)=box%dxi_ij(nnn)+mqmqa_data%dy_ik(vz,nnn)\r\n enddo\r\n!\r\n!---------------------------------------------------------------------\r\n case(3) ! **************************************************\r\n! Both icat and jcat are asymmetric NOT IMPLEMENTED\r\n write(*,788)icat,jcat,vz\r\n788 format('3XQ *** Illegal with 2 asymmetric cations ',2i3,' with ',i3)\r\n gx%bmperr=4399; goto 1000\r\n! tentative code below\r\n box%ivk_ij=[box%ivk_ij, ijklx(icat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n box%jvk_ji=[box%jvk_ji, ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! This is complicated, do not add ijklx(icat,vz,ia,ia), ijklx(jcat,vz,ia,ia)\r\n! and only once ijkl(vz,vz,ia,ia) .....\r\n! maybe not at all ?????????????\r\n! box%kvk_ijk=[box%kvk_ijk, ijklx(vz,vz,ia,ia)]\r\n! box%kvk_ijk=[box%kvk_ijk, ijklx(icat,vz,ia,ia), &\r\n! ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! BUT x_(vz,vz,ia,ia) appears twice in the denominator ....(and twice on top)\r\n box%all_ijk=[box%all_ijk, ijklx(icat,vz,ia,ia), &\r\n ijklx(jcat,vz,ia,ia), ijklx(vz,vz,ia,ia)]\r\n! The asymmetric xi is depend on y_ik update dxi_ij and dxu_ji\r\n do nnn=1,mqmqa_data%nquad\r\n box%dxi_ij(nnn)=box%dxi_ij(nnn)+mqmqa_data%dy_ik(icat,nnn)\r\n box%dxi_ji(nnn)=box%dxi_ji(nnn)+mqmqa_data%dy_ik(jcat,nnn)\r\n enddo\r\n!\r\n end select asymmetry\r\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r\n! write(*,778)icat,jcat,vz\r\n778 format('3XQ asymmetry set ',3i3,' box%all: ',10i3)\r\n goto 747\r\n!\r\n! loops below now redundant when we added savevz loops above ..... ????\r\n! code handling kvk_ijk terms due to extra x_ii and x_jj in ivk_ij and jvk_ji\r\n! copied from end of calcasymvar to avoid it is repeted at all calculations\r\n! skip first ivk_ij\r\n addkvkterm: do j=2,size(box%ivk_ij)\r\n do k=1,size(mqmqa_data%emquad)\r\n if(box%ivk_ij(j).eq.mqmqa_data%emquad(k)) then\r\n! we have an endmember quad in ivk_ij (in addition to the first)\r\n! Check if we have another endmember quad in jvk_ji, skip first jvk_ji\r\n! do l=1,size(box%jvk_ji)\r\n do l=2,size(box%jvk_ji)\r\n neverending: do m=1,size(mqmqa_data%emquad)\r\n if(box%jvk_ji(l).eq.mqmqa_data%emquad(m)) then\r\n if(k.ne.m) then\r\n! we have 2 different endmember quads in ivk_ij and jvk_ji, \r\n! if the mixed quad is not alreay present add it\r\n ny=ijklx(k,m,ia,ia)\r\n do abrakadabra=1,size(box%kvk_ijk)\r\n! check if this quad not already in box_kvk_ijk\r\n write(*,*)'3XQ check duplicate line 4041 !!'\r\n enddo\r\n! add this quad !!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r\n box%kvk_ijk=[box%kvk_ijk, ijklx(k,m,ia,ia)]\r\n! write(*,806)i,k,m,ijklx(k,m,ia,ia)\r\n! write(*,805)'kvk_ijk ',box%kvk_ijk\r\n endif\r\n endif\r\n enddo neverending\r\n enddo\r\n endif\r\n enddo\r\n enddo addkvkterm\r\n805 format(a,20i3)\r\n806 format('3XQ adding mixed quad to kvk_ijk',i3,2x,2i3,2x,i3)\r\n! end copied code\r\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r\n747 continue\r\n enddo vzloop\r\n! the vzloop above should be done whenever the asymmetry changes\r\n!\r\n! write(*,748)box%cat1,box%cat2\r\n748 format('3XQ Asymmetry updated for varkappa_ij: ',2i3)\r\n!--------------------------------------------------------------------\r\n! end of asymmetry detection loop\r\n!--------------------------------------------------------------------\r\n!\r\n endif vzloopupdate\r\n!\r\n!--------------------------------------------------------------------\r\n! Below arrays box%ivk_ij, box%jvk_ji, box%dxi_ij are used to\r\n! calculate \\varkappa and \\xi and their derivatives\r\n!--------------------------------------------------------------------\r\n!\r\n! Now use the structures ivk_ij, jvk_ji, kvk_ijk and dxi_ij, dxi_ji\r\n! write(*,*)'3QX in varkappa1 line 3900',allocated(box%ivk_ij),&\r\n! allocated(box%dvk_ij)\r\n varkappaij=0.0d0; varkappaji=0.0d0; sum=0.0d0; nugamma=0.0d0\r\n do ii=1,size(box%ivk_ij)\r\n varkappaij=varkappaij+mqf%xquad(box%ivk_ij(ii))\r\n! write(*,697)'ivk_ij',ii,box%ivk_ij(ii),varkappaij,xquad(box%ivk_ij(ii))\r\n697 format('Summing ',a,': ',2i3,2(1pe14.6))\r\n enddo\r\n600 format('Partial sum: ',i3,a,1pe12.4,' quad: ',5i3)\r\n do ii=1,size(box%jvk_ji)\r\n varkappaji=varkappaji+mqf%xquad(box%jvk_ji(ii))\r\n! write(*,697)'jvk_ji',ii,box%jvk_ji(ii),varkappaji,xquad(box%jvk_ji(ii))\r\n enddo\r\n do ii=1,size(box%kvk_ijk)\r\n sum=sum+mqf%xquad(box%kvk_ijk(ii))\r\n! write(*,697)'sum',ii,box%kvk_ijk(ii),sum,xquad(box%kvk_ijk(ii))\r\n enddo\r\n! all quad indices\r\n! write(*,696)' all_ijk: ',box%all_ijk\r\n696 format('Quad indices in',a,': ',20i4)\r\n sum=sum+varkappaij+varkappaji+nugamma\r\n! write(*,601)sum,nugamma\r\n601 format('Total value Denominator: ',1pe12.4,' nugamma: ',1pe12.4)\r\n! save normalized values and save also sum for use with derivatives\r\n! at initiation sum=0.0, fix that\r\n if(sum.eq.0.0d0) sum=1.0d0\r\n box%vk_ij=varkappaij/sum\r\n box%vk_ji=varkappaji/sum\r\n! the denominantor needed for derivatives\r\n box%denominator=sum\r\n! write(*,605)' vk_ij and vk_ji: ',box%vk_ij,box%vk_ji\r\n605 format(' ** Normalized values of ',a,2(1pe12.4))\r\n! and the derivatives ....\r\n!\r\n! Calculation of xi_ij using dxi\r\n sum1=0.0d0; sum2=0.0d0\r\n do di=1,mqmqa_data%nquad\r\n sum1=sum1+box%dxi_ij(di)*mqf%xquad(di)\r\n sum2=sum2+box%dxi_ji(di)*mqf%xquad(di)\r\n enddo\r\n box%xi_ij=sum1\r\n box%xi_ji=sum2\r\n!\r\n! debug output, ivk_ij, jvk_ji, kvk_ijk, dxi_ij, dxi_ji ---------------------\r\n! \r\n if(mqmqdebug .or. mqmqxcess) then\r\n nn1=size(box%ivk_ij); nn2=size(box%jvk_ji); nn3=size(box%kvk_ijk)\r\n nn4=mqmqa_data%nquad; nn5=mqmqa_data%nquad;\r\n if(allocated(box%asymm_nu)) then\r\n nn6=size(box%asymm_nu)\r\n else\r\n nn6=0\r\n endif\r\n if(allocated(box%asymm_gamma)) then\r\n nn7=size(box%asymm_gamma)\r\n else\r\n nn7=0\r\n endif\r\n write(*,700)2,nn1,nn2,nn3,nn4,nn5,nn6,nn7,nugamma\r\n700 format('3XQ Sizes: ',i1,': ',7i3,1pe12.4)\r\n write(*,710)'ivk_ij ',(box%ivk_ij(i),i=1,nn1)\r\n write(*,710)'jvk_ji ',(box%jvk_ji(i),i=1,nn2)\r\n write(*,710)'kvk_ijk ',(box%kvk_ijk(i),i=1,nn3)\r\n write(*,709)'dxi_ij ',(box%dxi_ij(i),i=1,nn4)\r\n write(*,709)'dxi_ji ',(box%dxi_ji(i),i=1,nn5)\r\n if(nn6.gt.0) write(*,708)'nu ',(box%asymm_nu(i),i=1,nn6)\r\n if(nn7.gt.0) write(*,708)'gamma ',(box%asymm_gamma(i),i=1,nn7)\r\n709 format('Factors ',a,': ',10f6.3)\r\n708 format('Ternary quad asymmetry ',a,': ',5i4)\r\n710 format('Quad in ',a,': ',5i4)\r\n!\r\n write(*,607)3,box%vk_ij,box%vk_ji\r\n607 format('Current values of vk_ij, vk_ji ',i2,2x,2(1pe15.5))\r\n endif\r\n! end debug output ----------------------------------------------------------\r\n! The asymmetric information collected as saved as quad index in local\r\n! ivk_ij, jvk_ji, kvk_ijk for the \\varkappa variables\r\n! These are needed for calculating derivatives dvk_ij\r\n!---------also for xi \r\n! dxi_ij and dxi_ji for the \\xi variables\r\n!\r\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \r\n! this code use the updated data structure to calculate quickly\r\n! This should be called by set constitution!!\r\n! write(*,*)'In varkappa1 calling dexcess_dq to allocate and set %dvk_ij?'\r\n! call dexcess_dq(box)\r\n! write(*,800)allocated(box%dvk_ij)\r\n!800 format(' *** Back from dexcess_dq to allocate %dvk_ij etc',l2)\r\n goto 900\r\n!\r\n500 continue \r\n!!!!!!!!!! here we use the asymmetry saved in box%asym1 and %asym2\r\n!------------------------------------------------\r\n! Here we calculate the derivatives using %asym1 and %asym2 ???\r\n! ??\r\n900 continue\r\n\r\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \r\n if(box%lastupdate.ne.newXupdate) then\r\n box%lastupdate=newXupdate\r\n! write(*,1001)box%seq,box%lastupdate\r\n1001 format('3XQ allinone record ',i3,' updated to new asymmetries ',i5)\r\n endif\r\n!\r\n1000 continue\r\n if(mqmqder) write(*,*)'3XQ Leaving varkappa1'\r\n return\r\n!\r\n1100 continue\r\n write(*,1105)icat,jcat,v\r\n1105 format('Error return from tersym for elements: ',3i4)\r\n goto 1000\r\n end subroutine varkappa1\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine dexcess_dq(mqf)\r\n!\\begin{verbatim}\r\n subroutine dexcess_skip_dq(nvkappa,mqf)\r\n! calculate the partial derivatives of a \\varkappa or \\xi variable\r\n! box(ij) is mqf%varkappa(ij)\r\n implicit none\r\n! type(gtp_allinone) :: box\r\n integer nvkappa\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n! in ivk_ij, jvk_ji etc specify the indices of quad fractions involved for vk_ij\r\n! A derivative wrt to a quad fractions included means it is 1, otherwise 0\r\n! vk_ij has a numerator and a denominator, both are sums of quad fractions\r\n! dvk_ij/dq_k is the result of the derivative of both\r\n! use type(zquad) for storing derivatives of ivk_ij, jvk_ji .. ???\r\n! if_ij, if_ji, if_ijk are 0/1 depeding on the quad indices in each term\r\n! integer k,v,dtij,dtji,dtdiv\r\n!\\end{verbatim}\r\n integer k,v,d_ij,d_ji,d_ijk,some\r\n double precision numerator, denominator\r\n type(gtp_allinone), pointer :: box\r\n!\r\n write(*,*)'3XQ in dexcess_dq',nvkappa,size(mqf%compvar)\r\n goto 1000\r\n!\r\n allbox: do some=1,nvkappa\r\n box=>mqf%compvar(some)\r\n if(.not.allocated(box%dvk_ij)) then\r\n! first time inititate arrays\r\n allocate(box%dvk_ij(mqmqa_data%nquad))\r\n allocate(box%dvk_ji(mqmqa_data%nquad))\r\n! below the arrays are initiated to zero\r\n endif\r\n! \r\n! calculate the derivatives of all vk_ij, vk_ji with respect to quads\r\n! The quad indices are stored in ivk_ij, jvk_ji and kvk_ijk\r\n!\r\n! \\sum x_i numerator ivk_ij\r\n! f=vk_i = --------- = ---------- = ------------------- \\delta_mv=1 if m=k\r\n! \\sum x_k denominator ivkij+jvkji+kvk_ijk\r\n!\r\n! denominator*\\delta_iv - numerator*\\delta_ijkv\r\n! df/dx_v = --------------------------------------------- \\delta_mv=1 if m=k\r\n! denominator**2\r\n! note value of numerator stored in vk_ij etc is already divided by denominator,\r\n! \\delta_iv (numerator/denominator)*\\delta_ijkv\r\n! thus df/dx_v = ------------ - -----------------------------------\r\n! denominator denominator\r\n!\r\n! many df/dx_v are zero ... trying to be smart? save only non-zero df/dx_v\r\n!----------------------------------------------------------\r\n! the arrays ivk_ij have only indices for the quads q they depend on\r\n! vk_ij is the sum of those quads. Many dvk_ij should be zero\r\n! the denominator always depend on the same fractions as the numerator\r\n box%dvk_ij=0.0d0\r\n box%dvk_ji=0.0d0\r\n write(*,10)box%seq,box%all_ijk\r\n10 format('3XQ In dexcess_dq: allinone ',i3,' depend on quads: ',2x,20i3)\r\n kloop: do k=1,mqmqa_data%nquad\r\n! we have to check all_ijk if vk depend on quad k\r\n! dvk_ij(k)=(if_ij/denominator_ij - if_ijk*numerator_ij)/denominator_ij\r\n! denominator_ijk and numerator_ij are sum of quad fractions\r\n!\r\n d_ijk=0; d_ij=0; d_ji=0\r\n! write(*,15)box%all_ijk\r\n15 format('kvk%ijk',20i3)\r\n tdloop: do v=1,size(box%all_ijk)\r\n if(k.eq.box%all_ijk(v)) then\r\n! k is part of v_ij, this assignment actually redundant\r\n d_ijk=1; goto 17\r\n endif\r\n enddo tdloop\r\n! varkappa independent of quad k\r\n box%dvk_ij(k)=0.0d0\r\n box%dvk_ji(k)=0.0d0\r\n cycle kloop\r\n!\r\n! nonzero: if(d_ijk.eq.1) then\r\n17 continue\r\n! this varkappa depend on quad fraction k, calculate derivative\r\n! write(*,20)'vk_ij ',v,box%denominator\r\n20 format('Denominator of ',a,' wrt quad ',i3,2x,1pe12.4) \r\n t1loop: do v=1,size(box%ivk_ij)\r\n if(k.eq.box%ivk_ij(v)) then\r\n d_ij=1; exit t1loop\r\n endif\r\n enddo t1loop\r\n! if(d_ij.eq.1) write(*,30)'ivk_ij loop ',v,box%vk_ij\r\n30 format('Numerator ',a,' wrt quad ',i3,1pe12.4)\r\n t2loop: do v=1,size(box%jvk_ji)\r\n if(k.eq.box%jvk_ji(v)) then\r\n d_ji=1; exit t2loop\r\n endif\r\n enddo t2loop\r\n! write(*,35)v,d_ijk,d_ij,d_ji\r\n35 format('All d_xyz: ',i3,4i4)\r\n! if(d_ji.eq.1) write(*,30)'jvk_ji loop ',v,box%vk_ji\r\n! Note that vk_ij and vk_ji are already divided by denominator\r\n box%dvk_ij(k)=(d_ij - box%vk_ij)/box%denominator\r\n box%dvk_ji(k)=(d_ji - box%vk_ji)/box%denominator\r\n enddo kloop\r\n! debug output of the derivatives\r\n if(mqmqdebug) then\r\n do k=1,mqmqa_data%nquad\r\n write(*,100)k,box%dvk_ij(k),box%dvk_ji(k)\r\n enddo\r\n100 format('3XQ In dexcess_dq: dvk_ij, dvk_ji wrt quad: ',i3,2(1pe14.6))\r\n endif\r\n enddo allbox\r\n! now derivatives of xi with respect to quads NOT DONE ???????\r\n!\r\n1000 continue\r\n write(*,*)'3XQ exit dexcess_dg'\r\n return\r\n end subroutine dexcess_skip_dq\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine set_ternary_asymmetry(line)\r\n!\\begin{verbatim}\r\n subroutine set_ternary_asymmetry(line)\r\n implicit none\r\n character*(*) line\r\n! to set asymmetries in a text\r\n!\\end{verbatim}\r\n integer i,j,ip,iq,ia,ib,ic,mm,icc(3),nc,kk,vz,toop(3)\r\n integer missasym\r\n integer iph,ics,icon,ipm\r\n double precision mass\r\n character missingcon*60\r\n character phase*24,const(3)*24,asymcode*6,asymoc*3\r\n type(gtp_phaserecord), pointer :: phrec\r\n!\r\n phase=' '\r\n missasym=0\r\n! called from gtp3E around line 5493\r\n if(mqmqdebug) write(*,10)trim(line)\r\n10 format('3XQ set_ternary_asymmetry called from gtp3E: \"',a,'\"')\r\n! write(*,*)'3E set_ternary_asymmetry to be fixed'\r\n! extract constituent indices and call setsym'\r\n! text is extacted from frist nonblank position ip to first space\r\n! first the phase, then 3 constituents finally the asymcode\r\n ip=0\r\n call getext(line,ip,2,phase,' ',iq)\r\n! write(*,20)trim(phase),iq\r\n20 format('3XQ Phase name: ',a,5x,i3)\r\n if(phase(1:1).ne.' ') then\r\n call find_phase_by_name(phase,iph,ics)\r\n if(gx%bmperr.ne.0) then\r\n write(*,21)trim(phase)\r\n21 format(/'3XQ Ternary asymmetries for phase \"',a,&\r\n '\" ignored as phase not selected')\r\n gx%bmperr=0\r\n goto 1000\r\n endif\r\n else\r\n goto 1100\r\n endif\r\n nc=size(phlista(iph)%constitlist)\r\n! write(*,*)'3XQ in set_ternary_asymmetry, found phase ',iph,nc\r\n!\r\n! debug listing of mqmqa_data%contyp\r\n! do vz=1,nc\r\n! write(*,33)(mqmqa_data%contyp(i,vz),i=1,14)\r\n! 4 5=FNN 6-7 8-9 same 11-12 13-14\r\n33 format('3XQ: ',4i3,2x,i3, 2x,2i3,2x,2i3,2x,i3,2x,2i3,2x,2i3)\r\n! enddo\r\n!\r\n extract_asymmetries: do while(ip.lt.len(line))\r\n! save constituent indices in icc\r\n icc=0\r\n asymcode=' '; const=' '; missingcon=' '\r\n ipm=1\r\n find3: do i=1,3\r\n call getext(line,ip,2,const(i),' ',iq)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! The terminator is usually \"!\" or \"/\"\r\n if(const(i).eq.'!' .or. const(i).eq.'/') goto 1000\r\n! we have to go through the list of constituents of the phase to find the\r\n! constituents as we need their sequental index .... SUCK\r\n! mm=len_trim(const(i))+1 as constituents in MQMQA the name has suffix\r\n! A small risk that it is an abbreviation ...\r\n mm=len_trim(const(i))\r\n if(mm.le.1) goto 1000\r\n compare: do j=1,nc\r\n! the names of the constituents are in the species structure!\r\n kk=phlista(iph)%constitlist(j)\r\n! write(*,50)const(i)(1:mm),splista(kk)%symbol(1:mm)\r\n50 format('Comparing \"',a,'\" and \"',a,'\" ',i3)\r\n if(const(i)(1:mm).eq.splista(kk)%symbol(1:mm)) then\r\n! Hmmmmm, it is not species index we want, we want the number of the\r\n! this species is phase constituent i, use mqmqa_data%contyp(5,i) !!\r\n! in mqmqa_data%contyp(5,j) is the pair index !!??\r\n vz=mqmqa_data%contyp(5,j)\r\n! write(*,53)'3XQ Found asymmetric: ',i,splista(kk)%symbol,j,vz\r\n53 format(a,i3,2x,a,5i4)\r\n icc(i)=vz\r\n! write(*,60)i,const(i),vz\r\n60 format('3XQ cation index: ',i3,2x,a,2x,i4)\r\n cycle find3\r\n endif\r\n enddo compare\r\n! write(*,*)'3XQ Asymmetric constituent not found',i,const(i)(1:mm)\r\n missingcon(ipm:)=const(i)\r\n ipm=len_trim(missingcon)+2\r\n! we have to read all constituents becaise some asymmetries may involve\r\n! constitutents not selected\r\n enddo find3\r\n! error if end of line\r\n if(ip.ge.len_trim(line)) goto 1100\r\n call getext(line,ip,2,asymcode,' ',iq)\r\n! TKK means the third quad has the Toop element\r\n! KTK means the second quad has the Toop element\r\n! KKT means the first quad has the Toop element\r\n! convert for example T3KT3 to TKK related to the 3 elements in the quads\r\n! the value to be saved is the element index of the first, second or third quad\r\n! write(*,*)'3XQ Asymmetric code: ',asymcode\r\n! if any icc is 0 skip\r\n do j=1,3\r\n if(icc(j).eq.0) then\r\n! write(*,*)'3XQ missing asymmetry constituents: ',trim(missingcon)\r\n missasym=missasym+1\r\n cycle extract_asymmetries\r\n endif\r\n enddo\r\n! write(*,100)trim(phase),icc(1),icc(2),icc(3),trim(asymcode)\r\n100 format('3XQ asymmetric ternary in ',a,' elements ',3i4,5x,a)\r\n! convert full asymmetry to OC\r\n call convert_asymm(asymcode,asymoc,icc,toop)\r\n! output from convert_asymm seems OK but with some redundat data\r\n! there can be several asymmetric ternaries\r\n! write(*,*)'3XQ Arrange actual order of cations in setasym'\r\n! do we need toop?\r\n! call setasym(iph,icc,toop,nquad,asymoc)\r\n call setasym(iph,icc,toop,asymoc)\r\n if(gx%bmperr.ne.0) goto 1000\r\n! stop 'debug'\r\n enddo extract_asymmetries\r\n!\r\n newXupdate=newXupdate+1\r\n! tersym is declared globally, it should be within a phase record\r\n! as each phase can have ternary symmetries\r\n!\r\n1000 continue\r\n if(missasym.gt.0) then\r\n write(*,1010)trim(phase),missasym\r\n1010 format('3XQ Phase ',a,&\r\n ' has ',i3,' ternary asymmetries for nonselected constituents')\r\n endif\r\n! phase\r\n return\r\n1100 write(*,1110)line(min(1,ip-10):ip+10)\r\n1110 format('Problem extracting ternary asymmetry: ',a)\r\n gx%bmperr=4499\r\n goto 1000\r\n end subroutine set_ternary_asymmetry\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine convert_asymm\r\n!\\begin{verbatim}\r\n subroutine convert_asymm(code1,code2,icc,toop)\r\n! convert from 6 to 3 letters\r\n implicit none\r\n character code1*6,code2*3\r\n! icc are the 3 cations in the ternary ... toop is ?\r\n integer icc(3),toop(3)\r\n!\\end{verbatim}\r\n character cha*1,chb*1\r\n integer ia,ib,iv,iw,ntoop\r\n code2='KKK'\r\n iw=0\r\n ntoop=0\r\n toop=0\r\n do iv=1,3\r\n iw=iw+1\r\n if(code1(iw:iw).eq.'T') then\r\n ntoop=ntoop+1\r\n ia=ichar(code1(iw+1:iw+1))-ichar('0')\r\n if(ia.gt.0 .and. ia.le.3) then\r\n! The T is followed by a digit indicating the constituent, 1, 2 or 3\r\n toop(ntoop)=iv\r\n code2(4-ia:4-ia)='T'\r\n! skip one position in code1\r\n iw=iw+1\r\n else\r\n! toop elementet is indicated by the 3 cation positions\r\n toop(ntoop)=iv\r\n code2(4-iv:4-iv)='T'\r\n endif\r\n! write(*,*)'3XQ Toop cation is: ',icc(ia),' position ',toop(ntoop)\r\n endif\r\n! write(*,10)code1,code2,iv,icc\r\n enddo\r\n write(*,10)code1,code2,icc,toop\r\n10 format('3XQ convert_asymm: \"',a,'\" to \"',a,'\" cations: ',3i2,' Toop: ',3i3)\r\n return\r\n end subroutine convert_asymm\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine setasym\r\n!\\begin{verbatim}\r\n subroutine setasym(iph,icc,toop,kkk)\r\n! set asymmetry of a ternary\r\n! the cation indices can be in any order, must be ordered.\r\n implicit none\r\n integer iph,icc(3), toop(3)\r\n character*3 kkk\r\n! \r\n! REDUNDANT AS INTEGRATED IN PMON6.F90\r\n!\r\n!\\end{verbatim}\r\n integer i,j,k,dim3,ntercat\r\n integer a,b,c,mm,v\r\n! default is 'KKK' which is symmetrical for the 3 binaries 1-2, 1-3 and 2-3\r\n! 'TKK' means element 3 is asymmetrical for 1-2\r\n! 'TKT' means element 3 is asymmetrical for 1-2 and element 1 for 2-3\r\n!\r\n! icc are the cation indices, toop is zero unless one or more toop cations\r\n! write(*,60)icc,toop,kkk\r\n60 format('3XQ ENTERING SETASYM: icc: ',3i3,' toop: ',3i3,' kkk: ',a)\r\n! format(a,3i3,3x,3i3,2x,a)\r\n!\r\n i=icc(1); j=icc(2); k=icc(3)\r\n!\r\n! write(*,*)'3XQ calling order3KKK '\r\n!\r\n call order3KKK(i,j,k,a,b,c,kkk)\r\n!\r\n if(a.lt.0) then\r\n write(*,*)'Problems 10 in order3 ',i,j,k,a,b,c\r\n stop\r\n endif\r\n! rearranged i, j, k\r\n! write(*,70)a,b,c,kkk\r\n70 format('3XQ rearranged order in setasym: ',3i4,5x,a)\r\n!\r\n! if order changed, change KKK, assume only one T\r\n!\r\n! any phase may have asymmetric ternaries but at present only MQMQA\r\n! if(.not.allocated(phlista(iph)%tersys)) then\r\n! stop\r\n! endif\r\n!\r\n! emergency ... should be checked, a system with 3 constituent has 1 ternary\r\n! dim3=size(tersys)\r\n! write(*,333)a,b,c,mqmqa_data%ncat,mm,size(tersys)\r\n333 format('3XQ In setasym: ',8i4)\r\n mm=terind(a,b,c)\r\n if(mm.le.0) then\r\n write(*,*)'3XQ terind cannot find this system',a,b,c\r\n stop\r\n end if\r\n! write(*,333)a,b,c,mqmqa_data%ncat,mm,size(tersys)\r\n!\r\n newXupdate=newXupdate+1\r\n! tersym is declared globally, it should be within a phase record\r\n! as each phase can have ternary symmetries\r\n! write(*,511)mm,' old ',tersys(mm)%asymm,tersys(mm)%isasym,a,b,c\r\n511 format('3XQ in setasym ternary: ',i4,a,' asymmetry <',a,'> ',3i3,2x,3i3)\r\n tersys(mm)%asymm=kkk\r\n tersys(mm)%isasym=0\r\n! or should one use i, j, k ???\r\n! the indices in tersys(mm)%el are the 3 element indices of the ternary\r\n! write(*,300)mm,tersys(mm)%el\r\n300 format('Element numbers in ternary ',i3,' are ',3i3)\r\n if(kkk(1:1).eq.'T') tersys(mm)%isasym(1)=tersys(mm)%el(3)\r\n if(kkk(2:2).eq.'T') tersys(mm)%isasym(2)=tersys(mm)%el(2)\r\n if(kkk(3:3).eq.'T') tersys(mm)%isasym(3)=tersys(mm)%el(1)\r\n write(*,511)mm,' new ',tersys(mm)%asymm,tersys(mm)%isasym,a,b,c\r\n!\r\n! for debugging list whole array\r\n! write(*,310)dim3\r\n310 format(/'Listing of the ',i3,' ternary systems and their asymmetry',&\r\n /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code')\r\n! ntercat=mqmqa_data%ncat*(mqmqa_data%ncat-1)*(mqmqma_data%ncat-2)/6\r\n! do i=1,ntercat\r\n! write(*,320)i,tersys(i)%seq,(tersys(i)%el(j),j=1,3),&\r\n! tersys(i)%isasym,tersys(i)%asymm\r\n320 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a)\r\n! enddo\r\n! write(*,330)\r\n330 format(/'Number in T/0 column is actual asymmetric element')\r\n! \r\n return\r\n end subroutine setasym\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine correlate_const_and_quads\r\n!\\begin{verbatim}\r\n subroutine correlate_const_and_quads(lokph)\r\n! this subroutine should for each mqmqa constituent create their\r\n! quad index element order for handling asymmetric variables in compvar\r\n! el1 1 1 1 .. 1 ! 2 2 .. 2 ! 3 .. ! n-1\r\n! el2 1 2 3 .. n-1 ! 2 3 .. n-1 ! 3 .. ! n-1\r\n! quad 1 2 3 n ! n+1 n+2 2n-1 ! 2n ! (n-1)n/2\r\n! With n elements and one anion there are n-1 cations\r\n! The anion element index can be any value from 1 to n\r\n!\r\n! i=el2ancat(j) is cation index of element j, a negative value mean anion\r\n! i=con2quad(j) is index in quad fraction array of constituent j\r\n! it is populated using ijklx(cat1,cat2,1,1) where the 1 is the anion\r\n! OC saves fractions in phase_varres%yfr(1..n) for a single sublattice\r\n! there is no need to transfer fractions from quad to phase_varres%yfr\r\n! A quad has 1 or 2 cations ALWAYS indexed from 1 .. n-1 (no anion fraction)\r\n! i=el2ancat(j) is the cation index element j. If j is anion a negative value\r\n! i=quadofel(j) is the cation index of an element i\r\n! The anion element index is not used \r\n! ... but its elllink is saved in xanione and element index in xanionalpha\r\n! \r\n implicit none\r\n integer iph,lokph,loksp,lokcs,nfr,isp,iel,jp,el1,el2,icon,endmem,mm\r\n integer cat1,cat2\r\n integer missing,ll,nocon\r\n logical noanion\r\n integer, allocatable, dimension(:) :: invert,inverse\r\n integer, allocatable, dimension(:) :: findan\r\n character*24 quadname\r\n!\r\n! called from create_asymmetry in gtp3B\r\n! write(*,7)lokph,nfr,noofel\r\n7 format(/'3XQ In correlate_const_and_quad',3i5//)\r\n!\r\n nfr=phlista(lokph)%nooffr(1)\r\n allocate(findan(noofel))\r\n! lokcs=phlista(lokph)%linktocs(1) composition set?\r\n! note element numbers are not in order, the anion may be anywhere\r\n!\r\n! first step, find anion, it is present in all constituents\r\n! Stupid to do this here, it has already been found but lost\r\n findan=0\r\n do isp=1,nfr\r\n loksp=phlista(lokph)%constitlist(isp)\r\n iel=size(splista(loksp)%ellinks)\r\n! if(iel.eq.3) then\r\n! write(*,3)isp,loksp,iel,splista(loksp)%symbol,&\r\n! (ellista(splista(loksp)%ellinks(jp))%symbol,jp=1,iel),&\r\n! (ellista(splista(loksp)%ellinks(jp))%alphaindex,jp=1,iel),&\r\n! (splista(loksp)%ellinks(jp),jp=1,iel)\r\n! else\r\n! write(*,2)isp,loksp,iel,splista(loksp)%symbol,&\r\n! (ellista(splista(loksp)%ellinks(jp))%symbol,jp=1,iel),&\r\n! (ellista(splista(loksp)%ellinks(jp))%alphaindex,jp=1,iel),&\r\n! (splista(loksp)%ellinks(jp),jp=1,iel)\r\n! endif\r\n!2 format('3XQ const: ',3i3,2x,a12,2x,2(a,2x),4x,2(i3),5x,2(i3))\r\n!3 format('3XQ const: ',3i3,2x,a12,2x,3(a,2x),3(i3),2x,3(i3))\r\n do jp=1,iel\r\n el1=splista(loksp)%ellinks(jp)\r\n findan(el1)=findan(el1)+1\r\n enddo\r\n enddo\r\n! write(*,4)'3XQ elements: ',findan\r\n4 format(a,20i3)\r\n! count the number of times an element occurs\r\n! write(*,22)(jp,elements(jp),ellista(jp)%alphaindex,ellista(jp)%symbol,&\r\n! jp=1,noofel)\r\n22 format(/'3XQ elements :',10(3i2,1x,a,';')/)\r\n el1=0\r\n! The anion should be present in all quads!\r\n do jp=1,noofel\r\n if(findan(jp).gt.el1) then\r\n el1=findan(jp); el2=jp;\r\n endif\r\n enddo\r\n! el2 is the element index is in ellista, el1 is the alphabetical order\r\n! write(*,*)'3QX anion is element: ',el1,el2,findan(el2)\r\n! \r\n mqmqa_data%xanione=el2\r\n mqmqa_data%xanionalpha=ellista(el2)%alphaindex\r\n! write(*,6)ellista(mqmqa_data%xanione)%symbol,&\r\n! mqmqa_data%xanione,mqmqa_data%xanionalpha\r\n6 format(/'3XQ line 3383 anion: ',a,' ellink: ',i3,' alphabetically: ',i3/)\r\n!\r\n! set up translation table for cations from ellink to 1..ncat\r\n! the anion has a negative value in el2ancat, the cations index 1..ncat\r\n! write(*,*)'3XQ in correlate_const_and_quads ... allocating el2ancat'\r\n! mqmqa_data is not allocated ... suck\r\n! if(allocated(mqmqa_data%el2ancat(noofel))) &\r\n! deallocate(mqmqa_data%el2ancat(noofel))\r\n allocate(mqmqa_data%el2ancat(noofel))\r\n! write(*,*)'Size of mqmqa_data%el2ancat ',size(mqmqa_data%el2ancat)\r\n do jp=1,noofel\r\n if(jp.lt.mqmqa_data%xanionalpha) then\r\n! if(jp.lt.mqmqa_data%xanione) then\r\n mqmqa_data%el2ancat(jp)=jp\r\n elseif(jp.gt.mqmqa_data%xanionalpha) then\r\n! elseif(jp.gt.mqmqa_data%xanione) then\r\n mqmqa_data%el2ancat(jp)=jp-1\r\n else\r\n mqmqa_data%el2ancat(jp)=-jp\r\n endif\r\n! write(*,*)'3xq mqmqa_data%el2cat: ',jp,mqmqa_data%el2ancat(jp)\r\n enddo\r\n! write(*,16)'3XQ Elements alphabetically: ',&\r\n! ((ellista(elements(jp))%symbol),jp=1,noofel)\r\n! write(*,17)'3XQ Elements in ellista order:',(elements(jp),jp=1,noofel)\r\n! write(*,17)'3XQ Element alpha indices: ',(jp,jp=1,noofel)\r\n! write(*,17)'3XQ Cation alpha indices: ',&\r\n! (mqmqa_data%el2ancat(jp),jp=1,noofel)\r\n15 format(a,20(i2,a2))\r\n16 format(a,20(1x,a2))\r\n17 format(a,20i3)\r\n!\r\n! We need to know how to transfer compositions from phase_varres%yfr to xquad\r\n allocate(mqmqa_data%con2quad(nfr))\r\n! loop though all constituents in the %constitlist, extract cations and\r\n! calculate its index in the xquad. Only done once!\r\n con2quad: do isp=1,nfr\r\n loksp=phlista(lokph)%constitlist(isp)\r\n! there are 2 or 3 element links, one of which is an anion\r\n el1=ellista(splista(loksp)%ellinks(1))%alphaindex\r\n cat1=mqmqa_data%el2ancat(el1)\r\n! cat1=mqmqa_data%el2ancat(splista(loksp)%ellinks(1))\r\n! write(*,18)'First: ',el1,cat1,cat1,splista(loksp)%symbol\r\n18 format(a,3i4,5x,a)\r\n first: if(cat1.lt.0) then\r\n! first link was to the anion, next must be a cation\r\n el1=ellista(splista(loksp)%ellinks(2))%alphaindex\r\n cat1=mqmqa_data%el2ancat(el1)\r\n! write(*,18)'Second: ',el1,&\r\n! mqmqa_data%el2ancat(splista(loksp)%ellinks(2)),cat1\r\n more1: if(size(splista(loksp)%ellinks).gt.2) then\r\n! there can be 1 or 2 cations, the first ellink was to an anion\r\n el1=ellista(splista(loksp)%ellinks(3))%alphaindex\r\n cat2=mqmqa_data%el2ancat(el1)\r\n! write(*,18)'Third: ',splista(loksp)%ellinks(3),&\r\n! mqmqa_data%el2ancat(splista(loksp)%ellinks(3)),cat2\r\n else\r\n! if there is no third element the single cation is doubled\r\n cat2=cat1\r\n endif more1\r\n else\r\n! we found one cation, the next ellink can be an anion or cation \r\n el1=ellista(splista(loksp)%ellinks(2))%alphaindex\r\n cat2=mqmqa_data%el2ancat(el1)\r\n! write(*,18)'Fourth: ',el1,&\r\n! mqmqa_data%el2ancat(el1),cat2\r\n second: if(cat2.lt.0) then\r\n more2:if(size(splista(loksp)%ellinks).gt.2) then\r\n! there can be 1 or 2 cations, the second ellink can be to the anion\r\n el1=ellista(splista(loksp)%ellinks(3))%alphaindex\r\n cat2=mqmqa_data%el2ancat(el1)\r\n! write(*,18)'Fifth: ',el1,&\r\n! mqmqa_data%el2ancat(el1),cat2\r\n else\r\n! the single cation is doubled\r\n cat2=cat1\r\n endif more2\r\n endif second\r\n endif first\r\n! when we come here we hav one or two cations\r\n mqmqa_data%con2quad(isp)=ijklx(cat1,cat2,1,1)\r\n! write(*,55)isp,cat1,cat2,mqmqa_data%con2quad(isp)\r\n55 format('3xq loop: ',i3,2x,2i3,2x,i5)\r\n enddo con2quad\r\n! allocate also array with all A/X quads\r\n allocate(mqmqa_data%emquad(mqmqa_data%ncat))\r\n! enter data in emquad\r\n cat1=1\r\n cat2=mqmqa_data%ncat\r\n do isp=1,mqmqa_data%ncat\r\n mqmqa_data%emquad(isp)=cat1; cat1=cat1+cat2; cat2=cat2-1\r\n enddo\r\n! list quads (why?)\r\n write(*,68)(mm,mm=1,mqmqa_data%nquad)\r\n68 format('3XQ quads: ',21i3)\r\n write(*,57)'3XQ emquads:',(mqmqa_data%emquad(isp),isp=1,mqmqa_data%ncat)\r\n57 format(a,25i4)\r\n!\r\n! loop for all constituents of the mqmqa phase\r\n! we should populate all structures of the %alphaindex of the element\r\n! skipping the alphaindex of the anion\r\n! write(*,60)'3XQ constituents :',(jp,jp=1,nfr),&\r\n! 'mqmqa_data%con2quad:',(mqmqa_data%con2quad(jp),jp=1,nfr)\r\n60 format(/a,10(i3,1x)/a,10(i3,1x))\r\n! icon is index of constituent in phase 1..n\r\n! splista(icon)%symbol is species symbol\r\n! write(*,65)\r\n65 format(/'3XQ Constituents in alphabetical order:')\r\n! write(*,70)(trim(splista(phlista(lokph)%constitlist(jp))%symbol),jp=1,nfr)\r\n!\r\n! write(*,*)'3XQ Constituents in quad order:'\r\n! write(*,70)(trim(splista(phlista(lokph)%constitlist(mqmqa_data%con2quad(jp)))%symbol),jp=1,nfr)\r\n!\r\n!70 format('3XQ: ',10(a,', '))\r\n!71 format('3XQ: ',2i3,3x,a)\r\n!\r\n allocate(inverse(nfr))\r\n! write(*,87)\r\n87 format(/'3XQ OC fraction order MQMQA quad order')\r\n do jp=1,nfr\r\n qqq: do el1=1,nfr\r\n cat1=mqmqa_data%con2quad(el1)\r\n if(cat1.eq.jp) then\r\n quadname=splista(phlista(lokph)%constitlist(el1))%symbol\r\n inverse(jp)=el1\r\n exit qqq\r\n endif\r\n enddo qqq\r\n! write(*,88)jp,trim(splista(phlista(lokph)%constitlist(jp))%symbol),&\r\n! el1,trim(quadname)\r\n88 format('Order ',i3,3x,a12,i5,2x,a)\r\n enddo\r\n!\r\n! this is if we need to convert from xquad array to yfr\r\n! write(*,89)(inverse(jp),jp=1,nfr)\r\n89 format('3XQ Quad2con: ',20i3)\r\n1000 continue\r\n return\r\n end subroutine correlate_const_and_quads\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine list_quads(kk)\r\n!\\begin{verbatim}\r\n subroutine list_quads(kk)\r\n! emergency subroutine because phlista protected in pmon6\r\n implicit none\r\n integer kk\r\n!\\end{verbatim}\r\n integer nel\r\n!\r\n kk=0\r\n! negative is anion\r\n write(*,2)(ellista(elements(nel))%symbol,nel=1,noofel)\r\n2 format(/'Element names: ',20(a2,1x))\r\n do nel=1,noofel\r\n if(mqmqa_data%el2ancat(nel).lt.0) kk=nel\r\n enddo\r\n! elements as quad numbers\r\n write(*,3)size(mqmqa_data%el2ancat),mqmqa_data%el2ancat\r\n3 format('Cation indices:',i2,2x,20i3)\r\n!3 format('3XQ el2ancat: ',i3,2x,20i3)\r\n if(kk.eq.0) then\r\n write(*,*)'You have a strange MQMQA system without any anion'\r\n else\r\n write(*,4)ellista(elements(kk))%symbol,mqmqa_data%xanionalpha,&\r\n mqmqa_data%xanione\r\n4 format('The anion element name, index and link: ',a,2i3)\r\n endif\r\n!\r\n return\r\n end subroutine list_quads\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine listconst\r\n!\\begin{verbatim}\r\n subroutine listconst(iph)\r\n! emergency subroutine because phlista protected in pmon6\r\n implicit none\r\n integer iph\r\n!\\end{verbatim}\r\n type(gtp_phase_varres), pointer :: phres\r\n integer lokph,lokcs,isp,iel,elx(4),elxx(4),jp,j1,j4,nel,cations(2),jj,kk\r\n character :: elsym(noofel)*2\r\n\r\n elsym=' '\r\n kk=0\r\n do nel=1,noofel\r\n elsym(nel)=ellista(elements(nel))%symbol\r\n if(mqmqa_data%el2ancat(nel).lt.0) kk=nel\r\n enddo\r\n write(*,2)(elsym(jj),jj=1,noofel)\r\n2 format(/'Element names: ',20(a2,1x))\r\n write(*,3)size(mqmqa_data%el2ancat),mqmqa_data%el2ancat\r\n3 format('3XQ el2ancat: ',i3,2x,20i3)\r\n if(kk.eq.0) then\r\n write(*,*)'You have a strange MQMQA system without any anion'\r\n endif\r\n write(*,4)elsym(kk),mqmqa_data%xanionalpha,&\r\n mqmqa_data%xanione\r\n4 format('3XQ The anion element name, index and link: ',a,2i3)\r\n!\r\n lokph=phases(iph)\r\n lokcs=phlista(lokph)%linktocs(1)\r\n isp=0\r\n! mqmqa_data%xanione=splista(j4)%ellinks(nel) \r\n! write(kou,5)lokcs,mqmqa_data%xanione,mqmqa_data%xanionalpha\r\n write(kou,5)\r\n5 format(/'Con Quad Nel Elements Elem index',2x,'Species name',&\r\n 15x,'Cations')\r\n specie: do jp=1,phlista(lokph)%nooffr(1)\r\n isp=isp+1\r\n j4=phlista(lokph)%constitlist(jp)\r\n nel=size(splista(j4)%ellinks)\r\n elsym=' '\r\n elxx=1000\r\n jj=0\r\n element: do iel=1,nel\r\n elx(iel)=splista(j4)%ellinks(iel)\r\n elsym(iel)=ellista(elx(iel))%symbol\r\n elxx(iel)=ellista(splista(j4)%ellinks(iel))%alphaindex\r\n j1=mqmqa_data%el2ancat(elxx(iel))\r\n if(j1.gt.0) then\r\n! con2cat(i) is the cation index of i, negative if anion\r\n jj=jj+1\r\n cations(jj)=j1\r\n endif\r\n enddo element\r\n if(jj.eq.1) cations(2)=cations(1)\r\n if(noofel.le.3) then\r\n write(kou,19)isp,mqmqa_data%con2quad(isp),nel,(elsym(kk),kk=1,3),&\r\n elxx,splista(j4)%symbol,cations\r\n19 format(i3,i4,2x,i4,1x,3(a,2x),4(1x,i2),2x,a,2x,2i3)\r\n else\r\n write(kou,20)isp,mqmqa_data%con2quad(isp),nel,(elsym(kk),kk=1,4),&\r\n elxx,splista(j4)%symbol,cations\r\n20 format(i3,i4,2x,i4,1x,4(a,2x),4(1x,i2),2x,a,2x,2i3)\r\n endif\r\n enddo specie\r\n write(*,*)'The quads are in the alphabetical order of the quad elements'\r\n return\r\n end subroutine listconst\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!\\addtotable subroutine listpartree\r\n!\\begin{verbatim}\r\n subroutine listpartree(lokph)\r\n! list all endmembers and excess parameter records for a phase\r\n! in order to understand the MQMQX phase\r\n implicit none\r\n integer lokph\r\n!\\end{verbatim}\r\n !\\end{verbatim}\r\n type (gtp_endmember), pointer :: endmemrec,em\r\n type (gtp_interaction), pointer :: intrec\r\n type (gtp_property), pointer :: proprec\r\n type (gtp_asymprop), pointer :: asymdata\r\n integer intlevel,nofr,fracs(10),npr,intsave,ii,nint,powers(3)\r\n! double precision vals(6)\r\n character*3 tab1\r\n character*6 tab2\r\n character*9 tab3\r\n!\r\n type stack\r\n type(gtp_interaction), pointer :: current\r\n end type stack\r\n type(stack), dimension(:), allocatable :: intstack\r\n! \r\n intlevel=0; fracs=0\r\n tab1='---'\r\n tab2='------'\r\n tab3='---------'\r\n allocate(intstack(5))\r\n write(*,5)\r\n5 format('3XQ list of the excess parameter tree')\r\n! \r\n endmemrec=>phlista(lokph)%ordered\r\n! if(associated(endmemrec)) write(*,*)'3XQ there is an endmember'\r\n emloop: do while(associated(endmemrec))\r\n nofr=1\r\n fracs(nofr)=endmemrec%fraclinks(1,1)\r\n intrec=>endmemrec%intpointer\r\n!\r\n if(associated(intrec)) write(*,10)fracs(1)\r\n10 format('3XQ interactions from endmember ',i3)\r\n intsave=0\r\n nofr=nofr+1\r\n intloop:do while(associated(intrec))\r\n fracs(nofr)=intrec%fraclink(1)\r\n proprec=>intrec%propointer\r\n if(.not.associated(proprec)) then\r\n write(*,20)intsave+1,fracs(nofr)\r\n20 format('3XQ interaction record level',i3,', constituent',i3)\r\n else\r\n proploop: do while(associated(proprec))\r\n if(.not.associated(proprec%asymdata)) then\r\n powers=0\r\n else\r\n powers(1)=proprec%asymdata%ppow\r\n powers(2)=proprec%asymdata%qpow\r\n powers(3)=proprec%asymdata%rpow\r\n endif\r\n npr=proprec%antalprop\r\n if(intsave.eq.0) then\r\n write(*,100)' ',intsave+1,npr,powers,(fracs(ii),ii=1,nofr)\r\n elseif(intsave.eq.1) then\r\n write(*,100)tab1,intsave+1,npr,powers,(fracs(ii),ii=1,nofr)\r\n elseif(intsave.eq.2) then\r\n write(*,100)tab2,intsave+1,npr,powers,(fracs(ii),ii=1,nofr)\r\n elseif(intsave.eq.3) then\r\n write(*,100)tab3,intsave+1,npr,powers,(fracs(ii),ii=1,nofr)\r\n else\r\n write(*,100)'---',intsave+1,npr,powers,(fracs(ii),ii=1,nofr)\r\n endif\r\n100 format('3XQ ',a,' at level ',i1,', func: ',i2,&\r\n ', powers: ',3i2,', constituents ',9i3)\r\n proprec=>proprec%nextpr\r\n enddo proploop\r\n endif\r\n if(associated(intrec%highlink)) then\r\n! save intrec%nextlink and jump to higher level\r\n intsave=intsave+1\r\n intstack(intsave)%current=>intrec%nextlink\r\n intrec=>intrec%highlink\r\n nofr=nofr+1\r\n fracs(nofr)=intrec%fraclink(1)\r\n else\r\n! check the nextlink, pop saved if empty\r\n intrec=>intrec%nextlink\r\n pop: do while(.not.associated(intrec))\r\n write(*,*)'3XQ pop stack'\r\n if(intsave.gt.0) then\r\n intrec=>intstack(intsave)%current\r\n intsave=intsave-1\r\n nofr=nofr-1\r\n else\r\n exit intloop\r\n endif\r\n enddo pop\r\n cycle intloop\r\n endif\r\n! if we come here there are no more interaction records for this endmember\r\n enddo intloop\r\n!\r\n! write(*,*)'3XQ next endmember'\r\n endmemrec=>endmemrec%nextem\r\n!\r\n enddo emloop\r\n write(*,*)'No more parameters'\r\n1000 continue\r\n return\r\n end subroutine listpartree\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!addtotable subroutine toop_ternary\r\n!\\begin(verbatim} subroutine toop_ternary\r\n subroutine toop_ternary(text,toop)\r\n! subroutine to detect a Toop cation, if toop=0 there is no Toop element\r\n character text*(*)\r\n integer toop\r\n!\\end{verbatim}\r\n character*1 toopindex\r\n integer ipos\r\n! this returns a number 1, 2 or 3 after the first T in text\r\n! No test if there are several Toop elemenets (with same or another number)\r\n ipos=index(text,'T')\r\n if(ipos.le.0 .or. ipos.eq.len(text)) then\r\n toop=0\r\n else\r\n toop=ichar(text(ipos+1:ipos+1))\r\n if(toop.lt.1 .or. toop.gt.3) then\r\n! the letter after the T must be a digit 1, 2 or 3\r\n write(*,*)'3XQ warning, ternary asymmetry error: \"'//trim(text)//'\"'\r\n toop=0\r\n endif\r\n endif\r\n1000 continue\r\n return\r\n end subroutine toop_ternary\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n!addtotable subroutine varkappadefs\r\n!\\begin(verbatim} subroutine varkappadefs\r\n! subroutine varkappadefs(phres)\r\n subroutine varkappadefs(phres)\r\n! subroutine to list \\varkappa, \\xi and y_ik definitions\r\n type(gtp_phase_varres), pointer :: phres\r\n! type(gtp_phase_varres), pointer :: mqmqavar\r\n!\\end{verbatim}\r\n integer nv,cat1,cat2,i,j,k,ip,i0,jp\r\n! type(gtp_mqmqa_var), pointer :: mqf\r\n type(gtp_allinone), pointer :: box\r\n character*300 line1,line2,qline\r\n character*2, dimension(:), allocatable :: quadcat\r\n type(gtp_mqmqa_var), pointer :: mqf\r\n!\r\n mqf=>phres%mqmqaf\r\n! copied from pmon\r\n! write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat\r\n4124 format('Listing of quads and asymmetries using varkappadefs:'/&\r\n 'The ',i3,' quads for ',i2,' cations are arranged ',&\r\n 'in order of the n cations:'/&\r\n 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/&\r\n 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/&\r\n 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n')\r\n!\r\n! identify the actual cations in all quads as above\r\n! write(*,50)(i,i=1,mqmqa_data%nquad)\r\n! create the quadcat indices used for the vk_ij quad dependences \r\n allocate(quadcat(mqmqa_data%nquad))\r\n line1='Cat1:'\r\n ip=6\r\n i0=ichar('0')\r\n k=1\r\n! To fix problems here see around line 4100 about box%ivk_ij, %jvk_ji %kvk_ijk\r\n do i=1,mqmqa_data%ncat\r\n do j=i,mqmqa_data%ncat\r\n line1(ip:ip+2)=' '//char(i0+i)\r\n quadcat(k)(1:1)=char(i0+i)\r\n k=k+1\r\n ip=ip+3\r\n enddo\r\n ip=ip+1\r\n enddo\r\n51 format(a)\r\n line2='Cat2:'\r\n qline='Quad:'\r\n ip=6\r\n k=1\r\n i0=ichar('0')\r\n do i=1,mqmqa_data%ncat\r\n do j=i,mqmqa_data%ncat\r\n line2(ip:ip+2)=' '//char(i0+j)\r\n quadcat(k)(2:2)=char(i0+j)\r\n if(k.lt.10) then\r\n qline(ip:ip+2)=' '//char(i0+k)\r\n else\r\n qline(ip:ip+2)=' 1'//char(i0+k-10)\r\n endif\r\n ip=ip+3\r\n k=k+1\r\n enddo\r\n ip=ip+1\r\n enddo\r\n! nice output of quads and cation dependencies\r\n write(*,51)trim(qline)\r\n write(*,51)trim(line1)\r\n write(*,51)trim(line2)\r\n!\r\n! quadcat(k)(1:2) are the 2 cation indices (as characters) in quad k\r\n! ivk_ij, ivk_ji, kvk_ijk arrays of quad indices indices\r\n! vkloop: do nv=1,size(mqf%compvar)\r\n! box=>mqf%compvar(nv)\r\n! box%ivk_ij(1..n) are indices of quads to be added \r\n! write(*,100)'vk_ij',(box%ivk_ij(cat1),cat1=1,size(box%ivk_ij))\r\n! write(*,100)'vk_ji',(box%jvk_ji(cat1),cat1=1,size(box%jvk_ji))\r\n! write(*,100)'denom',(box%kvk_ijk(cat1),cat1=1,size(box%kvk_ijk))\r\n!100 format(a,10i3)\r\n! enddo vkloop\r\n write(*,99)size(mqf%compvar)\r\n99 format('3XQ some ternary asymmetries may still be wrong',i3)\r\n!\r\n vkloop2: do nv=1,size(mqf%compvar)\r\n! _ij\r\n box=>mqf%compvar(nv)\r\n write(*,103)nv,size(box%ivk_ij),size(box%jvk_ji),&\r\n size(box%all_ijk),size(box%kvk_ijk)\r\n103 format('Varkappa index: ',i3,', summing quads: ',4i4)\r\n line1='x_'//quadcat(box%ivk_ij(1))\r\n ip=len_trim(line1)+1\r\n k=2\r\n do while(k.le.size(box%ivk_ij))\r\n! write(*,*)'3XQ bug here?',k,size(box%ivk_ij),ip\r\n line1(ip:)='+x_'//quadcat(box%ivk_ij(k))\r\n k=k+1\r\n ip=ip+5\r\n enddo\r\n! To fix problems here see around line 4100 about box%ivk_ij, %jvk_ji %kvk_ijk\r\n write(*,105)' nomin: vk_'//char(i0+box%cat1)//char(i0+box%cat2)//&\r\n ' = '//trim(line1)\r\n! _ji\r\n line2='x_'//quadcat(box%jvk_ji(1))\r\n ip=len_trim(line2)+1\r\n k=2\r\n do while(k.le.size(box%jvk_ji))\r\n line2(ip:)='+x_'//quadcat(box%jvk_ji(k))\r\n k=k+1\r\n ip=ip+5\r\n enddo\r\n write(*,105)' nomin: vk_'//char(i0+box%cat2)//char(i0+box%cat1)//&\r\n ' = '//trim(line2)\r\n! _denom\r\n! NOTE some quad fractions appear twice!! should be removed\r\n qline=trim(line1)//'+'//trim(line2)//' +x_'//quadcat(box%kvk_ijk(1))\r\n ip=len_trim(qline)+1\r\n k=2\r\n do while(k.le.size(box%kvk_ijk))\r\n qline(ip:)='+x_'//quadcat(box%kvk_ijk(k))\r\n k=k+1\r\n ip=ip+5\r\n enddo\r\n write(*,105)' denom: = '//trim(qline)\r\n105 format(a)\r\n!\r\n! write(*,110)'vk_',box%cat1,box%cat2,quadcat(box%ivk_ij(1)),\r\n! ((quadcat(box%jvk_ji(cat1)),cat1=2,size(box%jvk_ji))\r\n! \r\n! write(*,110)'vk_',box%cat1,box%cat2,&\r\n! (quadcat(box%jvk_ji(cat1)),cat1=1,size(box%jvk_ji))\r\n! write(*,120)'denom = vk_ij+vk_ji + ',&\r\n! (quadcat(box%kvk_ijk(cat1)),cat1=1,size(box%kvk_ijk))\r\n!110 format(a,2i1,' = x_',a,'+'))\r\n!120 format(a,20('x_',a,'+'))\r\n enddo vkloop2\r\n1000 continue\r\n return\r\n end subroutine varkappadefs\r\n\r\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\r\n\r\n ! asymmetry code\r\n ! j is the Toop element in i-j-\\nu\r\n ! i is the Toop element in i-j-\\gamma\r\n !\r\n ! \\sum_a=(i,\\nu) \\sum_b=(i,\\nu) x_ab/kk ivk_ij\r\n ! vk_ij/kk = ------------------------------------------------------- = -------\r\n ! \\sum_a=(i,j,\\nu,\\gamma) \\sum_b=(i,j,\\nu,\\gamma) x_ab/kk denom_ij\r\n !\r\n ! \\sum_a=(j,\\gamma) \\sum_b=(j,\\gamma) x_ab/kk jvk_ji\r\n ! vk_ji/kk = ------------------------------------------------------- = ------\r\n ! \\sum_a=(i,j,\\nu,\\gamma) \\sum_b=(i,j,\\nu,\\gamma) x_ab/kk denom_ij\r\n !\r\n ! NOTE x_ij = x_ji and occures only once in sums !!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r\n ! ivk_ij = x_i,i + x_i,\\nu + x_\\nu,\\nu\r\n ! jvk_ji = x_j,j + x_j,\\gamma + x_\\gamma,\\gamma\r\n ! denom = x_i,j + x_i,\\nu+x_j,\\gamma+x_\\nu,\\nu+x_\\nu,\\gamma+x_gamma,gamma\r\n !\r\n ! initiate: ivk_ij=[x_ii]; jvk_ji=[x_jj]; denom=[x_ij]\r\n !\r\n ! extradenom=[ ]\r\n ! binary loop vk: do i-j\r\n ! ternary loop: do g=1,n ------------------ g can be \\nu, \\gamma or both\r\n ! if(g=i or g=j) cycle ternary loop\r\n ! if(i is Toop in i-j-g) then ...............g is \\gamma\r\n ! jvk_ij=[ jvk_ij , x_gg, x_jg ]\r\n ! denom will at the end have jvk_ji and ivk_ij added. Add only x_ig\r\n ! denom_ij = [ denom_ij, x_ig]\r\n ! if(j is Toop in i-j-g) then ..............g is both \\nu and \\gamma\r\n ! ivj_ji=[ ivk_ij, x_gg, x_ig, x_jg ]\r\n ! endif\r\n ! there can have been previous \\gamma or \\nu, add extra x_\\gamma,\\nu\r\n ! do h=1,size(extradenom)\r\n ! denom_ij = [ denom_ij, x_gh ]\r\n ! enddo\r\n ! extradenom = [extradenom, g ]\r\n !-----------\r\n ! elseif(j is Toop in i-j-g) then ...........g is \\nu\r\n ! ivj_ji= [ ivk_ij, x_gg, x_jg ]\r\n ! denom_ij = [ denom_ij, x_gg, x_jg, x_ig ]\r\n ! endif\r\n ! enddo ternary loop\r\n ! enddo binary loop\r\n" }, { "path": "src/models/gtp3Y.F90", "content": "!\n! gtp3Y included in gtp3.F90\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 16. Section: grid minimizer\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine global_gridmin\n!\\begin{verbatim}\n subroutine global_gridmin(what,tp,xknown,nvsph,iphl,icsl,aphl,&\n nyphl,cmu,ceq)\n!\n! Starting rewriting 2017-02-01\n!\n! finds a set of phasey cons that is a global start point for an equilibrium \n! calculation at T and P values in tp and known mole fraction in xknown\n! It is intentional that this routine is independent of current conditions\n! It returns: nvsph stable phases, list of phases in iphl, amounts in aphl, \n! nyphl(i) is redundant, cmu are element chemical potentials of solution\n! WHAT determine what to do with the results, 0=just return solution,\n! 1=enter stable set and constitution of all phases in gtp datastructure\n! and create composition sets if necessary (and allowed)\n! what=-1 will check if any gridpoint is below current calculated equilibrium\n! ?? removed what -1 170428/BoS\n implicit none\n! nyphl(j) is the start position of the constitiuent fractions of phase j in\n integer, dimension(*) :: iphl,nyphl,icsl\n integer what,nvsph\n\n TYPE(gtp_equilibrium_data), pointer :: ceq\n double precision, dimension(2) :: tp\n! cmu(1..nrel) is the chemical potentials of the solution\n double precision, dimension(*) :: xknown,aphl,cmu\n!\\end{verbatim}\n! yarr is used for fractions in the call to generate_grid\n double precision, dimension(maxconst) :: yarr\n integer, parameter :: maxgrid=400000,maxy=2000,maxph=500\n integer :: starttid,endoftime\n real finish2\n! removed yphl as argument as it not needed outside global_gridmin\n! dimensioning can be problematic if many phases with many constituents as it\n! contains all constituent fractions of all gridpoints (before merge)\n! double precision, dimension(10* amounts of maxconst) :: yphl\n double precision, dimension(10*maxconst) :: yphl\n double precision amount,sum,gmax\n integer ibias,ics,ics2,icsno,icsx,ie,iph,iv,j1,j2,jp,kkz,kp,kph,jbias\n integer lokcs,lokph,mode,ng,nocsets,noofgridpoints,nr,nrel,nrph,ny,nyz\n integer preveq\n! nphl(iph) is last gridpoint that belongs to phase iph, nphl(0)=0\n! xarr(nrel,i) is the composition of gridpoint i\n! garr(i) is the Gibbs energy of gridpoint i\n! jgrid(j) is a gridpoint in the solution\n! phfrac(j) is the amount of the phase of that gridpoint\n! ngrid deleted\n integer, dimension(0:maxph) :: nphl\n integer, dimension(maxel) :: jgrid\n real garr(maxgrid),starting,finished\n real, dimension (:,:), allocatable :: xarr\n real, dimension (maxel,maxel) :: xsol\n double precision, dimension(maxel) :: phfrac,phsave,xdum\n double precision qq(5),savetp(2),xbase,totam\n integer, dimension(maxph) :: iphx\n character name1*24\n! integer idum(*)\n! debug\n logical trace,toomany\n! sort phases depending on number of gridpoints\n integer, dimension(:), allocatable :: gridpoints,phord,starttup\n! pph is set to number of phases participating, some may be suspended\n integer pph,zph,nystph,order(maxel),tbase,qbase,wbase,jj,zz,errall,eecliq\n!\n! write(*,*)'3Y in global_gridmin'\n! nystph=0\n if(btest(globaldata%status,GSNOGLOB)) then\n write(*,*)'3Y Grid minimization not allowed'\n gx%bmperr=4173; goto 1000\n endif\n call cpu_time(starting)\n call system_clock(count=starttid)\n nphl=0\n! Trace turn on output of grid on a file ocgrid.dat\n! trace=.true.\n toomany=.false.\n trace=.FALSE.\n! trace=.TRUE.\n if(trace) write(*,*)'3Y Trace set TRUE'\n savetp=ceq%tpval\n ceq%tpval=tp\n nrph=noph()\n if(nrph.gt.maxph) then\n! too many phases\n write(*,*)'3Y Too many phases for gridmin'\n gx%bmperr=4344; goto 1000\n endif\n nrel=noel()\n sum=zero\n! problem that extract_massbalcond did not object to condition x(fcc,a)=\n do ie=1,nrel\n if(xknown(ie).le.zero .or. xknown(ie).ge.one) then\n if(.not.btest(globaldata%status,GSNOTELCOMP)) then\n write(*,*)'3Y Gridmin cannot handle these composition conditions'\n gx%bmperr=4174; goto 1000\n else\n! we have other components than elements, fractions can be negative and >1\n write(kou,10)\n10 format('3Y Trying to use gridmininmizer whith other components',&\n ' than the elements'/' Can give warnings and error messages')\n gx%bmperr=4174; goto 1000\n endif\n endif\n sum=sum+xknown(ie)\n enddo\n if(ocv()) write(*,12)'3Y gridmin: ',sum,(xknown(ie),ie=1,nrel)\n12 format(a,1pe12.4,10(f8.4))\n if(abs(sum-one).gt.1.0D-8) then\n write(*,*)'3Y Sum of fractions not unity when calling global_gridmin'\n gx%bmperr=4174; goto 1000\n endif\n kp=1\n pph=0\n! write(*,*)'3Y allocating gridpoints 1',nrph\n allocate(gridpoints(nrph),stat=errall)\n allocate(phord(nrph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 1: ',errall\n gx%bmperr=4370; goto 1100\n endif\n eecliq=0\n if(globaldata%sysreal(1).gt.one) then\n! we must initiate EEC data for the liquid\n sliqmin=zero; sliqmax=zero; gliqeec=zero\n endif\n! write(*,*)'3Y loop for all phases',nrph,globaldata%sysreal(1)\n ggloop: do iph=1,nrph\n! include all phases with any composition set entered (but only once!)\n! EXCLUDE the MQMQA phase\n if(test_phase_status_bit(iph,PHMQMQA)) then\n write(*,*)'3Y The MQMQA phase excluded from gridminimizer'\n cycle ggloop\n endif\n do ics=1,noofcs(iph)\n! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed\n! ignore phases whith no entered composition sets\n! If a phase+compset FIX one should never be here as conditions wrong\n if(test_phase_status(iph,ics,amount,ceq).gt.PHDORM) then\n pph=pph+1\n iphx(pph)=iph\n if(eecliq.eq.0 .and. globaldata%sysreal(1).gt.one) then\n! write(*,*)'3Y looking for liquid: ',pph,iph\n if(btest(phlista(iph)%status1,PHLIQ)) then\n eecliq=phlista(iph)%alphaindex\n endif\n endif\n cycle ggloop\n endif\n enddo\n enddo ggloop\n!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n! if lutbug>0 open a file for grid graphics\n!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n! lutbug=37\n! There is some other gridoutput associated with trace\n if(lutbug.gt.0) then\n write(*,*)'3Y Opening gridmap.dat'\n open(lutbug,file='gridmap.dat',access='sequential',status='unknown')\n endif\n! we will generate a grid for pph phases, the phase index for phase 1..pph\n! is in iphx(1..pph)\n! always allocate a grid for maxgrid points\n! write(*,*)'3Y allocating gridpoints 2',nrel,maxgrid\n allocate(xarr(nrel,maxgrid),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 2: ',errall\n gx%bmperr=4370; goto 1000\n endif\n gmax=zero\n! write(*,11)'3Y gp1:',pph,(iphx(iph),iph=1,pph)\n! just to be sure\n nphl(0)=0\n!\n!------------------------------------------------------\n! For EEC we must always calculate the liquid phase first\n! it means its grid will be calculated twice because I do not want to change\n eec: if(eecliq.gt.0) then\n! if eecliq=1 the liquid is first and this is not needed\n! ng should be set to number of remaining points, ny and yphl is not used\n iv=1\n ng=maxgrid\n! possible output on gridmap.dat\n! if(lutbug.gt.0) then\n! lokph=phases(iphx(zph))\n! write(lutbug,16)trim(phlista(lokph)%name),zph,lokph,ng\n!16 format(/'Phase: ',a,3i7)\n! endif\n! write(*,*)'3Y calculate EEC data for liquid',eecliq,iphx(eecliq),iv,ng\n if(btest(globaldata%status,GSOGRID)) then\n! The possibility to use the old grid tested\n call generate_grid(0,eecliq,ng,nrel,&\n xarr(1,iv),garr(iv),ny,yarr,gmax,ceq)\n else\n call generic_grid_generator(0,eecliq,ng,nrel,&\n xarr(1,iv),garr(iv),ny,yarr,gmax,ceq)\n endif\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y grid error ',eecliq,gx%bmperr\n exit eec\n endif\n! write(*,*)'3Y sliqmax: ',sliqmax\n elseif(globaldata%sysreal(1).gt.one) then\n write(*,*)'3Y EEC will not work because there is no liquid'\n endif eec\n!\n!----------------------------------------------------------\n phloop: do zph=1,pph\n! for phase iphx(zph) the gridpoints will be stored from position nphl(zph-1)+1\n! ng should be set to number of remaining points, ny and yphl is not used\n iv=nphl(zph-1)+1\n ng=maxgrid-iv\n! write(*,*)'3Y generating grid for phase ',zph\n! possible output on gridmap.dat\n if(lutbug.gt.0) then\n lokph=phases(iphx(zph))\n write(lutbug,16)trim(phlista(lokph)%name),zph,lokph,ng\n16 format(/'Phase: ',a,3i7)\n endif\n! write(*,*)'3Y gridgen ',zph,iv,ng\n! this call will calculate gridpoints in phase zph, that may take time ...\n! ng is set to remaining dimension of garr, on return the number of generated\n! gridpoints, returned as xarr composition of these and\n! ny and yarr not used here\n!>>>>>>> important: changes here must be made also in global_equil_check\n! write(*,*)'3Y grid for phase:',zph,phlista(phases(iphx(zph)))%name,&\n! btest(globaldata%status,GSOGRID)\n if(btest(globaldata%status,GSOGRID)) then\n! The possibility to use the old grid tested\n call generate_grid(0,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),&\n ny,yarr,gmax,ceq)\n else\n! write(*,*)'3Y calling generic',iphx(zph),ng\n call generic_grid_generator(0,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),&\n ny,yarr,gmax,ceq)\n endif\n!>>>>>>>> impportant end!\n! write(*,*)'3Y grid done'\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y grid error ',iphx(zph),gx%bmperr\n exit phloop\n endif\n! nphl(zph) is last gridpoint in phase zph\n nphl(zph)=nphl(zph-1)+ng\n! write(*,*)'3Y gridpoint range for ',iphx(zph),nphl(zph-1)+1,nphl(zph)\n enddo phloop\n!----------------------------------------------------------\n! if lutbug>0 close it\n if(lutbug.gt.0) then\n close(lutbug)\n write(*,*)'3Y closed gridmap.dat with gridpoints'\n endif\n!++ write(*,11)'3Y gp2:',(nphl(iph),iph=1,nrph)\n11 format(a,10i7/(7x,10i7))\n if(gx%bmperr.ne.0) goto 1000\n! We should add the current set of stable phases in the grid if we have made\n! a successful calculation\n! if(.not.btest(ceq%status,EQNOEQCAL)) then\n! add the current set of stable phases and their constitution as gridpoints\n! write(*,*)'3Y Not yet adding current stable phases as gridpoints',&\n! what\n preveq=0\n! endif\n! we may be generating a list with all gridpoints ...\n if(trace) then\n write(*,*)'3Y Closing gridgen.dat'\n close(33)\n endif\n call system_clock(count=endoftime)\n call cpu_time(finished)\n! kp set to total number of grispoints in all phases\n kp=nphl(pph)\n noofgridpoints=kp\n! If WHAT is -1 then just compare all gridpoints with plane defined by\n! the chemical potentials cmu to see if any is below.\n! If so insert the gridpoint furtherst below the plane and set WHAT 10*iph+ics\n! write(*,*)'3Y global_gridmin what: ',what\n if(what.eq.-1) then\n write(*,*)'3Y Calling global_grimin with -1 no longer supported'\n stop\n goto 1000\n endif\n!-----------------------------------------------\n! write(*,109)ngrid(pph),finished-starting,endoftime-starttid\n109 format('3Y Gridmin Calculated ',i6,' gridpoints in ',1pe12.4,' seconds, ',&\n i7,' clockcycles')\n! find the minimum of nrel gridpoints among the kp-1 gridpoint\n! for current overall composition, xknown\n! write(*,*)'3Y globm 4: ',kp,garr(kp),xarr(1,kp)\n! phfrac=zero\n! start with all elements having chemical potential equal to gmax\n cmu(1)=gmax\n if(ocv()) write(*,*)'3Y Finding the gridpoints for the minimum: ',kp\n! write(*,*)'3Y Finding the gridpoints for the minimum: ',kp\n call find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace)\n if(gx%bmperr.ne.0) goto 1000\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n! write(*,*)'3Y total gridpoints: ',kp\n! gx%bmperr=4399; goto 1000\n! The solution with nrel gridpoints are in jgrid, the amount of each in phfrac\n! We later want the phases in ascending order and as the gridpoints are\n! in ascending order of the phases we sort the gridpoints (and amounts)\n! There must be one gridpoint per component (element)\n! write(*,62)(jgrid(jp),jp=1,nrel)\n62 format('3Y Gridp: ',10i6)\n call sortin(jgrid,nrel,order)\n do nyz=1,nrel\n phsave(nyz)=phfrac(order(nyz))\n enddo\n phfrac=phsave\n! get the phase and constitution for each\n nyz=1\n! Extracting constititution of the gridpoints in the solution\n if(trace) then\n write(31,745)\n745 format(/'Solution: ')\n endif\n do jp=1,nrel\n iphl(jp)=0\n enddo\n solloop: do jp=1,nrel\n! jgrid(jp) is a grid point in the solution, find which phase it is\n! and its constituent fractions\n mode=jgrid(jp)\n713 continue\n do zph=1,pph\n! write(*,*)'3Y mode and ibias 1: ',mode,ibias\n! nphl(zph) is the last gridpoint of phase zph, nphl(0) is 0\n if(mode.le.nphl(zph)) then\n mode=mode-nphl(zph-1)\n ibias=nphl(zph-1)\n goto 315\n else\n endif\n enddo\n! nphl(pph) is number of generated gridpoints\n if(mode-nphl(pph).le.preveq) then\n! gridpoint outside generated gridpoints, should be from previous solution\n write(*,*)'3Y previous stable phase included in solution',mode,preveq\n endif\n! gridpoint outside range should never occur\n write(*,*)'3Y gridpoint outside range ',jgrid(jp),nphl(pph)\n! It means element je=jgrid(jp)-nphl(pph) has no chemical potential\n! and possibly no composition. Find the gripoint with max of with this \n! component and add a small amont if it to avoid that an element has \n! no phase in which is can dissolve ...\n qbase=jgrid(jp)-nphl(pph)\n xbase=zero\n wbase=0\n do tbase=1,nphl(pph)\n if(xarr(qbase,tbase).gt.xbase) wbase=tbase\n enddo\n if(wbase.eq.0) then\n! we have failed to find a gridpoint with this element\n gx%bmperr=4147; goto 1000\n else\n write(*,*)'3Y using point: ',wbase\n phfrac(jp)=1.0D-4\n mode=wbase\n goto 713\n endif\n315 continue\n jbias=ibias\n! this call is to obtain the constitution of a phase in the solution\n! mode gives in grid point index in phase iphx(zph), ibias irrelevant (?)\n! NOTE jbias is changed by subroutine ??\n! ny is number of constituent fractions, yarr have the constituent fractions\n! write(*,317)'3Y point: ',mode,jp,iphl(jp),(iphl(nr),nr=1,jp)\n if(btest(globaldata%status,GSOGRID)) then\n! The possibility to use the old grid tested\n call generate_grid(mode,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),&\n ny,yarr,gmax,ceq)\n else\n! write(*,*)'3Y phase, jbias: ',iphx(zph),jbias\n call generic_grid_generator(mode,iphx(zph),jbias,nrel,xarr,garr,&\n ny,yarr,gmax,ceq)\n endif\n if(gx%bmperr.ne.0) goto 1000\n! write(*,317)'3Y after0: ',mode,jp,nyz,ibias,jbias,iphl(jp),&\n! (iphl(nr),nr=1,jp)\n iphl(jp)=iphx(zph)\n aphl(jp)=phfrac(jp)\n nyphl(jp)=ny\n! copy the constitution of all gridpoints to yphl, needed for possible merge\n do ie=1,ny\n yphl(nyz+ie-1)=yarr(ie)\n enddo\n nyz=nyz+ny\n! write(*,317)'3Y after1: ',mode,jp,nyz,ibias,jbias,iphl(jp),&\n! (iphl(nr),nr=1,jp)\n317 format(a,i6,4i4,i3,20i3)\n! finally copy the mole fractions to xsol, needed for possible merging\n do ie=1,nrel\n xsol(ie,jp)=xarr(ie,mode+ibias)\n enddo\n if(trace) then\n write(31,750)jp,jgrid(jp),iphl(jp),aphl(jp),(xsol(ie,jp),ie=1,nrel)\n write(31,760)(yphl(ie),ie=nyz-ny,nyz-1)\n750 format('Point: ',i2,', gridpoint: ',i5,' phase ',i3,&\n ' amount: ',1pe12.4,', Mole fractions:'/9(0pF8.5))\n760 format('Constitution:'/9(0pF8.5))\n endif\n enddo solloop\n! we have now start values from the gridminimizer\n if(trace) then\n write(*,*)'3Y Closing ocgrid.dat file'\n close(31)\n endif\n! there must be as many gridpoints (phases) as there are elements\n nvsph=nrel\n nr=nrel\n! write(*,*)'3Y merge in global?',btest(globaldata%status,GSNOMERGE)\n if(.not.btest(globaldata%status,GSNOMERGE)) then\n! For the moment we will only merge grid points in the gas phase\n call merge_gridpoints(nr,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n!-------------------------------------------\n! number of gridpoints, nr, may have changed\n! write(*,*)'3Y After merge_gripoints: ',nr,nvsph\n nvsph=nr\n! if what=-1 or 0 do nothing more, just exit\n if(what.le.0) goto 1000\n!------------------------------------------------------------\n! prepare for storing result in the ceq data structure\n! zero all phase amounts and driving forces\n do iph=1,nrph\n lokph=phases(iph)\n! lokcs=phlista(lokph)%cslink\n do ics=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ics)\n ceq%phase_varres(lokcs)%dgm=zero\n ceq%phase_varres(lokcs)%amfu=zero\n ceq%phase_varres(lokcs)%netcharge=zero\n if(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then\n! reset status of \"entered and stable\" to just \"entered\" \n ceq%phase_varres(lokcs)%phstate=phentered\n endif\n enddo\n enddo\n! store chemical potentials multiplied with RT if what not -1\n ceq%rtn=globaldata%rgas*ceq%tpval(1)\n do ie=1,nrel\n! write(*,*)'3Y grid chemical potential: ',ie,cmu(ie)*ceq%rtn\n! do not care about reference state for chempot(2)\n ceq%complist(ie)%chempot(1)=cmu(ie)*ceq%rtn\n ceq%complist(ie)%chempot(2)=cmu(ie)*ceq%rtn\n enddo\n! set driving force 0 for stable phases\n do ie=1,nvsph\n call set_driving_force(iphl(ie),1,zero,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n! store the most favourable constitution of the metastable phase\n! write(*,29)'3Y set constitution of metastable phases',pph,(iphx(ie),ie=1,pph)\n! write(*,29)'3Y gps: ',(nphl(ie),ie=0,pph)\n29 format(a,(20i5))\n call set_metastable_constitutions2(pph,nrel,nphl,iphx,xarr,garr,&\n nvsph,iphl,cmu,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y Constitution of metastable phases set'\n! maybe more composition sets needed\n do ie=1,nvsph\n icsl(ie)=0\n enddo\n nocsets=0\n! write(*,*)'3Y before loop1: ',nvsph,ceq%eqname\n! loop for all gripoints to store them in composition sets\n loop1: do j1=1,nvsph\n if(icsl(j1).eq.0) then\n! if non-zero a composition set has already been assigned in loop2\n icsl(j1)=1\n icsx=1\n loop2: do j2=j1+1,nvsph\n nextgridp: if(iphl(j1).eq.iphl(j2)) then\n! one more composition set needed, does it exist?\n icsx=icsx+1\n ics2=icsx\n! write(*,31)'3Y compset needed for phase ',j1,j2,iphl(j1),ics2\n31 format(a,10i4)\n call get_phase_compset(iphl(j1),ics2,lokph,lokcs)\n newset: if(gx%bmperr.ne.0) then\n! there is no such composition set, is automatic creation allowed?\n! NOTE: there is a EQNOACS bit also???\n if(btest(globaldata%status,GSNOACS) .or. &\n btest(ceq%status,EQNOACS)) then\n write(*,*)'3Y Not allowed to create composition sets'\n gx%bmperr=4177; goto 1000\n endif\n gx%bmperr=0\n! >>>>>>>>>>>>>>>>>>><\n! BEWARE >>> not only must this be done in all threads at the same time\n! one must also avoid that it is done when some thread is working on a set\n! of phase+composition sets transformed to EQCALC arrays. If so the\n! indices to lokcs etc will be incorrect ... ???\n! I think OMP has \"secure\" points where the treads can be stopped to wait\n! <<<<<<<<<<<<<<<<<<<<<<\n kph=iphl(j1)\n! write(*,*)'3Y extra composition set for phase: ',kph,j1,j2\n! It must be done in all equilibrium records, no equilibrium record needed!!!\n! one must be careful with the status word when creating comp.sets\n call enter_composition_set(kph,' ','AUTO',icsno)\n if(gx%bmperr.ne.0) then\n! write(*,*)'3Y Error entering composition set ',j1,gx%bmperr\n if(gx%bmperr.eq.4092) then\n! skip entering this set, it may work anyway ...\n if(.not.toomany) then\n write(kou,298)iphl(j1)\n298 format('Cannot enter enough composition sets',&\n ' for phase',i4,' but gridmin struggles on')\n toomany=.true.\n endif\n gx%bmperr=0\n! to avoid later trouble we should mark there is no compset for this gridp!!\n iphl(j2)=-kph\n icsl(j2)=-1\n cycle loop2\n else\n goto 1000\n endif\n endif\n call get_phase_compset(kph,icsno,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSAUTO)\n nocsets=nocsets+1\n icsl(j2)=icsno\n else\n! here we should check which composition set that should have which \n! constitution for example one fcc is metallic and another is cubic carbide\n call get_phase_name(iphl(j1),ics2,name1)\n icsl(j2)=ics2\n! check if the composition set is fix (2), dormant (2) or suspended (3)\n kkz=test_phase_status(iphl(j1),ics2,amount,ceq)\n! old kkz=2 means fix\n if(kkz.eq.PHFIXED) then\n write(*,*)'3Y Global minimization with fix phase!'\n gx%bmperr=4346; goto 1000\n elseif(kkz.lt.PHENTUNST) then\n write(*,*)'3Y Changing status for phase ',name1\n endif\n! this means status entered and unknown state. PHSTATE\n ceq%phase_varres(lokcs)%phstate=0\n endif newset\n endif nextgridp\n enddo loop2\n endif\n enddo loop1\n if(nocsets.gt.0) then\n if(.not.btest(globaldata%status,GSSILENT)) then\n write(*,*)'3Y Composition set(s) created: ',nocsets\n endif\n endif\n! Above one should consider if some user created compsets are dedicated to\n! certain cases (MC carbides or L1_2 ordered). These should have\n! a default constitution and CSDEFCON set)\n! finally store stable phase amounts and constitutions into ceq%phase_varres\n j1=1\n! write(*,*)'3Y allocating startup 3',nvsph\n allocate(starttup(nvsph),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 3: ',errall\n gx%bmperr=4370; goto 1000\n endif\n call extract_massbalcond(ceq%tpval,xdum,totam,ceq)\n if(gx%bmperr.ne.0) goto 1000\n sum=zero\n do iph=1,nvsph\n sum=sum+aphl(iph)\n enddo\n gmax=zero\n! write(*,*)'3Y no segmentation fault 1'\n! If there is a gas nvsph may be less than number of elements\n ceqstore: do iph=1,nvsph\n! write(*,*)'3Y no segmentation fault 2',iph\n if(iphl(iph).lt.0) then\n! this gripoint has no composition set because too many gridpoints in same phase\n starttup(iph)=0\n continue\n! write(*,*)'3Y no segmentation fault 3',iph\n else\n! write(*,*)'3Y segmentation fault 5',iph,iphl(iph),icsl(iph),j1\n call set_constitution(iphl(iph),icsl(iph),yphl(j1),qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y no segmentation fault 6',lokph,lokcs\n call get_phase_compset(iphl(iph),icsl(iph),lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y no segmentation fault 7'\n! This is a bit quiestionable but seems to work\n amount=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1)\n gmax=gmax+amount\n aphl(iph)=amount\n1789 format(a,2i4,5(1pe12.4))\n! write(*,*)'3Y no segmentation fault 8',lokcs,iph\n ceq%phase_varres(lokcs)%amfu=aphl(iph)\n ceq%phase_varres(lokcs)%phstate=PHENTSTAB\n starttup(iph)=ceq%phase_varres(lokcs)%phtupx\n j1=j1+nyphl(iph)\n endif\n! write(*,*)'3Y no segmentation fault 9',iph,nvsph\n enddo ceqstore\n!-----------------------------------------------------------------------\n! debug listing of tuples at gridpoints\n! write(*,*)'3Y no segmentation fault 10'\n! write(*,1411)(starttup(iph),iph=1,nvsph)\n!1411 format('3Y tupl:',18i4)\n!-----------------------------------------------------------------------\n! iv is total number of constituent fractions\n iv=j1\n! For safty, if any iphl is negative shift all values down for all gridpoints\n! I do not think yphl is used any more but ...\n j1=1\n iph=1\n870 continue\n if(iphl(iph).lt.0) then\n880 format(a,(20i4))\n do kph=iph,nvsph-1\n iphl(kph)=iphl(kph+1)\n icsl(kph)=icsl(kph+1)\n aphl(kph)=aphl(kph+1)\n kkz=nyphl(kph)\n nyphl(kph)=nyphl(kph+1)\n enddo\n iphl(nvsph)=-9\n! write(*,880)'3Y After: ',(iphl(j2),j2=1,nvsph)\n if(kph.lt.nvsph) then\n do j2=j1,iv\n yphl(j2)=yphl(j2+kkz)\n enddo\n iv=iv-kkz\n endif\n! we shifted all down, fewer gridpoints and do not increment iph below\n iph=iph-1\n nvsph=nvsph-1\n endif\n j1=j1+nyphl(iph)\n iph=iph+1\n if(iph.le.nvsph) goto 870\n!---------------------------------------\n! write(*,*)'3Y gridpoints: ',nvsph,iph\n1000 continue\n! write(*,*)'3Y no segmentation fault 20'\n! write(*,*)'3Y at 1000: ',phlista(1)%noofcs\n! restore tpval in ceq\n ceq%tpval=savetp\n call cpu_time(finish2)\n if(allocated(xarr)) deallocate(xarr)\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n! calling gridmin with what=-1 no longer supported\n! elseif(what.eq.-1) then\n! if(nystph.gt.0) what=nystph\n elseif(.not.btest(globaldata%status,GSSILENT)) then\n write(*,1010)noofgridpoints,finish2-starting,&\n endoftime-starttid,ceq%tpval(1)\n1010 format('Gridmin: ',i7,' points ',1pe10.2,' s and ',&\n i7,' clockcycles, T=',0pF8.2)\n! set the global bit that this is not a full equilibrium\n ceq%status=ibset(ceq%status,EQGRIDCAL)\n endif\n! deallocate \n if(allocated(gridpoints)) then\n deallocate(gridpoints)\n deallocate(phord)\n endif\n1100 continue\n if(ocv()) write(*,*)'3Y leaving global_gridmin'\n write(*,*)'3Y leaving global_gridmin'\n return\n end subroutine global_gridmin\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine generate_grid\n!\\begin{verbatim}\n subroutine generate_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! Different action depending of the value of mode, \n! for mode<0: (will no longer be used ... )\n! return the number of gridpoints that will be generated for phase iph in ngg\n! for mode=0:\n! on entry ngg is dimension of garr\n! on exit ngg is number of generated gridpoints ...\n! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i\n! for mode>0:\n! return site fractions of gridpoint mode in yarr, number of fractions in ny\n! iph is phase number, ngg is number of gridpoints, nrel number of elements,\n! if mode=0:\n! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints,\n! ngg is dimension of garr, gmax maximum G (start value for chem.pot)\n! if mode>0:\n! \"mode\" is a gridpoint of this phase in solution, return number of \n! constituent fractions in ny and fractions in yarr for this gridpoint\n! The current constitution is restored at the end of the subroutine\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n!\\end{verbatim} %+\n!\n! integer idum(*)\n integer lokph,errsave\n double precision, parameter :: yzero=1.0D-12\n integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend,nsl\n! used to save and restore constituent fractions\n double precision ydum(maxconst)\n integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy\n double precision, dimension(:), allocatable :: yfra\n double precision sites(maxsubl),qq(5)\n! endm(i,j) has constituent indices in i=1..nsl for endmember j \n integer, dimension(:,:), allocatable :: endm\n integer maxdim\n!--------------------------------\n! grid is generated by combining end endmembers\n! Number of endmemers is N\n! For endmember E=1..N set fraction of enmember \n! 0.99*Y_E + 0.01*Y_all N of these\n! 0.89*Y_E + 0.10*Y_F,F=/=E + 0.01*Y_all N*(N-1)\n! 0.74*Y_E + 0.25*Y_F,F=/=E + 0.01*Y_all N*(N-1)+N*(N-1)*(N-2)\n! + 0.15*Y_F + 0.1*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb)\n! 0.61*Y_E + 0.38*Y_F,F=/=E + 0.01*Y_all\n! + 0.25*Y_F + 0.13*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb)\n! added:\n! 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!----- N=2: total 2+2+2+2=8\n!----- N>2: total N*(1+(N-1)*(3+2*(N-2))); N=3:33, N=20:\n! with 2 endmembers: 2*(1+3)=2*4=8\n! (1.00,0.00)\n! (0.89,0.11) (0.74,0.26) (0.61,39)\n! (0.00,1.00) ...\n! with 3 endmembers: 3*11=33 gridpoints\n! (1.00,0.00,0.00) \n! (0.89,0.11,0.00)(0.89,0.00,0.11)\n! (0.74,0.26,0.00)(0.74,0.00.0.26)(0.74,0.15,0.11)(0.74,0.11,0.15)\n! (0.61,0.38,0.00)(0.61,0.00,0.38)(0.61,0.25,0.14)(0.61,0.14,0.25)\n! (0.00,1.00,0.00)\n! (0.11,0.89,0.00)(0.00,0.89.0.11)\n! with 4 endmembers: \n! (0.9925,0.0025,0.0025.0.0025)\n! (0.8925,0.1025,0.0025,0.0025) (-,0.0025,0.1025,-) (-,.0025,.0025,.1025) ...\n!---------\n! for n>50 only endmember: 51:51, N:N\n! for n=31-50 only one binary combination: \n! for n=26-30 only two binary combinations: \n! for n=2 and n=15-25 three binary cobinations: \n! for n=11-14 three binary and one ternary combination\n! for n<=10 use full grid: 2 binar and 2 ternar combinarions\n! NOTE for ybas=0.45 never add same endmember !!!\n double precision, dimension(5), parameter:: ybas=&\n [1.0D0,0.89D0,0.74D0,0.61D0,0.45D0]\n double precision, dimension(4), parameter :: ybin=&\n [0.11D0,0.26D0,0.39D0,0.15D0]\n double precision, dimension(3), parameter :: yter=[0.0D0,0.11D0,0.13D0]\n! added: not here ... just for the dense grid\n! double precision, dimension(2), parameter :: yqrt=[0.35D0,0.19D0]\n! for output of gridpoints\n integer jbas,sumngg,loksp,wrongngg,errall\n logical trace,isendmem\n save sumngg,wrongngg\n!\n! write(*,*)'Illegal call to generate_grid: ',mode\n! stop\n! if(mode.gt.0) write(*,*)'3Y entering generate_grid: ',mode,iph,ngg\n!---------------------------------------------------------\n! save current constitution in ydum\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1020\n!---------------------------------------------------------\n if(test_phase_status_bit(iph,PHEXCB)) then\n! This phase has charged endmembers, generate neutral gridpoints (also dense)\n call generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n goto 1000\n elseif(test_phase_status_bit(iph,PHIONLIQ)) then\n! This is the ionic liquid, requires a special grid, also used for dense\n! if(mode.gt.0) write(*,*)'3Y gridpoint in the liquid',mode\n call generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! if(mode.le.0) write(*,*)'3Y exit ionliq ',mode,ngg,ny\n if(mode.eq.-1) then\n wrongngg=ngg\n elseif(mode.eq.0) then\n! ionliq -1 makes a bad estimate of the number of gridpoints generated \n! give a warning if it may be too wrong ...\n if(ngg-wrongngg.gt.1000) then\n write(*,*)'3Y warning: ionic liquid gridpoints: ',ngg,wrongngg\n endif\n endif\n goto 1000\n elseif(test_phase_status_bit(iph,PHFORD) .or. &\n test_phase_status_bit(iph,PHBORD)) then\n! this phase has 4 sublattice fcc/hcp tetrahedral ordering,\n! this reduces the number of gridpoints UNFINISHED: NOT IMPLEMENTED YET\n! write(*,*)'3Y calling ordered grid 1'\n call generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! do not jump to 1000 until the fccord routine implemented correctly\n! write(*,*)'3Y back from fccord_grid 1, jump to 1000',ngg\n! This routine return gx%bmperr=-1 if if cannot handle the gridgenerating\n if(gx%bmperr.eq.-1) then\n gx%bmperr=0\n else\n goto 1000\n endif\n elseif((btest(globaldata%status,GSXGRID) .or. & \n test_phase_status_bit(iph,PHXGRID)) .and. &\n .not.test_phase_status_bit(iph,PHGAS)) then\n! Generate extra gridpoints for all phases or a special phase but never for gas\n call generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n goto 1000\n endif\n!\n! mode=0 means generate grid (-1 means estimate size of grid for allocation), \n! >0 means find constituent fractions for gridpoint in solution)\n!\n if(mode.eq.0) then\n! write(*,*)'3Y Generating grid for phase: ',iph\n! trace TRUE means generate outpt for each gridpoint\n! trace=.TRUE.\n trace=.FALSE.\n if(iph.eq.1 .and. trace) then\n! unit 33 is opened before calling this routine\n sumngg=0\n write(33,43)\n43 format('The constituent fractions, y, enclosed within parentheses',&\n 'for each sublattice'/'Mole fractions after x:, Gibbs energies',&\n ' after G:'/)\n endif\n if(trace) then\n call get_phase_record(iph,lokph)\n write(33,44)iph,phlista(lokph)%name\n44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a)\n endif\n else\n trace=.FALSE.\n endif\n!---------------------------------------------------------\n! calculate the number of endmembers and index of first constituent in subl ll\n nend=1\n inkl(0)=0\n do ll=1,nsl\n nend=nend*nkl(ll)\n inkl(ll)=inkl(ll-1)+nkl(ll)\n enddo\n! iliqneut=0\n! ionic liquids with neutrals ....\n! if(test_phase_status_bit(iph,PHIONLIQ)) then\n! loksp=0\n! do ny=nkl(1)+1,inkl(2)\n! loksp=knr(ny)\n! write(*,63)'3Y species: ',ny,knr(ny),loksp,&\n! splista(loksp)%charge,splista(loksp)%symbol\n63 format(a,3i4,F10.5,2x,a)\n! if(.not.btest(splista(loksp)%status,SPVA) .and. &\n! abs(splista(loksp)%charge).eq.zero) then\n! we have a neutral (vacancies has no mass), add an endmember for that\n! iliqneut=iliqneut+1\n! write(*,*)'3Y check for neutral: ',ny,iliqneut\n! endif\n! enddo\n! endif\n!\n ny=inkl(nsl)\n! write(*,1010)'3Y Saved ',iph,(ydum(i),i=1,ny)\n!\n! mode<0 means calculate size of arrays to allocate\n!\n negmode: if(mode.lt.0) then\n!---------------------------------------------------------\n! just determine the number of gridpoints for this phase for global minimimum\n! ideal gases should just have the endmembers ....\n ngg=nend\n lokph=phases(iph)\n if(nend.eq.1 .or. nend.gt.50 .or. &\n btest(phlista(lokph)%status1,PHID)) then\n! >50 or 1 endmember or ideal phase: only endmembers\n ngg=nend\n elseif(nend.gt.30) then\n! 31-50: only one binary combination\n ngg=nend*nend\n elseif(nend.gt.25) then\n! 26-30: two binary combinations\n ngg=nend*(1+2*(nend-1))\n elseif(nend.eq.2 .or. nend.ge.15) then\n! 2 or 15-25: three binary combinarions\n ngg=nend*(1+3*(nend-1))\n elseif(nend.gt.10) then\n! 11-14: three binary and one ternary combinarion \n! ngg=nend*(1+(nend-1)*(3+nend-2)) ! (ternary combination skipped)\n! ny=ngg\n ngg=nend*(1+3*(nend-1))\n! added yqrt\n! je=nend*(nend-1)*(nend-2)\n! write(*,*)'3Y endmemers, ngg and je: ',nend,ngg,je\n else\n! 3-10: three binary and two ternary combinarions (all)\n! and the added (quaternary) combinatin\n! ngg=nend*(1+(nend-1)*(3+2*(nend-2))) ! (ternary combinations skipped)\n! ny=ngg\n ngg=nend*(1+3*(nend-1))\n! added ygrt\n je=nend*(nend-1)*(nend-2)\n! write(*,*)'3Y endmemers, ngg and je: ',nend,ngg,je\n endif\n! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg\n! read(*,11)ch1\n11 format(a)\n! ngg=ngg+iliqneut\n! ngg=ngg\n if(ocv()) write(*,*)'3Y Generate grid: ',nend,ngg\n ny=nend\n goto 1001\n endif negmode\n!------------------------------------------------------------\n! for mode=0:\n! set gridpoint sitefractions and calculate G\n! for mode>0:\n! return sitefractions (for mode=gridpoint number (part of the solution))\n! BUT: The only way to find the site fraction of a gripoint is to generate\n! all gridpoints up the one specified by the value of mode (no G calculation)\n! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl)\n! if(mode.gt.0) then\n! write(*,*)'3Y looking for allocate error: ',nsl,nend,inkl(nsl)\n! endif\n! write(*,*)'3Y allocating endmem: ',nsl,nend,inkl(nsl)\n allocate(endm(nsl,nend),stat=errall)\n allocate(yfra(inkl(nsl)),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 4: ',errall\n gx%bmperr=4370; goto 1001\n endif\n nofy=inkl(nsl)\n! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll\n je=1\n do ll=1,nsl\n endm(ll,je)=inkl(ll-1)+1\n enddo\n100 continue\n je=je+1\n if(je.gt.nend) goto 120\n do ls=1,nsl\n endm(ls,je)=endm(ls,je-1)\n enddo\n ll=0\n110 ll=ll+1\n if(endm(ll,je).lt.inkl(ll)) then\n endm(ll,je)=endm(ll,je)+1\n elseif(ll.lt.nsl) then\n endm(ll,je)=inkl(ll-1)+1\n goto 110\n else\n gx%bmperr=4148; goto 1000\n endif\n goto 100\n120 continue\n! if(trace) then\n! do i=1,nend\n! write(33,125)i,(endm(ls,i),ls=1,nsl)\n!125 format('endmem: ',i4,2x,10i3)\n! enddo\n! endif\n150 continue\n!---------------------------------------\n! jump here from generate_fccord_grid ... not any more ...\n170 continue\n! now generate all combinations of endmembers\n! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg\n! read(*,11)ch1\n ngg=0\n lokph=phases(iph)\n endmem: do iend=1,nend\n yfra=yzero\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(1)\n enddo\n! write(*,180)'3Y yfra: ',1,iend,nkl(1),endm(1,iend),yfra(endm(1,iend))\n180 format(a,4i3,6(1pe16.7))\n isendmem=.TRUE.\n! initiate the loop variables below for endmembers and fractions\n ibas=2\n ibin=1\n iter=1\n jend=0\n kend=0\n200 continue\n ngg=ngg+1\n if(mode.gt.0) then\n! if ngg=mode we have found the gridpoint! store y and x and quit\n if(ngg.eq.mode) goto 500\n else\n! calculate G and composition and save\n! write(*,201)ibas,ngg,(yfra(is),is=1,inkl(nsl))\n201 format('3Y ggz: ',i2,i4,5(F10.6))\n if(ocv()) write(*,*)'3Y Calculating gridpoint: ',ngg\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Calculates gridpoint ',ngg,' for ',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! if(ngg.eq.15) then\n! write(*,520)'3Y cgx: ',(xarr(is,ngg),is=1,nrel)\n! endif\n if(trace) then\n if(isendmem) then\n write(33,153,advance='no')sumngg+ngg\n153 format('EM:',i4,' y: ')\n else\n write(33,154,advance='no')sumngg+ngg\n154 format('GP:',i4,' y: ')\n endif\n jbas=0\n do ls=1,nsl\n write(33,155,advance='no')(yfra(jbas+is),is=1,nkl(ls)-1)\n155 format('(',10(F4.2,','))\n write(33,156,advance='no')yfra(jbas+nkl(ls))\n156 format(F4.2,')')\n jbas=jbas+nkl(ls)\n enddo\n write(33,157,advance='no')(xarr(is,ngg),is=1,nrel)\n157 format(' x:',8(f8.5))\n write(33,158)garr(ngg)\n158 format(' G:',1pe12.4)\n endif\n isendmem=.FALSE.\n endif\n! depending on nend value or ideal generate combinations\n if(nend.eq.1 .or. nend.gt.50 .or. &\n btest(phlista(lokph)%status1,PHID)) cycle\n yfra=yzero\n combend: if(nend.gt.30) then\n! if nend=31..50, one binary combination, 961-2500\n! 0.89*Y_E + 0.11*Y_F,F=/=E\n jend=jend+1\n if(jend.eq.iend) jend=jend+1\n if(jend.gt.nend) cycle\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(ibas)\n yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin)\n enddo\n! write(*,180)'3Y yfra: ',ibas,iend,nkl(1),endm(1,jend),yfra(endm(1,jend))\n goto 200\n elseif(nend.gt.25) then\n! nend=26..30 two binary combinations, 1326-1770\n! 0.89*Y_E + 0.11*Y_F,F=/=E\n! 0.74*Y_E + 0.26*Y_F,F=/=E\n jend=jend+1\n if(jend.eq.iend) jend=jend+1\n if(jend.gt.nend) then\n if(ibas.eq.3) cycle\n jend=1\n ibas=3; ibin=2\n endif\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(ibas)\n yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin)\n enddo\n! write(*,180)'3Y yfra: ',ibas,jend,nkl(1),endm(1,jend),yfra(endm(1,jend))\n goto 200\n elseif(nend.eq.2 .or. nend.ge.15) then\n! nend=2 or nend=15..25, three binary combinations, ??-1825\n! 0.89*Y_E + 0.11*Y_F,F=/=E\n! 0.74*Y_E + 0.25*Y_F,F=/=E\n! 0.61*Y_E + 0.39*Y_F,F=/=E\n jend=jend+1\n if(jend.eq.iend) jend=jend+1\n if(jend.gt.nend) then\n if(ibas.eq.4) cycle\n ibas=ibas+1; ibin=ibin+1\n jend=1\n if(jend.eq.iend) jend=jend+1\n endif\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(ibas)\n yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin)\n enddo\n! write(*,180)'3Y yfra: ',ibas,jend,nkl(1),endm(1,jend),yfra(endm(1,jend))\n goto 200\n elseif(nend.gt.10) then\n! complicated here, iterating in both binary and ternary combinations ....\n! nend=11..14, 3 binary and one ternary combination, 1331-2744\n! 0.89*Y_E + 0.11*Y_F,F=/=E\n! 0.74*Y_E + 0.26*Y_F,F=/=E\n! + 0.15*Y_F + 0.11*Y_G,G=/=(E,F)\n! 0.61*Y_E + 0.39*Y_F,F=/=E\n if(iter.eq.2) then\n! we are interating in the ternary endmember\n stop 'no ternary for 100 return constitution for gridpoint number mode in yarr\n! iph is returned as phase index for gripoint mode\n! xarr(1..,nrel) the composition at the gripoint, garr not nused\n! ny is number of constituent fractions\n! yarr are the constituent fractions\n! gmax not used ??\n!\n implicit none\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! local loop variables etc\n integer ii,ij,ik,il,im,in,is,ie,iz,incl(0:maxsubl),maxng,ng,ncon\n integer nend,nendj,nendk,nendl,nendm\n integer ijs,iks,ils,ims,lokph,errall,disng,ngdis\n! these are for call of get_phase_data\n integer orddis1,orddis2,zz,nsl,nkl(maxsubl),knr(maxconst)\n double precision ydum(maxconst),sites(maxsubl),qq(5)\n! this is for generating endmembers\n integer, dimension(:,:), allocatable :: endm\n! these are for generating the constituion of gridpoint\n double precision, dimension(:,:), allocatable :: yendm\n double precision, dimension(:), allocatable :: yfra,ydis\n double precision aa\n integer :: warning1const=0\n character phname*24,ch1*1\n save warning1const\n! ----------------------------------------------------------------\n! these are the factors to generate gridpoints from endmember fractions\n double precision, dimension(5), parameter :: &\n! yf=[0.33D0,0.28D0,0.18D0,0.08D0,0.03D0]\n! yf=[0.33D0,0.28D0,0.18D0,0.08D0,0.03D0] to test with map3\n! ok yf=[0.33D0,0.28D0,0.18D0,0.14D0,0.11D0]\n! better but fails Fe-C at 1100 K and w(c)=0.03\n! yf=[0.11D0,0.33D0,0.14D0,0.28D0,0.18D0]\n! include a small factor\n! yf=[0.11D0,0.37D0,0.04D0,0.30D0,0.18D0]\n! Try to avoid several identical compositions, sum should be unity??\n yf=[0.07D0,0.28D0,0.16D0,0.45D0,0.04D0] ! used for 10 years ...\n! yf=[0.04D0,0.07D0,0.16D0,0.27D0,0.46D0] ! HEA OK, not map7\n! yf=[0.07D0,0.46D0,0.16D0,0.04D0,0.27D0]\n! yf=[0.28D0,0.07D0,0.45D0,0.16D0,0.04D0]\n! yf=[0.33D0,0.28D0,0.18D0,0.14D0,0.11D0] OK for fuel\n! yf=[0.11D0,0.13D0,0.18D0,0.23D0,0.35D0]\n! these are used for a phase with order/disorder but no permutations\n double precision, dimension(5), parameter :: &\n yf2=[0.10D0,0.20D0,0.30D0,0.25D0,0.15D0] ! not good ...\n!------------------------------------------------------------------\n! verydense not implemented\n logical gas,dense,verydense,gles,trace,orddis3\n! bugfix by Clement Instroini 18.02.14\n if(iph.lt.1 .or. iph.gt.noofph) then\n gx%bmperr=4050; goto 1000\n else\n lokph=phases(iph)\n endif\n! ngdis is normally 0, nonzero for phases with order/disorer transitions\n ngdis=0\n! disng counts the number of disordered constitutions\n disng=0\n! handle special phases like ionic crystals, ionic liquids and order/disorder\n! write(*,*)'3Y in generic_grid_generator',iph,ngg\n gas=.FALSE.\n! to have some output\n! if(mode.gt.0 .and. ny.eq.-100) then\n! if(mode.gt.0) then\n! write(*,*)'3Y turn on trace',mode,iph,ngg,ny\n! trace=.TRUE.\n! else\n! write(*,*)'3Y searching for y: ',mode,iph,ngg,ny\n! endif\n if(test_phase_status_bit(iph,PHEXCB)) then\n! crystalline phase with charged endmembers\n! write(*,*)'3Y charged grid ngg: ',ngg\n call generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n goto 1000\n elseif(test_phase_status_bit(iph,PHIONLIQ)) then\n! This is the ionic liquid, requires a special grid, also used for dense\n call generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n goto 1000\n elseif(test_phase_status_bit(iph,PHGAS)) then\n gas=.TRUE.\n elseif(test_phase_status_bit(iph,PHFORD) .or. &\n test_phase_status_bit(iph,PHBORD)) then\n! write(*,*)'3Y calling ordered grid 2'\n call generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! write(*,*)'3Y back from fccord_grid 2, jump to 1000',ngg\n! goto 200\n if(gx%bmperr.eq.-1) then\n! if gx%bmperr is -1 means problems in fccord_grid, use default grindgenerator\n gx%bmperr=0\n else\n goto 1000\n endif\n elseif((btest(globaldata%status,GSXGRID) .or. & \n test_phase_status_bit(iph,PHXGRID)) .and. &\n .not.test_phase_status_bit(iph,PHGAS)) then\n! Generate extra gridpoints for all phases or a special phase but never for gas\n! call generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n dense=.TRUE.\n else\n dense=.FALSE.\n endif\n! goto 1000\n!----------------\n! get phase model\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! max number of gridpoints allowed, ngg returned as number of gridpoints...\n maxng=ngg\n ngg=0\n! incl(ii) set to number of constituents up to including sublattice ii\n incl(0)=0\n nend=1\n do ii=1,nsl\n nend=nend*nkl(ii)\n incl(ii)=incl(ii-1)+nkl(ii)\n enddo\n ncon=incl(nsl)\n! nend is number of endmembers, endm(1..nsl,ii) are constituent index of ii\n! yendm(1..nsl,ii) has the constituent fractions for endmember ii\n! yfra is used to generate a constitutuon from a combination of endmembers\n! write(*,*)'3Y allocating endmem 2',nsl,nend,ncon,nend\n allocate(endm(nsl,nend),stat=errall)\n allocate(yendm(ncon,nend),stat=errall)\n allocate(yfra(ncon))\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 5: ',errall\n gx%bmperr=4370; goto 1000\n endif\n yendm=1.0D-12\n! set endm(1..nsl,1) to first constituent index for each sublattice\n do ij=1,nsl\n endm(ij,1)=incl(ij-1)+1\n yendm(endm(ij,1),1)=one\n enddo\n! loop to increment the constituents to generate all endmembers\n newend: do ii=2,nend\n ij=1\n! copy previous endmember\n do ij=1,nsl\n endm(ij,ii)=endm(ij,ii-1)\n enddo\n! increment one constituent starting from first sublattice\n do ij=1,nsl\n if(endm(ij,ii).lt.incl(ij)) then\n endm(ij,ii)=endm(ij,ii)+1\n do ik=1,nsl\n yendm(endm(ik,ii),ii)=one\n enddo\n cycle newend\n else\n endm(ij,ii)=endm(ij,1)\n endif\n enddo\n enddo newend\n! output seems OK here\n! write(*,20)'3Y gend1: ',iph,nsl,(nkl(ii),ii=1,nsl)\n20 format(a,2i3,2x,10i3)\n! write(*,20)'3Y gend2: ',ncon,nend,(incl(ii),ii=0,nsl)\n! do ii=1,nsl\n! write(*,21)(endm(ii,ij),ij=1,nend)\n!21 format(26i3)\n! enddo\n! do ii=1,nend\n! write(*,22)ii,(yendm(ij,ii),ij=1,incl(nsl))\n!22 format(i3,20F4.1)\n! enddo\n! jump here from generate_fccord_grid ... not any longer ...\n200 continue\n! now generate an grid depending on nend mixing up to 5 different endmembers.\n! up to for 4 endmembers 4*4*4*4*4=1024\n! 5 to 7 endmembers 7*7*7*7 =2401\n! 7 to 13 endmembers 13*13*13=2197\n! max 50 endmembers 50*50 = 2500\n! for N>50 endmembers = N\n! FOR DENSE about 10 times more\n! up to 7 endmembers 7*7*7*7*7 = 16807\n! 8 to 12 endmembers 12*12*12*12 = 20736\n! 13 to 15 endmembers 15*15*15 =33750\n! max 150 endmembers 150*150 = 22500\n! for N>150 = N\n!--------------------------------------\n ng=0\n if(gas) then\n do ii=1,nend\n do is=1,ncon\n yfra(is)=yendm(is,ii)\n enddo\n ng=ng+1\n if(mode.eq.0) then\n if(ng.gt.maxng) then\n write(*,*)'3Y Too many gridpoints 7',ng,maxng,iph\n gx%bmperr=4399; goto 1000\n endif\n if(ng.gt.0 .and. mod(ng,30000).eq.0) then\n lokph=phases(iph)\n write(*,*)'3Y Calculates grid point ',ng,' for phase ',&\n trim(phlista(lokph)%name)\n endif\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y error calculating gridpoint: ',&\n iph,gx%bmperr\n goto 1000\n endif\n elseif(mode.eq.ng) then\n! when mode>0 we just want to know the constituent fractions\n goto 900\n endif\n enddo\n goto 800\n endif\n! skip attempt to inlcude disordered gridpoints\n orddis1=0; orddis2=0\n! goto 150\n!==================================================================\n! For phases that can have order/disorder transition maybe generate\n! a few more gridpoints corresponing to the disordered state, for a\n! case with Li-Mg the disordered BCC with equal Li and Mg fractions\n! was not found and the ordered Li:Mg was not enough stable to be included\n! in the grid.\n call get_phase_name(iph,1,phname)\n two: if(nsl.eq.2 .or. nsl.eq.3) then\n! note: phases with 2 or 4 sublattice with permutations never come here\n ij=nkl(1)\n if(mode.eq.0) then\n! write(*,88)trim(phname),nsl,(nkl(ii),ii=1,nsl)\n! write(*,89)trim(phname),nsl,(sites(ii),ii=1,nsl)\n88 format('3Y grid1: ',a,i3,9i3)\n89 format('3Y grid2: ',a,i3,9F8.4)\n endif\n if(ij.gt.1 .and. nkl(2).eq.ij .and.&\n abs(sites(1)-sites(2)).lt.1.0D-12) then\n do ik=1,nkl(1)\n if(knr(ik).ne.knr(ik+ij)) exit two\n enddo\n else\n exit two\n endif\n! A phase with 2 (plus 1) or 4 (plus 1) and same set of constituents\n! on first two sublattices should have some additional gridpoints.\n! representing the disordered state. Note phases with permutations\n! calculated with a separate grid but that may be missing this also.\n orddis1=2\n orddis2=nkl(1)\n call get_phase_name(iph,1,phname)\n! if(mode.eq.0) then\n! write(*,101)trim(phname),nkl(1),nkl(2),orddis1,orddis2,&\n! sites(1),sites(2)\n101 format('3Y orddis2 ',a,4i3,2F6.3)\n! write(*,111)trim(phname),orddis2,nend,iph,orddis1,orddis2\n!111 format(/'3Y *** Warning ',a,' may be stable as disordered ',5i3)\n! For exampe: (A,B,C)(A,B,C)(D, E)\n! 1 2 3 \n! ordered endmembers: AAD ABD ACD BAD, BBD BCD CAD CBD CCD ...(only D=Va?)\n! disordered endmem: AAD BBD CCD\n! do ij=1,nend\n! write(*,112)(endm(ii,ij),ii=1,nsl)\n!112 format('3Y endm: ',9i3)\n! enddo\n! endif\n allocate(ydis(ncon))\n ydis=zero\n! this is selected as the value of loop variable ii for disordering\n! ngdis=ncon\n! ngdis=1\n ngdis=nkl(1)\n! read(*,10)ch1\n endif two\n!\n continue\n four: if(nsl.eq.4 .or. nsl.eq.5) then\n ij=nkl(1)\n! note: phases with 2 or 4 sublattice with permutations never come here\n! write(*,*)'3Y order/disorder? ',nsl,nkl(1)\n if(ij.gt.1 .and. nkl(2).eq.ij .and. nkl(3).eq.ij .and. nkl(4).eq.ij) then\n if(mode.eq.0) then\n! write(*,88)trim(phname),nsl,(nkl(ii),ii=1,nsl)\n! write(*,89)trim(phname),nsl,(sites(ii),ii=1,nsl)\n endif\n aa=sites(1)\n if(abs(aa-sites(2)).lt.1.0D-12 &\n .and. abs(aa-sites(3)).lt.1.0D-12 &\n .and. abs(aa-sites(4)).lt.1.0D-12) then\n do ik=1,ij\n if(knr(ik).ne.knr(ik+ij) .or. &\n knr(ik).ne.knr(ik+2*ij) .or. &\n knr(ik).ne.knr(ik+3*ij)) exit four\n enddo\n endif\n orddis1=4\n orddis2=nkl(1)\n! write(*,102)trim(phname),nkl(1),nkl(2),sites(1),sites(2),sites(3),&\n! sites(4)\n102 format('3Y orddis4 ',a,4i3,4F6.3)\n! if(mode.eq.0) write(*,111)trim(phname),orddis2,nend,orddis1,orddis2\n endif\n allocate(ydis(ncon))\n ydis=zero\n! this is selected as the value of loop variable ii for disordering\n! ngdis=ncon\n! ngdis=1\n ngdis=nkl(1)\n! read(*,10)ch1\n10 format(a)\n endif four\n!-----------------------\n150 continue\n gles=.not.dense\n! write(*,*)'3Y grid1: ',nend,mode,dense,gles\n iiloop: do ii=1,nend\n ijs=1\n nendj=nend\n if(nend.gt.150 .or. (gles .and. nend.gt.50)) then\n nendj=ii\n ijs=ii\n endif\n! write(*,*)'3Y ii:',ii,ijs,nendj\n ijloop: do ij=ijs,nendj\n iks=1\n nendk=nend\n if(nend.gt.15 .or. (gles .and. nend.gt.13)) then\n nendk=ij\n iks=ij\n endif\n ikloop: do ik=iks,nendk\n ils=1\n nendl=nend\n if(nend.gt.12 .or. (gles .and. nend.gt.7)) then\n nendl=ik\n ils=ik\n endif\n illoop: do il=ils,nendl\n ims=1\n nendm=nend\n if(nend.gt.7 .or. (gles .and. nend.gt.4)) then\n! with 4 endmembers 1024 gridpoints\n nendm=il\n ims=il\n endif\n imloop: do im=ims,nendm\n! sum up the weighted fractions from the different endmembers\n do is=1,ncon\n yfra(is)=yf(1)*yendm(is,ii)+yf(2)*yendm(is,ij)+&\n yf(3)*yendm(is,ik)+yf(4)*yendm(is,il)+&\n yf(5)*yendm(is,im)\n enddo\n orddis3=.TRUE.\n! if orddis1 is nonzero below return here to calculate for disordered state\n300 continue\n ng=ng+1\n! write(*,310)'3Y Y1:',ng,ii,ij,ik,il,im,yfra\n if(mode.eq.0) then\n! strange bug in map3, maxng was zero sometimes ...\n if(ng.gt.maxng) then\n if(maxng.lt.100) then\n if(warning1const.ne.iph) then\n write(*,*)'3Y max gripoints wrong 6: ',&\n maxng,iph,mode\n warning1const=iph\n endif\n else\n write(*,*)'3Y Too many gridpoints 6',ng,maxng,iph\n gx%bmperr=4399; goto 1000\n endif\n endif\n if(ng.gt.0 .and. mod(ng,30000).eq.0) &\n write(*,*)'3Y Calculate gridpoint ',ng,' for ',&\n trim(phlista(lokph)%name)\n! for debugging grid minimizer with MQMQA\n! write(*,*)'3Y Calculate grid point ',ng,' for phase ',&\n! trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq)\n! generate a GNUPLOT graph for dense grid\n! write(*,*)'3Y back from calc_gridpoint',ng,garr(ng)\n if(lutbug.gt.0) then\n! write(*,710)ng,nrel,garr(ng),(xarr(iz,ng),iz=1,nrel)\n write(lutbug,710)ng,nrel,garr(ng),&\n (xarr(iz,ng),iz=1,nrel)\n710 format(i5,i3,1pe10.2,10(0pF6.3))\n endif\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y error calculating gridpoint: ',&\n iph,gx%bmperr\n goto 1000\n endif\n! write(*,*)'3Y orddis:',ng,orddis1,orddis3,ngdis\n! The code below is to add some disordered constititutions to order/disorder\n! I tried several values of ii and this worked best. I do not know why\n if(ii.le.ngdis .and. orddis1.gt.0 .and. orddis3) then\n! generate an additional gridpoint as disordered\n! But only for the first loop of ii=1, otherwise too many gridpoints\n! write(*,310)'3Y YO:',ng,ii,ij,ik,il,im,yfra\n! orddis1 is 2 or 4; orddis2 is number of constituent in these sublattices\n! use fractions in yf2 !!!\n do is=1,ncon\n yfra(is)=yf2(1)*yendm(is,ii)+yf2(2)*yendm(is,ij)+&\n yf2(3)*yendm(is,ik)+yf2(4)*yendm(is,il)+&\n yf2(5)*yendm(is,im)\n enddo\n if(orddis1.eq.2) then\n disloop2: do zz=1,orddis2\n ydis(zz)=0.5D0*(yfra(zz)+yfra(zz+orddis2))\n enddo disloop2\n! write(*,310)'3Y YS1:',ng,ii,ij,ik,il,im,ydis\n! same fractions in both sublattice, disordered\n do zz=1,orddis2\n yfra(zz)=ydis(zz)\n yfra(zz+orddis2)=ydis(zz)\n enddo\n! fractions in 3rd sublattice not affected\n! write(*,310)'3Y YS1:',ng,ii,ij,ik,il,im,yfra\n else\n disloop4: do zz=1,orddis2\n ydis(zz)=0.25D0*(yfra(zz)+yfra(zz+orddis2)+&\n yfra(zz+2*orddis2)+yfra(zz+3*orddis2))\n enddo disloop4\n! same fractions in both sublattice, disordered\n do zz=1,orddis2\n yfra(zz)=ydis(zz)\n yfra(zz+orddis2)=ydis(zz)\n yfra(zz+2*orddis2)=ydis(zz)\n yfra(zz+3*orddis2)=ydis(zz)\n enddo\n endif\n! this should be made only once for each set of fractions\n disng=disng+1\n orddis3=.FALSE.\n! write(*,310)'3Y YD:',ng,disng,ii,ij,ik,il,im,yfra\n310 format(a,i4,i3,1x,5i2,11F5.2)\n! jump back to calculate this!!\n goto 300\n endif\n! write(*,323)'3Y imloop2: ',ng,ii,ij,ik,il,im,garr(ng),yfra\n elseif(mode.eq.ng) then\n! when mode>0 we just want to know the constituent fractions\n! write(*,*)'3Y found fractions for gridpoint',ng\n goto 900\n elseif(ii.le.ngdis .and. orddis1.gt.0 .and. orddis3) then\n if(mode.eq.ng+1) then\n! the gridpoint found is a disordered one, we have to disorder yfra as above\n if(orddis1.eq.2) then\n disloop2b: do zz=1,orddis2\n ydis(zz)=0.5D0*(yfra(zz)+yfra(zz+orddis2))\n enddo disloop2b\n do zz=1,orddis2\n yfra(zz)=ydis(zz)\n yfra(zz+orddis2)=ydis(zz)\n enddo\n! fractions in 3rd sublattice not affected\n else\n disloop4b: do zz=1,orddis2\n ydis(zz)=0.25D0*(yfra(zz)+yfra(zz+orddis2)+&\n yfra(zz+2*orddis2)+yfra(zz+3*orddis2))\n enddo disloop4b\n! same fractions in both sublattice, disordered\n do zz=1,orddis2\n yfra(zz)=ydis(zz)\n yfra(zz+orddis2)=ydis(zz)\n yfra(zz+2*orddis2)=ydis(zz)\n yfra(zz+3*orddis2)=ydis(zz)\n enddo\n endif\n! we have regenerated the disordered fractions for this gridpoint\n write(*,*)'3Y found disordered state for gridpoint',ng\n! write(*,310)'3Y YD:',ng,disng,ii,ij,ik,il,im,yfra\n goto 900\n else\n! we have to increment ng as we skip a gridpoint with a disordered fraction\n ng=ng+1\n endif\n!------------------------\n endif\n enddo imloop\n enddo illoop\n enddo ikloop\n enddo ijloop\n enddo iiloop\n! extra output for order/disordered phases\n if(orddis1.ne.0 .and. gx%bmperr.eq.0 .and. mode.eq.0) then\n call get_phase_name(iph,1,phname)\n write(*,790)trim(phname),disng\n790 format('3Y For ',a,i5,' additional disordered gridpoints calculated')\n endif\n! jump here for gas\n800 continue\n if(mode.gt.0) then\n write(*,*)'3Y Could not find gridpoint ',mode,' in phase ',iph,ng\n gx%bmperr=4399\n else\n ngg=ng\n endif\n goto 1000\n!--------------------------------------------\n! we found the gridpoint we were looking for\n900 continue\n ny=ncon\n do ii=1,ny\n yarr(ii)=yfra(ii)\n enddo\n1000 continue\n! write(*,*)'3Y finished generic mode ',mode,iph,ngg\n return\n end subroutine generic_grid_generator\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine generate_dense_grid\n!\\begin{verbatim} %-\n subroutine generate_dense_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! generates more gridpoints than default generate_grid\n! Different action depending of the value of mode, \n! for mode<0: \n! return the number of gridpoints that will be generated for phase iph in ngg\n! for mode=0:\n! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i\n! for mode>0:\n! return site fractions of gridpoint mode in yarr, number of fractions in ny\n! iph is phase number, ngg is number of gridpoints, nrel number of elements,\n! if mode=0:\n! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints,\n! ngg is dimension of garr\n! if mode>0:\n! \"mode\" is a gridpoint of this phase in solution, return number of \n! constituent fractions in ny and fractions in yarr for this gridpoint\n! The current constitution is restored at the end of the subroutine\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n!\\end{verbatim} %+\n!\n integer lokph,errsave\n double precision, parameter :: yzero=1.0D-12\n integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend\n double precision ydum(maxconst)\n integer ngdim,nsl\n integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy\n double precision, dimension(:), allocatable :: yfra\n double precision sites(maxsubl),qq(5)\n real, allocatable :: xbrr(:)\n! endm(i,j) has constituent indices in i=1..nsl for endmember j \n integer, dimension(:,:), allocatable :: endm\n!--------------------------------\n! grid is generated by combining end endmembers\n! Number of endmemers is N\n! For endmember E=1..N set fraction of enmember \n! 0.99*Y_E + 0.01*Y_all N*N of these\n! 0.95*Y_E + 0.03*Y_F + 0.01*Y_all, F.ne.E N*N*(N-1)\n! 0.91*Y_E + 0.07*Y_F + 0.02*Y_all, F.ne.E N*N*(N-1)\n! 0.80*Y_E + 0.15*Y_F + 0.05*Y_all, F.ne.E N*N*(N-1)\n! 0.68*Y_E + 0.25*Y_F + 0.07*Y_all, F.ne.E N*N*(N-1)\n! or 0.68*Y_E + 0.16*Y_F + 0.16*Y_all, F.ne.E N*N*(N-1)\n! 0.54*Y_E + 0.36*Y_F + 0.10*Y_all, F.ne.E N*N*(N-1)\n! 0.42*Y_E + 0.35*Y_F + 0.23*Y_G, F.ne.E.ne.G N*(N-1)*(N-2)\n! or 0.42*Y_E + 0.40*Y_F + 0.18*Y_G, F.ne.E.ne.G N*(N-1)*(N-2)\n! or 0.48*Y_E + 0.40*Y_F + 0.12*Y_G, F.ne.E.ne.G N*(N-1)*(N-2)\n! with 2 endmembers: 24 gridpoints\n! (1.00,0.00) (0.99,0.01) (0.01,0.99) (0.00,1.00)\n! (0.96,0.04) (0.04,0.96) *2\n! (0.93,0.07) (0.91,0.09) *2\n! (0.85,0.15) (0.80,0.20) *2\n! (0.75,0.25) (0.68,0.32) *2\n! (0.64,0.36) (0.57,0.43) *2\n! with 3 endmembers: 9+5*9*2+6=15+90=105\n! (1.00,0,0) (0.99,0.01,0) (0.99,0,0.01) *3\n! (0.97,0.03,0) (0.96,0.04,0) (0.96,0.03,0.01) *3 <50\n! (0.92,0.08,0) (0.90,0.10,0) (0.90,0.08,0.02) <25\n! (0.75,0.25,0) (0.68,0.32.0) (0.68,0.25,0.07) <20\n! (0.85,0.15,0) (0.80,0.20,0) (0.80,0,15,0.05) <15\n! (0.64,0.36,0) (0.54,0.46,0) (0.54,0.36,0.10) <11\n! (0.42,0.35,0.23) (0.42,0.23,0.35) (0.35,0.42,0.23) ... 6\n!----------\n! M= N*N + 5*N*N*(N-1) + N*(N-1)*(N-2)\n! N=10 100 + 5*100*9 + 10*9*8 = 4600+720 = 5320\n! N=20 400 + 400*19 + 0 >8000\n! ...\n integer, parameter :: breaks6=50\n integer, parameter, dimension(5) :: breaks=[9,12,15,18,21]\n! integer, parameter, dimension(5) :: breaks=[9,12,15,18,55]\n double precision, dimension(-1:6), parameter:: ybas=&\n [1.00D0,0.99D0,0.96D0,0.91D0,0.68D0,0.80D0,0.54D0,0.44D0]\n double precision, dimension(6), parameter :: ybin=&\n [0.03D0,0.07D0,0.16D0,0.15D0,0.36D0,0.44D0]\n! [0.03D0,0.07D0,0.25D0,0.15D0,0.36D0,0.35D0]\n double precision, dimension(6), parameter :: yter=&\n [0.01D0,0.02D0,0.16D0,0.05D0,0.10D0,0.12D0]\n! [0.01D0,0.02D0,0.07D0,0.05D0,0.10D0,0.23D0]\n! for output of gridpoints\n integer jbas,sumngg,loksp,l0,l1,ncon,jj,anion,isp,errall\n logical trace,isendmem\n double precision ysum\n save sumngg\n character ch1*1\n!\n! write(*,17)mode,iph,ngg\n17 format('3Y entering generate_dense_grid: ',i2,i3,i10)\n if(mode.eq.0) then\n! write(*,*)'3Y Generating grid for phase: ',iph\n! trace TRUE means generate outpt for each gridpoint\n! trace=.TRUE.\n trace=.FALSE.\n if(iph.eq.1 .and. trace) then\n! unit 33 is opened before calling this routine\n sumngg=0\n write(33,43)\n43 format('The constituent fractions, y, enclosed within parentheses',&\n 'for each sublattice'/'Mole fractions after x:, Gibbs energies',&\n ' after G:'/)\n endif\n if(trace) then\n call get_phase_record(iph,nend)\n! write(33,44)iph,phlista(nend)%name\n44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a)\n endif\n else\n trace=.FALSE.\n endif\n! write(*,*)'3Y Getting phase data',mode\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! calculate the number of endmembers and index of first constituent in subl ll\n nend=1\n inkl(0)=0\n lokph=phases(iph)\n do ll=1,nsl\n if(btest(phlista(lokph)%status1,PHIONLIQ) .and. ll.eq.2) then\n! multiply with charged anions and Va only, add neutrals\n do jj=1,nkl(2)\n! knr(i) is species(i) location but I use constitlist as I have access to it\n isp=phlista(lokph)%constitlist(nkl(1)+jj)\n if(btest(splista(isp)%status,SPION) .or. &\n btest(splista(isp)%status,SPVA)) then\n anion=anion+1\n cycle\n endif\n enddo\n nend=nend*anion+phlista(lokph)%nooffr(2)-anion\n else\n! this is the \"normal\" number of endmembers\n nend=nend*nkl(ll)\n endif\n inkl(ll)=inkl(ll-1)+nkl(ll)\n enddo\n! if(btest(phlista(lokph)%status1,PHIONLIQ)) then\n! write(*,*)'3Y ionic liq: ',anion,nend\n! endif\n ny=inkl(nsl)\n ncon=inkl(nsl)\n negmode: if(mode.lt.0) then\n!---------------------------------------------------------\n! just determine the number of gridpoints for this phase for global minimimum\n! ideal gases should just have the endmembers ....\n! Hm, gases with ions??\n ngdim=ngg\n ngg=nend\n lokph=phases(iph)\n! write(*,*)'3Y nend 1: ',mode,ngg\n if(nend.eq.1 .or. nend.gt.100 .or. &\n btest(phlista(lokph)%status1,PHID)) then\n! >100 or 1 endmember or ideal phase: only endmembers\n ngg=nend\n else\n ngg=nend\n! The limits for various combinations will be adjusted when testing ...\n! Max about 20000 gridpoints per phase\n! if(nend.ge.50) then\n! if(nend.ge.100) then\n ngg=ngg+nend*(nend-1)\n! write(*,*)'3Y dense -1A: ',iph,nend,ngg,breaks(5)\n! ATTENTION\n! The calculation below is not correct, it overestimates a bit the number of \n! gridpoints actually generated but it should not matter so much ... I hope\n! When matching a gridpoint in the solution the code to generate the\n! gridpoint is used, the code below is just an estimate for allocation\n! if(nend.le.50) then\n! Try 60 to handle 53 endmembers in liquid noc2500.TDB from TAF-ID\n! if(nend.le.60) then\n if(nend.le.breaks6) then\n if(nend.gt.breaks(5)) then\n ngg=ngg+nend*(nend-1)+nend*nend*(nend-1)\n! write(*,*)'3Y dense -1B: ',iph,nend,ngg,breaks(4)\n elseif(nend.gt.breaks(5)) then\n ngg=ngg+nend*(nend-1)+2*nend*nend*(nend-1)\n elseif(nend.gt.breaks(4)) then\n ngg=ngg+nend*(nend-1)+3*nend*nend*(nend-1)\n elseif(nend.gt.breaks(3)) then\n ngg=ngg+nend*(nend-1)+4*nend*nend*(nend-1)\n elseif(nend.gt.breaks(2)) then\n ngg=ngg+nend*(nend-1)+5*nend*nend*(nend-1)\n! elseif(nend.gt.breaks(1)) then\n else\n ngg=ngg+nend*(nend-1)+6*nend*nend*(nend-1)\n endif\n endif\n! write(*,*)'3Y dense -1X: ',iph,nend,ngg\n endif\n! write(*,*)'3Y endmembers and gridpoints: ',nend,ngg\n! read(*,11)ch1\n11 format(a)\n ny=nend\n goto 1001\n endif negmode\n!------------------------------------------------------------\n! for mode=0:\n! set gridpoint sitefractions and calculate G\n! for mode>0:\n! return sitefractions (for mode=gridpoint number (part of the solution))\n! BUT: The only way to find the site fraction of a gripoint is to generate\n! all gridpoints up the one specified by the value of mode (no G calculation)\n! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl)\n!\n! write(*,*)'3Y allocating yfra mm',inkl(nsl),nsl,nend\n allocate(yfra(inkl(nsl)),stat=errall)\n! endm(i,j) has constituent indices in i=1..nsl for endmember j \n! endm(1,1) is constituent in sublattice 1 of first endmember\n! endm(2,1) is constituent in sublattice 2 of first endmember\n! endm(nsl,2) is constituent in sublattice nsl of second endmember\n! endm(1..nsl,nend) are constituents in all sublattices of last endmember\n allocate(endm(nsl,nend),stat=errall)\n! inkl(nsl) is the number of fraction variables in the phase\n! allocate(yfra(inkl(nsl)))\n allocate(xbrr(noofel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 6: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! nofy=inkl(nsl)\n! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll\n je=1\n do ll=1,nsl\n endm(ll,je)=inkl(ll-1)+1\n enddo\n100 continue\n je=je+1\n! if je>nend we are finished ...\n if(je.gt.nend) goto 120\n do ls=1,nsl\n endm(ls,je)=endm(ls,je-1)\n enddo\n ll=0\n110 ll=ll+1\n if(endm(ll,je).lt.inkl(ll)) then\n endm(ll,je)=endm(ll,je)+1\n elseif(ll.lt.nsl) then\n endm(ll,je)=inkl(ll-1)+1\n goto 110\n else\n gx%bmperr=4148; goto 1000\n endif\n goto 100\n!---------------------------------------\n! We have now generated endm(1..nsl,j)\n120 continue\n! write(*,202)'3Y special 1: ',nsl,nend,inkl(nsl),endm(1,2),endm(2,2),&\n! endm(1,nend),endm(1,3),endm(2,3),endm(1,4),endm(2,4)\n! now generate all unary, binary and ternary combinations of endmember fractions\n! Note the sum of constituent fractions in all sublattices must be unity\n! By combining endmember fractions weighted according to ybas, ybin and yter\n! we can ensure that\n ngg=0\n l0=0\n l1=0\n lokph=phases(iph)\n endmem1: do iend=1,nend\n! we start with a new endmember iend, ybas(1) is 1.00\n l0=ngg\n yfra=yzero\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(-1)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n! this is for a single endmember\n! write(*,201)'3Y end: ',ngg,(yfra(is),is=1,inkl(nsl))\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints 4',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n201 format(a,i5,20(F5.2))\n elseif(ngg.eq.mode) then\n goto 500\n endif\n! binary combinations 0.99*y1 + 0.01*y2\n endmem2a: do jend=1,nend\n if(jend.eq.iend) cycle endmem2a\n yfra=zero\n! write(*,202)'3Y special 3: ',endm(1,2)\n do ls=1,nsl\n! to generate better start values for fcc-protototype ordering\n! write(*,202)'3Y ls iend endm: ',ls,iend,jend,endm(ls,iend)\n202 format(a,10i6)\n yfra(endm(ls,iend))=ybas(0)\n yfra(endm(ls,jend))=yfra(endm(ls,jend))+yter(1)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n! this is for 0.99*y1 + 0.01*y2\n! STRANGE error that destroyed endm after the call to calc_gridpoint!!\n! the error was due to wrong size allocated to xarr which is strange as it\n! is done elsewhere but the error disapperared when I allocated a larger\n! xarr although the allocated one did not seem too small. \n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Calculate grid point ',ngg,' for ',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! write(*,201)'3Y bin: ',ngg,(yfra(is),is=1,inkl(nsl))\n elseif(ngg.eq.mode) then\n goto 500\n endif\n enddo endmem2a\n! ternary combinations\n! ibas -1 0 1 2 3 4 5 6 \n! ybas 1.00D0,0.99D0,0.96D0,0.91D0,0.68D0,0.80D0,0.54D0,0.42D0\n! ybin 0.03D0,0.07D0,0.25D0,0.15D0,0.36D0,0.35D0\n! yter 0.01D0,0.02D0,0.07D0,0.05D0,0.10D0,0.23D0\n! if(nend.gt.50) cycle endmem1\n! if(nend.gt.60) cycle endmem1\n if(nend.gt.breaks6) cycle endmem1\n ibasloop: do ibas=1,6\n if(nend.ge.breaks(5) .and. ibas.eq.2) cycle endmem1\n if(nend.ge.breaks(4) .and. ibas.eq.3) cycle endmem1\n if(nend.ge.breaks(3) .and. ibas.eq.4) cycle endmem1\n if(nend.ge.breaks(2) .and. ibas.eq.5) cycle endmem1\n if(nend.ge.breaks(1) .and. ibas.eq.6) cycle endmem1\n endmem2b: do jend=1,nend\n if(jend.eq.iend) cycle endmem2b\n endmem3: do kend=1,nend\n yfra=zero\n do ls=1,nsl\n yfra(endm(ls,iend))=ybas(ibas)\n yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibas)\n yfra(endm(ls,kend))=yfra(endm(ls,kend))+yter(ibas)\n enddo\n ysum=zero\n do ls=1,inkl(nsl)\n ysum=ysum+yfra(ls)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n! this is for 0.96*y1 + 0.03*y2+0.01*y3\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y to calculate grid point ',ngg,' for ',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! write(*,201)'3Y ter: ',ngg,(yfra(is),is=1,inkl(nsl)),ysum\n elseif(ngg.eq.mode) then\n goto 500\n endif\n enddo endmem3\n enddo endmem2b\n l1=ngg\n enddo ibasloop\n enddo endmem1\n! write(*,*)'3Y Calculated points: ',ngg\n goto 1000\n!----------------------------------------\n! here we return the constitution for gridpoint \"mode\" in the solution\n! We must also return the mole fractions ... NO??\n500 continue\n! write(*,505)'3Y ggg: ',mode,iph,nsl,inkl(nsl),ny\n505 format(a,i7,i4,2x,i2,i5,i10)\n! write(*,510)'3Y ggy: ',mode,ngdim,ny,(yfra(i),i=1,ny)\n510 format(a,2i5,i3,10(F6.3))\n do i=1,ny\n yarr(i)=yfra(i)\n enddo\n! write(*,520)'3Y ggx: ',(xarr(is,ngg+ngdim),is=1,nrel)\n520 format(a,10(f8.5))\n1000 continue\n! these will be deallocated by default when exit this subroutine ...\n if(allocated(endm)) then\n deallocate(endm)\n deallocate(yfra)\n endif\n1001 continue\n! restore original constituent fractions\n! call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n errsave=gx%bmperr\n gx%bmperr=0\n! write(*,1010)'3Y Restore ',iph,(ydum(i),i=1,ny)\n1010 format(a,'const for ',i3,10(f6.3))\n call set_constitution(iph,1,ydum,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y Error restoring constitution for phase: ',iph,gx%bmperr\n endif\n gx%bmperr=errsave\n if(gx%bmperr.ne.0) write(*,*)'3Y gengrid error: ',gx%bmperr\n return\n end subroutine generate_dense_grid\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine generate_ionliq_grid\n!\\begin{verbatim} %-\n subroutine generate_ionliq_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! generates gridpoints for ionic liquid (also dense)\n! Different action depending of the value of mode, \n! for mode<0: \n! return the number of gridpoints that will be generated for phase iph in ngg\n! for mode=0:\n! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i\n! for mode>0:\n! return site fractions of gridpoint mode in yarr, number of fractions in ny\n! iph is phase number, ngg is number of gridpoints, nrel number of elements,\n! if mode=0:\n! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints,\n! ngg is dimension of garr\n! if mode>0:\n! \"mode\" is a gridpoint of this phase in solution, return number of \n! constituent fractions in ny and fractions in yarr for this gridpoint\n! The current constitution is restored at the end of the subroutine\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n!\\end{verbatim} %+\n!\n integer lokph,errsave\n double precision, parameter :: yzero=1.0D-12\n integer je,iend,jend,kend,lend,ll,nend\n double precision ydum(maxconst)\n integer ngdim,nsl\n integer nkl(2),knr(maxconst),inkl(0:2)\n double precision, dimension(:), allocatable :: yfra\n double precision, dimension(:,:), allocatable :: yendm\n double precision sites(2),qq(5)\n! endm(i,j) has constituent indices in i=1..nsl for endmember j \n integer, dimension(:,:), allocatable :: endm\n! try to have denser cation grid when Va as cation\n integer anionva,constva,hasva\n integer, allocatable, dimension(:) :: endwithva\n!--------------------------------\n! grid is generated by combining end endmembers\n! Number of endmemers is N\n! First level generate for 4 endmembers including same N**4 pemutations\n! 4 1+4 1+3 1+3+4 1+2 1+2+4 1+2+3 1+2+3+4\n! 0.52 0.54 0.63 0.65 0.87 0.81 0.98 1.00\n! 0.35 0.34 0.34 0.34 0.19 0.19 0.02 -\n! 0.11 0.19 0.02 - 0.02 - - -\n! 0.02 - - - - - - -\n! for 2: 1.00 0.98 0.87 0.81 0.65 0.63 0.54 0.52 ... =16\n! for 3: 1.00 0.98/2 0.98/3 ... =81\n! for N=4..7: N*N*N*N =256-2401\n! 1 when 8..15: skip 0.02 except first and last (not dense) \n! 2 when 16-25: 0.02 and 0.11 same except first and last (not dense) N*N*N+..\n! 3 when 26-60: 0.02, 0.11 and 0.35 same except first and last N*N+..\n! 4 >60 only endmembers\n!----------\n! IDE: \n! 1) binary liquid of all endmembers N*N (53*53=2809) (incl pure endmembers)\n! 2) ternary liquid of all cations with sanme anion or Va (4*11*10*9=2880)\n! 3) neutrals?\n integer, parameter, dimension(4) :: breaks=[8,15,25,60]\n double precision, dimension(1:4), parameter:: yf=&\n [0.52D0,0.35D0,0.11D0,0.02D0]\n! These are fractions of mixed cations for same anion, not all variants\n! Used only when there are many endmembers >15\n double precision, dimension(1:3), parameter:: yfc=&\n [0.42D0,0.33D0,0.25D0]\n! Used when mixing cations with same anion\n double precision, dimension(1:3), parameter:: yfx=&\n [0.42D0,0.14D0,0.08D0]\n! for output of gridpoints\n integer l1,ncon,jj,cation,anion,isp,iva,catloop,neutral1,errall\n integer looplim1,looplim2\n logical trace,dense\n character ch1*1,dummy*128\n!\n if(mode.eq.0) then\n trace=.FALSE.\n! trace=.TRUE.\n! write(*,*)'3Y Calculating the number of gridpoints for ionic liquid'\n! trace TRUE means generate outpt for each gridpoint\n if(trace) then\n! unit 33 is opened before calling this routine\n write(33,43)\n43 format('The constituent fractions, y, enclosed within parentheses',&\n 'for each sublattice'/'Mole fractions after x:, Gibbs energies',&\n ' after G:'/)\n endif\n if(trace) then\n call get_phase_record(iph,lokph)\n! write(33,44)iph,phlista(lokph)%name\n44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a)\n endif\n else\n trace=.FALSE.\n endif\n if(btest(globaldata%status,GSXGRID) .or. & \n test_phase_status_bit(iph,PHXGRID)) then\n! write(*,*)'Dense grid set'\n dense=.TRUE.\n else\n dense=.FALSE.\n endif\n! write(*,*)'3Y Getting phase data',mode\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! calculate the number of endmembers and index of first constituent in subl ll\n nend=1\n inkl(0)=0\n inkl(1)=nkl(1)\n cation=nkl(1)\n! Why is inkl(2) set like this? I have changed ncon below\n inkl(2)=nkl(1)+nkl(2)\n lokph=phases(iph)\n if(.not.btest(phlista(lokph)%status1,PHIONLIQ)) then\n write(*,*)'3Y internal error, this phase has not ionic liquid model!'\n gx%bmperr=4399; goto 1000\n endif\n! multiply with charged anions and Va only, add neutrals, nsl=2\n anion=0\n anionva=0\n do jj=1,nkl(2)\n! knr(i) is species(i) location but I use constitlist as I have access to it\n isp=phlista(lokph)%constitlist(nkl(1)+jj)\n if(btest(splista(isp)%status,SPVA)) anionva=jj\n if(btest(splista(isp)%status,SPION) .or. &\n btest(splista(isp)%status,SPVA)) then\n anion=anion+1\n cycle\n endif\n enddo\n! If no Va in anion sublattice anionva=0\n if(anionva.gt.0) then\n! if anaionva>0 allocate array for endmembers with Va\n allocate(endwithva(nkl(1)))\n! save constituent index for Va\n constva=nkl(1)+anionva\n hasva=1\n! write(*,*)'3Y anionva: ',mode,anionva,nkl(1),constva\n endif\n! error when compiling with -O2\n! nend=inkl(1)*anion+phlista(lokph)%nooffr(2)-anion\n nend=nkl(1)*anion+nkl(2)-anion\n ny=inkl(nsl)\n! ncon=inkl(nsl)\n! BoS corrected 2019/04/13: (U+4,Zr+4)(O-2,Va,O) has 5 constituents not 6\n ncon=inkl(1)+nkl(2)\n! write(*,45)'3Y liquid endmembers: ',mode,nkl(1),nkl(2),anion,nend\n45 format(a,5i5)\n negmode: if(mode.lt.0) then\n!---------------------------------------------------------\n! this is never executed as mode<0 no longer used\n! just estimate the number of gridpoints for the ionic liquid phase\n! pairs of cation+anion, cation+Va, neutrals\n ngdim=ngg\n ngg=nend\n lokph=phases(iph)\n write(*,*)'3Y nend 1: ',mode,ngg,breaks\n if(nend.eq.1 .or. nend.gt.breaks(4)) then\n!\n! NOTE mode<0 is NO LONGER USED, this code not used <<<<<<<<<<<60 endmembers: only endmembers\n! if more dense cation grid do not divide cation loop by 2\n ngg=nend+(cation-2)*cation*(cation+1)*anion/2\n elseif(.not.dense .and. nend.gt.breaks(3)) then\n! 26..60: between 676-3600\n! if more dense cation grid do not divide cation loop by 2\n ngg=nend*nend+(cation-2)*cation*(cation+1)*anion/2\n! write(*,*)'3Y catloop 17: ',ngg,nend,cation,anion,&\n! (cation-2)*cation*(cation+1)*anion/2\n elseif(.not.dense .and. nend.gt.breaks(2)) then\n! 16..25: ??\n ngg=nend*nend*2+(cation-2)*cation*(cation+1)*anion/2\n! write(*,*)'3Y catoop 18: ',ngg,nend,cation,anion\n elseif(nend.gt.breaks(1)) then\n! 8..15: ??\n ngg=nend*nend*nend\n else\n! 2..7, all combinations\n ngg=nend*nend*nend*nend\n endif\n! read(*,11)ch1\n11 format(a)\n ny=nend\n goto 1001\n endif negmode\n! the negmode if statement above no longer used ^^^^^^^^^^^^^^^^^^^^\n!------------------------------------------------------------\n! for mode=0:\n! set gridpoint sitefractions and calculate G\n! for mode>0:\n! return sitefractions (for mode=gridpoint number (part of the solution))\n! BUT: The only way to find the site fraction of a gripoint is to generate\n! all gridpoints up the one specified by the value of mode (no G calculation)\n! write(*,*)'3Y ggy: ',mode,iph,nsl,nend,inkl(nsl)\n!\n! endm(i,j) has constituent indices in i=1..nsl for endmember j \n! endm(1,1) is constituent in sublattice 1 of first endmember\n! endm(2,1) is constituent in sublattice 2 of first endmember\n! endm(nsl,2) is constituent in sublattice nsl of second endmember\n! endm(1..nsl,nend) are constituents in all sublattices of last endmember\n! if(mode.gt.0) write(*,*)'3Y allocate endm: ',nsl,nend\n! write(*,*)'3Y allocating endmembers 5:',nsl,nend,inkl(nsl)\n allocate(endm(nsl,nend),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 7: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! inkl(nsl) is the number of fraction variables in the phase\n! allocate(yfra(inkl(nsl)))\n! nofy=inkl(nsl)\n! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll\n! For neutrals in sublattice 2, sublattice 1 has -99 as constituent\n je=1\n do ll=1,nsl\n endm(ll,je)=inkl(ll-1)+1\n enddo\n! we may not have any anions, just Va!\n isp=endm(2,je)\n if(btest(splista(knr(isp))%status,SPVA)) then\n! save index for endmembers with va as anion\n! write(*,*)'3Y ionic liquid endmember with Va 1: ',je,hasva,nkl(1)\n endwithva(hasva)=je\n hasva=hasva+1\n endif\n! we can have an ionic liquid without any cation\n if(knr(1).eq.-99) endm(1,1)=-99\n genend: do while(je.lt.nend)\n je=je+1\n! next endmember is first equal to previous\n do ll=1,nsl\n endm(ll,je)=endm(ll,je-1)\n enddo\n! increment the constituent in the first sublattice\n if(endm(1,je).lt.inkl(1)) then\n endm(1,je)=endm(1,je)+1\n if(hasva.gt.1) then\n! write(*,*)'3Y ionic liquid endmember with Va 3: ',je,hasva,nkl(1)\n endwithva(hasva)=je\n hasva=hasva+1\n endif\n else\n endm(1,je)=1\n isp=endm(2,je)+1\n if(btest(splista(knr(isp))%status,SPVA)) then\n! save index for endmembers with va as anion\n! write(*,*)'3Y ionic liquid endmember with Va 2: ',je,hasva,nkl(1)\n endwithva(hasva)=je\n hasva=hasva+1\n endif\n if(splista(knr(isp))%charge.eq.zero .and. &\n .not.btest(splista(knr(isp))%status,SPVA)) then\n! The next constituent in second sublattice is not Va or a neutral\n exit genend\n else\n! the next constituent is an anion or Va\n endm(2,je)=endm(2,je)+1\n endif\n endif\n! write(*,171)'3Y endmember 1: ',je,endm(1,je),endm(2,je)\n enddo genend\n171 format(a,i3,' (',i2,':',i2,')')\n! we must generate endmembers for neutrals, wildcard -99 in first sublattice\n do iend=je,nend\n endm(1,iend)=-99\n endm(2,iend)=isp\n isp=isp+1\n! write(*,171)'3Y endmember 2: ',je,endm(1,je),endm(2,je)\n enddo\n! debug check\n if(mode.eq.0) then\n! write(*,*)'3Y NEW: mode, endmembers, gridpoints: ',mode,nend,ngg\n! write(*,111)(endm(1,je),endm(2,je),je=1,nend)\n111 format('3Y list: ',10(i4,i3)/11(i4,i3))\n endif\n! gx%bmperr=4399; goto 1000\n!---------------------------------------\n! We have now generated endm(1..nsl,j)\n!120 continue\n! write(*,202)'3Y special 1: ',nsl,nend,inkl(nsl),endm(1,2),endm(2,2),&\n! endm(1,nend),endm(1,3),endm(2,3),endm(1,4),endm(2,4)\n! we must allocate and set endmember fractions both for mode 0 and >0\n! if(mode.gt.0) write(*,*)'3Y allocate yendm: ',inkl(2),nend\n! write(*,*)'3Y allocating endmembers 6:',inkl(2),nend\n allocate(yendm(inkl(2),nend),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 8: ',errall\n gx%bmperr=4370; goto 1000\n endif\n yendm=zero\n! SOMETIMES IT CRASHED IF THIS LINE IS REMOVED\n write(dummy,*)'3Y endmember fractions:',mode,je\n do je=1,nend\n if(endm(1,je).lt.0) then\n! for neutrals set all fractions in first sublatice to unity/number of constit\n! The G value calculated for the endmember is same as if all were zero\n! but when mixing endmembers with cation fractions it may differ ....\n do l1=1,inkl(1)\n yendm(l1,je)=one/inkl(1)\n enddo\n else\n yendm(endm(1,je),je)=one\n endif\n yendm(endm(2,je),je)=one\n! write(*,213)je,(yendm(l1,je),l1=1,inkl(2))\n213 format('3Y#',i2,14F5.2/(15F5.2))\n enddo\n! if(mode.gt.0) write(*,*)'3Y allocate yfra: ',nsl,inkl(nsl)\n! allocate(yfra(inkl(nsl)))\n! this is a small allocation, max 1000 double\n allocate(yfra(ncon))\n!---------------------------------------------\n! now generate combinations of endmember fractions\n! Note the sum of constituent fractions in all sublattices should be unity\n ngg=0\n looplim1=breaks(4)\n looplim2=breaks(3)\n if(dense) then\n! write(*,*)'3Y dense ionic liquid grid',nend\n looplim1=nend+1\n looplim2=breaks(4)\n endif\n lokph=phases(iph)\n endmem1: do iend=1,nend\n endmem2: do jend=1,nend\n if(nend.gt.looplim1 .and. jend.ne.iend) cycle endmem2\n endmem3: do kend=1,nend\n if(nend.gt.looplim2 .and. kend.ne.jend) cycle endmem3\n endmem4: do lend=1,nend\n if(nend.gt.breaks(2) .and. lend.ne.kend) cycle endmem4\n do jj=1,ncon\n yfra(jj)=yf(1)*yendm(jj,iend)+yf(2)*yendm(jj,jend)+&\n yf(3)*yendm(jj,kend)+yf(4)*yendm(jj,lend)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y calculate ',ngg,' grid points for ',&\n trim(phlista(lokph)%name) \n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(lutbug.gt.0) then\n! debug output for NEW version of ionic liquid, the grid was quite strange\n write(lutbug,710)'A: ',ngg,nrel,ncon,garr(ngg),&\n (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon)\n710 format(a,i5,2i3,1pe10.2,10(0pF6.3))\n endif\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,&\n! ' gridpoints, more to go'\n! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel)\n! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon)\n211 format(a,i7,1pe12.4,0pf7.4,6f7.4,(3x,10f7.4))\n212 format(a,15F5.2,(16F5.2))\n elseif(ngg.eq.mode) then\n! when mode>0 we are searching for the constitution of a grid point\n! and we must know the yfra here!!\n goto 500\n endif\n enddo endmem4\n enddo endmem3\n enddo endmem2\n enddo endmem1\n! write(*,*)'3Y Calculated points 1: ',ngg,nend,breaks(2),dense\n! goto 1000\n! write(*,*)'3Y special cation loop: '\n! if(nend.le.breaks(2)) goto 1000\n! if(.not.dense .and. nend.le.breaks(2)) goto 1000\n if(.not.dense .and. cation.gt.breaks(3)) goto 1000\n! combinations 3 different cations with same anion\n anion2: do lend=0,anion-1\n catloop=lend*cation+1\n! REMEMBER: endmembers with same cation are ordered sequentially!!! \n! write(*,*)'3Y catloop: ',lend+1,cation,catloop,ngg\n! calculating \"c g\" followed by \"c n\" gives better result than \"c e\", why??\n! The reason was that I had forgotten to scale phase amounts with total moles\n endmem1b: do iend=catloop,catloop+cation-3\n endmem2b: do jend=iend+1,catloop+cation-2\n endmem3b: do kend=jend+1,catloop+cation-1\n! these loops generate a more dense grid but give same results in my test\n! endmem1b: do iend=catloop,catloop+cation-1\n! endmem2b: do jend=catloop,catloop+cation-1\n! if(jend.eq.iend) cycle endmem2b\n! endmem3b: do kend=catloop,catloop+cation-1\n! if(kend.eq.jend .or. kend.eq.iend) cycle endmem3b\n if(.not.dense .and. cation.gt.breaks(3)) then\n! write(*,*)'3Y skipping ternary cationloop'\n cycle endmem3b\n endif\n! mixing of 3 cations with the same anion\n do jj=1,ncon\n yfra(jj)=yfx(1)*yendm(jj,iend)+yfx(2)*yendm(jj,jend)+&\n yfx(3)*yendm(jj,kend)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y calculate ',ngg,' gridpoints for ',&\n trim(phlista(lokph)%name) \n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(lutbug.gt.0) then\n! debug output for NEW version of ionic liquid, the grid was quite strange\n write(lutbug,710)'B: ',ngg,nrel,ncon,garr(ngg),&\n (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon)\n endif\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,&\n! ' gridpoints, more to go'\n! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel)\n! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon)\n elseif(ngg.eq.mode) then\n! when mode>0 we are searching for the constitution of a grid point\n! and we must know the yfra here!!\n goto 500\n endif\n enddo endmem3b\n enddo endmem2b\n enddo endmem1b\n enddo anion2\n!--------\n! write(*,*)'3Y Calculated points 2: ',ngg,nend,breaks(2)\n! skip next loop for the moment ....... still\n goto 1000\n! combination of 2 different cations with same anion and a neutral\n! there are cation*anion endmembers (incl Va as anion), neutrals follow\n neutral1=cation*anion+1\n iva=ngg\n write(*,*)'3Y ionliqgrid3: ',neutral1,ngg\n recip: do lend=0,anion-1\n catloop=lend*cation+1\n! write(*,*)'3Y catloop: ',lend+1,cation,catloop,ngg\n! calculating \"c g\" followed by \"c n\" gives better result than \"c e\", why??\n! The reason was that I had forgotten to scale phase amounts with total moles\n endmem1c: do iend=catloop,catloop+cation-2\n endmem2c: do jend=iend,catloop+cation-1\n! now a neutral, \n endmem3c: do kend=neutral1,nend\n if(.not.dense .and. cation.gt.breaks(3)) then\n write(*,*)'skipping ternary cationloop'\n cycle endmem3c\n elseif(mode.eq.0) then\n write(*,480)'3Y cations: ',lend+1,iend,jend,kend,ngg\n480 format(a,10i5)\n endif\n! mixing of cations with the same anion and a neutral\n do jj=1,ncon\n yfra(jj)=yfc(1)*yendm(jj,iend)+yfc(2)*yendm(jj,jend)+&\n yfc(3)*yendm(jj,kend)\n enddo\n ngg=ngg+1\n if(mode.eq.0) then\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Gridmin calculated ',ngg,&\n ' gridpoints for ',trim(phlista(lokph)%name)\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! if(mod(ngg,10000).eq.0) write(*,*)'Calculated ',ngg,&\n! ' gridpoints, more to go'\n! write(*,211)'3Y ny:',ngg,garr(ngg),(xarr(jj,ngg),jj=1,nrel)\n! write(*,212)'3Yy: ',(yfra(jj),jj=1,ncon)\n elseif(ngg.eq.mode) then\n! when mode>0 we are searching for the constitution of a grid point\n! and we must know the yfra here!!\n goto 500\n endif\n enddo endmem3c\n enddo endmem2c\n enddo endmem1c\n enddo recip\n write(*,*)'3Y ionliqgrid7: ',neutral1,ngg,iva\n!\n! write(*,*)'3Y Calculated points 2: ',ngg\n! generate combinations of ternary anions if not done above\n goto 1000\n!----------------------------------------\n! jump here to return the constitution for gridpoint \"mode\" in the solution\n500 continue\n if(ny.ne.ncon) write(*,*)'3Y ny and ncon: ',ny,ncon\n! do jj=1,ny\n do jj=1,ncon\n yarr(jj)=yfra(jj)\n enddo\n1000 continue\n! these should be deallocated by default when exit this subroutine ...\n if(allocated(endm)) then\n deallocate(endm)\n deallocate(yfra)\n deallocate(yendm)\n endif\n1001 continue\n! restore original constituent fractions, also if error in this routine\n! call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n errsave=gx%bmperr\n gx%bmperr=0\n call set_constitution(iph,1,ydum,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y Error restoring constitution for phase: ',iph,gx%bmperr\n endif\n gx%bmperr=errsave\n if(gx%bmperr.ne.0) write(*,*)'3Y ionliq_grid error: ',gx%bmperr\n return\n end subroutine generate_ionliq_grid\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine generate_fccord_grid\n!\\begin{verbatim} %-\n subroutine generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! This generates grid for a phase with 4 sublattice fcc/bcc/hcp ordering\n! NO LONGER USED: mode<0 just number of gridpoints in ngg, for allocations\n! mode=0 calculate mole fraction and G for all gridpoints\n! mode>0 return constitution for gridpoint mode in yarr\n implicit none\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n logical, save :: once=.TRUE.\n integer nsl,maxng,mend,nend,kend,ncon,i1,i2,i3,i4,i5,ij,ik,iz,ls,gridlimit\n integer nkl(1000),knr(1000),incl(0:9),loksp,lokph,jj\n integer, allocatable, dimension(:,:) :: endm\n double precision, allocatable, dimension(:,:) :: yendm\n double precision, allocatable, dimension(:) :: yfra\n double precision, allocatable, dimension(:) :: ysave\n double precision ydum(1000),ysame(1000),sites(9),qq(5)\n! this generates >3000 gridpoints for a binary (A,B)(A,B)(A,B)(A,B)\n! integer, parameter, dimension(3,4) :: &\n! limits=reshape([150,50,20, 100,30,15, 20,10,7, 12,7,4],shape(limits))\n integer, parameter, dimension(3,4) :: &\n limits=reshape([150,50,20, 100,30,15, 20,10,7, 12,7,4],shape(limits))\n! from generic_grid_generator\n! logical dense,gles,defgrid\n double precision, dimension(5), parameter :: &\n yf=[0.07D0,0.28D0,0.16D0,0.45D0,0.04D0]\n integer ii,ijs,iks,il,ils,im,ims,is,nendj,nendk,nendl,nendm,ng,errall\n character phname*32\n! NOTHING IMPLEMENTED YET oh yes it is ...\n! write(*,*)'3Y in generate_fccord_grid ',ngg\n if(mode.lt.0) then\n write(*,*)'3Y mode <0 not allowed'\n gx%bmperr=4399; goto 1000\n endif\n! check that F or B bit set\n if(.not.(test_phase_status_bit(iph,PHFORD) .or. &\n test_phase_status_bit(iph,PHBORD))) then\n write(*,*)'3Y calling ordered grid without F or B bit'\n gx%bmperr=4399; goto 1000\n endif\n!\n! get phase model\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1010\n! max number of gridpoints allowed, ngg returned as number of gridpoints ???\n! maxng is zero ...\n maxng=ngg\n ngg=0\n! incl(ii) set to number of constituents up to including sublattice ii\n incl(0)=0\n nend=1\n do ij=1,nsl\n nend=nend*nkl(ij)\n incl(ij)=incl(ij-1)+nkl(ij)\n enddo\n ncon=incl(nsl)\n! if nend<15 there is a single constituent on the ordered sublattices\n if(nend.lt.16) then\n gx%bmperr=-1\n goto 1010\n endif\n! nend is number of endmembers, endm(1..nsl,ii) are constituent index of ii\n! yendm(1..nsl,ii) has the constituent fractions for endmember ii\n! yfra is used to generate a constitutuon from a combination of endmembers\n! write(*,*)'3Y allocating endmembers 8:',nsl,nend,ncon\n if(nsl*nend.gt.100000) then\n call get_phase_name(iph,1,phname)\n write(*,*)'3Y Limiting gridpoints in ',trim(phname),nend,30000\n! I am not sure if nend is checked in the loops below, may cause segmentation\n! fault\n nend=30000\n endif\n allocate(endm(nsl,nend),stat=errall)\n allocate(yendm(ncon,nend),stat=errall)\n allocate(yfra(ncon),stat=errall)\n allocate(ysave(ncon),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 9: ',errall\n gx%bmperr=4370; goto 1000\n endif\n yendm=1.0D-12\n do ij=1,ncon\n ysave(ij)=ydum(ij)\n enddo\n! set endm(1..nsl,1) to first constituent in each sublattice\n do ij=1,nsl\n endm(ij,1)=incl(ij)\n! endm(ij,1)=incl(ij-1)+1\n! yendm(endm(ij,1),1)=one\n enddo\n! loop to increment the constituents to generate all endmembers\n! We should avoid all permutations according to BCC\n! A:A:A:A \n! A:A:A:B ingnore all permutations of B in sublattices\n! A:A:A:C - A:A:A:X\n! A:A:B:B - A:A:B:X\n! A:A:C:C - A:A:X:X\n! A:B:A:B - A:B:A:X <<<<<<< special for BCC\n! A:C:A:C - A:X:A:X\n! A:B:B:C - A:B:B:X\n! A:B:C:C - A:B:X:X\n! A:C:C:C - A:X:X:X\n! B:B:B:B \n! B:B:B:C - B:B:B:X \n! etc\n! X:X:X:X\n! endm(1..nsl,1) set to first in all sublattices\n! ordering always on the first 4 sublattices\n! endm(1..nsl,jj) contains constituent indices in sublattice 1..nsl\n! skip vacancies in the ordered sublattices ...\n kend=1\n sl1: do i1=1,nkl(1)\n endm(1,kend)=incl(0)+i1\n if(btest(splista(knr(endm(1,kend)))%status,SPVA)) then\n! write(*,*)'Skipping vacancies in ordered sublattices: ',&\n! trim(splista(knr(endm(1,kend)))%symbol),kend,knr(endm(1,kend))\n cycle sl1\n endif\n sl2: do i2=i1,nkl(2)\n endm(2,kend)=incl(1)+i2\n if(btest(splista(knr(endm(2,kend)))%status,SPVA)) cycle sl2\n sl3: do i3=i2,nkl(3) \n endm(3,kend)=incl(2)+i3\n if(btest(splista(knr(endm(3,kend)))%status,SPVA)) cycle sl3\n sl4: do i4=i3,nkl(4)\n endm(4,kend)=incl(3)+i4\n if(btest(splista(knr(endm(4,kend)))%status,SPVA)) cycle sl4\n extra: if(nsl.gt.4) then\n! write(*,16)'3Y endm 1: ',0,kend,(endm(ik,kend),ik=1,nsl)\n rest: do ls=5,nsl\n! Hm, problems to loop over constituents in sublattices nsl>4\n sl5: do i5=1,nkl(ls)\n! write(*,16)'3Y endm 2: ',i5,ls,kend,&\n! (endm(ik,kend),ik=1,nsl),incl(ls)\n if(endm(ls,kend).ge.incl(ls)) then\n! reset the constiuent in sublattice ls to the first in this sublattice\n endm(ls,kend)=incl(ls-1)+1\n else\n endm(ls,kend)=endm(ls,1)+1\n endif\n do ik=1,nsl\n yendm(endm(ik,kend),kend)=one\n enddo\n! write(*,16)'3Y endm 3: ',i5,ls,kend,&\n! (endm(ik,kend),ik=1,nsl),0\n16 format(a,3i5,4i4,2i7)\n kend=kend+1\n! this can be ver very many so maybe nend set to lower value above\n if(kend.eq.nend) then\n write(*,*)'3Y limiting grid in ',trim(phname),kend\n goto 1000\n endif\n do iz=1,nsl\n endm(iz,kend)=endm(iz,kend-1)\n enddo\n enddo sl5\n enddo rest\n else\n! write(*,16)'3Y yendm 3: ',kend,(endm(ik,kend),ik=1,nsl)\n do ik=1,nsl\n yendm(endm(ik,kend),kend)=one\n enddo\n! write(*,16)'3Y endm 4: ',0,ls,kend,&\n! (endm(ik,kend),ik=1,nsl),0\n kend=kend+1\n! this can be ver very many so maybe nend set to lower value above\n if(kend.eq.nend) then\n write(*,*)'3Y limiting grid in ',trim(phname),kend\n goto 1000\n endif\n do iz=1,nsl\n endm(iz,kend)=endm(iz,kend-1)\n enddo\n endif extra\n enddo sl4\n enddo sl3\n enddo sl2\n enddo sl1\n if(mode.eq.0 .and. test_phase_status_bit(iph,PHBORD)) then\n! for BCC ordered phase add endmember with same constituents in first and third\n! sublattices and loop in the others like A:B-X:A:B-X and B:C-X:B:C-X\n! write(*,*)'3Y Grid minimizer has no gridpoints for B32 ordering',kend-1\n! stop 'too many gridpoints'\n endif\n! kend has been incremented one too much\n nend=kend-1\n! write(*,*)'3Y ordered endmemb: ',nend\n! if(mode.eq.0) then\n! output adapted to 5 sublattices (interstitial)\n! if(nsl.eq.5) then\n! write(*,17)'3Y orded:',nend,((endm(ls,mend),ls=1,nsl),mend=1,nend)\n17 format(a,i3,4(i4,4i3)/,(12x,i4,4i3,i4,4i3,i4,4i3,i4,4i3))\n! do i2=1,nend\n! write(*,18)i2,(endm(ls,i2),ls=1,nsl),(yendm(i1,i2),i1=1,nsl)\n18 format('3Y yendm: ',i5,2x,4i3,2x,4F6.3)\n! enddo\n! elseif(nsl.eq.4) then\n! output adapted to 4 sublattices\n! write(*,19)'3Y ordend: ',((endm(ls,mend),ls=1,nsl),mend=1,nend)\n19 format(a,4(i4,3i3)/,(11x,i4,3i3,i4,3i3,i4,3i3,i4,3i3))\n! endif\n! endif\n!\n! copied from generic_grid_generator\n!\n! now generate an grid depending on nend mixing up to 5 different endmembers.\n! up to for 4 endmembers 4*4*4*4*4=1024\n! 5 to 7 endmembers 7*7*7*7 =2401\n! 7 to 13 endmembers 13*13*13=2197\n! max 50 endmembers 50*50 = 2500\n! for N>50 endmembers = N\n! FOR DENSE about 10 times more\n! up to 7 endmembers 7*7*7*7*7 = 16807\n! 8 to 12 endmembers 12*12*12*12 = 20736\n! 13 to 15 endmembers 15*15*15 =33750\n! max 150 endmembers 150*150 = 22500\n! for N>150 = N\n!--------------------------------------\n! dense=.FALSE.\n! gles=.FALSE.\n! defgrid=.TRUE.\n if(btest(globaldata%status,GSOGRID)) then\n gridlimit=3\n elseif(btest(globaldata%status,GSXGRID) .or. & \n test_phase_status_bit(iph,PHXGRID)) then\n gridlimit=1\n else\n gridlimit=2\n endif\n! write(*,*)'3Y in generate_ordered_grid ',iph,nend,gridlimit,&\n! btest(globaldata%status,GSOGRID)\n ng=0\n!-----------------------\n iiloop: do ii=1,nend\n ijs=1\n nendj=nend\n if(nend.ge.limits(gridlimit,1)) then\n! if(nend.eq.150 .or. (gles .and. nend.gt.40)) then\n nendj=ii\n ijs=ii\n endif\n! write(*,*)'3Y ii:',ii,ijs,nendj\n ijloop: do ij=ijs,nendj\n iks=1\n nendk=nend\n if(nend.ge.limits(gridlimit,2)) then\n! if(nend.gt.15 .or. (gles .and. nend.gt.13)) then\n nendk=ij\n iks=ij\n endif\n ikloop: do ik=iks,nendk\n ils=1\n nendl=nend\n if(nend.ge.limits(gridlimit,3)) then\n! if((nend.gt.12 .or. (gles .and. nend.gt.7)) then\n nendl=ik\n ils=ik\n endif\n illoop: do il=ils,nendl\n! illoop: do il=1,nendl\n ims=1\n nendm=nend\n if(nend.ge.limits(gridlimit,4)) then\n! if(nend.gt.7 .or. (gles .and. nend.gt.4)) then\n! with 4 endmembers 1024 gridpoints\n nendm=il\n ims=il\n endif\n imloop: do im=ims,nendm\n! sum up the weighted fractions from the different endmembers\n do is=1,ncon\n yfra(is)=yf(1)*yendm(is,ii)+yf(2)*yendm(is,ij)+&\n yf(3)*yendm(is,ik)+yf(4)*yendm(is,il)+&\n yf(5)*yendm(is,im)\n enddo\n ng=ng+1\n if(mode.eq.0) then\n! write(*,322)'3Y imloop: ',ng,ii,ij,ik,il,im\n322 format(a,i8,5i4)\n! write(*,323)'3Y imloop1: ',ng,ii,ij,ik,il,im,0.0D0,yfra\n323 format(a,i5,5i3,': ',1pe12.4,0p20F5.2)\n! strange bug in map3, maxng was zero sometimes ...\n if(ng.gt.maxng) then\n if(maxng.lt.100) then\n write(*,*)'3Y max gripoints wrong 6: ',maxng,iph,mode\n else\n write(*,*)'3Y Too many gridpoints 6',ng,maxng,iph\n gx%bmperr=4399; goto 1000\n endif\n endif\n if(ng.gt.0 .and. mod(ng,30000).eq.0) then\n lokph=phases(iph)\n write(*,*)'3Y Gridmin calculated ',ng,&\n ' gridpoints for ',trim(phlista(lokph)%name)\n endif\n call calc_gridpoint(iph,yfra,nrel,xarr(1,ng),garr(ng),ceq)\n if(lutbug.gt.0) then\n write(lutbug,710)'F: ',ngg,nrel,ncon,garr(ngg),&\n (xarr(jj,ngg),jj=1,nrel),(yfra(jj),jj=1,ncon)\n710 format(a,i5,2i3,1pe10.2,10(0pF6.3))\n endif\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y error calculating gridpoint: ',&\n iph,gx%bmperr\n goto 1000\n endif\n! write(*,323)'3Y imloop2: ',ng,ii,ij,ik,il,im,garr(ng),yfra\n elseif(mode.eq.ng) then\n! when mode>0 we just want to know the constituent fractions\n goto 900\n endif\n enddo imloop\n enddo illoop\n enddo ikloop\n enddo ijloop\n enddo iiloop\n! do ii=1,ng\n! write(*,700)ii,garr(ii),(xarr(ij,ii),ij=1,nrel)\n700 format('3Y gp: ',i5,1pe12.4,9(0pF6.3))\n! enddo\n800 continue\n if(mode.gt.0) then\n write(*,*)'3Y could not find gridpoint ',mode,' in phase ',iph,ng\n gx%bmperr=4399\n else\n ngg=ng\n endif\n goto 1000\n!--------------------------------------------\n! we found the gridpoint we were looking for\n900 continue\n ny=ncon\n do ii=1,ny\n yarr(ii)=yfra(ii)\n enddo\n!\n!\n1000 continue\n if(mode.eq.0) then\n! restore the composition\n call set_constitution(iph,1,ysave,qq,ceq)\n endif\n! nothing done, just exit\n1010 continue\n return\n! dense gles\n end subroutine generate_fccord_grid\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine generate_charged_grid\n!\\begin{verbatim} %-\n subroutine generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! This generates grid for a phase with charged constituents\n! mode<0 just number of gridpoints in ngg, needed for allocations\n! mode=0 calculate mole fraction and G for all gridpoints\n! mode>0 return constitution for gridpoint mode in yarr\n implicit none\n integer mode,iph,ngg,nrel,ny\n real xarr(nrel,*),garr(*)\n double precision yarr(*),gmax\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl)\n! double precision, dimension(:), allocatable :: yfra\n double precision sites(maxsubl),ydum(maxconst),qq(5)\n integer nend,ll,nsl,i1,i2,i3,loksp,mm,lokph,lokcs,np,nm,nn,ncc,iz,loopf,jj\n integer, dimension(:,:), allocatable :: neutral\n integer, dimension(10) :: gtype\n! integer, dimension(:), allocatable :: savengg\n! integer ielno(10)\n! double precision stoi(10),smass,qsp\n double precision charge,ratio1,ratio2\n double precision, dimension(:), allocatable :: y1,y2,y3,y4,y5\n real xdum(nrel),gdum\n integer, parameter :: ncf5=5,ncf3=3,alloneut=300000\n integer ncf,maxngg,ncon,maxgp1,errall\n integer, parameter :: maxgp2=10000,maxgp3=20000\n! These are used to combine endmembers\n double precision, dimension(7), parameter :: nfact=&\n [0.01D0,0.1D0,0.33D0,0.51D0,0.67D0,0.9D0,0.99D0]\n double precision, dimension(ncf5), parameter :: cfact5=&\n [0.05D0,0.3D0,0.5D0,0.7D0,0.95D0]\n double precision, dimension(ncf3), parameter :: cfact3=&\n [0.1D0,0.5D0,0.9D0]\n logical single,endout,dense,skipped\n! all endmembers will have a record of this type\n type gtp_charged_endmem\n! one species number for each sublattice\n integer, dimension(:), allocatable :: constit\n double precision charge\n end type gtp_charged_endmem\n type(gtp_charged_endmem), dimension(:), allocatable :: endmem\n! this should be saved or passed as argument\n! save savengg\n! we will select 5 or 3 gripoints below\n! endout=.true.\n endout=.FALSE.\n! skipped=.TRUE.\n skipped=.FALSE.\n if(endout) write(*,*)'3Y charged grid phase:',iph\n! ncf=ncf5\n! if(.not.allocated(savengg)) then\n! allocate(savengg(noofph))\n! savengg=0\n! endif\n maxngg=ngg\n ngg=0\n gtype=0\n! get the phase data\n call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! Clement Introini bugfix\n lokph=phases(iph)\n!\n! I will handle this by first generate all endmembers with their charge\n! and then try to combine them to get neutral gridpoints.\n nend=1\n inkl(0)=0\n do ll=1,nsl\n nend=nend*nkl(ll)\n! inkl(ll) is the number of constituents up to and including sublattice ll\n inkl(ll)=inkl(ll-1)+nkl(ll)\n enddo\n! ncon is the total number of constituents\n ncon=inkl(nsl)\n! write(*,*)'3Y Charged grid for phase ',iph,mode,nend,ncon\n if(nend.eq.1) then\n! a single endmember, just check it is neutral\n ngg=1\n charge=zero\n do ll=1,nsl\n loksp=knr(ll)\n charge=charge+sites(ll)*splista(loksp)%charge\n enddo\n if(charge.eq.zero) then\n np=ngg\n if(ngg.gt.maxngg) then\n write(*,*)'3Y too many gripoints 2',ngg,maxngg,iph\n gx%bmperr=4399; goto 1000\n endif\n if(mode.eq.0) then\n! if mode=0 calculate G for this endmember\n! write(*,*)'3Y a single neutral endmember for ',iph,mode\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints for ',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,ydum,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n endif\n! finally remove the request for external charge balance !!!\n! write(*,*)'3Y No external charge balance for phase:',iph,lokcs,mode\n call get_phase_compset(iph,1,lokph,lokcs)\n phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHEXCB)\n goto 1000\n endif\n call get_phase_compset(iph,1,lokph,lokcs)\n! write(*,*)'3Y Phase suspended as net charge: ',phlista(lokph)%name\n! suspend all composition sets\n do mm=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(mm)\n ceq%phase_varres(lokcs)%phstate=PHSUS\n enddo\n goto 1000\n endif\n!\n np=0\n nm=0\n nn=0\n! Problem with CU2ZN1SN1S4 maybe because of sublattce with just VA ??\n! write(*,10)'3Y nend: ',iph,nend,0.0D0,(nkl(ll),ll=1,nsl)\n10 format(a,2i4,5x,1pe12.4,10i3)\n! allocate a record for each endmembers\n allocate(endmem(nend),stat=errall)\n allocate(endmem(1)%constit(nsl),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 10: ',errall\n gx%bmperr=4370; goto 1000\n endif\n charge=zero\n do ll=1,nsl\n endmem(1)%constit(ll)=inkl(ll-1)+1\n loksp=knr(endmem(1)%constit(ll))\n! write(*,*)'3Y species location: ',loksp\n! call get_species_data(loksp,mm,ielno,stoi,smass,qsp)\n! if(gx%bmperr.ne.0) goto 1000\n charge=charge+sites(ll)*splista(loksp)%charge\n enddo\n endmem(1)%charge=charge\n! write(*,15)'3Y end1: ',mode,iph,nsl,charge,1,endmem(1)%constit\n15 format(a,3i3,1pe12.4,i4,2x,8i3)\n if(charge.gt.zero) then\n np=np+1\n elseif(charge.lt.zero) then\n nm=nm+1\n else\n nn=nn+1\n endif\n! write(*,10)'3Y endmem: ',1,0,charge,endmem(1)%constit\n emloop: do i2=2,nend\n! a small allocation\n allocate(endmem(i2)%constit(nsl))\n endmem(i2)%constit=endmem(i2-1)%constit\n sloop: do ll=1,nsl\n if(endmem(i2)%constit(ll).lt.inkl(ll)) then\n exit sloop\n elseif(ll.lt.nsl) then\n endmem(i2)%constit(ll)=endmem(1)%constit(ll)\n else\n exit emloop\n endif\n enddo sloop\n endmem(i2)%constit(ll)=endmem(i2)%constit(ll)+1\n charge=zero\n do mm=1,nsl\n loksp=knr(endmem(i2)%constit(mm))\n charge=charge+sites(mm)*splista(loksp)%charge\n enddo\n endmem(i2)%charge=charge\n! write(*,15)'3Y endx: ',mode,iph,nsl,charge,i2,endmem(i2)%constit\n if(charge.gt.zero) then\n np=np+1\n elseif(charge.lt.zero) then\n nm=nm+1\n else\n nn=nn+1\n endif\n enddo emloop\n mm=nn*nn+np*nm*(nn+np+nm)\n! not using phase grid bit: test_phase_status_bit(iph,PHXGRID)\n! default grid density with this big system\n if(mm.gt.30000) then\n! very many components, minimum number of loops (no low density option)\n ncf=1; maxgp1=maxgp2\n if(btest(globaldata%status,GSXGRID) .or. &\n test_phase_status_bit(iph,PHXGRID)) then\n! higher density requested\n ncf=ncf3; maxgp1=maxgp3\n elseif(btest(globaldata%status,GSYGRID)) then\n! maximum density requested (may cause grid overflow ...)\n ncf=ncf5; maxgp1=maxgp3\n endif\n elseif(mm.gt.10000) then\n! default grid density with a medium size system\n ncf=ncf3; maxgp1=maxgp2\n if(btest(globaldata%status,GSOGRID)) then\n! lower density requested\n ncf=1\n elseif(btest(globaldata%status,GSXGRID) .or. &\n test_phase_status_bit(iph,PHXGRID)) then\n! higher density requested\n ncf=ncf5\n elseif(btest(globaldata%status,GSYGRID))then\n! maximum density requested\n ncf=ncf5; maxgp1=maxgp3\n endif\n else\n! default grid for a small system\n ncf=ncf5; maxgp1=maxgp2\n if(btest(globaldata%status,GSOGRID)) then\n! lower density requested\n ncf=ncf3\n elseif(btest(globaldata%status,GSXGRID) .or. &\n btest(globaldata%status,GSYGRID) .or. &\n test_phase_status_bit(iph,PHXGRID)) then\n! higher density requested, this is maximum\n ncf=ncf5; maxgp1=maxgp3\n endif\n endif\n! the statements below replaced by if statements above\n! if(.not.dense .and. mm.gt.5000) then\n! maxgp1 used to skip some combinations\n! ncf=1; maxgp1=maxgp2\n! elseif(dense) then\n! testing ...\n! ncf=ncf5; maxgp1=maxgp4\n! elseif(dense .or. mm.gt.2000) then\n! ncf=ncf3; maxgp1=maxgp3\n! else\n! maximum dense grid\n! ncf=ncf5; maxgp1=maxgp3\n! endif\n! debug output\n! if(mode.eq.0) then\n! write(*,'(a,10i7)')'3Y Generating charged grid: ',mode,iph,&\n! nend,mm,ncf,maxgp1\n! noc2500 with just C1_MO2 ((12 * 2 * 2)=48 endmem) and GAS gives\n! level C1_MO2 nend mm ncf maxgpl total gridpoints\n! low density 0 22 48 21012 1 10000 11998\n! default 1 3 10000 33284\n! high 2 5 10000 42651\n! maximum 3 5 20000 57446\n!\n! endif\n! now calculate the number of gridpoints, consider single endmembers, \n! binary and ternary combinations in a triple loop\n np=0\n nn=0\n! if(mode.ge.0) then\n! we have saved the number of gridpoints from the mode=-1 call here\n! np=savengg(iph)\n! write(*,*)'3Y allocate neutral: ',mode,alloneut\n! guess a safe value ...\n allocate(neutral(alloneut,0:3),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 11: ',errall\n gx%bmperr=4370; goto 1000\n endif\n neutral=0\n np=0\n if(endout) write(*,*)'3Y starting generating grid in ionic solid phase',nend\n loop1: do i1=1,nend\n charge1A: if(endmem(i1)%charge.eq.zero) then\n! first endmember neutral, one gridpoint\n np=np+1\n if(mode.ge.0) then\n! for generating Y and G we save which endmembers to combine in neutral(*,0)\n neutral(np,0)=0\n neutral(np,1)=i1\n endif\n if(endout) write(*,298)'3Y generated 1 gp: ',np,mode,1,0,i1,0,0\n298 format(a,2i7,2i2,2x,3i4)\n endif charge1A\n gtype(1)=gtype(1)+1\n loop2: do i2=i1+1,nend\n charge1: if(endmem(i1)%charge.eq.zero) then\n! first endmember neutral, that gridpoint already created\n charge2A: if(endmem(i2)%charge.eq.zero) then\n!-----------------------------------------------------------------------\n! second endmember neutral, generate 7 points between them, (the point at pure\n! i2 that will be generated later): 0.01; 0.1; 0.34; 0.51; 0.67; 0.9; 0.99\n if(mode.ge.0) then\n do ll=1,7\n neutral(np+ll,0)=1\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n enddo\n endif\n np=np+7\n if(endout) write(*,298)'3Y generated 7 gps: ',np,mode,3,1,i1,i2,0\n gtype(2)=gtype(2)+7\n else\n!-----------------------------------------------------------------------\n! second endmember has charge, a third endmember needed with opposite charge\n loop3A: do i3=i2+1,nend\n if(endmem(i2)%charge*endmem(i3)%charge.lt.zero) then\n! second and third endmembers have opposite charge, we have ncf gridpoints\n! I1_n(I2_(1/c2)I3_(1/c3)_(1-n) where c2 is charge of i2 and c3 charge of i3\n if(gtype(3).gt.maxgp1) then\n if(skipped) &\n write(*,*)'Skipping gridpoints type 3',gtype(3)\n exit charge2A\n endif\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=2\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3A gps: ',&\n np,mode,3,2,i1,i2,i3\n gtype(3)=gtype(3)+ncf\n endif\n enddo loop3A\n endif charge2A\n!=======================================================================\n! first endmember has a charge\n elseif(endmem(i2)%charge.eq.zero) then\n! second endmember is neutral, we need a third with opposite charge to first\n loop3B: do i3=i2+1,nend\n if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then\n! first and third endmembers have opposite charge, we have ncf gridpoints\n! (I1_(1/c1)I3_(1/c3))_n(I2)_(1-n) where c1 is charge of i1 and c3 charge of i3\n! where n is 0.1; 0.5; 0.9\n if(gtype(4).gt.maxgp1) then\n if(endout) write(*,*)'Skipping gridpoints type 4',gtype(4)\n exit loop3B\n endif\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=3\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3B gps: ',&\n np,mode,3,3,i1,i2,i3\n gtype(4)=gtype(4)+ncf\n endif\n enddo loop3B\n!-----------------------------------------------------------------------\n! first and second endmembers have charge with opposite sign\n elseif(endmem(i1)%charge*endmem(i2)%charge.lt.zero) then \n! we have one gridpoint I1_(1/c1)I2_(1/c2)\n np=np+1\n if(mode.ge.0) then\n neutral(np,0)=4\n neutral(np,1)=i1\n neutral(np,2)=i2\n endif\n if(endout) write(*,298)'3Y generated 1 gp: ',np,mode,1,4,i1,i2,0\n gtype(5)=gtype(5)+1\n!-----------------------------------------------------------------------\n loop3C: do i3=i2+1,nend\n charge3A: if(endmem(i3)%charge.eq.zero) then\n! third is neutral, we have ncf more gripoints\n! at (I1_(1/c1)I2_(1/c2))_n(I3)_(1-n)\n if(gtype(6).gt.maxgp1) then\n if(skipped) write(*,*)'Skipping gridpoints type 6',gtype(6)\n exit charge3A\n endif\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=5\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3C gps: ',&\n np,mode,3,5,i1,i2,i3\n gtype(6)=gtype(6)+ncf\n elseif(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then\n!-------------------------------------------------------------\n! all 3 endmembers are charged, those of i2 and i3 have same sign, ncf gridp\n! (I1_(1/c1)I2_(1/c2))_n(I1_(1/c1)I3_(1/c3))_(1-n)\n if(gtype(7).gt.maxgp1) then\n if(skipped) write(*,*)'Skipping gridpoints type 7',gtype(7)\n exit charge3A\n endif\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=6\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3D gps: ',&\n np,mode,3,6,i1,i2,i3\n gtype(7)=gtype(7)+ncf\n elseif(gtype(8).lt.maxgp1) then\n!-------------------------------------------------------------\n! all 3 endmembers are charged, those of i1 and i3 have same sign, ncf gridp\n! (I1_(1/c1)I2_(1/c2))_n(I2_(1/c2)I3_(1/c3))_(1-n)\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=7\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3E gps: ',&\n np,mode,3,7,i1,i2,i3\n gtype(8)=gtype(8)+ncf\n else\n if(skipped) write(*,*)'Skipping gridpoints type 8,',gtype(8)\n endif charge3A\n enddo loop3C\n!-----------------------------------------------------------------------\n! first and second endmembers have charge with same sign\n elseif(gtype(9).lt.maxgp1) then\n! we need a third endmember with opposite charge unless too many endmembers\n loop3D: do i3=i2+1,nend\n if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then\n! all 3 endmembers are charged, those of i1 and i2 have same sign, ncf gridp\n! (I1_(1/c1)I3_(1/c2))_n(I2_(1/c1)I3_(1/c3))_(1-n)\n if(mode.ge.0) then\n do ll=1,ncf\n neutral(np+ll,0)=8\n neutral(np+ll,1)=i1\n neutral(np+ll,2)=i2\n neutral(np+ll,3)=i3\n enddo\n endif\n np=np+ncf\n if(endout) write(*,298)'3Y generated 3F gps: ',&\n np,mode,3,8,i1,i2,i3\n gtype(9)=gtype(9)+ncf\n endif\n enddo loop3D\n if(endout) write(*,777)'3Y loop3',gtype\n else\n if(skipped) write(*,*)'3Y skipping gridpoints type 9',gtype(9)\n endif charge1\n if(endout) write(*,777)'3Y loop2 ',gtype\n enddo loop2\n if(endout) write(*,777)'3Y loop1 ',gtype\n777 format(a,10i6)\n enddo loop1\n!=======================================================================\n if(endout) write(*,*)'3Y finished all loops for ionic phase: ',ngg\n! if(mode.eq.0) then\n! write(*,*)'3Y ionic crystal: ',iph,np\n! endif\n! if(mode.lt.0) then\n! we have just calculated the number of gridpoints, save and exit\n! write(*,*)'3Y neutral gridpoints: ',np\n! ngg=np\n! savengg(iph)=ngg\n! else\n! Generate the composition of the gridpoints from 1-3 endmembers and\n! if mode=0 calculate the composition and Gibbs energy for the gridpoints\n! if mode>0 return the constitution of gridpoint mode.\n! How do I know mode is mode gridpoint in this phase??\n! write(*,29)'3Y we are here?',iph,mode,np,nsl,inkl(nsl)\n!29 format(a,10i5)\n ncc=inkl(nsl)\n allocate(y1(ncc),stat=errall)\n allocate(y2(ncc),stat=errall)\n allocate(y3(ncc),stat=errall)\n allocate(y4(ncc),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 12: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! write(*,*)'3Y Charged grid: ',mode,nend,ncon,ncc\n! write(*,*)'3Y allocated neutral: ',mode,alloneut,np\n! loopf keeps track if several gridpoints belong together\n! if(.not.(allocated(neutral))) then\n! write(*,*)'3Y ionic liquid has not allocated neutral array'\n! allocate(neutral(alloneut,0:3))\n! neutral=0\n! endif\n loopf=0\n ygen: do nm=1,np\n! neutral(nm,0) is endmember combination (0 to 8), ,1..3) is endmember index\n nn=neutral(nm,0)\n i1=neutral(nm,1)\n i2=neutral(nm,2)\n i3=neutral(nm,3)\n if(loopf.eq.0) then\n! when loopf=0 we have a new set of endmembers, zero yi\n y1=zero\n y2=zero\n y3=zero\n endif\n! we must generate all gridpoints to have corrrect loopf\n! if(mode.gt.0) then\n! if(mode.ne.nm) exit\n! cycle\n! endif\n! now we must generate correct constituent fractions and calculate G (mode=0)\n! write(*,*)'3Y select case',iph,nn\n select case(nn)\n case default\n write(*,*)'3Y case error in generate_charged_grid!!'\n!----------------------- first endmember is neutral, 1 gridpoint\n! single neutral endmember\n case(0)\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n enddo\n y4=y1\n! write(*,300)'3Y gp0 ',nm,nn,loopf,i1,i2,i3,zero,y4\n300 format(a,i5,2i2,3i3,1pe10.2,7(0pf6.3),13(f6.3))\n!----------------------- first and second endmembers are neutral, 7 gridpoints\n! combine with factors: 0.01; 0.10; 0.33; 0.51; 0.67; 0.9; 0.01\n case(1)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n enddo\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=nfact(loopf)*y1(iz)+nfact(8-loopf)*y2(iz)\n enddo\n if(loopf.ge.7) loopf=0\n! write(*,300)'3Y gp1 ',nm,nn,loopf,i1,i2,i3,zero,y4\n!----------------------- first endmember is neutral, 2 and 3 charged, 3 gridp\n! ratio 2/3 depend on charge, ratio 1/(2+3)\n case(2)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i2)%charge)+abs(endmem(i3)%charge))\n ratio2=abs(endmem(i2)%charge)/&\n (abs(endmem(i2)%charge)+abs(endmem(i3)%charge))\n do iz=1,ncc\n y2(iz)=ratio1*y2(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp2 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- first charged, second neutral, third charged, 3 gridp\n! ratio 1/3 depend on charge, ratio 2/(1+3): 0.1; 0.5; 0.9\n case(3)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n! neutral combination of 1 and 3\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n do iz=1,ncc\n y1(iz)=ratio1*y1(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp3 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- first charged, second opposite, 1 gridp\n! ratio 1/2 depend on charge\n case(4)\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n enddo\n! neutral combination of 1 and 2\n ratio1=abs(endmem(i2)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n do iz=1,ncc\n y4(iz)=ratio1*y1(iz)+ratio2*y2(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge\n! write(*,300)'3Y gp4 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- first charged, second opposite, third neutral, 3 gridp\n! ratio 1/2 depend on charge, ratio 3(1+2): 0.1; 0.5; 0.9\n case(5)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n! neutral combination of 1 and 2\n ratio1=abs(endmem(i2)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n do iz=1,ncc\n y1(iz)=ratio1*y1(iz)+ratio2*y2(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp5 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- all charged, 2 and 3 same sign, 3 gridp\n! ratio depend on charge\n case(6)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n! neutral combination of 1 and 3\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n do iz=1,ncc\n y3(iz)=ratio1*y1(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge\n! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,&\n! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,&\n! ratio1,ratio2,charge\n! neutral combination of 1 and 2\n ratio1=abs(endmem(i2)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i1)%charge)+abs(endmem(i2)%charge))\n do iz=1,ncc\n y1(iz)=ratio1*y1(iz)+ratio2*y2(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp6 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- all charged, 1 and 3 same sign, 3 gridp\n! ratio depend on charge\n case(7)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n! neutral combination of 1 and 2\n ratio1=abs(endmem(i2)%charge)/&\n (abs(endmem(i2)%charge)+abs(endmem(i1)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i2)%charge)+abs(endmem(i1)%charge))\n do iz=1,ncc\n y1(iz)=ratio1*y1(iz)+ratio2*y2(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge\n! write(*,410)'3Y gp charge 1+2: ',nm,i1,i2,i3,&\n! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,&\n! ratio1,ratio2,charge\n! neutral combination of 2 and 3\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i2)%charge))\n ratio2=abs(endmem(i2)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i2)%charge))\n do iz=1,ncc\n y2(iz)=ratio1*y2(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp7 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- all charged, 1 and 2 same sign, 3 gridp\n! ratio depend on charge\n case(8)\n if(loopf.eq.0) then\n do ll=1,nsl\n y1(endmem(i1)%constit(ll))=one\n y2(endmem(i2)%constit(ll))=one\n y3(endmem(i3)%constit(ll))=one\n enddo\n! neutral combination of 1 and 3\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n ratio2=abs(endmem(i1)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i1)%charge))\n do iz=1,ncc\n y1(iz)=ratio1*y1(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge\n! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,&\n! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,&\n! ratio1,ratio2,charge\n410 format(a,i4,3i3,6(1pe10.2))\n! neutral combination of 2 and 3\n ratio1=abs(endmem(i3)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i2)%charge))\n ratio2=abs(endmem(i2)%charge)/&\n (abs(endmem(i3)%charge)+abs(endmem(i2)%charge))\n do iz=1,ncc\n y2(iz)=ratio1*y2(iz)+ratio2*y3(iz)\n enddo\n charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge\n endif\n loopf=loopf+1\n do iz=1,ncc\n y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz)\n enddo\n if(loopf.ge.ncf) loopf=0\n! write(*,300)'3Y gp8 ',nm,nn,loopf,i1,i2,i3,charge,y4\n!----------------------- \n end select\n! if(iph.ge.72) write(*,*)'3Y end select',iph,mode\n!===============================================================\n! Here we have the neutral constituent fraction in y4\n! if mode>0 we have found the requested constitution\n! if(mode.lt.0) then\n! write(*,*)'3Y We should never be here ...'\n! goto 1000\n if(mode.gt.0) then\n if(mode.eq.nm) then\n! ncc and ncon should be identical, ny is returned as number of constituents\n ny=ncc\n do ll=1,ny\n yarr(ll)=y4(ll)\n enddo\n! write(*,507)'3Y Solution gp: ',mode,ny,y4\n507 format(a,2i5,10F7.4)\n goto 1000\n endif\n! continue searching for correct gridpoint of the solution\n else\n ngg=ngg+1\n if(ngg.gt.maxngg) then\n write(*,*)'3Y too many gripoints 3',ngg,maxngg,iph\n gx%bmperr=4399; goto 1000\n endif\n if(ngg.gt.0 .and. mod(ngg,30000).eq.0) &\n write(*,*)'3Y Gridmin calculated ',ngg,' gridpoints for ',&\n trim(phlista(lokph)%name)\n call calc_gridpoint(iph,y4,nrel,xarr(1,ngg),garr(ngg),ceq)\n if(lutbug.gt.0) then\n! ny, ncon, ncc ??\n write(lutbug,710)'I: ',ngg,nrel,ncon,garr(ngg),&\n (xarr(jj,ngg),jj=1,nrel),(y4(jj),jj=1,ncon)\n710 format(a,i5,2i3,1pe10.2,20(0pF6.3))\n endif\n if(gx%bmperr.ne.0) goto 1000\n! created a bug here, used ngg instead of nm .... suck\n! if(garr(ngg).gt.gmax) gmax=garr(ngg)\n if(garr(ngg).gt.gmax) gmax=garr(ngg)\n! write(*,512)nm,qq(2),gdum,(xarr(ll,nm),ll=1,nrel)\n512 format('3Y gridpoint: ',i5,2(1pe12.4),7(0pF5.2),14(F5.2))\n! if(iph.ge.72) then\n! write(*,*)'3Y calling done'\n! write(*,515)(xarr(ll,nm),ll=1,nrel)\n!515 format('3Y yx: ',10F6.3)\n! endif\n endif\n enddo ygen\n!\n1000 continue\n! deallocate creates problems ...\n! if(allocated(savengg)) then\n! deallocate(savengg)\n! deallocate(endmem)\n! endif\n! if(allocated(neutral)) then\n! deallocate(neutral)\n! deallocate(y1)\n! deallocate(y2)\n! deallocate(y3)\n! deallocate(y4)\n! endif\n! restore original constitution\n! write(*,*)'3Y Gridpoints for: ',iph,mode,np\n call set_constitution(iph,1,ydum,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error restoring constitution for: ',iph,gx%bmperr\n endif\n return\n end subroutine generate_charged_grid\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine calc_gridpoint\n!\\begin{verbatim}\n subroutine calc_gridpoint(iph,yfra,nrel,xarr,gval,ceq)\n! called by global minimization routine\n! Not adopted to charged crystalline phases as gridpoints have net charge\n! but charged gripoints have high energy, better to look for neutral ones ...\n implicit none\n real xarr(*),gval\n integer iph,nrel\n double precision yfra(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! ny just needed for debugging ...\n integer i,lokres,lokph\n double precision qq(5),xmol(nrel),ytemp(maxconst),gg,ss\n TYPE(gtp_phase_varres), pointer :: varres\n! set constitution and calculate G per mole atoms and composition\n!\n! BEWARE must be tested for parallel processing\n!\n! write(*,'(a,F8.2)')'3Y in calc_gridpoint',globaldata%sysreal(1)\n call set_constitution(iph,1,yfra,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y constitution set',qq(1)\n call calcg(iph,1,0,lokres,ceq)\n! write(*,*)'3Y calculated G error:',gx%bmperr\n if(gx%bmperr.ne.0) goto 1000\n call calc_phase_mol(iph,xmol,ceq)\n! write(*,*)'3Y calculated x, error:',gx%bmperr\n if(gx%bmperr.ne.0) goto 1000\n!-------------------------------------------------\n! globaldata%sysreal(1) is positive if EEC activated\n if(globaldata%sysreal(1).gt.one) then\n! if eec check if this is the liquid and if so select the maximum S ??\n varres=>ceq%phase_varres(lokres)\n lokph=varres%phlink\n! value per mole component gres(2,1) is the -entropy NOTE ss is postive!!\n ss=-varres%gval(2,1)/qq(1)\n gg=varres%gval(1,1)\n! I do not understand why iph and lokph is not the same!!\n! write(*,*)'3Y liqtest: ',iph,lokph\n eecheck: if(btest(phlista(lokph)%status1,PHLIQ)) then\n! write(*,*)'In calc_gridpoint liquid: ',sliqmax\n! if(sliqmax.gt.zero) exit eecheck\n! neecgrid=neecgrid+1\n! note varres%gval(2,1) is -S !! Should we test max or min of liquid S ??\n! write(*,*)'Determining sliqmax: ',ss,sliqmax\n if(ss.gt.sliqmax) then\n! write(*,'(a,i3,5(1pe10.2))')'Liquid gridpoint: ',iph,&\n! ss,sliqmin,gliqeec,varres%gval(1,1)/qq(1)\n sliqmax=ss; gliqeec=varres%gval(1,1)/qq(1)\n endif\n! note sliqmax is - dg/dt and always positive. It is the max entropy\n! for the liquid at any gridpoint. If the solid has higher entropy\n! it should not be allowed to be stable.\n elseif(sliqmax.gt.zero) then\n! this is a solid and we have a value for sliqmax for EEC to work better\n! write(*,*)'In calc_gridpoint solid: ',varres%gval(2,1)/qq(1),sliqmax\n if(ss.gt.sliqmax) then\n! the solid s=-dG/dt is larger than sliqmax make the G more positive\n! Note values are divided by RT. Multiply with the number of atoms?\n varres%gval(1,1)=(gg+1.5D1)\n! varres%gval(1,1)=(gliqeec+one)\n! write(*,'(a,2i3,5(1pe10.2))')'3Y Solid corr: ',iph,lokres,&\n! ss,sliqmax,gg,varres%gval(1,1),qq(1)\n endif\n else\n write(*,*)'3Y Gridminimizer has no Sliqmax for solid',iph\n endif eecheck\n! list EEC values\n! write(*,11)'3Y EEC set: ',iph,xmol(1),ss,sliqmax,gg,varres%gval(1,1)\n11 format(a,i3,F8.4,5(1pe12.4))\n endif\n!--------------------------------------\n do i=1,nrel\n xarr(i)=real(xmol(i))\n enddo\n! write(*,111)'3Y X:',qq(1),(xarr(i),i=1,nrel)\n111 format(a,1pe12.4,20(F8.4))\n! handle special problems\n if(qq(1).lt.5.0D-1) then\n! number of real atoms less than 50%, a gridpoint with mainly vacancies ....\n! write(*,12)'3Y real atoms less than 0.5',lokres,qq(1),&\n! ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n12 format(a,i5,3(1pe12.4))\n gval=1.0E3\n! gval=max(1.0E2,real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)))\n elseif(abs(qq(2)).gt.1.0D-14) then\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! the gridpoint has net charge, qq(2), make gval more positive. \n! Note gval(1,1) is divided by RT so around -5<0\n! There is special grid generator combining charged gripoints!!!!\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+20*qq(2)**2)\n! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+5*qq(2)**2)\n write(*,*)'3Y Problem with net charge ',iph,qq(2)\n gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+qq(2)**2)\n if(ocv()) write(*,66)'3Y charged gp: ',&\n ceq%phase_varres(lokres)%gval(1,1)/qq(1),qq(1),abs(qq(2))\n66 format(a,6(1pe12.4))\n else\n gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1))\n endif\n! write(*,'(a,1pe10.2,10(0pF6.3))')'3Y gp: ',gval,(xarr(i),i=1,nrel)\n! write(*,12)'All gridpoints: ',lokres,qq(1),gval\n! read(*,20)ch1\n20 format(a)\n1000 continue\n return\n end subroutine calc_gridpoint\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine calcg_endmember\n!\\begin{verbatim}\n subroutine calcg_endmember(iphx,endmember,gval,ceq)\n! calculates G for one mole of real atoms for a single end member\n! used for reference states. Restores current composition (but not G or deriv)\n! endmember contains indices in the constituent array, not species index\n! one for each sublattice\n! HERE G is divided by the number of atoms in the endmember\n implicit none\n integer iphx\n double precision gval\n integer endmember(maxsubl)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer iph,ierr,kk0,ll,lokres,nsl,lokph\n integer nkl(maxsubl),knr(maxconst)\n double precision savey(maxconst),sites(maxsubl),yfra(maxconst)\n double precision qq(5),saveg(6)\n! when called by matsmin negative iph should be interpreted as index to\n! phlista, convert to phase index ... suck\n if(iphx.lt.0) then\n iph=phlista(-iphx)%alphaindex\n else\n iph=iphx\n endif\n! write(*,*)'3Y calcg_endmember: ',iphx,' ',trim(phlista(abs(iphx))%name),&\n! iph,' ',trim(phlista(iph)%name)\n!\n call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1100\n! set constitution to be just the endmember\n! It is difficult to make this simpler as one can have magnetic contributions\n! to G, thus it is not sufficient just to calculate the G function, one must\n! calculate TC etc.\n yfra=zero\n kk0=0\n do ll=1,nsl\n if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then\n yfra(endmember(ll))=one\n else\n write(*,16)'3Y endmember outside range 1: ',iph,ll,endmember(ll),&\n kk0,kk0+nkl(ll)\n16 format(a,10i5)\n gx%bmperr=4160; goto 1100\n endif\n kk0=kk0+nkl(ll)\n enddo\n! write(*,17)'3Y set: ',kk0,(yfra(ll),ll=1,kk0)\n17 format(a,i3,5(1pe12.4))\n call set_constitution(iph,1,yfra,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! this was necessary using this routine when reference states are\n! defined for components\n! The calcg below returns lokres but we need it to save G values first!!!\n call get_phase_compset(iph,1,lokph,lokres)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y saving gval: ',lokres,iph\n do ll=1,6\n saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)\n enddo\n! just calculate Gm no derivatives!\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(qq(1).ge.1.0D-2) then\n! avoid calculating endmembers with too many vacancies. gval is divided by RT\n gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! write(*,*)'3Y gval: ',gval,qq(1)\n else\n! write(*,*)'3Y End member has no atoms'\n gx%bmperr=4161; goto 1000\n endif\n1000 continue\n! restore constitution and gval even if there has been an error flag!!\n ierr=gx%bmperr\n if(gx%bmperr.ne.0) gx%bmperr=0\n! write(*,17)'3Y res: ',kk0,(savey(i),i=1,kk0)\n do ll=1,6\n ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll)\n enddo\n call set_constitution(iph,1,savey,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y Error resetting constitution: ',ierr,gx%bmperr\n endif\n! return first error if any\n if(ierr.ne.0) gx%bmperr=ierr\n1100 continue\n return\n end subroutine calcg_endmember\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine calcg_endmemberx\n!\\begin{verbatim}\n subroutine calcg_endmemberx(iphx,endmember,gval,ceq)\n! calculates G for single end member with current number of atoms\n! used for reference states. Restores current composition (but not G or deriv)\n! endmember contains indices in the constituent array, not species index\n! one for each sublattice\n! THIS ONE does not divide with the number of atoms\n implicit none\n integer iphx\n double precision gval\n integer endmember(maxsubl)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer iph,ierr,kk0,ll,lokres,nsl,lokph\n integer nkl(maxsubl),knr(maxconst)\n double precision savey(maxconst),sites(maxsubl),yfra(maxconst)\n double precision qq(5),saveg(6)\n! when called by matsmin negative iph should be interpreted as index to\n! phlista, convert to phase index ... suck\n if(iphx.lt.0) then\n iph=phlista(-iphx)%alphaindex\n else\n iph=iphx\n endif\n! write(*,*)'3Y calcg_endmember: ',iphx,' ',trim(phlista(abs(iphx))%name),&\n! iph,' ',trim(phlista(iph)%name)\n!\n call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1100\n! set constitution to be just the endmember\n! It is difficult to make this simpler as one can have magnetic contributions\n! to G, thus it is not sufficient just to calculate the G function, one must\n! calculate TC etc.\n yfra=zero\n kk0=0\n do ll=1,nsl\n if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then\n yfra(endmember(ll))=one\n else\n write(*,16)'3Y endmember outside range 1: ',iph,ll,endmember(ll),&\n kk0,kk0+nkl(ll)\n16 format(a,10i5)\n gx%bmperr=4160; goto 1100\n endif\n kk0=kk0+nkl(ll)\n enddo\n! write(*,17)'3Y set: ',kk0,(yfra(ll),ll=1,kk0)\n17 format(a,i3,5(1pe12.4))\n call set_constitution(iph,1,yfra,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! this was necessary using this routine when reference states are\n! defined for components\n! The calcg below returns lokres but we need it to save G values first!!!\n call get_phase_compset(iph,1,lokph,lokres)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y saving gval: ',lokres,iph\n do ll=1,6\n saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)\n enddo\n! just calculate Gm no derivatives!\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! DO NOT DIVIDE WITH QQ\n gval=ceq%phase_varres(lokres)%gval(1,1)\n1000 continue\n! restore constitution and gval even if there has been an error flag!!\n ierr=gx%bmperr\n if(gx%bmperr.ne.0) gx%bmperr=0\n! write(*,17)'3Y res: ',kk0,(savey(i),i=1,kk0)\n do ll=1,6\n ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll)\n enddo\n call set_constitution(iph,1,savey,qq,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y Error resetting constitution: ',ierr,gx%bmperr\n endif\n! return first error if any\n if(ierr.ne.0) gx%bmperr=ierr\n1100 continue\n return\n end subroutine calcg_endmemberx\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine calcg_endmember6\n!\\begin{verbatim} %-\n subroutine calcg_endmember6(iph,endmember,gval,ceq)\n! calculates G AND ALL DERIVATEVS wrt T and P for one mole of real atoms\n! for a single end member, used for reference states. \n! Restores current composition and G (but not deriv)\n! endmember contains indices in the constituent array, not species index\n! one for each sublattice\n! THIS ONE returns 6 values: G, dG/dT; dG/dP; d2G/dT2; d2G/dTdP; d2G/dP2\n implicit none\n integer iph\n double precision gval(6)\n integer endmember(maxsubl)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ierr,kk0,ll,lokres,lokph,nsl\n integer nkl(maxsubl),knr(maxconst),ics\n double precision savey(maxconst),sites(maxsubl),qq(5),yfra(maxconst)\n double precision saveg(6),savedabnorm(3)\n!\n call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq)\n if(gx%bmperr.ne.0) goto 1100\n! set constitution to be just the endmember\n! It is difficult to make this simpler as one can have magnetic contributions\n! to G, this it is not sufficient just to calculate the G function, one must\n! calculate TC etc.\n yfra=zero\n kk0=0\n! NOTE abnorm(1) not restored by setting constitution, why?\n ics=1\n call get_phase_compset(iph,ics,lokph,lokres)\n if(gx%bmperr.ne.0) goto 1000\n savedabnorm=ceq%phase_varres(lokres)%abnorm\n! write(*,432)'3Y em6a: ',ceq%phase_varres(lokres)%gval(3,1),&\n! ceq%phase_varres(lokres)%abnorm(1),ceq%phase_varres(lokres)%amfu\n432 format(a,6(1pe12.4))\n! write(*,11)'3Y refstate: ',iph,nsl,nkl(1),endmember(1)\n11 format(a,10i5)\n do ll=1,nsl\n if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then\n yfra(endmember(ll))=one\n else\n write(*,16)'3Y endmember outside range 2',ll,endmember(ll),&\n kk0,nkl(ll)\n16 format(a,10i5)\n gx%bmperr=4160; goto 1100\n endif\n kk0=kk0+nkl(ll)\n enddo\n! write(*,17)'set: ',kk0,(yfra(i),i=1,kk0)\n17 format(a,i3,5(1pe12.4))\n call set_constitution(iph,1,yfra,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! we do not know lokres here !! YES we do now\n! ics=1\n! call get_phase_compset(iph,ics,lokph,lokres)\n! if(gx%bmperr.ne.0) goto 1000\n do ll=1,6\n! Why dividing with qq(1)???\n! saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1)\n saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)\n enddo\n! third argument to calcg is 2 to calculate all derivatives\n call calcg(iph,1,2,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(qq(1).ge.1.0D-2) then\n! avoid calculating endmembers with too many vacancies. gval is divided by RT\n! gval(1..6,1) are G, G.T, G.P, G.T.T, G.T.P and G.P.P\n do ll=1,6\n gval(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1)\n enddo\n else\n! write(*,*)'End member has no atoms'\n gx%bmperr=4161; goto 1000\n endif\n! we do not restore values of other properties like TC BMAGN etc\n do ll=1,6\n ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll)\n enddo\n1000 continue\n ierr=gx%bmperr\n if(gx%bmperr.ne.0) gx%bmperr=0\n! restore constitution\n! write(*,17)'res: ',kk0,(savey(i),i=1,kk0)\n call set_constitution(iph,1,savey,qq,ceq)\n! this is probably redundant ...\n ceq%phase_varres(lokres)%abnorm=savedabnorm\n! write(*,432)'3Y em6b: ',ceq%phase_varres(lokres)%gval(3,1),&\n! ceq%phase_varres(lokres)%abnorm(1),ceq%phase_varres(lokres)%amfu\n if(gx%bmperr.ne.0) then\n if(ierr.ne.0) then\n write(*,*)'Double errors in calcg_endmember: ',ierr,gx%bmperr\n endif\n endif\n! return first error if any\n if(ierr.ne.0) gx%bmperr=ierr\n1100 continue\n return\n end subroutine calcg_endmember6\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine find_gridmin\n!\\begin{verbatim}\n subroutine find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace)\n! there are kp gridpoints, nrel is number of components\n! composition of each gridpoint in xarr, G in garr\n! xknown is the known overall composition\n! return the gridpoints of the solution in jgrid, the phase fraction in phfrac\n! cmu are the final chemical potentials\n implicit none\n integer, parameter :: jerr=50\n integer kp,nrel\n integer, dimension(*) :: jgrid\n real xarr(nrel,*),garr(*)\n double precision xknown(*),phfrac(*),cmu(nrel)\n logical trace\n!\\end{verbatim}\n!------------------------------------------------------------------------\n! How to include conditions on chemical potentials (activities) ??\n! Assume mix of conditions N(A)=value and MU(B)=value\n! 1. find gridpoints with phase alpha for pure A with highest MU(A),\n! set NP(alpha)=N(A) \n! 2. Tangent plane is \\sum_A MU(A)+\\sum_B MU(B)\n! 2. seach gridpoint with composition N(C) most below tangent plane \n! 3. setup matrix with rows \\sum_alpha N(alpha,A)*NP(alpha) = N(A) \n! replacing the gridpoints one by onw with the new\n! to find a set of gridpoints with positive NP(alpha)\n! 4. replace the gridpoint that gives positive NP(alpha) with the new\n! 5. repeat from 3 intil no gridpoint lower\n! The set of gridpoints should now fullfill the massbalance for A and MU(B)\n!---------------------------------------------------------------------------\n! inverting just a C1_MO2 phase I got phfmain around 1.0e-13 as smallest\n double precision, parameter :: phfmin=1.0D-15\n real xmat(nrel,nrel),xmatsave(nrel,nrel),xmaxx(nrel)\n! used to solve the linear system of equations\n double precision qmat(nrel,nrel+1),qmatsave(nrel,nrel+1)\n double precision zmat(nrel,nrel+1),cmusave(nrel)\n integer notuse(kp),i,ie,iel,ierr,iesave,inerr,inuse,ip,je,jj,jp,jsave,nj\n integer nrel1,nyp,griter,nopure(nrel),gpfail,evigloop\n double precision phfsave(nrel)\n integer, dimension(jerr) :: removed\n real gmin(nrel),dg,dgmin,gplan,gy,gvvp\n! gridpoints that has less difference with the plane than this limit is ignored\n real, parameter :: dgminlim=1.0E-6\n logical checkremoved,linglderr,grindingon,failadd\n character ch1*1\n! if trace then open file to write grid\n linglderr=.FALSE.\n grindingon=.TRUE.\n failadd=.TRUE.\n if(trace) then\n write(*,*)'3Y Opening ocgrid.dat to write grid solution'\n open(31,file='ocgrid.dat ',access='sequential')\n write(31,700)nrel,kp,(xknown(inuse),inuse=1,nrel)\n700 format('Output from OC gridmin'/' Elements: ',i2,', gridpoints: ',i5,&\n ', composition: '/6(F7.4))\n write(31,*)' Gridpoints in use: '\n do inuse=1,kp\n write(31,710)inuse,(xarr(inerr,inuse),inerr=1,nrel),garr(inuse)\n710 format(i6,6(1pe12.4))\n enddo\n endif\n! initiallize local arrays\n inuse=kp\n inerr=0\n removed=0\n notuse=0\n cmu=zero\n xmat=zero\n qmat=zero\n do je=1,nrel\n xmat(je,je)=9.9D-1\n jgrid(je)=0\n enddo\n nrel1=nrel+1\n checkremoved=.false.\n! write(*,11)'3Y fm8: ',(xknown(i),i=1,nrel)\n!11 format(a,7(F8.4))\n! Find the lowest Gibbs energy as close as possible to each pure element\n! or with max content\n nopure=0\n! skip code below until label 88\n goto 88\n!----------------------------------------------------------------------\n do ip=1,kp\n! write(*,118)'3Y pure: ',ip,(xarr(je,ip),je=1,nrel)\n118 format(a,i5,10F6.3)\n do je=1,nrel\n if(xarr(je,ip).ge.xmat(je,je)) then\n if(jgrid(je).gt.0) then\n if(garr(ip).gt.gmin(je)) goto 120\n! if(gmin(je).lt.garr(ip) .and. &\n! xarr(je,ip).eq.xmat(je,je)) then\n! goto 120\n! endif\n endif\n xmat(je,je)=xarr(je,ip)\n jgrid(je)=ip\n gmin(je)=garr(ip)\n! write(*,*)'3Y pure: ',je,ip,gmin(je)\n! elseif(jgrid(je).eq.0 .and. xarr(je,ip).gt.xmaxx(je)) then\n! failed attempt to handle cases with no gridpoint for a pure element\n! xmaxx(je)=xarr(je,ip)\n! nopure(je)=ip\n! gmin=garr(ip)\n! write(*,*)'3Y nopure: ',je,ip,xarr(je,ip)\n endif\n120 continue\n enddo\n enddo\n! check that we have nrel gridpoints for the pure elements\n do je=1,nrel\n if(jgrid(je).eq.0) then\n! no gridpoint assigned to this element!! error (note C in pure fcc has no gp)\n! gx%bmperr=4149; goto 1000\n write(*,122)'3Y Warning, no gridpoint for pure element ',je\n! nopure(je),xmaxx(je)\n122 format(a,2i5,2F7.4)\n if(nopure(je).eq.0) then\n! write(*,122)'3Y No solubility in any phase for element ',je\n gx%bmperr=4149; goto 1000\n elseif(xarr(je,nopure(je)).gt.xknown(je)) then\n! accept gripoint with highest content of element je outside known composition\n do ie=1,nrel\n xmat(ie,je)=xarr(ie,nopure(je))\n enddo\n gmin(je)=garr(ip)\n phfrac(je)=xknown(je)\n else\n write(*,122)'3Y Composition outside phase compositions for element',&\n je,nopure(je),xmaxx(je),xknown(je)\n gx%bmperr=4149; goto 1000\n endif\n else\n ip=jgrid(je)\n do ie=1,nrel\n xmat(ie,je)=xarr(ie,ip)\n enddo\n gmin(je)=garr(ip)\n phfrac(je)=xknown(je)\n endif\n enddo\n! skip code above-----------------------------------------\n88 continue\n! set start matrix with chemical potential equal to cmu(1) (max G all gridpoint)\n! for all components\n do iel=1,nrel\n phfrac(iel)=xknown(iel)\n xmat(iel,iel)=one\n cmu(iel)=1.0D8\n! jgrid value here is dummy ...\n jgrid(iel)=kp+iel\n! we must also set gridpoint enegies!!! maybe 1.0D20 better ....\n gmin(iel)=1.0D8\n enddo\n! check inial chemical potentials and gripoint energies...\n! write(*,63)'3Ymu: ',(cmu(ie),ie=1,nrel)\n!63 format(a,8(1pe10.2))\n! write(*,63)'3Ygm: ',(gmin(ie),ie=1,nrel)\n! Add nrel \"gridpoints\" for the pure elements\n! kp=kp+nrel\n! output of start matrix\n! do ip=1,nrel\n! write(*,121)ip,phfrac(ip),cmu(ip),(xmat(je,ip),je=1,nrel)\n! enddo\n! write(*,119)'3Y start: ',0,0,kp,zero,(jgrid(ip),ip=1,nrel)\n119 format(a,3i6,1pe12.4/(12i6))\n121 format('3Y: ',i2,2(1pe10.2),12(0pf5.2))\n123 format('3Y: ',i2,1pe12.4,10(0pf6.3))\n! looking for tbase calculation error\n! if(trace) write(*,770)(jgrid(je),je=1,nrel)\n!770 format('Initial set of gridpoints: ',(/15i5))\n do je=1,nrel\n if(one-xmat(je,je).lt.1.0d-12) then\n cmu(je)=dble(gmin(je))\n else\n! we should have a composition for an almost pure element\n gx%bmperr=4150; goto 1000\n endif\n enddo\n! copy this into qmat (double precision)\n do ie=1,nrel\n do je=1,nrel\n qmat(je,ie)=dble(xmat(je,ie))\n enddo\n enddo\n qmatsave=qmat\n! debug output\n! do je=1,nrel\n! write(*,177)'3Y fm4: ',jgrid(je),phfrac(je),(xmat(ie,je),ie=1,nrel)\n! enddo\n177 format(a,i5,1pe11.3,2x,5(1pe11.3))\n gvvp=zero\n do ie=1,nrel\n gvvp=gvvp+xknown(ie)*cmu(ie)\n enddo\n if(trace) then\n write(31,715)nrel\n715 format(/'3Y Initial matrix:',i3)\n do je=1,nrel\n write(31,720)'3Y1:',xknown(je),xknown(je),(xmat(ie,je),ie=1,nrel)\n enddo\n720 format(a,2F7.4,1x,8f7.3)\n write(31,730)gvvp,(cmu(je),je=1,nrel)\n730 format('3Y Gibbs energy: ',1pe14.6/'Chemical potentials: '/6(1pe12.4))\n endif\n griter=0\n gpfail=0\n! write(*,175)'3Y ini: ',gvvp,(cmu(ie),ie=1,nrel)\n175 format(a,(1e12.4),2x,6(1pe12.4))\n! write(*,*)'3Y gvvp: ',gvvp\n! check we have the correct global composition\n! call chocx('fgm1 ',nrel,jgrid,phfrac,xmat)\n! if(gx%bmperr.ne.0) goto 1000\n! write(*,173)gvvp,(jgrid(i),i=1,nrel)\n173 format('3Y fms: ',1pe12.4,10i5)\n! read(*,174)ch1\n!174 format(a)\n!----------------------------------------------------------\n! All setup for starting the search\n! search the gridpoint most below the current hyperplane, cmu are \n! the chemical potentials of each pure element for the current lowest plane.\n! set notuse nonzero for all points above so they can be skipped next time\n! TBASE problem, notuse suspended as a point may fall below later ... ???\n evigloop=0\n200 continue\n griter=griter+1\n dgmin=zero\n nyp=0\n! write(*,*)'3Y Gridpoints in use: ',inuse\n! ovall=zero\n! do i=1,nrel\n! ovall=ovall+xknown(i)*cmu(i)\n! enddo\n! write(*,203)'3Y ff:',inuse,ovall,(cmu(je),je=1,nrel)\n203 format(a,i4,1pe12.4,6(1pe11.3))\n pointloop: do jp=1,kp\n included: if(notuse(jp).eq.0) then\n gplan=zero\n! first index in xarr is component, second is gridpoint\n do iel=1,nrel\n gplan=gplan+xarr(iel,jp)*cmu(iel)\n enddo\n dg=garr(jp)-gplan\n! write(*,209)'3Y fmz: ',dg,garr(jp),gplan\n209 format(a,3(1pe12.4))\n if(dg.gt.zero) then\n! inuse=inuse-1\n! we cannot be sure that a point that has a positive value now will always be\n! above the surface of the chemical potentials!!!\n! notuse(jp)=1\n else\n! if this is the most negative dg we should include it in the solution\n if(dg.lt.dgmin) then\n dgmin=dg; nyp=jp\n! write(*,*)'3Y Lower G: ',griter,nyp,kp,dgmin\n endif\n! debugging LC_CsI (61) and SC_CsI (94)\n! if(jp.eq.61 .or. jp.eq.94) &\n! write(*,44)'3Y extra: ',jp,dg,dgmin,garr(jp),gplan\n44 format(a,i5,5(1pe12.4))\n endif\n! else\n! write(*,*)'3X Excluded: ',griter,jp\n endif included\n enddo pointloop\n!-----------------------------------------------------------\n! OUTPUT AFTER EACH SEARCH\n! if lower gridpoint nyp>0\n! write(*,43)griter,nyp,kp,dgmin,(jgrid(ie),ie=1,nrel)\n43 format('3Y Finished loop ',i6,' for all gridpoints: ',2i6,1pe12.4/12i6)\n! TBASE bug------------------------\n! jp=94\n! do iel=1,nrel\n! gplan=gplan+xarr(iel,jp)*cmu(iel)\n! enddo\n! dg=garr(jp)-gplan\n! write(*,7677)jp,gplan,garr(jp),dg,(xarr(iel,jp),iel=1,nrel)\n!7677 format('3Y Gridpoint: ',i5,3(1pe12.4)/(10f7.4))\n! TBASE bug------------------------end\n! if nyp=0 we have found the lowest tangent plane including the composition\n if(nyp.eq.0 .or. abs(dgmin).lt.dgminlim) then\n if(trace) write(31,*)'Found the solution after iterations: ',griter,dgmin\n! write(31,*)'Found the solution after iterations: ',griter,dgmin\n goto 900\n else\n if(trace) write(*,*)'3Y new gridpoint: ',griter,nyp,dgmin\n endif\n! inuse=inuse-1\n notuse(nyp)=1\n! write(*,211)'3Y ny:',nyp,dgmin,(xarr(ie,nyp),ie=1,nrel)\n! if(trace) write(*,212)'3Y Found gridpoint ',nyp,inuse,dgmin,garr(nyp)\n! evigloop happends when two gridpoints are exchanged\n! uncomment the line below indicated gridmin can be improved ...\n! write(*,212)'3Y Found gridpoint ',nyp,inuse,dgmin,garr(nyp)\n211 format(a,i7,1pe12.4,0pf7.4,6f7.4,(3x,10f7.4))\n212 format(a,2i8,6(1pe11.3))\n!-------------------------------------------------------------------------\n! A case found when this seach never enden\n evigloop=evigloop+1\n if(evigloop.gt.500) then\n write(*,*)'3Y Gridmin gives up finding minimal set of gridpoints',evigloop\n goto 900 \n endif\n qmat=qmatsave\n do i=1,nrel\n phfsave(i)=phfrac(i)\n enddo\n ie=0\n! loop to try to replace an old gridpoint by nyp. Try to replace all.\n300 continue\n ie=ie+1\n if(ie.gt.nrel) then\n! tried to change all columns but no solution, error\n! write(*,301)'3Y Failed gp: ',nyp,gpfail,(xarr(i,nyp),i=1,nrel)\n301 format(a,i7,i3,1pe10.2,2x,8(0pF5.2))\n gpfail=gpfail+1\n if(griter.gt.10*nrel .and. gpfail.gt.8*nrel) then\n! this must be wrong!! Maybe someone can understand it ...\n if(grindingon) then\n write(*,*)'3Y Grid minimizer problem but grinding on '\n grindingon=.false.\n endif\n! gx%bmperr=4346; goto 1000\n endif\n! listing restored solution ......\n! xtx=zero\n! do jjq=1,nrel\n! write(*,177)'3Y flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel)\n! do jjz=1,nrel\n! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq)\n! enddo\n! enddo\n! gvv=zero\n! do jjq=1,nrel\n! gvv=gvv+xtx(jjq)*cmu(jjq)\n! enddo\n! write(*,175)'3Y cur: ',gvv,(cmu(ie),ie=1,nrel)\n!\n! >>>> problem with gas phase test case cho1 with x(c)=.2 x(o)=x(H)=.4\n! The gridpoints returned not good, probably due to too many gridpoints ...\n!\n if(trace) write(*,*)'3Y Failed when trying to add gridpoint ',nyp\n if(failadd) then\n write(*,*)'3Y Failed trying to use some gridpoints ' \n failadd=.false.\n endif\n if(checkremoved) goto 950\n! just ignore this gridpoint and continue, it has been added to notuse\n! and will be checked again later as \"removed\"\n inerr=inerr+1\n if(inerr.gt.jerr) then\n inerr=1\n endif\n removed(inerr)=nyp\n goto 200\n endif\n! replace one column in qmat by new composition\n do je=1,nrel\n qmat(je,ie)=dble(xarr(je,nyp))\n enddo\n! right hand side are the known composition\n do je=1,nrel\n qmat(je,nrel1)=xknown(je)\n enddo\n! solver, note qmat is destroyed inside lingld, nrel is dimension\n! qmat matrix with left hand side as additional column i.e. QMAT(1..ND1,ND2)\n! phfrac(ND1) is result array, nz number of unknown, ierr nonzero=error\n! do ik=1,nrel1\n! write(*,317)'3Y fm6A: ',(qmat(je,ik),je=1,nrel)\n! enddo\n! do je=1,nrel\n! write(*,55)(qmat(je,iel),iel=1,nrel+1)\n! enddo\n!55 format('3Yq:',7(1pe11.3))\n call lingld(nrel,nrel1,qmat,phfrac,nrel,ierr)\n if(ierr.ne.0) then\n! error may occur and is not fatal, just try to replace next column\n! write(*,*)'3Y failed replace: ',dgmin\n if(.not.linglderr) then\n if(ocv()) write(*,*)'3Y gridmin warning(s) using lingld: ',ierr,nyp\n linglderr=.TRUE.\n endif\n qmat=qmatsave\n do i=1,nrel\n phfrac(i)=phfsave(i)\n enddo\n goto 300\n endif\n! write(*,299)'3Y q: ',ierr,(phfrac(iel),iel=1,nrel)\n!299 format(a,i5,7(1pe10.2))\n! read(*,302)ch1\n302 format(a)\n! write(*,*)'3Y fm6B: ',ie,ierr\n! write(*,317)'3Y fm6C: ',(phfrac(i),i=1,nrel)\n317 format(a,6(1pe12.4))\n!-----------------------\n! if solution has only positive values accept this, ierr nonzero if singular\n do je=1,nrel\n if(phfrac(je).le.phfmin .or. phfrac(je).gt.one) then\n! maybe problems if known composition have almost zero of some components?\n! restore qmat\n! write(*,*)'3Y fm6D: ',je\n qmat=qmatsave\n do i=1,nrel\n phfrac(i)=phfsave(i)\n enddo\n goto 300\n endif\n enddo\n! write(*,*)'3Y Replaced column: ',ie,nyp\n! we have found that column ie should be replaced\n!--------------------------------------------------\n! update xmat, qmatsave and gmin\n! as we may fail to find the solution for the chemical potentials later\n! keep a copy that can be restored\n iesave=ie\n jsave=jgrid(iesave)\n! mark that the replaced gridpoint should be checked again ....\n! write(*,*)'3Y Putting gridpoint back: ',jgrid(ie)\n! DO NOT SAVE THE PURE ELEMENT POINTS ... >k\n! write(*,*)'3Y for notuse: ',ie,jgrid(ie),size(notuse)\n if(jgrid(ie).le.size(notuse)) then\n notuse(jgrid(ie))=0\n endif\n jgrid(ie)=nyp\n xmatsave=xmat\n do je=1,nrel\n xmat(je,ie)=xarr(je,nyp)\n qmatsave(je,ie)=dble(xarr(je,nyp))\n enddo\n gmin(ie)=garr(nyp)\n! do ik=1,nrel\n! write(*,317)'3Y fm6F: ',(xmat(je,ik),je=1,nrel)\n! enddo\n! write(*,317)'3Y fm6G: ',(gmin(je),je=1,nrel)\n! to solve for the chemical potentials we have ro replace the rows by\n! columns, there is a TRANSPOSE command for symmetrical matrices\n do ie=1,nrel\n do je=1,nrel\n zmat(ie,je)=qmatsave(je,ie)\n enddo\n enddo\n! we have changed the solution, calculate new chemical potentials\n do je=1,nrel\n zmat(je,nrel1)=gmin(je)\n enddo\n! do ik=1,nrel1\n! write(*,317)'3Y fm8A: ',(zmat(je,ik),je=1,nrel)\n! enddo\n cmusave=cmu\n call lingld(nrel,nrel1,zmat,cmu,nrel,ierr)\n if(ierr.ne.0) then\n! this should also be handelled by ignoring the new gridpoint but\n! here we must restore the xmat, qmatsave and cmu.\n write(*,*)'3Y Failed to calculate chemical potentials',ierr\n! if(trace) write(*,*)'3Y Error from LINGLD for chem.pot.: ',ierr,nyp\n if(checkremoved) goto 950\n inerr=inerr+1\n if(inerr.gt.jerr) then\n inerr=1\n endif\n removed(inerr)=nyp\n jgrid(iesave)=jsave\n cmu=cmusave\n xmat=xmatsave\n do ie=1,nrel\n do je=1,nrel\n qmatsave(ie,je)=dble(xmat(ie,je))\n enddo\n enddo\n! we may have successfully added a removed gridpoint\n if(checkremoved) then\n goto 950\n endif\n goto 200\n endif\n! check new chemical potentials ...\n! write(*,63)'3Yny: ',(cmu(ie),ie=1,nrel)\n! calculate total G\n! gvv=zero\n! do ie=1,nrel\n! do je=1,nrel\n! first index is component, second is species\n! gvv=gvv+xmat(je,ie)*cmu(je)\n! enddo\n! enddo\n! if(trace) write(*,*)'3Y New total G: ',gvv,gvvp\n! check if gvv is lower than previous\n! if(gvv.gt.gvvp) then\n! write(*,*)'3Y *** Gibbs energy increased, restore!'\n! endif\n! gvvp=gvv\n!----------------------------------------------------------\n! debug output as we have changed one gridpoint\n! xtx=zero\n! do jjq=1,nrel\n! write(*,177)'3Y gpf: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel)\n! do jjz=1,nrel\n! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq)\n! enddo\n! enddo\n! gvv=zero\n! do jjq=1,nrel\n! gvv=gvv+xtx(jjq)*cmu(jjq)\n! enddo\n! write(*,175)'3Y ny4: ',gvv,(cmu(ie),ie=1,nrel)\n! write(*,317)'3Y new cmu: ',(cmu(je),je=1,nrel)\n! read(*,321)ch1\n!321 format(a)\n gy=zero\n do ie=1,nrel\n gy=gy+xknown(ie)*cmu(ie)\n enddo\n! write(*,199)griter,gvvp,gy\n199 format('3Y Gibbs energy changed: ',i5,2(1pe15.6))\n gvvp=gy\n!\n if(trace) then\n write(31,740)griter,nyp\n740 format(/'Iteration ',i6,' found gridpoint: ',i6,', new matrix:')\n do je=1,nrel\n write(*,720)'3Yz:',phfrac(je),xknown(je),(xmat(je,ie),ie=1,nrel)\n enddo\n write(31,730)gvvp,(cmu(je),je=1,nrel)\n endif\n if(checkremoved) then\n write(*,198)nyp\n198 format('3Y Added previously removed gridpoint ',i6)\n goto 950\n endif\n!----------------------------------------------\n! here we go back to loop through all gridpoints again\n! write(*,*)'3Y New search: ',griter\n goto 200\n!==============================================\n900 continue\n if(gpfail.gt.0) then\n! NOTE is a H-O gas with N(H)=2 N(O)=1 it fails to find H2O because then\n! there is just one gridpoint stable!\n write(*,906)gpfail\n906 format('3Y Gridmin could not make use of ',i7,' gridpoint(s)')\n endif\n! write(*,*)'3Y Gridmin has found a solution'\n! write(*,316)'3Y fm9A: ',(jgrid(i),i=1,nrel)\n! do ik=1,nrel\n! write(*,317)'3Y fm9B: ',(xmat(je,ik),je=1,nrel)\n! enddo\n! write(*,317)'3Y fm9C: ',(garr(je),je=1,nrel)\n! write(*,317)'3Y fm9D: ',(cmu(je),je=1,nrel)\n! write(*,317)'3Y fm9E: ',(phfrac(je),je=1,nrel)\n316 format(a,10i5)\n nj=0\n! do j=1,jerr\n! if(removed(j).gt.0) then\n! write(*,*)'3Y Failed testing gridpoint ',removed(j)\n! nj=nj+1\n! endif\n! enddo\n950 continue\n nj=0\n checkremoved=.true.\n! write(*,*)'3Y Checking removed gridpoints',inerr\n! xtx=zero\n! do jjq=1,nrel\n! write(*,177)'3Y flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel)\n! do jjz=1,nrel\n! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq)\n! enddo\n! enddo\n! gvv=zero\n! do jjq=1,nrel\n! gvv=gvv+xtx(jjq)*cmu(jjq)\n! enddo\n! write(*,175)'3Y cur: ',gvv,(cmu(ie),ie=1,nrel)\n!----------------\n testloop: do jj=1,inerr\n jp=removed(jj)\n! write(*,*)'3Y Checking removed gridpoint: ',jj,jp\n if(jp.gt.0) then\n gplan=zero\n do iel=1,nrel\n gplan=gplan+xarr(iel,jp)*cmu(iel)\n enddo\n dg=garr(jp)-gplan\n if(dg.lt.zero) then\n! if(trace) write(*,985)jp,dg,garr(jp),gplan\n! write(*,982)jp,dg,garr(jp),gplan\n982 format('3Y Removed gridpoint ',i5,' is below surface ',3(1pe12.4))\n! try to include it ....\n ie=0\n removed(jj)=-jp\n nyp=jp\n goto 300\n else\n! write(*,983)jp,dg\n983 format('3Y Removed gridpoint ',i5,' above surface ',1pe12.4)\n removed(jj)=-jp\n endif\n endif\n enddo testloop\n if(inerr.gt.0 .and. nj.eq.0) then\n! if(trace) write(*,986)inerr\n986 format('3Y None of the ',i3,' removed gridpoints below final surface')\n endif\n if(trace) write(*,771)(jgrid(je),je=1,nrel)\n771 format('3Y Final set of gridpoints: ',(/15i5))\n! xtx=0\n! do iii=1,nrel\n! write(*,987)jgrid(iii),phfrac(iii),(xarr(i,jgrid(iii)),i=1,nrel)\n!987 format('3Y GP: ',i5,F7.4,2x,6F9.6)\n! do j=1,nrel\n! xtx(j)=xtx(j)+phfrac(iii)*xarr(j,jgrid(iii))\n! enddo\n! enddo\n! write(*,988)(xtx(i),i=1,nrel)\n!988 format('3Y MF: ',6F9.6)\n!\n! call chocx('fgme ',nrel,jgrid,phfrac,xmat)\n1000 continue\n! write(*,*)'3Y exit find_gridmin'\n return\n end subroutine find_gridmin\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine merge_gridpoints\n!\\begin{verbatim}\n subroutine merge_gridpoints(nv,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq)\n!\n! BEWARE not adopted for parallel processing\n!\n! if the same phase has several gridpoints check if they are really separate\n! (miscibility gaps) or if they can be murged. Compare them two by two\n! nv is the number of phases, iphl(i) is the index of phase i, aphl(i) is the\n! amount of phase i, nyphl is the number of site fractions for phase i, \n! and yphl is the site fractions packed together\n!\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer nv,nrel\n integer, dimension(*) :: iphl,nyphl\n double precision, dimension(*) :: aphl,yphl,cmu\n logical trace\n real xsol(maxel,*)\n!\\end{verbatim}\n integer i,ip,iph,jp,jump,kk,klast,kp,lokres,nm,jj,mj,lokph,j,npm\n integer notuse(nv),incy(nv)\n double precision ycheck(maxconst),qq(5),xerr(maxel),xfromy(maxel)\n double precision summu,sumam\n logical igen\n real xmix(maxel)\n double precision a1,a2,gdf,gval1,gval2,gval3,gval4,gval5,gmindif\n character phname*24\n!\n! gmindif is the value to accept to merge two gridpoints\n! It should be a variable that can be set by the user for finetuning\n! write(*,*)'3Y Now we try to merge gridpoints in the same phase'\n! write(*,7)'3Y Merge_gridpoints is dissabled for the moment',nv\n!7 format(a,i3)\n! NOTE, always merge gripoints in ideal phases like gas\n! UNFINISHED\n gmindif=ceq%gmindif\n! used for testing 190603/BoS\n! gmindif=-1.0D-2\n! write(*,'(a,i3,1pe12.4)')'3Y Entering merge_gridpoints',nv,ceq%gmindif\n! goto 1100\n!---------------------\n notuse=0\n nm=0\n npm=0\n! write(*,67)'3Y yl: ',(aphl(i),nyphl(i),i=1,nv)\n67 format(a,20(F7.3,i4))\n incy(1)=1\n do i=2,nv\n incy(i)=incy(i-1)+nyphl(i-1)\n enddo\n! start points of fractions for all gridpoints\n! write(*,68)'3Y ys: ',(incy(i),i=1,nv)\n68 format(a,20i5)\n summu=zero\n xerr=zero\n! constitution of solution gridpoints\n! do jp=1,nv\n! write(*,69)'3Y y:',(yphl(incy(jp)+i-1),i=1,nyphl(jp))\n! enddo\n69 format(a,(12F6.2))\n! this calculate the overall composition from gridpoints\n do jp=1,nv\n summu=summu+aphl(jp)\n do i=1,nrel\n xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp)\n enddo\n enddo\n! write(*,73)'3Y in1: ',summu,(xerr(i),i=1,nrel)\n73 format(a,F5.2,2x,9(f7.4))\n!----------------------------------------------\n100 continue\n igen=.false.\n firstgp: do jp=1,nv-1\n! write(*,*)'3Y notuse 1: ',jp,notuse(jp)\n if(notuse(jp).ne.0) cycle firstgp\n secondgp: do kp=jp+1,nv\n! write(*,*)'3Y notuse 2: ',kp,notuse(kp)\n if(notuse(kp).ne.0) cycle secondgp\n sameph: if(iphl(jp).eq.iphl(kp)) then\n gdf=zero\n iph=iphl(jp)\n lokph=phases(iph)\n if(btest(phlista(lokph)%status1,PHID)) then\n! always merge gridpoints in ideal phases for example gas\n goto 200\n endif\n! do not merge gridpoints in other phases\n if(btest(globaldata%status,GSNOMERGE)) cycle secondgp\n! calculate G at 0 and 1 and 0.25, 0.5, 0.75 mix of gridpoints\n! if any of these abouve the line between any two others do not merge\n! as merged gridpoints are below the initial common tahnegt plane we cannot\n! use that as reference\n call set_constitution(iph,1,yphl(incy(jp)),qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gval1=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! second point\n call set_constitution(iph,1,yphl(incy(kp)),qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gval5=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! take middle point\n a1=5.0D-01\n a2=5.0D-01\n do i=0,nyphl(jp)-1\n ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i)\n enddo\n call set_constitution(iph,1,ycheck,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gval3=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! Check if this is above the mean of gval1 and gval5, if so quit merge\n gdf=gval3-a1*gval1-a2*gval5\n! merge require that difference is less than gmindif or phase ideal\n if(gdf.gt.gmindif) then\n! middle is higher, no merge 1-3-5\n! write(*,830)'3Y not merged 9: ',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n endif\n! calculate G at 0.25\n a1=7.5D-01\n a2=2.5D-01\n do i=0,nyphl(jp)-1\n ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i)\n enddo\n call set_constitution(iph,1,ycheck,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gval2=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! Check if this is above the mean of gval1 and gval5, if so quit merge\n gdf=gval2-a1*gval1-a2*gval5\n if(gdf.gt.gmindif) then\n! middle is higher, no merge 1-2-5\n! write(*,830)'3Y not merged 1: ',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n else\n! also compare between gval1 and gval3\n gdf=gval2-a1*gval1-a2*gval3\n if(gdf.gt.gmindif) then\n! gval2 is s higher, no merge 1-2-3\n! write(*,830)'3Y not merged 2: ',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n endif\n endif\n! finally calculate at 0.75\n! calculate G at 0.25\n a1=2.5D-01\n a2=7.5D-01\n do i=0,nyphl(jp)-1\n ycheck(i+1)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i)\n enddo\n call set_constitution(iph,1,ycheck,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calcg(iph,1,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gval4=ceq%phase_varres(lokres)%gval(1,1)/qq(1)\n! Check if this is above the mean of gval1 and gval5, if so quit merge\n gdf=gval4-a1*gval1-a2*gval5\n if(gdf.gt.gmindif) then\n! gval4 is higer mo merge 1-4-5\n! write(*,830)'3Y not merged 3',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n else\n gdf=gval4-a1*gval1-a2*gval5\n if(gdf.gt.gmindif) then\n! gval4 is higer mo merge 1-4-5\n! write(*,830)'3Y not merged 4',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n endif\n gdf=gval4-a1*gval1-a2*gval5\n if(gdf.gt.gmindif) then\n! gval4 is higer mo merge 1-4-5\n! write(*,830)'3Y not merged 5',jp,kp,gdf,iphl(jp),gmindif\n cycle secondgp\n endif\n endif\n! compared 1-3-5, 1-2-5, 1-2-3, 1-4-5, 3-4-5, 2-3-5 \n! in no case the middle point was above, that means merge\n!--------------------------------------------- here we merge !!\n200 continue\n! gridpoint in ideal phase or point in between has lower G, merge\n call get_phase_name(iphl(jp),1,phname)\n if(gx%bmperr.ne.0) then\n phname='UNKNOWN'; gx%bmperr=0\n endif\n! write(*,830)'3Y merging:',jp,kp,gdf,aphl(jp),aphl(kp),trim(phname)\n830 format(a,2i4,3(1pe12.4),' in ',a)\n! If merging use correct phase amounts\n npm=npm+1\n a1=aphl(jp)/(aphl(jp)+aphl(kp))\n a2=aphl(kp)/(aphl(jp)+aphl(kp))\n! write(*,162)'3Y p1:',a2,(yphl(incy(jp)+j),j=0,nyphl(jp)-1)\n! write(*,162)'3Y p2:',a2,(yphl(incy(kp)+j),j=0,nyphl(kp)-1)\n162 format(a,1pe12.4,12(0pF5.2))\n! The gridpoint jp has new amount, composition and constitution\n! SURPRISE: adding together constituent fractions does not reproduce\n! the correct molefractions if the constituents are molecules .... ????\n aphl(jp)=aphl(jp)+aphl(kp)\n do i=0,nyphl(jp)-1\n yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i)\n enddo\n call set_constitution(iph,1,yphl(incy(jp)),qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! extract correct mole fractions\n call calc_phase_mol(iph,xfromy,ceq)\n! write(*,162)'3Y ym:',0.0D0,(yphl(incy(jp)+i),i=0,nyphl(jp)-1)\n! write(*,162)'3Y xy:',0.0D0,(xfromy(i),i=1,nrel)\n! calculate mole fractions from xsol to compare!!\n do i=1,nrel\n xerr(i)=a1*xsol(jp,i)+a2*xsol(kp,i)\n enddo\n! write(*,162)'3Y xj+xk:',0.0D0,(xerr(i),i=1,nrel)\n do i=1,nrel\n xsol(i,jp)=xerr(i)\n enddo\n igen=.true.\n nm=nm+1\n! Mark the gripoint that has disappeared\n iphl(kp)=-iphl(kp)\n notuse(kp)=1\n! check overall composition of solution ...\n summu=zero\n xerr=zero\n do i=1,nrel\n if(iphl(i).lt.0) cycle\n summu=summu+aphl(i)\n! write(*,*)'3Y point: ',i,aphl(i)\n do jj=1,nrel\n xerr(jj)=xerr(jj)+aphl(i)*xsol(jj,i)\n enddo\n enddo\n! write(*,73)'3Y nu: ',summu,(xerr(jj),jj=1,nrel)\n! the chemical potentials has changed but how? Approximate the change by\n! making gmindif more negative for each merge (does not affect ideal phases)\n! I do not understand this but I keep it for the moment\n! gmindif=2.0D0*gmindif\n gmindif=1.2D0*gmindif\n! after merging always restart loop\n goto 100\n endif sameph\n enddo secondgp\n enddo firstgp\n! if two gridpoints merged compare all grispoints again\n if(igen) goto 100\n!----------------------------------------\n! shift fractions for the removed phases\n450 continue\n! write(*,*)'3Y at label 450: ',nm\n klast=0\n do jp=1,nv\n klast=klast+nyphl(jp)\n enddo\n!\n! uncomment listing here if error moving fractions\n! write(*,502)nv,(iphl(i),i=1,nv)\n! write(*,502)0,(incy(i),i=1,nv)\n! write(*,502)klast,(nyphl(i),i=1,nv)\n502 format('3Y check1: ',i3,2x,20i4)\n! kk=0\n! do j=1,nv\n! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j))\n! kk=kk+nyphl(j)\n! enddo\n!\n kk=0\n jp=1\n do while(jp.lt.nv)\n if(iphl(jp).lt.0) then\n! shift all fractions down. klast should be updated each shift but ...\n jump=nyphl(jp)\n! write(*,503)jp,kk,klast,jump\n503 format('3Y check3: ',5i5)\n! write(*,555)'3Y nyy1: ',(yphl(ip),ip=kk+1,kk+jump)\n555 format(a,6(1pe12.4))\n do ip=kk+1,klast-jump\n yphl(ip)=yphl(ip+jump)\n enddo\n! write(*,555)'3Y nyy2: ',(yphl(ip),ip=kk+1,kk+jump)\n do kp=jp,nv-1\n iphl(kp)=iphl(kp+1)\n aphl(kp)=aphl(kp+1)\n nyphl(kp)=nyphl(kp+1)\n enddo\n nv=nv-1\n else\n kk=kk+nyphl(jp)\n jp=jp+1\n endif\n500 continue\n enddo\n if(iphl(nv).lt.0) nv=nv-1\n! write(*,*)'3Y final number of gridpoints: ',nv\n! list overall composition with merged gridpoints\n summu=zero\n xerr=zero\n! this calculate the overall composition from gridpoints\n! write(*,87)'3Y aphl: ',nv,(aphl(jp),jp=1,nv)\n87 format(a,i2,7(1pe10.2))\n do jp=1,nv\n summu=summu+aphl(jp)\n do i=1,nrel\n xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp)\n enddo\n enddo\n! write(*,73)'3Y in2: ',summu,(xerr(i),i=1,nrel)\n! uncomment here if problems shifting fractions\n! write(*,502)nv,(iphl(i),i=1,nv)\n! write(*,502)0,(incy(i),i=1,nv)\n! write(*,502)klast,(nyphl(i),i=1,nv)\n! kk=0\n! do j=1,nv\n! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j))\n! kk=kk+nyphl(j)\n! enddo\n! if there are two or more gripoints in the same phase we have a \n! miscibility gap and may have to create miscibility gaps.\n!\n! >>>> unfinished\n!\n510 format(i3,':',6(1pe12.4))\n1000 continue\n if(npm.gt.0) write(*,'(a,i2,a)')'3Y Removed ',npm,' gridpoints by merging'\n if(ocv()) write(*,*)'3Y At return from merge_gridpoints: ',nv\n return\n!------------------------------------------\n! temporary fix to avoid creating several composition sets in ideal gas\n1100 continue\n! write(*,1102)'3Y merge ideal: ',nv,(iphl(jp),jp=1,nv)\n1102 format(a,i2,20i3)\n nm=0\n notuse=0\n incy(1)=1\n do i=2,nv\n incy(i)=incy(i-1)+nyphl(i-1)\n enddo\n1110 continue\n igen=.FALSE.\n do jp=1,nv-1\n do kp=jp+1,nv\n if(notuse(kp).ne.0) cycle\n if(iphl(jp).eq.iphl(kp)) then\n iph=iphl(jp)\n lokph=phases(iph)\n if(btest(phlista(lokph)%status1,PHID)) then\n! add together gridpoints in ideal phases (gas)\n! write(*,*)'3Y merging gridpoints in ideal phase'\n sumam=aphl(jp)+aphl(kp)\n a1=aphl(jp)/sumam\n a2=aphl(kp)/sumam\n aphl(jp)=aphl(jp)+aphl(kp)\n! sum the constituent fractions \n do i=0,nyphl(jp)-1\n yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i)\n enddo\n! sum also mole fractions!!\n do i=1,nrel\n xsol(i,jp)=a1*xsol(i,jp)+a2*xsol(i,kp)\n enddo\n notuse(kp)=1\n igen=.TRUE.\n nm=nm+1\n iphl(kp)=-iphl(kp)\n endif\n endif\n enddo\n enddo\n if(igen) goto 1110\n if(nm.eq.0) goto 1000\n goto 450\n!\n end subroutine merge_gridpoints\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_metastable_constitutions2\n!\\begin{verbatim}\n subroutine set_metastable_constitutions2(pph,nrel,nphl,iphx,xarr,garr,&\n nr,iphl,cmu,ceq)\n! this subroutine goes through all the metastable phases\n! after a global minimization and sets the constituion to the most\n! favourable one. Later care should be taken that exiting higher composition\n! sets are not set equal to the stable\n! pph number of phases for which a grid has been calculated\n! nrel number of components\n! nphl(p) is last gridpoint for phase(p), nphl(0)=0, p=1,pph\n! iphx(p) phase number of phase(p) (skipping dormant and suspended phases)\n! xarr(1..nrel,i) composition of gridpoint i\n! garr(i) Gibbs energy/RT for gridpoint i\n! nr is the number of stable phases in the solution\n! iphl(s) the phase number of the stable phases s (not ordered)\n! cmu are the chemical potentials/RT of the solution\n! ceq equilibrium record\n! called by global_gridmin\n implicit none\n integer pph,nrel,nr\n integer, dimension(0:*) :: nphl\n integer, dimension(*) :: iphl,iphx\n double precision, dimension(*) :: cmu\n real garr(*),xarr(nrel,*)\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer ig1,ign,ip,iph,ics,jph,lokcs,lokph,mode,ny,ie,ig,kp,i,zph\n double precision yarr(maxconst),qq(5),xxx,dgmin,gmax\n real dg,gplan\n! write(*,*)'3Y In set_metastable constitution'\n! goto 1000\n! The phases that have gridpoints calculated are in iphx(1..pph)\n phloop: do zph=1,pph\n iph=iphx(zph)\n do jph=1,nr\n if(iph.eq.iphl(jph)) then\n! this phase is stable, skip\n cycle phloop\n endif\n enddo\n! this phase is metastable, find its gridpoint closesed to the tangent plane\n! the grid points belonging to phase iph is between nphl(zph-1) and nphl(zph)\n! NOTE nphl(0)=0\n ig1=nphl(zph-1)+1\n ign=nphl(zph)\n! if ign=ig1 there is a single gridpoint, otherwise seach for minimim\n dgmin=-1.0d12\n ip=0\n! search for gripoint closeset to stable plane defined by cmu\n igloop: do ig=ig1,ign\n if(garr(ig).ge.999.0) then\n! gridpoints in phases with more than 50% vacancies have their garr(ig)=1.0D3\n! write(*,*)'Skipping gridpoint with too few atoms'\n cycle igloop\n endif\n gplan=zero\n do ie=1,nrel\n gplan=gplan+xarr(ie,ig)*cmu(ie)\n enddo\n dg=gplan-garr(ig)\n if(abs(dg).lt.abs(dgmin)) then\n ip=ig\n dgmin=dg\n endif\n enddo igloop\n! write(*,79)'3Y metastable: ',trim(phlista(iph)%name),iph,zph,&\n! ig1,ip,ign,dgmin\n79 format(a,a,2i4,3i6,1pe12.4)\n! write(*,81)'3Y x: ',ip-nphl(zph),(xarr(ie,ip),ie=1,nrel)\n! write(*,81)'3Y x: ',ip-ig1,(xarr(ie,ip),ie=1,nrel)\n81 format(a,i4,(10F6.3))\n if(ign.gt.ig1) then\n! if ign=ig1 the phase has fixed constitution\n! otherwise retrieve constitution for this gridpoint and insert it in phase\n! we must provide mode and iph. The subroutine returns ny and yarr\n! mode is the gridpoint in the phase\n! mode=ip-nphl(zph)\n mode=ip-ig1+1\n! find the constitution of this gridpoint\n! call generate_grid(mode,iph,ign,nrel,xarr,garr,ny,yarr,gmax,ceq)\n! write(*,*)'3Y Get constitution of metastable phase ',iph,mode\n if(mode.gt.0) then\n! this call returnes the constitution of gridpoint \"mode\"\n! if mode=0 it generates the grid ... infinite loop\n call generic_grid_generator(mode,iph,ign,nrel,xarr,garr,&\n ny,yarr,gmax,ceq)\n if(gx%bmperr.ne.0) then\n write(*,120)trim(phlista(iph)%name)\n120 format('3Y Failed to set metastable constitution of ',a)\n gx%bmperr=0; cycle phloop\n endif\n! write(*,81)'3Y y: ',mode,(yarr(ie),ie=1,ny)\n call set_constitution(iph,1,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n endif\n! set driving force also for phases with fix composition\n call set_driving_force(iph,1,dgmin,ceq)\n500 continue\n enddo phloop\n1000 continue\n return\n end subroutine set_metastable_constitutions2\n \n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function global_equil_check1\n!\\begin{verbatim}\n logical function global_equil_check1(mode,addtuple,yfr,ceq)\n! subroutine global_equil_check(ceq,newceq)\n!\n! This subroutine checks there are any gridpoints below the calculated solution\n! if not it is taken as a correct global equilibrium\n! This avoids creating any new composition sets but may fail in some cases\n! to detect that the equilibrium is not global.\n! mode=1 means try to recalculate equilibrium if not global (not implemented)\n! if a gridpoint below is found addtuple and yfr returned with this\n implicit none\n integer mode,addtuple\n double precision, allocatable, dimension(:) :: yfr\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), target :: cceq\n TYPE(gtp_equilibrium_data), pointer :: pceq\n logical global,newcs,notglobwarning1,notglobwarning2,wrongfrac,addgridpoint\n real, allocatable :: xarr(:,:),garr(:)\n real sumx\n double precision, dimension(maxconst) :: yarr\n double precision totmol,totmass,amount,gmax,dgmax,dgtest\n integer, allocatable :: kphl(:),iphx(:)\n integer gmode,iph,ngg,nrel,ny,ifri,firstpoint,sumng,nrph,ii,jj,nz,lokcs\n integer ics,pph,nyfas,gpz,iphz,nggz,errall,haha\n integer, parameter :: maxgrid=400000\n!\n! write(*,*)'3Y In global_equil_check1',mode\n global=.TRUE.\n if(btest(globaldata%status,GSNOGLOB)) then\n write(*,*)'3Y Ignoring call to global_equil_check as global turned off!'\n goto 2000\n endif\n notglobwarning1=.TRUE.\n notglobwarning2=.TRUE.\n addgridpoint=.TRUE.\n if(mode.ne.1) addgridpoint=.FALSE.\n dgmax=zero\n addtuple=0\n! Problem with invariant when mapping but not here\n! if(inveq(haha,ceq)) then\n! write(*,*)'3Y equilibrium is invariant when entering',haha\n! else\n! write(*,*)'3Y equilibrium is not invariant when entering',haha\n! endif\n! COPY the whole equilibrium record to avoid destroying anything!!\n! otherwise I had strange problems with amounts of phases ??\n cceq=ceq\n pceq=>cceq\n nrph=noofph\n allocate(kphl(0:nrph+1),stat=errall)\n allocate(iphx(nrph+1),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 13: ',errall\n gx%bmperr=4370; goto 1000\n endif\n!\n sumng=0\n ifri=0\n firstpoint=1\n iphx=0\n kphl=0\n ifri=0\n pph=0\n wrongfrac=.true.\n ggloop: do iph=1,nrph\n! include all phases with any composition set entered (but only once!)\n if(test_phase_status_bit(iph,PHMQMQA)) then\n write(*,7)\n7 format('3Y MQMQA phase excluded from global test')\n cycle ggloop\n endif\n do ics=1,noofcs(iph)\n! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed\n! ignore phases whith no composition set entered\n! If a phase+compset FIX one should never be here as conditions wrong\n if(test_phase_status(iph,ics,amount,pceq).gt.PHDORM) then\n pph=pph+1\n iphx(pph)=iph\n cycle ggloop\n endif\n enddo\n enddo ggloop\n!\n nrel=noofel\n! write(*,11)'3Y gpa:',pph,(iphx(iph),iph=1,pph)\n! allocate arrays, added 1 to avoid a segmenentation fault ....\n allocate(xarr(nrel,maxgrid),stat=errall)\n allocate(garr(maxgrid),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 14: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! calculate the composition and G for the gridpoints\n ii=1\n loop2: do ifri=1,pph\n ngg=maxgrid-ii\n! write(*,10)'3Y calling generic_grid 2: ',ifri,iphx(ifri),ngg,pph\n10 format(a,2i5,2i10,5i5)\n!>>>>>>> important: changes here must be made also in global_gridmin\n if(btest(globaldata%status,GSOGRID)) then\n! The possibility to use the old grid tested\n call generate_grid(0,iphx(ifri),ngg,nrel,xarr(1,ii),&\n garr(ii),ny,yarr,gmax,pceq)\n else\n call generic_grid_generator(0,iphx(ifri),ngg,nrel,xarr(1,ii),&\n garr(ii),ny,yarr,gmax,pceq)\n endif\n!>>>>>>>> impportant end!\n! write(*,*)'3Y Back from grid generator: ',ifri,iphx(ifri),ngg\n if(gx%bmperr.ne.0) goto 1000\n kphl(ifri)=kphl(ifri-1)+ngg\n ii=kphl(ifri)+1\n enddo loop2\n sumng=kphl(pph)\n! write(*,11)'3Y gpc:',(kphl(iph),iph=1,nrph)\n11 format(a,10i7/(7x,10i7))\n! write(*,*)'3Y Calculated ',sumng,' gridpoints for check.',kphl(0)\n! We have calculated sumng gripoints in pph phases\n! check if any gridpoint is below the G surface defined by cmuval\n iph=0\n nyfas=0\n iphz=0\n loop4: do ifri=1,sumng\n! keep track of the phase the gridpoint belongs to\n if(ifri.gt.nyfas) then\n! iph is the phase index in phasetuple (and phases)\n iph=iph+1\n! ny=ny+kphl(iph)\n nyfas=kphl(iph)\n endif\n gmax=zero\n sumx=0.0E0\n do ngg=1,nrel\n gmax=gmax+dble(xarr(ngg,ifri))*pceq%cmuval(ngg)\n sumx=sumx+xarr(ngg,ifri)\n enddo\n! if(ifri.eq.sumng) write(*,*)'3Y OK ',ifri,iph\n if(abs(sumx-1.0E0).gt.1.0E-4) then\n cycle loop4\n endif\n! write(*,75)'3Y check: ',ifri,iphx(iph),garr(ifri),gmax,garr(ifri)-gmax\n75 format(a,i6,i4,5(1pe12.4))\n dgtest=gmax-dble(garr(ifri))\n stableornot: if(dgtest.gt.1.0D-4*abs(gmax)) then\n! stableornot: if(dgtest.gt.1.0D-7*abs(gmax)) then\n! if(dgtest.gt.dgmax) then\n!------------------------------------------------------------------\n! write(*,76)'3Y gridpoint below G surface: ',ifri,iph,iphx(iph),&\n! dgtest,1.0D-4*dgmax\n76 format(a,i7,2i4,2(1pe12.4))\n! if the phase is stoichiometric and stable this is a rounding off problem\n! find the phase record using the phase tuple\n lokcs=phasetuple(iph)%lokvares\n nz=size(pceq%phase_varres(lokcs)%sites)-&\n size(pceq%phase_varres(lokcs)%yfr)\n if(nz.eq.0) then\n if(pceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) cycle loop4\n! if number of constituent fractions equal to sublattice the composition is fix\n! If this is a test at a node point we may have an allotropic phase whicj is\n! stable, then the driving force should be small ... check if dgm is very small\n write(*,'(a,i5,F10.2,2(1pe12.4))')'3Y allotrop DGM: ',&\n lokcs,pceq%tpval(1),pceq%phase_varres(lokcs)%dgm\n if(pceq%phase_varres(lokcs)%dgm.lt.2.0D-1) cycle loop4\n endif\n! This phase should be stable, maybe there are others?\n if(dgtest.lt.dgmax) cycle loop4\n dgmax=dgtest\n! This gridpoint is the currently lowest below the current G plane\n! write(kou,77)ifri,iph,iphx(iph),trim(phlista(phases(iphx(iph)))%name)\n77 format('3Y found a stable gridpoint: ',3i5,' in ',a)\n global=.FALSE.\n gpz=ifri\n! iphz=iph\n iphz=iphx(iph)\n nggz=kphl(iph-1)\n! write(*,*)'3Y saving most stable gp: ',gpz,iphz\n endif stableornot\n! if(ifri.eq.sumng) write(*,*)'OK ',ifri\n enddo loop4\n! no gridpoint below current G surface\n! write(*,*)'3Y finished loop4',iphz,global\n goto 1000\n! Found gridpoint below gmax, if mode=/=1 just return error message\n500 continue\n write(*,*)'3Y Sorry I have not yet implemented automatic recalculation!'\n if(mode.eq.1) then\n! Here we try to recalculate the equilibrium with a new phase stable\n continue\n else\n write(*,*)'3Y Please include this phase and recalculate equilibrium'\n endif\n!\n1000 continue\n!1010 continue\n! write(*,*)'3Y global_equil_check label 1000',global,gx%bmperr\n! set the error code here so we can finish this routine\n if(.not.global) then\n! write(*,1011)'3Y most stable gridpoint: ',gpz,nggz,iphz,dgmax\n1011 format(a,2i7,i3,1pe12.4)\n addornot: if(addgridpoint) then\n! Add this gripoint as entered and recalculate\n! extract constitution, ny=-100 to get some output ..\n! write(*,*)'3Y Trying to extract constitution, ngg:'\n! ny=-100\n if(btest(globaldata%status,GSOGRID)) then\n! we do not have ifri and iphx here\n call generate_grid(gpz-nggz,iphz,nggz,nrel,xarr,&\n garr,ny,yarr,gmax,pceq)\n else\n call generic_grid_generator(gpz-nggz,iphz,nggz,nrel,&\n xarr,garr,ny,yarr,gmax,pceq)\n endif\n if(ny.gt.0) then\n! write(*,83)'3Y gpy: ',ny,(yarr(ngg),ngg=1,ny)\n83 format(a,i7,9F7.4,(8x,14F5.2))\n! a small allocate\n allocate(yfr(ny))\n do ngg=1,ny\n yfr(ngg)=yarr(ngg)\n enddo\n else\n write(*,*)'3Y Failed extract constitution',ny\n endif\n else\n! This gridpoint is for a phase that is not stable but has a stable grid point\n! but we will not try to recalculate\n if(notglobwarning1) then\n! write this once only\n write(kou,87)trim(phlista(phases(iphz))%name),pceq%tpval(1),&\n (xarr(ngg,gpz),ngg=1,nrel)\n87 format(/' *** Gridtest found equilibrium not global, ',a,&\n ' is stable at T=',F8.2/5x,'with mole fractions:'/(1x,13F6.3))\n notglobwarning1=.FALSE.\n endif\n endif addornot\n addtuple=iphz\n gx%bmperr=4352\n endif\n! write(*,*)'3Y Deallocating, check due to segmentation fault ...'\n if(allocated(xarr)) then\n deallocate(xarr)\n deallocate(garr)\n deallocate(kphl)\n deallocate(iphx)\n endif\n2000 continue\n! if(inveq(haha,ceq)) then\n! write(*,*)'3Y equilibrium is invariant when at exit',haha\n! else\n! write(*,*)'3Y equilibrium is not invariant when at exit',haha\n! endif\n global_equil_check1=global\n return\n end function global_equil_check1\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine check_all_phases\n!\\begin{verbatim}\n subroutine check_all_phases(mode,ceq)\n!\n! This function check for all phases if there are any gridpoints\n! closer (or below) to the current calculated solution\n! if so it changes the composition of the phase\n! If a gridpoint is BELOW the current plane an error code is returned\n! phase should be stable with another composition an error code is returned\n! It does not creating any new composition sets\n! It can be usd during STEP/MAP to update compositions of metastable\n! phases which have become stuck in a local minimium\n! if error 4365 or 4364 is set mode will return index in meqrec%phr \n! of the phase that should be stable\n implicit none\n integer mode\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), target :: cceq\n TYPE(gtp_equilibrium_data), pointer :: pceq\n integer iph,phstat,saverr\n!\n! write(*,*)'3Y In check_all_phases'\n! COPY the whole equilibrium record to avoid destroying anything!!\n! otherwise I had strange problems with amounts of phases ??\n saverr=0\n cceq=ceq\n pceq=>cceq\n! mode will be updated inside check_phase_grid to correspond to meqrec%phr index\n mode=0\n ggloop: do iph=1,noofph\n! include all phases with any composition set entered (but only once!)\n! loop for composition sets inside check_phase as they all have the same grid\n call check_phase_grid(iph,mode,pceq,ceq)\n if(gx%bmperr.ne.0) then\n! if a stable phase need a new composition terminate and return error\n if(gx%bmperr.eq.4366) then\n! grid minimizer needed to create new composition set is needed\n write(*,*)'3Y New composition set needed: ',gx%bmperr,mode,mode\n goto 1000\n elseif(gx%bmperr.eq.4365) then\n! new stable phase composition inserted in unstable composition set\n! go back and take halfstep in step/map\n write(*,*)'3Y found stable phase: ',gx%bmperr,mode,mode\n goto 1000\n saverr=gx%bmperr\n endif\n gx%bmperr=0\n endif\n enddo ggloop\n if(saverr.ne.0) gx%bmperr=saverr\n!\n1000 continue\n return\n end subroutine check_all_phases\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine check_phase_grid\n!\\begin{verbatim}\n subroutine check_phase_grid(iph,jcs,pceq,ceq)\n!\n! This function check for A SINGLE PHASE if there are any gridpoints\n! closer (or below) to the current calculated solution if so it\n! changes the composition of the phase If a gridpoint is below the\n! phase should be stable with another composition an error code is\n! returned It does not creating any new composition sets but may fail\n! It can be usd during STEP/MAP to update compositions of metastable\n! phases which have become stuck in a local minimium\n! NOTE pceq is a pointer to a copy of the real equilibrium record\n! ceq is a pointer to the real equilibrium record\n! jcs is returned as the composition set that should be stable (if any)\n implicit none\n integer iph,jcs\n TYPE(gtp_equilibrium_data), pointer :: ceq,pceq\n!\\end{verbatim}\n real, allocatable :: xarr(:,:),garr(:)\n double precision, dimension(maxel) :: x1mol,wmass\n double precision, dimension(maxconst) :: yarr\n double precision totmol,totmass,amount,gmax,dgmax,dgtest\n double precision, parameter :: mindg=1.0D-6\n! max 9 composition sets\n double precision gorig,gbest,gdiff,gset(9),gplan,am,qq(5)\n! for debugg\n double precision yold(100)\n integer, allocatable :: kphl(:),iphx(:)\n integer ii,jj,kk,nrel,lokcs,moded,ny,ics,ics2,ncs,stcs(4),nstcs,ie,ngg\n integer phstat,lokph,lokres,errall\n logical skip\n integer, parameter :: maxgrid=100000\n!\n! write(*,*)'3Y In check_phase_grid: ',iph\n nrel=noofel\n moded=0\n! allocate arrays\n allocate(xarr(nrel,maxgrid),stat=errall)\n allocate(garr(maxgrid),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 15: ',errall\n gx%bmperr=4370; goto 1000\n endif\n gset=-one\n skip=.TRUE.\n! loop for all composition sets\n ncs=noofcs(iph)\n stcs=0\n nstcs=0\n gloop: do ics=1,ncs\n! calculate G for current composition, ignore dormant and suspended sets\n phstat=test_phase_status(iph,ics,amount,pceq)\n if(phstat.lt.PHDORM) cycle gloop\n skip=.FALSE.\n call calcg(iph,ics,moded,lokcs,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call calc_phase_molmass(iph,ics,x1mol,wmass,totmol,totmass,am,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! abnorm(1) is number of atoms per formula unit\n gorig=pceq%phase_varres(lokcs)%gval(1,1)/&\n pceq%phase_varres(lokcs)%abnorm(1)\n! calculate the difference with the current stable tangent plane\n! It can be zero if the composition set is stable\n gplan=zero\n do ii=1,nrel\n gplan=gplan+x1mol(ii)*pceq%cmuval(ii)\n enddo\n! this is the original drivining force for each composition set\n gset(ics)=gorig-gplan\n! there can be more than one stable composition set ... fix another time ...\n if(phstat.ge.PHENTSTAB) then\n if(nstcs.ge.4) then\n! write(*,*)'More than 4 stable composition sets of phase',iph\n gx%bmperr=4399; goto 1000\n endif\n! write(*,*)'Stable phase and set: ',iph,ics,gset(ics)\n nstcs=nstcs+1; stcs(nstcs)=ics\n endif\n enddo gloop\n! all composition sets suspended or dormant in this phase\n if(skip) goto 1000\n! write(*,20)'3Y phase grid: ',nstcs,ncs,(gset(ii),ii=1,ncs)\n!20 format(a,2i2,6(1pe12.4))\n!\n! now calculate the gridpoints, composition and G\n ngg=maxgrid\n! write(*,*)'Calculate grid for phase ',iph,nrel,ngg\n call generic_grid_generator(0,iph,ngg,nrel,xarr,garr,ny,yarr,gmax,pceq)\n! write(*,*)'3Y error & grid: ',gx%bmperr,ngg\n if(gx%bmperr.ne.0) goto 1000\n! loop through all gridpoints to find one closesed to the stable tangent plane\n! ngg set to number of real gridpoints\n! note mixed single and double precision but that is OK\n gbest=-1.0D3\n do ii=1,ngg\n gplan=zero\n do jj=1,nrel\n gplan=gplan+xarr(jj,ii)*pceq%cmuval(jj)\n enddo\n! note gdiff should be negative if metetstable\n gdiff=gplan-garr(ii)\n! write(*,22)'3Y GRID: ',ii,gdiff,gbest,garr(ii),gplan\n22 format(a,i4,4(1pe12.4))\n if(gdiff.gt.gbest) then\n kk=ii; gbest=gdiff\n endif\n enddo\n!\n! write(*,30)'3Y Gridpoint ',kk,gbest,(xarr(ii,kk),ii=1,nrel)\n30 format(a,i4,e12.4,10(F8.5))\n! now we compare the best gridpoint with the composition sets\n loop1: do ics=1,ncs\n! jcs will be the correct phase index inside meqrec%phr array ??\n jcs=jcs+1\n phstat=test_phase_status(iph,ics,amount,pceq)\n if(phstat.lt.PHDORM) cycle loop1\n! extract constitution for the best gridpoint kk\n call generic_grid_generator(kk,iph,ngg,nrel,xarr,garr,&\n ny,yarr,gmax,pceq)\n if(gbest.ge.mindg) then\n! there is a gridpoint below the tangent plane\n! If there is a metastable composition set copy the gripoint constitution\n! to that and recalculate. If no free composition set test if the grid\n! point can be merged with a stable composition set. If not recalculate\n! with grid minimizer\n if(nstcs.gt.0) then\n! There is one or more stable composition set, if there is an unstable one\n! then set the gridpoint constitution in that\n if(nstcs.eq.ncs) then\n! All composition sets already stable! \n! we have to compare if the G curve between the gridpoint and all the\n! composition sets is convex or concave. NOT IMPLEMENTED\n! loop2: do ics2=1,nstcs\n! if(stcs(ics2).lt.0) cycle loop2\n! call calc_phase_molmass(iph,stcs(ics2),x1mol,wmass,totmol,&\n! totmass,am,pceq)\n! if(gx%bmperr.ne.0) goto 1000\n! we should check here if there is a maximum G between the gridpoint and the\n! stable composition set. To be done ...\n! write(*,*)'3Y New composition set needed'\n! gx%bmperr=4365; goto 1000\n! enddo loop2\n! we arrive here if we could not merge gridpoint with a stable composition set\n! the error code demand a global grid minimization.\n write(*,*)'3Y New composition set needed for:',iph,ncs,nstcs\n! write(*,90)1,iph,ics,ceq%tpval(1),gbest,gset(ics)\n call set_constitution(iph,ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gx%bmperr=4365; goto 1000\n elseif(gset(ics).lt.zero) then\n! there is at least one unstable composition set, check if gset(ics)<0\n! and insert the GRIDPOINT constitution if gset(ics) negative\n! This composition set is not stable, insert stable gridpoint constitution\n write(*,90)2,iph,ics,ceq%tpval(1),gbest,gset(ics),4365\n90 format('3Y stable gridpoint ',i1,2x,2i4,F10.2,2(1pe12.4),i5)\n! Check old constitution\n! call get_phase_compset(iph,ics,lokph,lokres)\n! write(*,95)'3Y oldy: ',ceq%phase_varres(lokres)%yfr\n! write(*,95)'3Y newy: ',(yarr(ii),ii=1,ny)\n call set_constitution(iph,ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! this error code demand recalculation without grid minimizer\n gx%bmperr=4365; goto 1000\n endif\n else\n! There are no stable composition sets, we can set the stable gridpoint\n! constitution in this composition set and request a new equilibrium calculation\n! NOTE we use ceq pointer to set yarr in original record\n write(*,90)3,iph,ics,ceq%tpval(1),gbest,gset(ics),4365\n! Check old constitution\n! call get_phase_compset(iph,ics,lokph,lokres)\n! write(*,95)'3Y oldy: ',ceq%phase_varres(lokres)%yfr\n! write(*,95)'3Y newy: ',(yarr(ii),ii=1,ny)\n95 format(a,10(F7.4))\n call set_constitution(iph,ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n gx%bmperr=4365; goto 1000\n endif\n elseif(gbest.gt.gset(ics)) then\n! SKIP THIS FOR THE MOMENT\n! The best gridpoint is not stable but it is closer to tangent plane than this\n! composition set WHICH THUS MUST BE UNSTABLE!.\n! This change can avoid a phase is stuck in a local minimum\n! BUT if another composition set is stable do not change because it the\n! gridpoint is probably close to the stable composition.\n if(nstcs.eq.0) then\n write(*,92)iph,ics,ceq%tpval(1),gbest,gset(ics)\n92 format('3Y better gridpoint in ',i4,i2,F10.2,2(1pe12.4))\n call set_constitution(iph,ics,yarr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n! This do not require a new calculation\n! else\n! Nothing to do as the best gridpoint is further away from tangent plane\n! than this metastable composition set\n endif\n enddo loop1\n! The allocated arrays should deallocate by themselves\n1000 continue\n return\n end subroutine check_phase_grid\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine separate_constitutions\n!\\begin{verbatim}\n subroutine separate_constitutions(ceq)\n! This is called during step/map\n! Go through all entered phases and if there are two composition sets\n! that have similar constitutions then separate them\n! Used during mapping of for example Fe-Cr to detect the miscibility gap\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer phtup,nextset,lokcs1,lokcs2,ic,ll,lokph,ss,ts\n! max 9 sublattices\n integer iymin(9),iymax(9),qq\n double precision ymax(9),ymin(9),ysame\n double precision, allocatable :: yarr(:)\n! write(*,*)'3Y Check if two composition sets are same: ',ceq%tpval(1)\n allph: do phtup=1,nooftup()\n nextset=phasetuple(phtup)%nextcs\n if(nextset.le.0) cycle allph\n lokph=phasetuple(phtup)%lokph\n lokcs1=phasetuple(phtup)%lokvares\n lokcs2=phasetuple(nextset)%lokvares\n ymin=one\n ymax=zero\n iymin=0\n iymax=0\n! ts=ceq%phase_varres(lokcs1)%tnoofr\n ts=phlista(lokph)%tnooffr\n ll=1\n qq=phlista(lokph)%nooffr(1)\n do ic=1,ts\n ysame=ceq%phase_varres(lokcs1)%yfr(ic)\n if(abs(ysame-ceq%phase_varres(lokcs2)%yfr(ic)).gt.1.0D-2) then\n! write(*,66)'3Y two compsets not same:',lokcs1,lokcs2,ceq%tpval(1)\n! write(*,77)'3Y d1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts)\n! write(*,77)'3Y d2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts)\n cycle allph\n else\n! map8 gave segmentation fault here, fixed ??\n! write(*,10)'3Y qq: ',phtup,nextset,ic,qq,ll,ts,&\n! phlista(lokph)%nooffr(ll),size(phlista(lokph)%nooffr),&\n! size(ceq%phase_varres(lokcs2)%yfr)\n!10 format(a,10i5)\n if(ic.gt.qq) then\n ll=ll+1\n qq=qq+phlista(lokph)%nooffr(ll)\n endif\n if(ysame.lt.ymin(ll)) then\n iymin(ll)=ic; ymin(ll)=ysame\n endif\n if(ysame.gt.ymax(ll)) then\n iymax(ll)=ic; ymax(ll)=ysame\n endif\n endif\n enddo\n! These two composition sets have identical compositions, skip if both stable\n! write(*,66)'3Y two compsets same:',lokcs1,lokcs2,ceq%tpval(1),&\n! (ymin(ic),ymax(ic),ic=1,ll)\n66 format(a,2i3,f8.2,2x,(8F6.3))\n if(ceq%phase_varres(lokcs1)%phstate.ge.PHENTSTAB) then\n if(ceq%phase_varres(lokcs2)%phstate.ge.PHENTSTAB) then\n! write(*,*)'Wow, two identical phases stable!',lokcs1,lokcs2\n cycle allph\n endif\n! write(*,77)'3Y s1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts)\n! set the constitution of lokcs2 to one-the stable\n! or maybe to its default??\n lokph=phasetuple(phtup)%lokph\n ic=0\n phsubl1: do ll=1,phlista(lokph)%noofsubl\n if(phlista(lokph)%nooffr(ll).eq.1) then\n ic=ic+1; cycle phsubl1\n endif\n ysame=0.1/real(phlista(lokph)%nooffr(ll))\n do ss=1,phlista(lokph)%nooffr(ll)\n ic=ic+1\n if(ic.eq.iymin(ll)) then\n ceq%phase_varres(lokcs2)%yfr(ic)=0.9\n else\n ceq%phase_varres(lokcs2)%yfr(ic)=ysame\n endif\n enddo\n enddo phsubl1\n! write(*,77)'3Y s1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts)\n! write(*,77)'3Y s2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts)\n77 format(a,i3,8F6.3)\n else\n! lokcs1 is not stable, change its constitution away from lokcs2\n! elseif(ceq%phase_varres(lokcs2)%phstate.ge.PHENTSTAB) then\n! set the constitution of lokcs1 to one-the lokcs2\n! or maybe to its default??\n lokph=phasetuple(phtup)%lokph\n ic=0\n phsubl2: do ll=1,phlista(lokph)%noofsubl\n if(phlista(lokph)%nooffr(ll).eq.1) then\n ic=ic+1; cycle phsubl2\n endif\n! very strange, if I divide with real(phlista(lokph)%nooffr(ll)-1) \n! the metastable exrapolation is still there !!\n ysame=0.1/real(phlista(lokph)%nooffr(ll))\n do ss=1,phlista(lokph)%nooffr(ll)\n ic=ic+1\n if(ic.eq.iymin(ll)) then\n ceq%phase_varres(lokcs1)%yfr(ic)=0.9\n else\n ceq%phase_varres(lokcs1)%yfr(ic)=ysame\n endif\n enddo\n enddo phsubl2\n! write(*,77)'3Y z1:',lokcs1,(ceq%phase_varres(lokcs1)%yfr(ss),ss=1,ts)\n! write(*,77)'3Y z2:',lokcs2,(ceq%phase_varres(lokcs2)%yfr(ss),ss=1,ts)\n! else\n! write(*,*)'Both compsets unstable'\n endif\n enddo allph\n1000 continue\n end subroutine separate_constitutions\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function allotropes\n!\\begin{verbatim}\n logical function allotropes(irem,iadd,iter,ceq)\n! This function return TRUE if the phases indicated by IREM and IADD both have\n! fixed and identical composition, i.e. they are componds and allotropes\n! Such a transition can cause problems during a STEP command.\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer iadd,irem,iter\n!\\end{verbatim} %+\n integer lokph1,lokph2,nofr,jj\n double precision x1mol(maxel),x2mol(maxel),wmass(maxel),totmol,totmass,am\n logical allo\n allo=.false.\n goto 1000\n! write(*,*)'3A checking allotropes',irem,iadd\n write(*,10)iter,trim(phlista(phases(irem))%name),&\n trim(phlista(phases(iadd))%name)\n10 format('3A checking allotropes',i5,2x,a,2x,a)\n lokph1=phases(irem)\n lokph2=phases(iadd)\n! spurious segmentation faults here ...\n if(lokph1.le.0 .or. lokph2.le.0) then\n! composition ses created during mapping are not included in phases array ??\n write(*,*)'3A error checking allotropes: ',lokph1,lokph2\n goto 1000\n endif\n! check if both have fixed composition\n if(phlista(lokph1)%noofsubl-phlista(lokph1)%tnooffr.eq.0 .and. &\n phlista(lokph2)%noofsubl-phlista(lokph2)%tnooffr.eq.0) then\n! they have fixed composition but can be modelled differently\n! we have to calculate their mole fractions ...\n call calc_phase_molmass(irem,1,x1mol,wmass,totmol,totmass,am,ceq)\n call calc_phase_molmass(irem,1,x2mol,wmass,totmol,totmass,am,ceq)\n if(gx%bmperr.ne.0) goto 1000\n do jj=1,noofel\n if(abs(x1mol(jj)-x2mol(jj)).gt.1.0D-6) exit\n enddo\n! Fortran standard says jj>noofel if loop finish without exit\n if(jj.gt.noofel) then\n allo=.true.\n! write(*,*)'The phases are allotropes!',ceq%tpval(1)\n endif\n endif\n1000 continue\n allotropes=allo\n return\n end function allotropes\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function same_stoik\n!\\begin{verbatim}\n logical function same_stoik(iph,jph)\n! MAYBE IDENTICAL TO ALLOTROPES ?\n! return TRUE if phase iph and jph are both stoichiometric and have the\n! same composition Used to check when adding a phase during equilibrium\n! calculation as it normally fails to have two such phases stable\n! iph and jph are phase tuple indices\n implicit none\n integer iph,jph\n!\\end{verbatim} %+\n integer loki,lokj,ll,kk\n logical same\n!\n same=.false.\n! iph and jph can be second or later composition sets\n! write(*,*)'3F same_stoik 1: ',iph,jph,&\n! phasetuple(iph)%lokph,phasetuple(jph)%lokph\n! loki=phases(iph); lokj=phases(jph)\n if(iph.le.0 .or. iph.gt.nooftup() .or. jph.le.0 .or.jph.gt.nooftup()) then\n write(*,*)'Calling same_stoik with illegal arguments ',iph,jph\n gx%bmperr=4399; goto 1000\n endif\n loki=phasetuple(iph)%lokph; lokj=phasetuple(jph)%lokph\n if(.not.btest(phlista(loki)%status1,PHNOCV)) goto 1000\n if(.not.btest(phlista(lokj)%status1,PHNOCV)) goto 1000\n if(phlista(loki)%noofsubl.ne.phlista(lokj)%noofsubl) goto 1000\n kk=0\n do ll=1,phlista(loki)%noofsubl\n if(firsteq%phase_varres(phlista(loki)%linktocs(1))%sites(ll).ne.&\n firsteq%phase_varres(phlista(lokj)%linktocs(1))%sites(ll)) goto 1000\n kk=kk+1\n if(phlista(loki)%constitlist(kk).ne.&\n phlista(lokj)%constitlist(kk)) goto 1000\n enddo\n same=.true.\n1000 continue\n same_stoik=same\n return\n end function same_stoik\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function fixedcomposition\n!\\begin{verbatim}\n logical function fixedcomposition(iph)\n! returns TRUE if phase cannot vary its composition\n integer iph\n!\\end{verbatim}\n integer lokph\n lokph=phases(iph)\n! Wow a bug! using iph instead of lokph!!\n if(phlista(lokph)%tnooffr-phlista(lokph)%noofsubl.eq.0) then\n! write(*,*)'3G fixedcomposition: ',iph,lokph,&\n! phlista(lokph)%tnooffr,phlista(lokph)%noofsubl\n fixedcomposition=.true.\n else\n fixedcomposition=.false.\n endif\n1000 continue\n return\n end function fixedcomposition\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n!> 17. Section: miscellaneous\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function phvarlok\n!\\begin{verbatim}\n integer function phvarlok(lokph)\n! return index of the first phase_varres record for phase with location lokph\n! needed for external routines as phlista is private\n implicit none\n integer lokph\n!\\end{verbatim}\n phvarlok=phlista(lokph)%linktocs(1)\n return\n end function phvarlok\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine palmtree\n!\\begin{verbatim}\n subroutine palmtree(lokph)\n! Initiates a numbering of all interaction trees of an endmember of a phase\n! Called from calcg_internal for each phase unless PHPALM set\n implicit none\n integer lokph\n!\\end{verbatim}\n integer seq,level\n type(gtp_endmember), pointer :: endm\n type(gtp_interaction), pointer :: intrec\n type stack\n type(gtp_interaction), pointer :: p1\n end type stack\n type(stack), dimension(5) :: int_stack\n logical both\n both=.false.\n endm=>phlista(lokph)%ordered\n70 continue\n emloop:do while(associated(endm))\n intrec=>endm%intpointer\n seq=0\n level=0\n100 continue\n do while(associated(intrec))\n level=level+1\n if(level.gt.5) then\n write(*,*)'3Y Interaction more than 5 levels deep!'\n gx%bmperr=4347; goto 1000\n endif\n int_stack(level)%p1=>intrec\n seq=seq+1\n intrec%order=seq\n intrec=>intrec%highlink\n enddo\n if(level.gt.0) then\n intrec=>int_stack(level)%p1\n level=level-1\n intrec=>intrec%nextlink\n goto 100\n endif\n endm=>endm%nextem\n enddo emloop\n if(.not.both .and. associated(phlista(lokph)%disordered)) then\n endm=>phlista(lokph)%disordered\n both=.true.\n goto 70\n endif\n1000 continue\n return\n end subroutine palmtree\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine sortinphtup\n!\\begin{verbatim}\n subroutine sortinphtup(n,m,xx)\n! subroutine to sort the values in xx which are in phase and compset order\n! in phase tuple order. This is needed by the TQ interface\n! The number of values belonging to the phase is m (for example composition)\n! argument ceq added as new composition sets can be created ...\n integer n,m\n! double precision xx(n*m)\n double precision xx(*)\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n!\n integer iz,jz,kz,lz,lokph,aha,errall\n double precision, dimension(:), allocatable :: dum\n! I assume the values are NP(*), maybe there are other cases ...\n! Karl had overflow error in dum ... no problem to make it a little larger\n! but then I cannot set xx=dum below ...\n allocate(dum(n*m+10),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 16: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! write(*,*)'3F corrected sortinphtup',n,m\n! write(*,10)'3F in: ',(xx(iz),iz=1,n*m)\n10 format(a,10(f7.4))\n kz=0\n do iz=1,noofph\n lokph=phases(iz)\n do jz=1,phlista(lokph)%noofcs\n! if(jz.gt.1) then\n! in xx the values are sequentially for all composition sets for this phase\n! But they should be stored in tuple order and compset 2 etc comes at the end\n! the index to the tuple is in %phtups\n! phlista(lokph)%linktocs(jz) is index of phase_varres record for compset\n! firsteq%phase_varres(..)%phtupx is index of phase tuple for compset\n! There can be m values (for example compositions) for each phase\n! BUG FIXED: Sigli example gives hard error here\n! index '0' of array 'firsteq' below lower boundary of 1\n aha=(firsteq%phase_varres(phlista(lokph)%linktocs(jz))%phtupx-1)*m\n! if(aha.ne.kz) then\n! write(*,*)'3F shifting from, to, values: ',kz,aha,m\n! endif\n do lz=1,m\n dum(aha+lz)=xx(kz+lz)\n enddo\n kz=kz+m\n enddo\n enddo\n! xx=dum\n do iz=1,n*m\n xx(iz)=dum(iz)\n enddo\n deallocate(dum)\n! write(*,10)'3F ut: ',(xx(iz),iz=1,n*m)\n1000 continue\n return\n end subroutine sortinphtup\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function get_mpi_index\n!\\begin{verbatim}\n integer function get_mpi_index(mpi)\n! Return the index of a model parameter identifier\n character mpi*(*)\n!\\end{verbatim} %+\n! propid(jj)%symbol is *4\n character text*4\n integer jj\n text=mpi\n do jj=1,ndefprop\n if(propid(jj)%symbol.eq.text) exit\n enddo\n!\n if(jj.gt.ndefprop) then\n write(*,*)'3A no such model parameter identifier: ',trim(mpi)\n gx%bmperr=4399; jj=-1\n endif\n! write(*,*)'3A get_mpi_index: ',text,ndefprop,jj\n get_mpi_index=jj\n return\n end function get_mpi_index\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n!\\addtotable integer function getmqindex\n!\\begin{verbatim}\n! integer function getmqindex()\n! This is necessary because mqindex is private, replaced by getmpiindex ...\n!\\end{verbatim}\n! getmqindex=mqindex\n! return\n! end function getmqindex\n!\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function allowenter\n!\\begin{verbatim}\n logical function allowenter(mode)\n! Check if certain commands are allowed\n! mode=1 means entering an element or species\n! this routine is no longer used when entering species\n! mode=2 means entering a phase\n! mode=3 means entering an equilibrium\n! returns TRUE if command can be executed\n implicit none\n integer mode\n!\\end{verbatim}\n! write(*,*)'3Y In allowenter: ',mode\n logical yesorno\n yesorno=.FALSE.\n if(mode.le.0 .or. mode.gt.3) goto 1000\n if(mode.eq.1) then\n! enter element or species not allowed after entering first phase\n if(noofph.gt.0) goto 1000\n yesorno=.TRUE.\n elseif(mode.eq.2) then\n! enter phases of a disordred fraction set not allowed\n! if there are no elements or after entering a second equilibrium\n! write(*,*)'3Y allowenter ',mode,noofel,eqfree,noofph\n if(noofel.eq.0) goto 1000\n if(eqfree.gt.2) goto 1000\n yesorno=.TRUE.\n elseif(mode.eq.3) then\n! there must be at least one phase before entering a second equilibrium\n! Note this is tested also for entering the default equilibrium\n! write(*,*)'3Y mode 3: ',eqfree,noofph\n if(eqfree.ge.2 .and. noofph.eq.0) goto 1000\n yesorno=.TRUE.\n endif\n1000 continue\n allowenter=yesorno\n! write(*,*)'3Y: allowenter:',yesorno,mode\n return\n end function allowenter\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable logical function proper_symbol_name\n!\\begin{verbatim}\n logical function proper_symbol_name(name,typ)\n! checks that name is a proper name for a symbol\n! A proper name must start with a letter A-Z\n! for typ=0 it must contain only letters, digits and underscore\n! for typ=1 it may contain also +, - maybe ?\n! It must not be equal to a state variable\n implicit none\n integer typ\n character name*(*)\n!\\end{verbatim}\n character name2*64,ch1*1,chx*1\n integer jl\n logical korrekt\n! write(*,*)'3Y entering proper_symbol_name: ',name,typ\n korrekt=.FALSE.\n if(typ.lt.0 .or. typ.gt.0) then\n gx%bmperr=4139; goto 1000\n endif\n name2=name\n call capson(name2)\n if(.not.ucletter(name2(1:1))) then\n! the first character of a symbol must always be a letter A-Z\n! write(*,*)'3Y Wrong first letter of symbol: ',name2(1:1),':',name2(1:5)\n gx%bmperr=4137; goto 1000\n endif\n jl=1\n! write(*,*)'3Y check name: ',name2\n100 continue\n jl=jl+1\n ch1=name2(jl:jl)\n! always finish when fining a space \n if(ch1.eq.' ') then\n! any symbol with at least 3 characters OK\n if(jl.le.2) then\n! A single letter must be a state variable\n if(name2(1:1).eq.'A' .or. name2(1:1).eq.'B' .or. &\n name2(1:1).eq.'G' .or. name2(1:1).eq.'H' .or. &\n name2(1:1).eq.'M' .or. name2(1:1).eq.'N' .or.&\n name2(1:1).eq.'P' .or. name2(1:1).eq.'Q' .or. &\n name2(1:1).eq.'S' .or. &\n name2(1:1).eq.'T' .or. name2(1:1).eq.'U' .or.&\n name2(1:1).eq.'V' .or. name2(1:1).eq.'W' .or. &\n name2(1:1).eq.'X' .or. name2(1:1).eq.'Y') then\n if(jl.eq.2) then\n gx%bmperr=4137; goto 1000\n elseif(name2(2:2).eq.'F' .or. name2(2:2).eq.'M' .or. &\n name2(2:2).eq.'P' .or. name2(2:2).eq.'U' .or. &\n name2(2:2).eq.'V' .or. name2(2:2).eq.'W') then\n! A two letter name must not have certain second letter\n gx%bmperr=4137; goto 1000\n endif\n endif\n endif\n korrekt=.TRUE.\n name(jl:)=' '\n goto 1000\n endif\n if(typ.eq.0) then\n if(ch1.ge.'0' .and. ch1.le.'9') goto 100\n if(ch1.ge.'A' .and. ch1.le.'Z') goto 100\n if(ch1.eq.'_') goto 100\n gx%bmperr=4138\n! else\n! unknown type of symbol\n! gx%bmperr=4139\n endif\n!\n1000 continue\n!\n if(.not.korrekt) write(*,*)'3Y Illegal name: ',name2,jl\n proper_symbol_name=korrekt\n return\n end function proper_symbol_name\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine compmassbug\n!\\begin{verbatim}\n subroutine compmassbug(ceq)\n! debug subroutine\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer cp,sp,ep\n! elements(1..n) is ordered alphabetcally\n! complist(1..n) is initially also ordered alphabetcally but with errors ... \n! \n do cp=1,noofel\n sp=ceq%complist(cp)%splink\n ep=splista(sp)%ellinks(1)\n write(*,100)cp,sp,ep,trim(ellista(ep)%name),trim(splista(sp)%symbol),&\n ellista(ep)%alphaindex,ellista(ep)%splink,&\n ceq%complist(cp)%mass,mass_of(cp,ceq),&\n ellista(ep)%mass,splista(sp)%mass\n100 format(3i3,2x,a2,2x,a2,2i3,3x,4(1pe12.4))\n enddo\n write(*,*)\n return\n end subroutine compmassbug\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine list_free_lists\n!\\begin{verbatim}\n subroutine list_free_lists(lut)\n! for debugging the free lists and routines using them\n implicit none\n integer lut\n!\\end{verbatim}\n integer lok,last\n write(lut,1007)noofel,noofsp,noofph,noofem,noofint,noofprop,&\n notpf(),highcs,eqfree-1,nsvfun,reffree-1,addrecs\n1007 format('Records for elements, species, phases: ',3i5/&\n 'end members, interactions, properties: ',3i5/&\n 'TP-funs, composition sets, equilibria: ',3i5/&\n 'state variable functions, references, additions: ',3i5)\n!----------------------------\n! first free is csfree, free list is only in equilibrium firsteq\n600 continue\n write(lut,610)csfree,highcs\n610 format('Phase_varres first free/highcs: ',2i5)\n! NOTE csfree can be higher than highcs ... after deletion pointers can go back\n! UNFINISHED??\n! lok=csfree\n! list free list for composition sets\n! write(*,*)'3Y csfree and highcs: ',csfree,highcs\n!611 continue\n! last=lok\n! lok=firsteq%phase_varres(last)%nextfree\n! write(*,*)'3Y lok: ',last,lok\n! if(lok.gt.0) goto 611\n!\n lok=csfree\n620 continue\n if(lok+5.lt.highcs) then\n last=lok\n lok=firsteq%phase_varres(last)%nextfree\n write(*,*)'3Y free varres record at: ',lok,last\n if(lok.le.0) then\n write(lut,*)'Error in phase_varres free list',last,lok\n goto 1000\n else\n goto 620\n endif\n endif\n! no more\n630 continue\n1000 continue\n return\n end subroutine list_free_lists\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_phase_amounts\n!\\begin{verbatim}\n subroutine set_phase_amounts(jph,ics,val,ceq)\n! set the amount formula units of a phase. Called from user i/f\n! iph can be -1 meaning all phases, all composition sets\n implicit none\n integer jph,ics\n double precision val\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer iph,lokph,lokcs\n double precision amount\n if(jph.lt.0) then\n iph=1; ics=1\n else\n iph=jph\n endif\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n100 continue\n if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700\n! ceq%phase_varres(lokcs)%amount(1)=val\n ceq%phase_varres(lokcs)%amfu=val\n700 continue\n if(jph.lt.0) then\n ics=ics+1\n710 continue\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0;\n iph=iph+1\n if(iph.gt.noofph) goto 1000\n ics=1; goto 710\n endif\n goto 100\n endif\n1000 continue\n return\n end subroutine set_phase_amounts\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_default_constitution\n!\\begin{verbatim}\n subroutine set_default_constitution(iph,ics,ceq)\n! the current constitution of (iph#ics) is set to its default constitution\n! (if any), otherwise a random value. The amount of the phase not changed\n implicit none\n integer iph,ics\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer lokph,lokcs,ll,jj,kk,kk0\n type(gtp_phase_varres), pointer :: cset\n double precision, allocatable :: yarr(:)\n double precision sum, qq(5),var\n!\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n cset=>ceq%phase_varres(lokcs)\n! we must use set_constitution at the end to update various internal variables\n allocate(yarr(phlista(lokph)%tnooffr))\n! if(btest(cset%status2,CSDEFCON)) then\n if(allocated(cset%mmyfr)) then\n! there is an allocated default constitution\n! write(*,12)'3Y mmfy: ',(cset%mmyfr(kk),kk=1,phlista(lokph)%tnooffr)\n kk=0\n subl1: do ll=1,phlista(lokph)%noofsubl\n kk0=kk\n sum=zero\n if(phlista(lokph)%nooffr(ll).gt.1) then\n do jj=1,phlista(lokph)%nooffr(ll)\n! negative mmy(kk) means < , a maximum, set a small value\n kk=kk+1\n if(cset%mmyfr(kk).lt.0.0E0) then\n yarr(kk)=0.01D0\n else\n yarr(kk)=one\n endif\n sum=sum+yarr(kk)\n enddo\n kk=kk0\n! the sum of fractions should be unity, hm done in set_constitution also ...\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n yarr(kk)=yarr(kk)/sum\n enddo\n else\n! a single constituent, just increment kk and leave fraction as unity\n kk=kk+1\n yarr(kk)=one\n endif\n enddo subl1\n! write(*,12)'3Y defy: ',(yarr(kk),kk=1,phlista(lokph)%tnooffr)\n12 format(a,10F6.3)\n else\n! there is no default constitution, set equal amount of all fractions\n! with some randomness\n! write(*,*)'3Y No default constituition for: ',iph,ics\n! if(btest(cset%status2,CSDEFCON)) then\n! write(*,*)'3Y default constitution set not allocated'\n! endif\n kk=0\n subl2: do ll=1,phlista(lokph)%noofsubl\n if(phlista(lokph)%nooffr(ll).gt.1) then\n! set equal amount of all fractions with some variation\n sum=one/real(phlista(lokph)%nooffr(ll))\n var=0.1D0*sum\n do jj=1,phlista(lokph)%nooffr(ll)\n kk=kk+1\n yarr(kk)=sum+var\n var=-0.9D0*var\n enddo\n else\n! a single constituent, just increment kk and ensure the fraction is unity\n kk=kk+1\n yarr(kk)=one\n endif\n enddo subl2\n endif\n! write(*,411)yarr\n411 format('3Y set_def_const: ',8F7.4,(10f7.4))\n! in this routine the fractions in each sublattice is normallized to be unity\n call set_constitution(iph,ics,yarr,qq,ceq)\n deallocate(yarr)\n1000 continue\n return\n end subroutine set_default_constitution\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine todo_before\n!\\begin{verbatim}\n subroutine todo_before(mode,ceq)\n! this could be called before an equilibrium calculation\n! It should remove any phase amounts and clears CSSTABLE\n! DUMMY\n!\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer mode\n!\\end{verbatim}\n integer iph,ics,lokph,lokcs\n!\n! write(*,*)'3Y Todo_before ... not implemented'\n goto 1000\n!\n phloop: do iph=1,noph()\n lokph=phases(iph)\n! skip hidden phases\n if(btest(phlista(lokph)%status1,PHHID)) cycle\n300 csloop: do ics=1,phlista(lokph)%noofcs\n lokcs=phlista(lokph)%linktocs(ics)\n! ceq%phase_varres(lokcs)%amount(1)=zero\n ceq%phase_varres(lokcs)%amfu=zero\n! ceq%phase_varres(lokcs)%status2=&\n! ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE)\n enddo csloop\n enddo phloop\n!\n1000 continue\n return\n end subroutine todo_before\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine todo_after_found_equilibrium\n!\\begin{verbatim}\n subroutine todo_after_found_equilibrium(mode,addtuple,ceq)\n! this is called after an equilibrium calculation by calceq2 and calceq3\n! It marks stable phase (set CSSTABLE and remove any CSAUTO)\n! It removes redundant unstable composition sets created automatically\n! (CSAUTO set). It will also shift stable composition sets to loweest \n! possible (it will take into account if there are default constituent \n! fractions, CSDEFCON set).\n! mode determine some of the actions, at present only >0 or <0 matters\n!\n! >>>>>>>>>>> THIS IS DANGEROUS IN PARALLEL PROCESSING\n! It should work in step and map as a composition set that once been stable\n! will never be removed except if one does global minimization during the\n! step and map. The function global_equil_check works on a copy of the\n! ceq record and creates only a grid, it does not create any composition sets.\n! NOTE that automatically entered metallic-FCC and MC-carbides may shift\n! composition sets. Such shifts can be avoided by manual entering composition\n! sets with default constitutions, but that does not always work as comparing\n! a stable constitution with several defaults is not trivial ...\n!\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer mode,addtuple\n!\\end{verbatim}\n integer iph,ics,lokph,lokics,jcs,lokjcs,lastset,lokkcs,kzz,jtup,qq\n integer jstat2,fit,phs,haha1,haha2,disfravares,addph,icsno\n double precision val,xj1,xj2,extra(5)\n logical notok,noremove,globalok,once\n character jpre*4,jsuf*4\n real, dimension(:), allocatable :: tmmyfr\n double precision, dimension(:), allocatable :: yfr\n! THIS ROUTINE MUST BE CLEANED UP\n!\n! write(*,*)'3Y in todo_after',mode\n!----------------------------------------------------------------\n addtuple=0\n if(btest(globaldata%status,GSNOAFTEREQ)) goto 1000\n nostart: if(mode.lt.0 .or. btest(globaldata%status,GSTGRID)) then\n! if mode<0 the conditions did not allow gridmin before use it after\n if(btest(globaldata%status,GSNOGLOB)) goto 200\n! Problems with this calculation so global_equil_check is disabled inside ...\n write(*,3)\n3 format('3Y Testing if any gridpoint is below the calculated equilibrium')\n if(btest(globaldata%status,GSNOTELCOMP)) then\n write(*,*)'3Y Cannot test global equilibrium when these components'\n goto 1000\n endif\n qq=1\n! this generates a grid for test\n globalok=global_equil_check1(qq,addph,yfr,ceq)\n! write(*,*)'3Y Back from global_equil_check1',gx%bmperr,lokph\n if(globalok) then\n! if TRUE equilibrium OK or it could not be tested\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y Testing equilibrium with global minimizer failed'\n goto 1000\n endif\n! write(*,*)'3Y Grid minimizer test of equilibrium OK'\n else\n! if FALSE the test showed this is not a global equilibrium, handle this!\n gx%bmperr=0\n lokph=phases(addph)\n write(*,*)'3Y Equilibrium wrong, gridtest found ',phlista(lokph)%name\n if(btest(globaldata%status,GSNORECALC)) goto 1000\n! write(*,*)'3Y add as stable: ',phlista(lokph)%name\n! we should add addph to the stable set of phases and recalculate\n! we have to check the state of all composition sets\n do ics=1,9\n lokics=phlista(lokph)%linktocs(ics)\n! write(*,*)'3Y Checking: ',addph,ics,lokph,lokics\n if(lokics.eq.0) then\n! If we are not allowed to create composition sets quit\n if(btest(globaldata%status,GSNOACS)) goto 1000\n! we have to create a new composition set and set that stable\n! return with error code to initiate new calculation, icsno returned\n! write(*,*)'3Y Creating a new composition set',addph\n call enter_composition_set(addph,' ','CHKD',icsno)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating composition set',gx%bmperr\n goto 1000\n endif\n call get_phase_compset(addph,icsno,lokph,lokics)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'3Y ceated comp.set: ',ceq%phase_varres(lokics)%phtupx\n ceq%phase_varres(lokics)%status2=&\n ibset(ceq%phase_varres(lokics)%status2,CSAUTO)\n! we must set the constitution also!!\n call set_constitution(addph,icsno,yfr,extra,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y error setting y of new comp.set'\n goto 1000\n endif\n! set some positive amount\n ceq%phase_varres(lokics)%amfu=1.0D-3\n! I do not think the tuple has been created ... just set the phase index\n addtuple=ceq%phase_varres(lokics)%phtupx\n write(*,*)'3Y recalculate with: ',addtuple,icsno,lokics\n gx%bmperr=4358\n goto 1000\n elseif(ceq%phase_varres(lokics)%phstate.lt.PHENTUNST) then\n! this set is dormant, ignore this stable ste and give no error\n write(*,*)'3Y Skip dormant phase no',&\n ceq%phase_varres(lokics)%phtupx\n! if there is a dormant composition set do not enter a new\n goto 200\n elseif(ceq%phase_varres(lokics)%phstate.eq.PHENTERED) then\n! This composition set is entered but not stable, set it as stable and\n! jump back with error code and calculate again\n ceq%phase_varres(lokics)%phstate=PHENTSTAB\n ceq%phase_varres(lokics)%amfu=1.0D-3\n addtuple=ceq%phase_varres(lokics)%phtupx\n! write(*,*)'3Y recalculate with gridpoint stable',addtuple,ics\n! we must set the constitution also!!\n call set_constitution(addph,ics,yfr,extra,ceq)\n gx%bmperr=4358\n goto 1000\n else\n! phase is stable or even fix, there is a miscibility gap, check if there are\n! any more composition sets?\n! write(*,*)'3Y phase has a stable comp.set: ',addph,ics\n endif\n enddo\n! no cleanup\n goto 1000\n endif\n endif nostart\n!--------------------------------------------------------------------\n! Shift all stable composition down to lower comp.sets\n200 continue\n! write(*,*)'3Y Shifting composition sets'\n phloop1: do iph=1,noph()\n lokph=phases(iph)\n if(btest(phlista(lokph)%status1,PHHID)) cycle\n csloop1: do ics=2,phlista(lokph)%noofcs\n lokics=phlista(lokph)%linktocs(ics)\n! write(*,*)'3Y shift down: ',ics,lokics,&\n! ceq%phase_varres(lokics)%phstate,&\n! btest(ceq%phase_varres(lokics)%status2,CSAUTO),&\n! btest(ceq%phase_varres(lokics)%status2,CSTEMPAR)\n if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB .and. &\n btest(ceq%phase_varres(lokics)%status2,CSTEMPAR)) then\n! btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then\n fit=100\n! This comp.set is stable, check if a lower compset is unstable\n csloop2: do jcs=1,ics-1\n lokjcs=phlista(lokph)%linktocs(jcs)\n if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) then\n! do not bother if composition of lokics fits defaults in lokjcs\n! if(.not.checkdefcon(lokics,lokjcs,fit,ceq)) cycle csloop2\n! write(*,*)'3Y Moving stable comp.set ',ics,' down to ',jcs\n goto 500\n elseif(jcs.eq.ics-1) then\n if(fit.gt.2) then\n! No lower unstable comp.set, or no one which almost fit default const,\n! lokics must remain stable, remove CSAUTO bit\n! Do not remove the suffix _AUTO\n! write(*,*)'3Y Keeping AUTO comp.set ',ics,lokics\n ceq%phase_varres(lokics)%status2=&\n ibclr(ceq%phase_varres(lokics)%status2,CSAUTO)\n exit csloop2\n endif\n else\n cycle csloop2\n endif\n! Accept a default consitution which almost fits the default\n! write(*,*)'3Y Accept fit to default: ',fit,lokics,lokjcs\n500 continue\n! write(*,*)'3Y Move stable to lower unstable compsets'\n! move STABLE lokics to UNSTABLE lokjcs\n! save some jcs values of amount, dgm, status, pre&suffix and tuple index\n xj1=ceq%phase_varres(lokjcs)%amfu\n xj2=ceq%phase_varres(lokjcs)%dgm\n jtup=ceq%phase_varres(lokjcs)%phtupx\n jstat2=ceq%phase_varres(lokjcs)%status2\n jpre=ceq%phase_varres(lokjcs)%prefix\n jsuf=ceq%phase_varres(lokjcs)%suffix\n phs=ceq%phase_varres(lokjcs)%phstate\n! write(*,489)lokics,lokjcs\n if(ocv()) write(*,489)ceq%phase_varres(lokics)%phtupx,jtup\n489 format('3Y move results from tuplet ',i4,' to ',i4)\n! write(*,501)lokics,ceq%phase_varres(lokics)%mmyfr\n! write(*,501)lokjcs,ceq%phase_varres(lokjcs)%mmyfr\n501 format('3Y 501: ',i5,10F5.1)\n! copy main content of the phase_varres(lokics) record to phase_varres(lokjcs)\n! BEWARE mmyfr must be kept!\n! BEWARE disordered fraction set!!!!\n disfravares=ceq%phase_varres(lokjcs)%disfra%varreslink\n if(allocated(ceq%phase_varres(lokjcs)%mmyfr)) then\n allocate(tmmyfr(size(ceq%phase_varres(lokjcs)%mmyfr)))\n tmmyfr=ceq%phase_varres(lokjcs)%mmyfr\n ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics)\n ceq%phase_varres(lokics)%mmyfr=tmmyfr\n deallocate(tmmyfr)\n endif\n ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics)\n! Some content in jcs must be set or restorted separately\n ceq%phase_varres(lokjcs)%phtupx=jtup\n ceq%phase_varres(lokjcs)%status2=jstat2\n ceq%phase_varres(lokjcs)%prefix=jpre\n ceq%phase_varres(lokjcs)%suffix=jsuf\n ceq%phase_varres(lokjcs)%phstate=PHENTSTAB\n! ceq%phase_varres(lokjcs)%status2=&\n! ibset(ceq%phase_varres(lokjcs)%status2,CSSTABLE)\n! write(*,501)lokics,ceq%phase_varres(lokics)%mmyfr\n! write(*,501)lokjcs,ceq%phase_varres(lokjcs)%mmyfr\n! maybe CSAUTO bit set, always remove it!\n! write(*,*)'3Y Ensure CSAUTO cleared in ',jcs\n ceq%phase_varres(lokjcs)%status2=&\n ibclr(ceq%phase_varres(lokjcs)%status2,CSAUTO)\n! Some content in ics must be set separately from saved values of jcs\n ceq%phase_varres(lokics)%amfu=xj1\n ceq%phase_varres(lokics)%dgm=xj2\n ceq%phase_varres(lokics)%phstate=phs\n! clear the stable bit and set AUTO of ics ??\n! ceq%phase_varres(lokics)%status2=&\n! ibclr(ceq%phase_varres(lokics)%status2,CSSTABLE)\n! if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) &\n! write(*,*)'3Y AUTO bit already set in ',ics\n ceq%phase_varres(lokics)%status2=&\n ibset(ceq%phase_varres(lokics)%status2,CSAUTO)\n! move the link to the disordered fraction set\n ceq%phase_varres(lokjcs)%disfra%varreslink=&\n ceq%phase_varres(lokics)%disfra%varreslink\n ceq%phase_varres(lokics)%disfra%varreslink=disfravares\n exit csloop2\n enddo csloop2\n endif\n enddo csloop1\n enddo phloop1\n! haha2=phlista(lokph)%linktocs(1)\n! write(*,*)'3Y mitt 1:',lokph,haha2,ceq%phase_varres(haha2)%disfra%varreslink\n! haha2=phlista(lokph)%linktocs(2)\n! if(haha2.gt.0) &\n! write(*,*)'3Y mitt 2:',lokph,haha2,ceq%phase_varres(haha2)%disfra%varreslink\n! Here we may try to ensure that the stable comp.sets fits the\n! default constitutions of their current set\n! write(*,*)'3Y Try to shift stable comp.sets. to match default const.'\n! SEGNENTATION FAULT efter this write statement when reading unformatted file\n call shiftcompsets(ceq)\n!\n! upto now is safe ... now remove CSAUTO comp.sets if allowed\n! check if allowed to remove\n if(btest(globaldata%status,GSNOREMCS)) goto 1000\n!\n! Now try to remove unstable composition sets with CSTEMPAR bit set\n! write(*,*)'3Y loop to remove comp sets and auto bits'\n once=.TRUE.\n phloop: do iph=1,noph()\n noremove=.FALSE.\n lokph=phases(iph)\n if(btest(phlista(lokph)%status1,PHHID)) cycle\n! loop backwards for compsets to remove unstable with CSAUTO set\n lastset=phlista(lokph)%noofcs\n csloopdown: do ics=lastset,2,-1\n lokics=phlista(lokph)%linktocs(ics)\n! write(*,*)'3Y Checking comp.set ',ics\n! auto: if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then\n auto: if(btest(ceq%phase_varres(lokics)%status2,CSTEMPAR)) then\n if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) then\n! comp.set was created automatically but is not stable, it can be removed\n if(noeq().eq.1) then\n! we have just one equilibrium, OK to remove even in parallel ...\n if(once) then\n if(ocv()) write(*,801)lokics\n801 format('3Y Removing unstable phase tuple(s)',i5)\n once=.FALSE.\n endif\n! write(*,802)'3Y removing unstable phase tuple/compset ',&\n! ceq%phase_varres(lokics)%phtupx,lokics\n802 format(a,3i5)\n! remove the higherst composition set\n call remove_composition_set(iph,.FALSE.)\n if(gx%bmperr.ne.0) then\n write(*,*)'3Y failed to remove tuplet:',&\n ceq%phase_varres(lokics)%phtupx\n! reset the error code but exit the attempt to clean up\n gx%bmperr=0; goto 1000\n endif\n! write(*,*)'3Y Phase tuple removed for phase: ',iph\n!$ elseif(omp_get_num_threads().gt.1) then\n! we are running with several threads, just suspend the compset for the\n! equilibrium in this thread\n!$ call suspend_composition_set(iph,.TRUE.,ceq)\n else\n! when more than one equilibria in sequential eexecution suspend the compset\n! in all equilibria where it is not stable\n call suspend_composition_set(iph,.FALSE.,ceq)\n endif\n else\n! the comp.set is stable, clear the CSAUTO and CSTEMPAR bits\n! write(*,*)'3Y this comp.set. should never be removed'\n ceq%phase_varres(lokics)%status2=&\n ibclr(ceq%phase_varres(lokics)%status2,CSAUTO)\n ceq%phase_varres(lokics)%status2=&\n ibclr(ceq%phase_varres(lokics)%status2,CSTEMPAR)\n endif\n endif auto\n enddo csloopdown\n enddo phloop\n!\n1000 continue\n! write(*,*)'3Y Leaving todo_after!'\n! lokph=1\n! jcs=phlista(lokph)%linktocs(1)\n! write(*,*)'3Y after 1: ',lokph,jcs,ceq%phase_varres(jcs)%disfra%varreslink\n! jcs=phlista(lokph)%linktocs(2)\n! write(*,*)'3Y Leaving todo_after'\n! if(jcs.gt.0) &\n! write(*,*)'after 2: ',lokph,jcs,ceq%phase_varres(jcs)%disfra%varreslink\n return\n end subroutine todo_after_found_equilibrium\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine checkdefcon\n!\\begin{verbatim}\n subroutine checkdefcon(lokics,lokjcs,fit,ceq)\n! check if composition of lokics fits default constitution in lokjcs\n! return TRUE if lokics fits default in lokjcs\n! NOTE lokics and lokjcs can be the same!!\n integer lokics,lokjcs,fit\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer kk\n real xdef\n! write(*,*)'3Y in checkdefcon: ',lokics,lokjcs\n if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then\n if(.not.allocated(ceq%phase_varres(lokjcs)%mmyfr)) then\n! write(*,'(a,i3,a)')'3Y *** Warning: phasetuple ',&\n! ceq%phase_varres(lokjcs)%phtupx,' has no default constitution'\n fit=0; goto 1000\n endif\n! write(*,9)(ceq%phase_varres(lokjcs)%mmyfr(fit),&\n! fit=1,size(ceq%phase_varres(lokjcs)%yfr))\n9 format('3Y default: ',10F6.2)\n fit=1\n do kk=1,size(ceq%phase_varres(lokjcs)%mmyfr)\n! do kk=1,size(ceq%phase_varres(lokjcs)%yfr)\n xdef=ceq%phase_varres(lokjcs)%mmyfr(kk)\n if(xdef.eq.0) then\n! no default for this constitution\n fit=fit+1\n elseif(xdef.lt.0.0) then\n! A fraction with a maximum set (mmyfr<0) must be below mmyfr(kk)\n if(ceq%phase_varres(lokics)%yfr(kk).lt.abs(xdef)) fit=fit+1\n! write(*,11)ceq%phase_varres(lokics)%yfr(kk),' < ',xdef,kk,fit\n11 format('3Y If ',F10.6,a,F10.6,' increment ',2i3)\n else\n! A fraction with a minimum set (mmyfr>0) should be above mmyfr(kk)\n if(ceq%phase_varres(lokics)%yfr(kk).gt.xdef) fit=fit+1\n! write(*,11)ceq%phase_varres(lokics)%yfr(kk),' > ',xdef,kk,fit\n endif\n enddo\n! write(*,*)'3Y checkdefcon fit: ',fit,kk\n else\n! no default constitution, perfect fit!!\n fit=size(ceq%phase_varres(lokjcs)%yfr)\n endif\n1000 continue\n return\n end subroutine checkdefcon\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine shiftcompsets\n!\\begin{verbatim} %-\n subroutine shiftcompsets(ceq)\n! check phase with several composition sets if they should be shifted\n! to fit the default constitution better\n! IGNORE UNSTABLE COMP.SETS\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer lokph,iph,ics,lokics,jcs,lokjcs,bestfit(9,9),jj,kk,kki,kkj\n integer moveto(9)\n character ch1*1\n! write(*,*)'3Y in shiftcompsets'\n phloop: do iph=1,noofph\n lokph=phases(iph)\n manycs: if(phlista(lokph)%noofcs.gt.1) then\n! seach all compset which default constitution that fits best a stable one\n bestfit=0\n csloop1: do ics=1,phlista(lokph)%noofcs\n lokics=phlista(lokph)%linktocs(ics)\n! ignore UNSTABLE compsets with CSAUTO set ??\n if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) cycle csloop1\n call checkdefcon(lokics,lokics,kk,ceq)\n! write(*,*)'3Y fit 1: ',kk,phlista(lokph)%tnooffr\n bestfit(ics,ics)=kk\n if(kk.eq.phlista(lokph)%tnooffr) cycle csloop1\n! if no default or not perfect fit compare with other compsets\n! write(*,*)'3Y compare with next compset'\n csloop2: do jcs=1,phlista(lokph)%noofcs\n if(jcs.eq.ics) cycle csloop2\n lokjcs=phlista(lokph)%linktocs(jcs)\n if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) cycle csloop2\n call checkdefcon(lokics,lokjcs,kk,ceq)\n! write(*,*)'3Y fit 2: ',kk,phlista(lokph)%tnooffr\n bestfit(jcs,ics)=kk\n enddo csloop2\n enddo csloop1\n! do ics=1,phlista(lokph)%noofcs\n! write(*,17)(bestfit(jcs,ics),jcs=1,phlista(lokph)%noofcs)\n! enddo\n17 format('3Y bestfit: ',9i5)\n! when we are here whe can use bestfit to shift constitutions\n moveto=0\n shiftfrom: do ics=1,phlista(lokph)%noofcs\n kk=bestfit(ics,ics)\n if(kk.eq.phlista(lokph)%tnooffr) cycle shiftfrom\n shiftto: do jcs=2,phlista(lokph)%noofcs\n if(bestfit(jcs,ics).gt.kk) then\n kk=bestfit(jcs,ics)\n write(*,*)'3Y shifting: ',ics,jcs\n call switch_compsets2(lokph,ics,jcs,ceq)\n endif\n enddo shiftto\n enddo shiftfrom\n! just check do nothing for the moment ....\n! if moveto(ics) is zero do not move. otherwise moveto moveto(ics)\n! but if moveto(moveto(ics)) is zero look for a moveto() that is negative ...\n endif manycs\n enddo phloop\n! \n1000 continue\n return\n end subroutine shiftcompsets\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine switch_compsets2\n!\\begin{verbatim} %-\n subroutine switch_compsets2(lokph,ics1,ics2,ceq)\n! copy constitution and results from ic2 to ic1 and vice versa\n integer lokph,ics1,ics2\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer iph,lokcs1,lokcs2,ncon,idum,ncc\n double precision, dimension(:), allocatable :: val\n double precision, dimension(:,:), allocatable :: gval,d2gval\n double precision, dimension(:,:,:), allocatable :: dgval\n double precision qq(5),xdum\n!\n! write(*,*)'3Y In switch_compsets ',lokph,ics1,ics2\n lokcs1=phlista(lokph)%linktocs(ics1)\n lokcs2=phlista(lokph)%linktocs(ics2)\n! save current constitution of lokcs1 in val\n ncon=size(ceq%phase_varres(lokcs1)%yfr)\n allocate(val(ncon))\n val=ceq%phase_varres(lokcs1)%yfr\n! set the constitution in lokcs1 equal to that in lokcs2. This call \n! also updates a number of other variables in the record\n iph=phlista(lokph)%alphaindex\n call set_constitution(iph,ics1,ceq%phase_varres(lokcs2)%yfr,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call set_constitution(iph,ics2,val,qq,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! copy some variables: phstate, amfu and dgm\n idum=ceq%phase_varres(lokcs1)%phstate\n ceq%phase_varres(lokcs1)%phstate=ceq%phase_varres(lokcs2)%phstate\n ceq%phase_varres(lokcs2)%phstate=idum\n xdum=ceq%phase_varres(lokcs1)%amfu\n ceq%phase_varres(lokcs1)%amfu=ceq%phase_varres(lokcs2)%amfu\n ceq%phase_varres(lokcs2)%amfu=xdum\n xdum=ceq%phase_varres(lokcs1)%dgm\n ceq%phase_varres(lokcs1)%dgm=ceq%phase_varres(lokcs2)%dgm\n ceq%phase_varres(lokcs2)%dgm=xdum\n! listprop will be the same\n! Now copy result arrays\n ncon=ceq%phase_varres(lokcs1)%nprop\n allocate(gval(6,ncon))\n gval=ceq%phase_varres(lokcs1)%gval\n ceq%phase_varres(lokcs1)%gval=ceq%phase_varres(lokcs2)%gval\n ceq%phase_varres(lokcs2)%gval=gval\n! ceq%phase_varres(lokph1)%ncc is not the dimension of dgval, why??\n ncc=size(ceq%phase_varres(lokcs1)%yfr)\n allocate(dgval(3,ncc,ncon))\n! write(*,77)'3Y copycomp: ',ncc,ncon,&\n! size(dgval),size(ceq%phase_varres(lokcs1)%dgval),&\n! ceq%phase_varres(lokcs2)%ncc,\n!77 format(a,10i5)\n dgval=ceq%phase_varres(lokcs1)%dgval\n ceq%phase_varres(lokcs1)%dgval=ceq%phase_varres(lokcs2)%dgval\n ceq%phase_varres(lokcs2)%dgval=dgval\n allocate(d2gval(ncc*(ncc+1)/2,ncon))\n d2gval=ceq%phase_varres(lokcs1)%d2gval\n ceq%phase_varres(lokcs1)%d2gval=ceq%phase_varres(lokcs2)%d2gval\n ceq%phase_varres(lokcs2)%d2gval=d2gval\n! addg!!\n! if(btest(ceq%phase_varres(lokcs1)%status2\n if(allocated(ceq%phase_varres(lokcs1)%addg)) then\n val(1)=ceq%phase_varres(lokcs1)%addg(1)\n ceq%phase_varres(lokcs1)%addg(1)=ceq%phase_varres(lokcs2)%addg(1)\n ceq%phase_varres(lokcs2)%addg(1)=val(1)\n endif\n! curlat, cinvy, cxmol, cdxmol?\n1000 continue\n! deallocate\n deallocate(val)\n deallocate(gval)\n deallocate(dgval)\n deallocate(d2gval)\n return\n end subroutine switch_compsets2\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine select_composition_set\n!\\begin{verbatim}\n subroutine select_composition_set(iph,ics,yarr,ceq)\n! PROBABLY NOT USED but should be implemenented\n! if phase iph wants to become stable and there are several user defined\n! composition sets with default composition limits this subroutine tries to\n! select the one that fits these limits best.\n! For example if an FCC phase that could be an austenite (low carbon content)\n! or a cubic carbo-nitride (high carbon or nitrogen content, low vacancy)\n! Less easy to handle ordered phases like B2 or L1_2 as ordering can be\n! in any sublatittice ... but with option B and F that is possible\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n double precision, dimension(*) :: yarr\n integer iph,ics\n!\\end{verbatim}\n double precision, parameter :: yl=0.1D0,yh=0.5D0\n integer best,lokph,maxnh,ncc,jcs,lokcs,nh,jl\n lokph=phases(iph)\n best=1\n maxnh=0\n ncc=phlista(lokph)%tnooffr\n do jcs=1,phlista(lokph)%noofcs \n! loop through all composition sets\n lokcs=phlista(lokph)%linktocs(jcs)\n! compare yarr with ceq%phase_varres(lokcs)%mmyfr\n nh=0\n do jl=1,ncc\n if(ceq%phase_varres(lokcs)%mmyfr(jl).lt.zero) then\n if(yarr(jl).lt.yl) nh=nh+1\n elseif(ceq%phase_varres(lokcs)%mmyfr(jl).gt.zero) then\n if(yarr(jl).gt.yh) nh=nh+1\n endif\n enddo\n if(nh.gt.maxnh) then\n maxnh=nh\n best=jcs\n endif\n enddo\n! if only one compset return this!\n ics=best\n!\n1000 continue\n return\n end subroutine select_composition_set\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine verify_phase_varres_array\n!\\begin{verbatim}\n subroutine verify_phase_varres_array(ieq,verbose)\n! This subroutine checks that the phase varres array is consistent\n! in equilibrium ieq. For ieq=1 it also checks the free list\n! UNFINISHED and not yet used BUT IMPORTANT\n implicit none\n integer ieq,verbose\n!\\end{verbatim}\n integer free,lokcs,lokph \n type(gtp_phase_varres), pointer :: vares\n type(gtp_equilibrium_data), pointer :: ceq\n ceq=>eqlista(ieq)\n if(ieq.eq.1) then\n! check free list inside phase_varres records\n if(csfree.lt.1 .or. csfree.gt.size(ceq%phase_varres)) then\n write(*,*)'3Y ERROR: csfree value outside limits: ',csfree\n goto 1000\n endif\n lokcs=csfree\n50 continue\n if(lokcs.lt.1 .or. lokcs.gt.size(ceq%phase_varres)) then\n write(*,*)'3Y ERROR: varres free list index outside limits: ',lokcs\n goto 1000\n endif\n lokcs=ceq%phase_varres(lokcs)%nextfree\n if(lokcs.lt.size(ceq%phase_varres)) goto 50\n!-------\n write(*,*)'3Y varres free list seems OK.'\n endif\n!-------\n! check each used varres record that it has a correct phase pointer etc.\n! UNFINISHED\n1000 continue\n return\n end subroutine verify_phase_varres_array\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine set_emergency_startpoint\n!\\begin{verbatim}\n subroutine set_emergency_startpoint(mode,phl,amfu,ceq)\n! this is called if no previous equilibrium and if grid minimizer\n! cannot be used. Select for each element a phase with as much of that\n! element as possible to set as stable. Set the remaining phases to a default\n! composition. It will never create any compositon sets\n!\n implicit none\n integer mode,phl(*)\n double precision amfu(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer iph,lokph,lokcs,iel,errall\n integer, allocatable, dimension(:) :: selected\n double precision, allocatable, dimension(:,:) :: maxel\n double precision, allocatable, dimension(:) :: wmass\n double precision totmol,totmass,am\n!\n write(*,*)'In emergency startpoint: ',mode,noofel,noofph\n allocate(selected(noofel),stat=errall)\n allocate(maxel(noofel,noofph),stat=errall)\n allocate(wmass(noofel),stat=errall)\n if(errall.ne.0) then\n write(*,*)'3Y allocation error 17: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! phl=0\n! amfu=zero\n maxel=zero\n phloop1: do iph=1,noofph\n lokph=phases(iph)\n lokcs=phlista(iph)%linktocs(1)\n if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop1\n if(phlista(iph)%tnooffr-phlista(iph)%noofsubl.eq.0) then\n call calc_phase_molmass(iph,1,maxel(1,iph),wmass,totmol,totmass,am,ceq)\n if(gx%bmperr.ne.0) goto 1000\n else\n write(*,*)'3Y TODO: Phases with variable composition not included yet'\n endif\n! loop through all fractions to find limits \n enddo phloop1\n! do iph=1,noofph\n! write(*,100)iph,(maxel(iel,iph),iel=1,noofel)\n! enddo\n100 format('3Y maxel: ',i3,6(F8.5))\n selected=0\n wmass=zero\n phloop2: do iph=1,noofph\n lokph=phases(iph)\n lokcs=phlista(iph)%linktocs(1)\n if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop2\n elloop1: do iel=1,noofel\n if(maxel(iel,iph).gt.wmass(iel)) then\n wmass(iel)=maxel(iel,iph)\n selected(iel)=iph\n! we can only have one element selected per phase ...\n cycle phloop2\n endif\n enddo elloop1\n enddo phloop2\n! write(*,*)'3Y Emergency startpoint testing',mode\n! write(*,200)'3Y selected: ',(selected(iel),iel=1,noofel)\n200 format(a,10i4)\n! Now set default constitution of all non-selected and non-suspended phases\n phloop3: do iph=1,noofph\n lokph=phases(iph)\n lokcs=phlista(iph)%linktocs(1)\n if(ceq%phase_varres(lokcs)%phstate.le.PHDORM) cycle phloop3\n do iel=1,noofel\n if(iph.eq.selected(iel)) cycle phloop3\n enddo\n! write(*,*)'3Y TODO set default constitutions: ',iph\n call set_default_constitution(iph,1,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo phloop3\n mode=noofel\n do iph=1,mode\n phl(iph)=selected(iph)\n enddo\n!\n1000 continue\n return\n end subroutine set_emergency_startpoint\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function ocv\n!\\begin{verbatim}\n logical function ocv()\n! returns TRUE if GSVERBOSE bit is set\n!\\end{verbatim} %+\n! typical use: if(ocv()) write(*,*)....\n ocv=btest(globaldata%status,GSVERBOSE)\n return\n end function ocv\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function ceqsize\n!\\begin{verbatim}\n integer function ceqsize(ceq)\n! calculates the size in words (4 bytes) of an equilibrium record\n implicit none\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer sum,vsum,ivs,vss\n! write(*,*)'In ceqsize 1'\n!\n! integer status,multiuse,eqno,next\n! character eqname*24\n! double precision tpval(2),rtn\n! svfunres: the values of state variable functions valid for this equilibrium\n! double precision, dimension(:), allocatable :: svfunres\n sum=18+2*size(ceq%svfunres)\n write(*,*)'total + svfunres: ',sum,size(ceq%svfunres)\n! the experiments are used in assessments and stored like conditions \n! lastcondition: link to condition list\n! lastexperiment: link to experiment list\n! TYPE(gtp_condition), pointer :: lastcondition,lastexperiment\n! assuming a pointer is 4 bytes (2 words)\n sum=sum+4\n! components and conversion matrix from components to elements\n! complist: array with components\n! compstoi: stoichiometric matrix of compoents relative to elements\n! invcompstoi: inverted stoichiometric matrix\n! TYPE(gtp_components), dimension(:), allocatable :: complist\n! double precision, dimension(:,:), allocatable :: compstoi\n! double precision, dimension(:,:), allocatable :: invcompstoi\n! a gtp_component record is about 20 words, invcompstoi same as compsoti\n if(allocated(ceq%complist)) sum=sum+20*size(ceq%complist)+&\n 4*size(ceq%compstoi)\n write(*,*)'total + complist:',sum,20*size(ceq%complist),4*size(ceq%compstoi)\n! one record for each phase+composition set that can be calculated\n! phase_varres: here all calculated data for the phase is stored\n! TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres\n! each phase_varres record is different for each phase\n vsum=0\n! highcs is highest used free phase_varres record\n do ivs=1,highcs\n vss=vssize(ceq%phase_varres(ivs))\n write(*,*)'Phase varres: ',ivs,vss\n vsum=vsum+vss\n enddo\n sum=sum+vsum\n write(*,*)'total + varres',sum,vsum\n! index to the tpfun_parres array is the same as in the global array tpres \n! eq_tpres: here local calculated values of TP functions are stored\n! TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres\n! each tpfun_parres record is 8 double\n sum=sum+16*size(ceq%eq_tpres)\n! current values of chemical potentials stored in component record but\n! duplicated here for easy acces by application software\n! double precision, dimension(:), allocatable :: cmuval\n if(allocated(ceq%cmuval)) sum=sum+2*size(ceq%cmuval)\n write(*,*)'total + cmuval: ',sum,2*size(ceq%cmuval)\n! xconc: convergence criteria for constituent fractions and other things\n! double precision xconv\n! delta-G value for merging gridpoints in grid minimizer\n! smaller value creates problem for test step3.BMM, MC and austenite merged\n! double precision :: gmindif=-5.0D-2\n! maxiter: maximum number of iterations allowed\n! integer maxiter\n sum=sum+5\n! this is to save a copy of the last calculated system matrix, needed\n! to calculate dot derivatives, initiate to zero\n! integer :: sysmatdim=0,nfixmu=0,nfixph=0\n! integer, allocatable :: fixmu(:)\n! integer, allocatable :: fixph(:,:)\n! double precision, allocatable :: savesysmat(:,:)\n sum=sum+3+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat)\n write(*,*)'total + savesysmat:',sum,size(ceq%fixmu),size(ceq%fixph),&\n size(ceq%savesysmat)\n ceqsize=sum\n1000 continue\n return\n end function ceqsize\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function vssize\n!\\begin{verbatim}\n integer function vssize(varres)\n! calculates the size in words (4 bytes) of a phase_varres record\n implicit none\n type(gtp_phase_varres) :: varres\n!\\end{verbatim}\n integer sum\n! write(*,*)'In vssize 1'\n! integer nextfree,phlink,status2,phstate\n! double precision, dimension(2) :: abnorm\n! character*4 prefix,suffix\n sum=10\n! changed to allocatable\n! integer, dimension(:), allocatable :: constat\n! double precision, dimension(:), allocatable :: yfr\n! real, dimension(:), allocatable :: mmyfr\n! double precision, dimension(:), allocatable :: sites\n if(allocated(varres%constat)) sum=sum+size(varres%constat)\n write(*,*)'varressum+yfr: ',sum,size(varres%constat),3*size(varres%yfr)\n if(allocated(varres%yfr)) sum=sum+3*size(varres%yfr)\n! write(*,*)'In vssize 2',sum\n! for ionic liquid derivatives of sites wrt fractions (it is the charge), \n! 2nd derivates only when one constituent is vacancy\n! 1st sublattice P=\\sum_j (-v_j)*y_j + Qy_Va\n! 2nd sublattice Q=\\sum_i v_i*y_i\n! double precision, dimension(:), allocatable :: dpqdy\n! double precision, dimension(:), allocatable :: d2pqdvay\n if(allocated(varres%dpqdy)) sum=sum+size(varres%dpqdy)\n if(allocated(varres%d2pqdvay)) sum=sum+size(varres%d2pqdvay)\n write(*,*)'varressum+ionliq',sum,size(varres%dpqdy),size(varres%d2pqdvay)\n! for extra fraction sets, better to go via phase record index above\n! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this\n! way means the record is stored inside this record.\n! type(gtp_fraction_set) :: disfra\n! size of disfra record??\n sum=sum+10\n if(allocated(varres%disfra%dsites)) sum=sum+size(varres%disfra%dsites)\n if(allocated(varres%disfra%nooffr)) sum=sum+size(varres%disfra%nooffr)\n if(allocated(varres%disfra%splink)) sum=sum+size(varres%disfra%splink)\n if(allocated(varres%disfra%y2x)) sum=sum+size(varres%disfra%y2x)\n if(allocated(varres%disfra%dxidyj)) sum=sum+size(varres%disfra%dxidyj)\n write(*,*)'varresum incl disfra and pointer: ',sum,varres%disfra%varreslink\n! It seems difficult to get the phdapointer in disfra record to work\n! ---\n! arrays for storing calculated results for each phase (composition set)\n! amfu: is amount formula units of the composition set (calculated result)\n! netcharge: is net charge of phase\n! dgm: driving force (calculated result)\n! amcom: not used\n! damount: set to last change of phase amount in equilibrium calculations\n! qqsave: values of qq calculated in set_constitution\n! double precision amount(2),dgm,amcom,damount,qqsave(3)\n! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3)\n! double precision amfu,netcharge,dgm,amcom,damount\n sum=sum+10\n! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop\n! nprop: the number of different properties (set in allocate)\n! ncc: total number of site fractions (redundant but used in some subroutines)\n! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ???\n! listprop(1): is number of calculated properties\n! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc\n! 2=TC, 3=BMAG. Properties defined in the gtp_propid record\n! integer nprop,ncc\n! integer, dimension(:), allocatable :: listprop\n if(allocated(varres%listprop)) sum=sum+2+size(varres%listprop)\n write(*,*)'varresum + listprop: ',sum,size(varres%listprop)\n! gval etc are for all composition dependent properties, gval(*,1) for G\n! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P\n! dgval(1,j,1): is first derivatives of G wrt fractions j\n! dgval(2,j,1): is second derivatives of G wrt fractions j and T\n! dgval(3,j,1): is second derivatives of G wrt fractions j and P\n! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j\n! double precision, dimension(:,:), allocatable :: gval\n! double precision, dimension(:,:,:), allocatable :: dgval\n! double precision, dimension(:,:), allocatable :: d2gval\n if(allocated(varres%gval)) sum=sum+2*size(varres%gval)\n if(allocated(varres%dgval)) sum=sum+2*size(varres%dgval)\n if(allocated(varres%d2gval)) sum=sum+2*size(varres%d2gval)\n write(*,*)'varresum + gvals: ',sum,2*size(varres%gval),&\n 2*size(varres%dgval),2*size(varres%d2gval)\n! added for strain/stress, current values of lattice parameters\n! double precision, dimension(3,3) :: curlat\n! saved values from last equilibrium calculation\n! double precision, dimension(:,:), allocatable :: cinvy\n! double precision, dimension(:), allocatable :: cxmol\n! double precision, dimension(:,:), allocatable :: cdxmol\n if(allocated(varres%cinvy)) sum=sum+18+2*size(varres%cinvy)\n if(allocated(varres%cxmol)) sum=sum+18+2*size(varres%cxmol)\n if(allocated(varres%cdxmol)) sum=sum+18+2*size(varres%cdxmol)\n write(*,*)'varresum + saved: ',sum\n!\n1000 continue\n vssize=sum\n return\n end function vssize\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function inveq\n!\\begin{verbatim}\n logical function inveq(phases,ceq)\n! Only called for mapping tie-lines not in plane. If tie-lines in plane\n! then all nodes are invariants.\n integer phases\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer nrel,ii,nostph,tpvar,degf,www\n type(gtp_condition), pointer :: pcond,lastcond\n type(gtp_state_variable), pointer :: stvr\n! How to know if the ceq is invariant? Gibbs phase rule, Degrees of freedom\n! f = n + z - w - p\n! where n is number of components, z=2 if T and P variable, \n! z=1 if T or P variable, z=0 if both T and P fixed,\n! w is number of other potential conditions (MU, AC)\n! p is number of stable phases.\n! write(*,*)'3Y in inveq'\n nrel=noel()\n! sum up nubler of stable phases and check if T and P are fixed\n nostph=0\n! ntups=nooftup()\n! do ii=1,noofphasetuples()\n do ii=1,nooftup()\n if(ceq%phase_varres(phasetuple(ii)%lokvares)%phstate.gt.0) &\n nostph=nostph+1\n enddo\n! loop all conditions\n lastcond=>ceq%lastcondition\n pcond=>lastcond\n tpvar=2\n www=0\n100 continue\n if(pcond%active.eq.0) then\n! condtion is active\n stvr=>pcond%statvar(1)\n! statevarid 1 is T and 2 is P\n if(stvr%statevarid.eq.1 .or. stvr%statevarid.eq.2) then\n! Hm, ceq is not the equilibrium record for the node point ...\n tpvar=tpvar-1\n elseif(stvr%statevarid.lt.10) then\n! potential/activity condition for a component\n www=www+1\n endif\n endif\n pcond=>pcond%next\n if(.not.associated(pcond,lastcond)) goto 100\n!\n! Hm again, ignore tpvar?\n! degf=nrel+tpvar-www-nostph\n degf=nrel-www-nostph\n! write(*,'(a,8i4)')'3Y in inveq 2',nrel,tpvar,www,nostph,degf\n if(degf.lt.0) then\n! We have an invariant equilibrium, return the number of stable phases\n phases=nostph\n inveq=.true.\n! write(*,200)'3Y An invariant equilibrium!',nrel,tpvar,nostph,phases\n!200 format(a,5i7)\n else\n! write(*,210)degef,nrel,tpvar,phases\n!210 format('3Y not invariant eq, elements, stable phases: ',4i4)\n! if not invariant isoplet node there are 3 exits (2 lines crossing)\n phases=nostph\n inveq=.false.\n endif\n1000 continue\n return\n end function inveq\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/models/gtp3Z.F90", "content": "!\n! gtp3Z included in gtp3.F90\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!> 18. Section: TP functions \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n!***************************************************************\n! library with TP functions used by general thermodynamic package\n!\n! the declarations below are all moved to gtp3Z.F90\n!\n! MODULE TPFUNLIB\n!\n! Copyright 2009-2015, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n!-------------------------------------------------------------------------\n!\n!\n!\\addtotable subroutine tpfun_init\n!\\begin{verbatim}\n subroutine tpfun_init(nf,tpres)\n! allocate tpfuns and create a free list inside the tpfuns\n implicit none\n integer nf\n! use tpres declared externally for parallel processing\n TYPE(tpfun_parres), dimension(:), allocatable :: tpres\n!\\end{verbatim}\n integer ifri\n allocate(tpfuns(nf))\n! write(*,*)'3Z allocated tpfuns: ',nf\n! tpres allocated when creating equilibria\n! allocate(tpres(nf))\n! create free list for named functions records\n freetpfun=1\n do ifri=1,nf-1\n tpfuns(ifri)%nextorsymbol=ifri+1\n tpfuns(ifri)%noofranges=0\n tpfuns(ifri)%status=0\n tpfuns(ifri)%forcenewcalc=0\n! should also be initiallized ??\n! tpres(ifri)%forcenewcalc=0\n enddo\n! The last TP function has no next link\n tpfuns(nf)%nextorsymbol=-1\n return\n END SUBROUTINE tpfun_init\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function notpf\n!\\begin{verbatim}\n integer function notpf()\n! number of tpfunctions because freetpfun is private\n implicit none\n!\\end{verbatim}\n notpf=freetpfun-1\n end function notpf\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_tpfun_by_name\n!\\begin{verbatim}\n subroutine find_tpfun_by_name(name,lrot)\n! returns the location of a TP function\n! if lrot>0 then start after lrot, this is to allow finding with wildcard *\n implicit none\n integer lrot\n character name*(*)\n!\\end{verbatim} %+\n character name1*16\n integer i,j\n name1=name\n call capson(name1)\n if(lrot.le.0 .or. lrot.ge.freetpfun) then\n j=1\n else\n! if 1 < lrot < freetpfun start looking from lrot+1\n j=lrot+1\n endif\n do i=j,freetpfun-1\n if(compare_abbrev(name,tpfuns(i)%symbol)) then\n lrot=i; goto 1000\n endif\n enddo\n gx%bmperr=4060\n1000 continue\n return\n end SUBROUTINE find_tpfun_by_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_tpfun_by_name_exact\n!\\begin{verbatim} %-\n subroutine find_tpfun_by_name_exact(name,lrot,notent)\n! returns the location of a TP function, notent TRUE if not entered\n implicit none\n integer lrot\n logical notent\n character name*(*)\n!\\end{verbatim}\n character name1*16\n integer i\n notent=.FALSE.\n name1=name\n call capson(name1)\n do i=1,freetpfun-1\n if(name.eq.tpfuns(i)%symbol) then\n lrot=i\n if(btest(tpfuns(i)%status,TPNOTENT)) then\n notent=.TRUE.\n endif\n goto 1000\n endif\n enddo\n gx%bmperr=4060\n1000 continue\n return\n end SUBROUTINE find_tpfun_by_name_exact\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine eval_tpfun\n!\\begin{verbatim}\n subroutine eval_tpfun(lrot,tpval,result,tpres)\n! subroutine eval_tpfun(lrot,tpval,symval,result)\n! evaluate a TP function with several T ranges\n implicit none\n integer lrot\n double precision tpval(2),result(6),xxx\n! changes to avoid memory leak in valgrind\n TYPE(tpfun_parres), dimension(*) :: tpres\n!\\end{verbatim}\n integer nr,ns\n TYPE(tpfun_expression), pointer :: exprot\n! mini is the maximum relative difference between calculated and current values\n! of T and P for using the stored values of a function\n double precision, parameter :: mini=1.0D-8\n! use lowest range for all T values lower than first upper limit\n! and highest range for all T values higher than the next highest limit\n! one should signal if T is lower than lowest limit or higher than highest\n! used saved reults if same T and P\n!\n if(lrot.le.0) then\n result=zero\n goto 1000\n elseif(btest(tpfuns(lrot)%status,TPCONST)) then\n! TP symbol is a constant, value stored in tpfuns(lrot)%limits(1)\n! This takes care of updating assessment parameters!!\n result=zero\n result(1)=tpfuns(lrot)%limits(1)\n! wow, we must not forget to store the constant in tpres(lrot)%results!\n! write(*,*)'3Z const: ',tpres(lrot)%forcenewcalc,tpfuns(lrot)%forcenewcalc\n! write(*,*)'3Z store: ',lrot,result(1),tpres(lrot)%results(1)\n goto 990\n else\n! check if previous values can be used\n! tpfuns(lrot)%forcenewcalc is located with the function expression\n! tpres(lrot)%forcenewcalc is different for each ceq, there can be several\n! IT IS MEANINGLESS TO COMPARE THEM ... \n if(tpres(lrot)%forcenewcalc.eq.tpfuns(lrot)%forcenewcalc) then\n if(abs(tpres(lrot)%tpused(1)-tpval(1)).le.&\n mini*tpres(lrot)%tpused(1) .and. &\n (abs(tpres(lrot)%tpused(2)-tpval(2)).le.&\n mini*tpres(lrot)%tpused(2))) then\n result=tpres(lrot)%results\n! write(*,12)'3Z oldval: ',lrot,tpres(lrot)%forcenewcalc,&\n! tpfuns(lrot)%forcenewcalc,tpres(lrot)%results(1),tpval(1)\n!12 format(a,i5,2i4,4(1pe12.4))\n goto 1000\n endif\n! else\n! write(*,*)'3Z forced recalc: ',lrot,tpres(lrot)%forcenewcalc,&\n! tpfuns(lrot)%forcenewcalc\n endif\n! new values must be calculated\n! write(*,23)'3Z new T,P: ',lrot,tpres(lrot)%tpused,tpval\n!23 format(a,i4,4(1pe12.4))\n! result=zero\n endif\n! we must calculate the function\n! write(*,35)'3Z new TPval:',lrot,tpfuns(lrot)%forcenewcalc,&\n! tpres(lrot)%forcenewcalc,&\n! abs(tpres(lrot)%tpused(1)-tpval(1)),abs(tpres(lrot)%tpused(2)-tpval(2))\n!35 format(a,3i5,2(1pe12.4))\n nr=tpfuns(lrot)%noofranges\n if(nr.eq.1) then\n exprot=>tpfuns(lrot)%funlinks(1)\n call ct1efn(exprot,tpval,result,tpres)\n else\n ns=1\n do while(ns.lt.nr)\n if(tpval(1).lt.tpfuns(lrot)%limits(ns+1)) then\n exprot=>tpfuns(lrot)%funlinks(ns)\n call ct1efn(exprot,tpval,result,tpres)\n! for debug output below\n nr=ns\n goto 900\n endif\n ns=ns+1\n enddo\n exprot=>tpfuns(lrot)%funlinks(nr)\n call ct1efn(exprot,tpval,result,tpres)\n endif\n! save the calculated results\n900 continue\n if(gx%bmperr.ne.0) then\n write(*,901)gx%bmperr,tpfuns(lrot)%symbol\n901 format('Error ',i5,' evaluating tp function: ',a)\n goto 1000\n endif\n990 continue\n! new: do i=1,6\n! tpres(lrot)%results(i)=result(i)\n! enddo new\n! xxx=tpres(lrot)%results(1)\n tpres(lrot)%results=result\n tpres(lrot)%forcenewcalc=tpfuns(lrot)%forcenewcalc\n tpres(lrot)%tpused(1)=tpval(1)\n tpres(lrot)%tpused(2)=tpval(2)\n! Searching for strange bug when entering parameter ...\n! write(*,991)'3Z new value: ',lrot,tpres(lrot)%forcenewcalc,&\n! tpres(lrot)%results(1),tpval(1),xxx\n!991 format(a,2i5,6(1pe12.4))\n!22 format(A,i3,4(1PE11.2))\n1000 continue\n return\n end subroutine eval_tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_tpfun\n!\\begin{verbatim}\n subroutine list_tpfun(lrot,nosym,str)\n! lists a TP symbols with several ranges into string str\n! lrot is index of function, if nosym=0 the function name is copied to str\n implicit none\n character str*(*)\n integer nosym,lrot\n!\\end{verbatim} %+\n integer ip,nr\n character line*2048,tps(2)*1\n TYPE(tpfun_expression), pointer :: exprot\n! Handle variables\n if(lrot.le.0) then\n! constant equal to zero ??\n str=' =0; N '\n goto 1000\n elseif(btest(tpfuns(lrot)%status,TPCONST)) then\n! UNFINISHED temporarily list all optimizing variables\n if(btest(tpfuns(lrot)%status,TPOPTCON)) then\n if(tpfuns(lrot)%limits(1).eq.zero) then\n! this is a clumsy way to suppress listing optimizing coeff that are zero\n str='_A00 '; goto 1000\n endif\n endif\n line=tpfuns(lrot)%symbol\n ip=len_trim(line)\n line(ip+1:ip+3)=' = '\n ip=ip+4\n call wrinum(line,ip,12,0,tpfuns(lrot)%limits(1))\n goto 900\n endif\n! these are the symbols used to represent T and P\n tps(1)='T'\n tps(2)='P'\n if(nosym.eq.0) then\n line=tpfuns(lrot)%symbol\n ip=len_trim(line)\n line(ip+1:ip+3)=' = '\n ip=ip+4\n else\n line='= '\n ip=3\n endif\n if(lrot.le.0) then\n line(ip:)=' 298.15 0; 6000 N'\n goto 900\n endif\n! nr=1\n do nr=1,tpfuns(lrot)%noofranges\n! write(line(ip:ip+10),10)tpfuns(lrot)%limits(nr)\n!10 format(F8.2,' Y ')\n! ip=ip+9\n! write(*,*)'tpfun4: ',lrot,tpfuns(lrot)%noofranges,nr\n if(tpfuns(lrot)%limits(nr).gt.1.0D3) then\n call wrinum(line,ip,8,0,tpfuns(lrot)%limits(nr))\n else\n! problem as 298.15 is written as 298.14999 and\n! problem that 1 is written as 1.00001\n! call wrinum(line,ip,6,0,tpfuns(lrot)%limits(nr)+1.0D-5)\n call wrinum(line,ip,6,0,tpfuns(lrot)%limits(nr))\n endif\n line(ip:ip+2)=' Y '\n ip=ip+1\n if(nr.gt.1) ip=ip+2\n exprot=>tpfuns(lrot)%funlinks(nr)\n call ct1wfn(exprot,tps,line,ip)\n line(ip:ip+1)='; '\n ip=ip+2\n enddo\n! write(line(ip:ip+10),11)tpfuns(lrot)%hightlimit\n!11 format(F8.2,' N ')\n! ip=ip+11\n call wrinum(line,ip,8,0,tpfuns(lrot)%hightlimit)\n line(ip:ip+2)=' N '\n900 continue\n! write(*,*)'list_tpfun: ',len(str),len_trim(line)\n if(len_trim(line).gt.len(str)) then\n write(kou,910)'3Z *** WARNING: Character for listing funtion too short',&\n len_trim(line),len(str)\n910 format(a,2i5)\n endif\n str=line\n!20 format(a)\n1000 continue\n return\n end subroutine list_tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_all_funs\n!\\begin{verbatim} %-\n subroutine list_all_funs(lut)\n! list all functions except those starting with _ (parameters)\n implicit none\n integer lut\n!\\end{verbatim}\n! implicit double precision (a-h,o-z)\n integer nosym,ifun\n character str*2048,number*4\n logical once\n! nosym=0 means the local symbol name is included in the listing\n once=.TRUE.\n nosym=0\n write(lut,10)\n10 format(/'List of all symbols used in phase parameters (TP-functions):'/ &\n! ' Predefined symbols:'/&\n! ' BELOW(TB) = something;'/&\n! ' ABOVE(TB) = 1-BELOW(TB);'/&\n ' Nr Name = T-low expression; T-high Y/N')\n20 format(I4,1x,A)\n! write(*,*)'First free index: ',freetpfun\n do ifun=1,freetpfun-1\n write(str,20)ifun\n call list_tpfun(ifun,nosym,str(6:))\n if(str(6:9).eq.'_A00 ') then\n if(once) then\n write(lut,30)\n30 format(' *** Optimizing coefficents that are zero are not listed')\n once=.FALSE.\n endif\n else\n if(str(6:6).ne.'_') call wrice2(lut,0,12,78,1,str)\n endif\n enddo\n return\n end subroutine list_all_funs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_unentered_funs\n!\\begin{verbatim}\n subroutine list_unentered_funs(lut,nr)\n! counts and list functions with TPNOTENT bit set if lut>0\n implicit none\n integer lut,nr\n!\\end{verbatim}\n! implicit double precision (a-h,o-z)\n integer nosym,ifun\n nr=0\n do ifun=1,freetpfun-1\n if(btest(tpfuns(ifun)%status,TPNOTENT)) then\n if(lut.gt.0) write(lut,30)tpfuns(ifun)%symbol\n30 format('Missing function: ',a)\n nr=nr+1\n endif\n enddo\n!1000 continue\n return\n end subroutine list_unentered_funs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1xfn\n!\\begin{verbatim}\n subroutine ct1xfn(string,ip,nc,coeff,koder,fromtdb)\n!...compiles an expression in string from position ip\n! it can refer to T and P or symbols in fnsym\n! compiled expression returned in coeff and koder\n!\n! >>> this is very messy\n!\n!...algorithm for function extraction\n! 10*T**2 -5*T*LOG(T) +4*EXP(-5*T**(-1))\n!\n! AT LABEL 100 start of expression or after (\n! sign=1\n! -, sign=-1 goto 200\n! +, skip\n!\n! AT LABEL 200 after sign\n! if A-Z goto 300\n! if 0-9, extract number goto 400\n! ( goto 100\n! ; END or ERROR\n! empty END or ERROR\n! anything else ERROR\n!\n! AT LABEL 300 symbol\n! if T or P, extract power if any incl () goto 400\n! unary fkn? extract ( goto 100\n! symbol goto 400\n!\n! AT LABEL 400 after factor\n! -, sign=-1 goto 200\n! sign=1\n! +, skip goto 200\n! ) goto 400\n! ** or ^ extract and store power incl () goto 400\n! * goto 200\n! empty goto 900\n!\n! for TDB compatibility skip #\n!\n! check consistency\n implicit none\n integer ip,nc,koder(5,*)\n character string*(*)\n double precision coeff(*)\n logical fromtdb\n!\\end{verbatim} %+\n! implicit double precision (a-h,o-z)\n! integer, parameter :: nunary=5\n integer, parameter :: nunary=6\n integer, parameter :: lenfnsym=16\n double precision, parameter :: zero=0.0D0,one=1.0D0\n integer i,j,jss,levelp,mterm,ipower,nterm\n double precision sign,val,another\n character ch1*1\n logical zeroc\n character symbol*(lenfnsym),unary(nunary)*6\n character*2, parameter :: tsym='T ',psym='P '\n! NEIN is the Einstein function\n! MAX1 is 1.0 if argument is larger than 1.0, error if argument negative\n! LOG is LOG10 and LN is the natural logarithm!!!\n DATA unary/'LOG ','LN ','EXP ','ERF ','GEIN','MAX1 '/\n! DATA unary/'LOG ','LN ','EXP ','ERF ','INTEIN','MAX1 '/\n! DATA unary/'LOG ','LN ','EXP ','ERF ','XNEIN ','MAX1 '/\n! DATA unary/'LOG ','LN ','EXP ','ERF ','XNEIN '/\n! DATA unary/'LOG ','LN ','EXP ','ERF ','ABOVE ','BELOW '/\n!\n! coeff(nterm) double with coefficient\n! koder(1,nterm) power of T\n! koder(2,nterm) power of P\n! koder(3,nterm) power of linked symbol (see koder(5,nterm)\n! koder(4,nterm) level of parenthesis\n! koder(5,nterm) symbol link or -(unary function index)\n mterm=nc\n levelp=0\n nterm=1\n coeff(1)=zero\n do i=1,5\n koder(i,1)=0\n enddo\n! write(*,*)'3Z ct1xfn: ',trim(string(ip:))\n!\n!...start of expression or after(\n100 if(eolch(string,ip)) goto 800\n zeroc=.FALSE.\n ch1=biglet(string(ip:ip))\n sign=one\n if(ch1.eq.'-') then\n sign=-one\n ip=ip+1\n if(coeff(nterm).ne.zero) nterm=nterm+1\n if(nterm.gt.mterm) then\n gx%bmperr=4000\n goto 1000\n endif\n coeff(nterm)=zero\n do i=1,5\n koder(i,nterm)=0\n enddo\n endif\n if(ch1.eq.'+') then\n ip=ip+1\n if(coeff(nterm).ne.zero) nterm=nterm+1\n if(nterm.gt.mterm) then\n gx%bmperr=4000\n goto 1000\n endif\n coeff(nterm)=zero\n do i=1,5\n koder(i,nterm)=0\n enddo\n endif\n!\n!...allowed: unsigned number or symbol (any previous sign in \"sign\")\n200 continue\n if(eolch(string,ip)) goto 800\n ch1=biglet(string(ip:ip))\n if(ch1.eq.'(') then\n levelp=levelp+1\n if(nterm.eq.0) then\n nterm=1\n coeff(nterm)=zero\n do i=1,5\n koder(i,nterm)=0\n enddo\n endif\n koder(4,nterm)=levelp\n ip=ip+1\n goto 100\n elseif(ch1.eq.';') then\n goto 900\n endif\n if(ch1.ge.'A' .and. ch1.le.'Z') goto 300\n!...this check because getrel accepts + and - and no sign is allowed\n if(.not.(ch1.ge.'0' .and. ch1.le.'9') .and. ch1.ne.'.') then\n write(*,*)'ct1xfn 66:',ip,ch1,' >',trim(string),'<'\n gx%bmperr=4001\n goto 1000\n endif\n! write(*,202)ip,string(1:ip+5)\n!202 format('Expected real at position: ',i5,' in >',a,'< ')\n call getrel(string,ip,val)\n if(buperr.ne.0) then\n gx%bmperr=buperr\n goto 1000\n endif\n! looking for 0*fun bug\n if(val.eq.zero) zeroc=.TRUE.\n! write(*,*)'ct1xfn 1: ',nterm,ip,val\n!...if nterm>0 and coeff(nterm)=0 then store this coefficent there\n if(nterm.gt.0 .and. coeff(nterm).eq.zero) then\n coeff(nterm)=sign*val\n! write(*,*)'ct1xfn 2: ',nterm,val,coeff(nterm)\n else\n nterm=nterm+1\n if(nterm.gt.mterm) then\n gx%bmperr=4000; goto 1000\n endif\n coeff(nterm)=sign*val\n sign=one\n! write(*,*)'ct1xfn 3: ',nterm,val,coeff(nterm)\n do i=1,5\n koder(i,nterm)=0\n enddo\n endif\n goto 400\n!\n!...unsigned symbol, first character at ip\n300 continue\n symbol=' '\n call ct1getsym(string,ip,symbol)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'ct1xfn 5: ',nterm,ip,coeff(nterm)\n!...one can have a symbol as first part, then create a term\n! otherwise symbols are usually part of a term already created\n if(nterm.eq.0) then\n nterm=1\n coeff(nterm)=one\n do i=1,5\n koder(i,nterm)=0\n enddo\n elseif(coeff(nterm).eq.zero) then\n! this can happen if one has no coefficient in front of a function!!!\n! write(*,*)'ct1xfn 5A: ',nterm,ip,coeff(nterm)\n if(.not.zeroc) coeff(nterm)=sign*one\n! write(*,*)'ct1xfn 5B: ',nterm,ip,coeff(nterm)\n endif\n!...check if T or P\n if(symbol(1:2).eq.tsym) then\n if(string(ip:ip).eq.'^' .or. string(ip:ip+1).eq.'**') then\n ip=ip+1\n if(string(ip:ip).eq.'*') ip=ip+1\n call ct1power(string,ip,ipower)\n if(gx%bmperr.ne.0) goto 1000\n else\n ipower=1\n endif\n koder(1,nterm)=koder(1,nterm)+ipower\n goto 400\n elseif(symbol(1:2).eq.psym) then\n! allow powers as ^ or **\n if(string(ip:ip).eq.'^' .or. string(ip:ip+1).eq.'**') then\n ip=ip+1\n if(string(ip:ip).eq.'*') ip=ip+1\n call ct1power(string,ip,ipower)\n if(gx%bmperr.ne.0) goto 1000\n else\n ipower=1\n endif\n koder(2,nterm)=koder(2,nterm)+ipower\n goto 400\n endif\n!...check if unary operator\n do j=1,nunary\n if(symbol(1:6).eq.unary(j)) goto 380\n enddo\n! here search tpfuns for symbols, there are freetpfun-1 of them\n do jss=1,freetpfun-1\n if(symbol.eq.tpfuns(jss)%symbol) goto 350\n enddo\n!...unknown new symbol\n if(fromtdb) then\n! if we are reading a TDB file allow references to unknown functions\n! We will scan for un-entered TPfuns later\n! write(*,*)'Unknown symbol to be entered later: ',symbol\n call store_tpfun_dummy(symbol)\n else\n! otherwise give error message\n write(*,*)'TPFUN contain unknown symbol: ',symbol,freetpfun-1\n gx%bmperr=4002; goto 1000\n endif\n! we have found the symbol\n350 continue\n if(koder(5,nterm).ne.0) then\n! two symbols multipled with each other\n if(koder(3,nterm).ne.0) then\n write(*,*)'too many symbols in one term: ',koder(3,nterm)\n gx%bmperr=4022; goto 1000\n else\n! set new function in koder(3,nterm), otherwise written in oposite order\n koder(3,nterm)=1000+jss\n endif\n else\n koder(5,nterm)=jss\n endif\n goto 400\n!...unary function must be follwed by (\n380 continue\n ch1=string(ip:ip)\n if(ch1.ne.'(') then\n gx%bmperr=4003\n goto 1000\n else\n ip=ip+1\n levelp=levelp+1\n koder(4,nterm)=levelp\n if(koder(5,nterm).ne.0) then\n! this is like R*T*LN(1E-5*P), save link to R in koder(3,nterm)\n if(koder(3,nterm).ne.0) then\n write(*,*)'too many symbols in one term: ',koder(3,nterm)\n gx%bmperr=4022; goto 1000\n elseif(koder(5,nterm).lt.0) then\n write(*,*)'two unary functions in one term: ',koder(3,nterm)\n gx%bmperr=4023; goto 1000\n else\n koder(3,nterm)=1000+koder(5,nterm)\n endif\n endif\n koder(5,nterm)=-j\n!...new term for argument of unary function, set coefficint to zero\n! to mark that none has been found.\n nterm=nterm+1\n if(nterm.gt.mterm) then\n write(*,*)'ct1xfn 8: ',nterm,mterm,ip\n gx%bmperr=4000\n goto 1000\n endif\n coeff(nterm)=zero\n do i=1,5\n koder(i,nterm)=0\n enddo\n goto 100\n endif\n!\n!...after a factor of a term: ),operator *, ^, +, - (division / not allowed)\n400 continue\n if(eolch(string,ip)) goto 800\n ch1=string(ip:ip)\n!...+ or - means new term\n if(ch1.eq.'-' .or. ch1.eq.'+') goto 100\n sign=one\n after: if(ch1.eq.')') then\n koder(4,nterm)=levelp\n if(levelp.eq.0) then\n gx%bmperr=4004\n goto 1000\n endif\n levelp=levelp-1\n ip=ip+1\n goto 400\n elseif(ch1.eq.'^') then\n ip=ip+1\n call ct1power(string,ip,ipower)\n if(koder(3,nterm).ne.0) then\n! several symbols or unary and power, too complicated\n gx%bmperr=4024; goto 1000\n endif\n koder(3,nterm)=ipower\n goto 400\n elseif(ch1.eq.'*') then\n! write(*,*)'3Z we found a multiplication: ',trim(string),ip\n ip=ip+1\n ch1=string(ip:ip)\n if(ch1.eq.'*') then\n ip=ip+1\n call ct1power(string,ip,ipower)\n if(koder(3,nterm).ne.0) then\n! several symbols or unariy and power, too complicated\n gx%bmperr=4024; goto 1000\n endif\n koder(3,nterm)=ipower\n goto 400\n elseif(ch1.ge.'0' .and. ch1.le.'9') then\n! multiplying value in coeff(nterm) with another number\n! write(*,*)'3Z string and position: \"',trim(string),'\"',ip\n! write(*,*)'3Z multplication followed by digit: ',ch1,nterm\n! write(*,*)'3Z data: ',buperr,coeff(nterm),trim(string(ip:))\n! Does getrel increment ip?? NO\n call getrel(string,ip,another)\n if(buperr.ne.0) then\n! write(*,*)'2Z error from getrel',buperr\n gx%bmperr=buperr; goto 1000\n endif\n! write(*,'(a,i2,2(1pe12.4))')'3Z multiplying two numbers: ',nterm,&\n! coeff(nterm),another\n coeff(nterm)=coeff(nterm)*another\n! now we expect an operator or ) or ;\n goto 400\n! else\n! multiply symbol with something ....\n! write(*,*)'ct1xfn 4: ',nterm,ip,coeff(nterm)\n!654 format(a,i5,'\"',a,'\"',i5)\n endif\n! new we expect a symbol or end of expression\n goto 200\n elseif(ch1.eq.';') then\n goto 900\n endif after\n write(*,777)ch1,ip,trim(string)\n777 format('3Z Illegal character \"',a,'\" at pos ',i3,' in expression \"',a,'\"')\n gx%bmperr=4005\n goto 1000\n! no more characters, check!!\n800 continue\n!\n!...; or no more characters, expression finished, check!!\n900 continue\n if(levelp.gt.0) then\n gx%bmperr=4006\n goto 1000\n endif\n nc=nterm\n!990 format('ct1xfn 99> ',1PE15.6,5I7)\n1000 continue\n return\n end subroutine ct1xfn\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1getsym\n!\\begin{verbatim} %-\n subroutine ct1getsym(string,ip,symbol)\n!...extracts an symbol\n! implicit double precision (a-h,o-z)\n implicit none\n integer ip\n character string*(*),symbol*(*)\n!\\end{verbatim} %+\n integer, parameter :: lenfnsym=16\n integer jp\n character ch1*1,chs*1,localsym*(lenfnsym)\n! these 2 functions are declared in METLIB and no type decration needed here\n jp=0\n localsym=' '\n symbol=' '\n100 continue\n ch1=biglet(string(ip:ip))\n! write(6,*)'ct1getsym 2 >',ch1,'<',ip\n if((ch1.ge.'A' .and. ch1.le.'Z') .or. &\n (jp.gt.0 .and. ch1.eq.'_') .or. &\n (jp.gt.0 .and. (ch1.ge.'0' .and. ch1.le.'9'))) then\n jp=jp+1\n! ignore characters after length of localsym\n if(jp.le.len(localsym)) then\n localsym(jp:jp)=ch1\n endif\n ip=ip+1\n goto 100\n endif\n symbol=localsym\n!1000 return\n end subroutine ct1getsym\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1power\n!\\begin{verbatim} %-\n subroutine ct1power(string,ip,ipower)\n!...extracts an integer power possibly surrounded by ( )\n implicit none\n integer ip,ipower\n character string*(*)\n!\\end{verbatim} %+\n integer ich,isig,lp,jp\n character ch1*1,chs*1\n! write(*,*)'3Z ct1power: ',trim(string(ip:))\n lp=0\n isig=1\n ipower=0\n100 continue\n ch1=string(ip:ip)\n! write(*,*)'3Z ct1power ch1: \"',ch1,'\" ',lp,isig\n if(ch1.eq.'(') then\n if(lp.gt.0) then\n gx%bmperr=4007\n goto 1000\n elseif(ipower.ne.0) then\n gx%bmperr=4008\n goto 1000\n endif\n jp=ip+1\n if(eolch(string,jp)) then\n gx%bmperr=4009\n goto 1000\n endif\n chs=string(jp:jp)\n! if(chs.eq.'-') then\n! to allow (+2) etc after a (\n if(chs.eq.'-' .or. chs.eq.'+') then\n!...mark ( and save sign, update ip (incremented below)\n lp=1\n! isig=-1\n if(chs.eq.'-') isig=-1\n ip=jp\n endif\n elseif(ch1.eq.')') then\n if(ipower.ne.0) then\n!...the ) can belong to other parts of the expression ???\n if(lp.eq.1) then\n ip=ip+1\n lp=0\n endif\n goto 900\n endif\n gx%bmperr=4010\n goto 1000\n elseif(ch1.ge.'0' .and. ch1.le.'9') then\n ich=ichar(ch1)-ichar('0')\n ipower=10*ipower+ich\n else\n! no ) if ipower=0 then error\n if(ipower.eq.0) lp=99\n! write(*,*)'3Z ct1power: no ( or digit or ) or some other error',lp,ipower\n goto 900\n endif\n ip=ip+1\n if(ipower.gt.100) then\n gx%bmperr=4011\n goto 1000\n endif\n goto 100\n! error return unless lp=0, then it coulld be just T**3, T**(+3) should be OK\n900 if(lp.gt.0) then\n if(gx%bmperr.eq.0) gx%bmperr=4012\n goto 1000\n endif\n ipower=isig*ipower\n! write(*,*)'3Z exit ct1power: ',trim(string(ip:)),ipower,gx%bmperr\n1000 return\n end subroutine ct1power\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1mfn\n!\\begin{verbatim} %-\n subroutine ct1mfn(symbol,nranges,tlimits,lokexpr,lrot)\n!...creates a root record with name symbol and temperature ranges\n! highest T limit is in tlimits(nranges+1)\n! implicit double precision (a-h,o-z)\n implicit none\n integer nranges,lrot\n character*(*) symbol\n TYPE(tpfun_expression), dimension(*) :: lokexpr\n real tlimits(*)\n!\\end{verbatim} %+\n! special for unformatted files, lrot < 0 and this index MUST be used\n! ignore freetpfun!!\n integer ir\n character name*16\n if(lrot.lt.0) then\n! store funtion at this specific place!!\n lrot=-lrot\n! if(lrot.gt.freetpfun) then\n write(*,*)'Storing at position above freetpfun',lrot\n! gx%bmperr=4399; goto 1000\n! endif\n else\n lrot=freetpfun\n! write(*,*)'ct1mfn: ',freetpfun\n! write(*,*)'ct1mfn: ',lrot,tpfuns(lrot)%nextorsymbol\n if(lrot.gt.0) then\n freetpfun=tpfuns(lrot)%nextorsymbol\n tpfuns(lrot)%nextorsymbol=0\n else\n! no more tpfun records\n write(*,*)'No more space for TP functions: ',size(tpfuns)\n gx%bmperr=4014; goto 1000\n endif\n endif\n allocate(tpfuns(lrot)%limits(nranges))\n allocate(tpfuns(lrot)%funlinks(nranges))\n do ir=1,nranges\n tpfuns(lrot)%limits(ir)=tlimits(ir)\n! should this be an assignment or setting a link?\n tpfuns(lrot)%funlinks(ir)=lokexpr(ir)\n enddo\n tpfuns(lrot)%hightlimit=tlimits(nranges+1)\n tpfuns(lrot)%noofranges=nranges\n! save name as upper case\n name=symbol\n call capson(name)\n tpfuns(lrot)%symbol=name\n1000 continue\n return\n end subroutine ct1mfn\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct2mfn\n!\\begin{verbatim} %-\n subroutine ct2mfn(symbol,nranges,tlimits,lokexpr,lrot)\n!...stores a TPfun in an existing lrot record with name symbol\n! and temperature ranges, highest T limit is in tlimits(nranges+1)\n implicit none\n integer nranges,lrot\n character*(*) symbol\n TYPE(tpfun_expression), dimension(*) :: lokexpr\n real tlimits(*)\n!\\end{verbatim} %+\n integer ir\n character name*16\n if(lrot.gt.0 .and. lrot.lt.freetpfun .and. &\n btest(tpfuns(lrot)%status,TPNOTENT)) then\n if(tpfuns(lrot)%noofranges.gt.0) then\n write(*,*)'This TPfun has already been entered ...',symbol\n gx%bmperr=4348; goto 1000\n endif\n else\n! illegal value of lrot\n gx%bmperr=4349; goto 1000\n endif\n allocate(tpfuns(lrot)%limits(nranges))\n allocate(tpfuns(lrot)%funlinks(nranges))\n do ir=1,nranges\n tpfuns(lrot)%limits(ir)=tlimits(ir)\n! should this be an assignment or setting a link?\n tpfuns(lrot)%funlinks(ir)=lokexpr(ir)\n enddo\n tpfuns(lrot)%hightlimit=tlimits(nranges+1)\n tpfuns(lrot)%noofranges=nranges\n! clear the bit that this TPFUN is not entered\n tpfuns(lrot)%status=ibclr(tpfuns(lrot)%status,TPNOTENT)\n! write(*,*)'Clearing noentered bit: ',lrot,tpfuns(lrot)%symbol\n! name already stored\n! name=symbol\n! call capson(name)\n! tpfuns(lrot)%symbol=name\n1000 continue\n return\n end subroutine ct2mfn\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1mexpr\n!\\begin{verbatim} %-\n subroutine ct1mexpr(nc,coeff,koder,lrot)\n!...makes a datastructure of an expression. root is returned in lrot\n! implicit double precision (a-h,o-z)\n implicit none\n integer nc,koder(5,*)\n! TYPE(tpfun_expression), pointer :: lrot\n TYPE(tpfun_expression) :: lrot\n! TYPE(tpfun_expression), pointer :: noexpr\n double precision coeff(*)\n!\\end{verbatim} %+\n integer i\n! write(*,*)'3Z in ct1mexpr',nc\n lrot%noofcoeffs=nc\n if(nc.le.0) then\n! nullify(lrot)\n goto 1000\n endif\n! allocate an expression record and then allocate all arrays\n! allocate(lrot)\n lrot%noofcoeffs=nc\n allocate(lrot%coeffs(nc))\n allocate(lrot%tpow(nc))\n allocate(lrot%ppow(nc))\n allocate(lrot%wpow(nc))\n allocate(lrot%plevel(nc))\n allocate(lrot%link(nc))\n! store data\n save2: do i=1,nc\n lrot%coeffs(i)=coeff(i)\n lrot%tpow(i)=koder(1,i)\n lrot%ppow(i)=koder(2,i)\n lrot%wpow(i)=koder(3,i)\n lrot%plevel(i)=koder(4,i)\n lrot%link(i)=koder(5,i)\n enddo save2\n1000 continue\n! write(*,*)'3Z leaving ct1mexpr'\n return\n end subroutine ct1mexpr\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1efn\n!\\begin{verbatim} %-\n subroutine ct1efn(inrot,tpval,val,tpres)\n!...evaluates a datastructure of an expression. Value returned in val\n! inrot is root expression tpfunction record\n! tpval is valuse of T and P,\n! val is array of values calculated here\n! tpres is array of all calculated functions\n! first and second derivatives of T and P also calculated and returned\n! in order F, F.T, F.P, F.T.T, F.T.P, F.P.P\n!\n! if function already calculated one should never enter this subroutine\n!\n! It can call \"itself\" by reference to another TP function and for\n! that case one must store results in levels.\n implicit none\n double precision val(6),tpval(*)\n TYPE(tpfun_expression), pointer :: inrot\n TYPE(tpfun_parres), dimension(*) :: tpres\n!\\end{verbatim}\n integer mlev,level,jpow,link2\n double precision mini\n parameter (mlev=10,mini=1.0D-8)\n TYPE tpfun_nest\n TYPE(tpfun_nest), pointer :: previous\n TYPE(tpfun_expression), pointer :: exprot\n integer savenc,saveic,savelink4,level,savetp\n double precision saveval(6)\n end TYPE tpfun_nest\n TYPE(tpfun_nest), pointer :: temp,topsave\n TYPE(tpfun_expression), pointer :: exprot,nyrot\n double precision symval(6),sym,dsymdp,dsymdt\n double precision sym1,sym2,dsym1dt,dsym2dt,dsym1dp,dsym2dp\n double precision ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2,cc\n double precision gg,dgdt,dgdp,d2gdt2,d2gdtdp,d2gdp2,cc1\n integer i,ic,mc,lrot,ipow,link,nc,unfun,itpow,tprot,link3,link4\n double precision t0,breakfun(6)\n integer becareful\n!\n val=zero\n level=0\n link4=0\n exprot=>inrot\n nullify(topsave)\n becareful=0\n! write(*,*)'ct1efn 0: ',tpval(1)\n!-----------------------------------------------\n! return here for a linked function\n100 continue\n if(.not.associated(exprot)) then\n! this is not an error, just return zero or the value of a constant !!!\n goto 900\n endif\n!------------------------------------------\n ic=0\n nc=exprot%noofcoeffs\n!------------------------------------------------\n! return here for each new term and after evaluating linked symbols\n200 continue\n eval: do while (ic.lt.nc)\n ic=ic+1\n cc=exprot%coeffs(ic)\n if(cc.eq.zero) cycle eval\n ipow=exprot%tpow(ic)\n if(ipow.ne.0) then\n ff=cc*tpval(1)**ipow\n dfdt=cc*ipow*tpval(1)**(ipow-1)\n dfdp=zero\n d2fdt2=cc*ipow*(ipow-1)*tpval(1)**(ipow-2)\n d2fdtdp=zero\n d2fdp2=zero\n else\n ff=cc\n dfdt=zero\n dfdp=zero\n d2fdt2=zero\n d2fdtdp=zero\n d2fdp2=zero\n endif\n ipow=exprot%ppow(ic)\n if(ipow.ne.0) then\n! calculate backwards not to destroy value of ff\n d2fdp2=ff*ipow*(ipow-1)*tpval(2)**(ipow-2)\n d2fdtdp=dfdt*ipow*tpval(2)**(ipow-1)\n d2fdt2=d2fdt2*tpval(2)**ipow\n dfdp=ff*ipow*tpval(2)**(ipow-1)\n dfdt=dfdt*tpval(2)**ipow\n ff=ff*tpval(2)**ipow\n endif\n!...power of symbols is handeled below\n! ipow=exprot%wpow(ic)\n ipow=exprot%plevel(ic)\n!...igore this at present, should never be set ...\n! if(ipow.ne.0) then\n! gx%bmperr=4017\n! goto 1000\n! endif\n!>>>>>>>>>>>>> very uncertain code from here <<<<<<<<<<<<<<<<<<<<<<\n link=exprot%link(ic)\n link3=exprot%wpow(ic)\n! nonzero link4 inserted in the wrong term in step3.OCM ...\n link4=0\n! if(link.ne.0) write(*,201)'funev: ',lrot,ic,link,link3\n!201 format(a,10i5)\n! write(*,'(a,5i4,1pe12.4)')'3Z intein2: ',ic,ipow,link,link3,link4,ff\n if(link.lt.0 .and. link3.gt.1000) then\n! if link is negative (unary funktion) and link3 is >1000 (link)\n! we must evaluate link3 first\n link4=link3-1000\n if(abs(tpres(link4)%tpused(1)-tpval(1)).lt.&\n mini*tpres(link4)%tpused(1) .and. &\n abs(tpres(link4)%tpused(2)-tpval(2)).lt.&\n mini*tpres(link4)%tpused(2)) then\n! The test for forcenewcalc is not reasonable:\n! tpres%forcenewcalc is local for each equilibrium\n! tpfun(link4)%forcenewcalc is global for whole system. If we calculate in\n! parallel there is no reason they should be the same\n! It creates problem in testcond1.OCM after adding a mobility parameter\n! although I do not understand why that should create the problem\n! I added it to be sure that updated assessment parameters should be used\n! but there seems no problem with that ...\n! Better to speed a few months to rerwrite the whole TPFUN package ...\n! mini*tpres(link4)%tpused(2) .and. &\n! added test of forcenewcalc ... removed ??\n! tpres(link4)%forcenewcalc.eq.tpfuns(link4)%forcenewcalc) then\n! function in link3-1000 is evaluated, multiply it with ff\n sym1=tpres(link4)%results(1)\n dsym1dt=tpres(link4)%results(2)\n dsym1dp=tpres(link4)%results(3)\n d2fdp2=sym1*d2fdp2+2.0D0*dsym1dp*dfdp+&\n tpres(link4)%results(6)*ff\n d2fdtdp=sym1*d2fdtdp+dsym1dp*dfdt+dsym1dt*dfdp+&\n tpres(link4)%results(5)*ff\n d2fdt2=sym1*d2fdt2+2.0D0*dsym1dt*dfdt+&\n tpres(link4)%results(4)*ff\n dfdp=sym1*dfdp+dsym1dp*ff\n dfdt=sym1*dfdt+dsym1dt*ff\n ff=sym1*ff\n! write(*,202)'mulnk 0: ',lrot,ic,link,link4,0,sym1,ff\n else\n! we must first evaluate link3, after that is done we come here again\n! and take the else path below\n tpres(link4)%forcenewcalc=tpfuns(link4)%forcenewcalc\n! DANGER changing wpow\n! write(*,22)'3Z wpow 1: ',level,nc,ic,exprot%wpow(ic),link-1000\n exprot%wpow(ic)=-1000+link\n link=link3-1000\n link4=link3\n endif\n elseif(link3.lt.-1000) then\n! now we have evaluated the symbol, we must multiply that\n! with ff and then evaluate the unary function\n d2fdp2=d2fdp2*symval(1)+2.0D0*dfdp*symval(3) &\n +ff*symval(6)\n d2fdtdp=d2fdtdp*symval(1)+dfdp*symval(2) &\n +dfdt*symval(3)+ff*symval(5)\n d2fdt2=d2fdt2*symval(1)+2.0D0*dfdt*symval(2) &\n +ff*symval(4)\n dfdp=dfdp*symval(1)+ff*symval(3)\n dfdt=dfdt*symval(1)+ff*symval(2)\n ff=ff*symval(1)\n! DANGER, restoring wpow, note also wpow pop below!\n! write(*,22)'3Z wpow 2: ',level,nc,ic,exprot%wpow(ic),link4\n!22 format(a,7i7)\n exprot%wpow(ic)=link4\n endif\n!-------------------------------------------------------------\n! write(*,'(a,5i4,1pe12.4)')'3Z intein3: ',ic,ipow,link,link3,link4,ff\n evlink: if(link.gt.0) then\n! link to another symbol, extract its value and use chain rule\n! extract the results from the symbol if already calculated\n! if not calculated then do that and then recalculate this term\n linkif: if(abs(tpres(link)%tpused(1)-tpval(1)).lt.&\n mini*tpres(link)%tpused(1) .and. &\n abs(tpres(link)%tpused(2)-tpval(2)).lt.&\n! mini*tpres(link)%tpused(2)) then\n mini*tpres(link)%tpused(2) .and. &\n! added this check as it seems new assessment coefficients are nor used!!\n tpres(link)%forcenewcalc.eq.tpfuns(link)%forcenewcalc) then\n! Valgrid complained about uninitial variable in if above, I do not know which\n jpow=exprot%wpow(ic)\n!---------------------------------------------\n jpowif: if(jpow.gt.1000) then\n! suck, two functions have to be multiplied ....\n link2=jpow-1000\n jpowev: if(abs(tpres(link2)%tpused(1)-tpval(1)).lt.&\n mini*tpres(link2)%tpused(1) .and. &\n abs(tpres(link2)%tpused(2)-tpval(2)).lt.&\n! mini*tpres(link2)%tpused(2)) then\n mini*tpres(link2)%tpused(2) .and. &\n! added this check as it seems new assessment coefficients are nor used!!\n tpres(link2)%forcenewcalc.eq.tpfuns(link2)%forcenewcalc) then\n! both functions are evaluated, multiply the two functions here\n! one function is in tpres(link)%results, the other in tpres(link2)%results\n sym1=tpres(link)%results(1)\n dsym1dt=tpres(link)%results(2)\n dsym1dp=tpres(link)%results(3)\n sym2=tpres(link2)%results(1)\n dsym2dt=tpres(link2)%results(2)\n dsym2dp=tpres(link2)%results(3)\n symval(6)=sym1*tpres(link2)%results(6)+&\n 2.0D0*dsym1dp*dsym2dp+&\n tpres(link)%results(6)*sym2\n symval(5)=sym1*tpres(link2)%results(5)+&\n dsym1dp*dsym2dt+dsym1dt*dsym2dp+&\n tpres(link)%results(5)*sym2\n symval(4)=sym1*tpres(link2)%results(4)+&\n 2.0D0*dsym1dt*dsym2dt+&\n tpres(link)%results(4)*sym2\n symval(3)=sym1*dsym2dp+dsym1dp*sym2\n symval(2)=sym1*dsym2dt+dsym1dt*sym2\n symval(1)=sym1*sym2\n else\n! function link2 must be evaluated, push and calculate\n tpres(link2)%forcenewcalc=tpfuns(link2)%forcenewcalc\n if(btest(tpfuns(link2)%status,TPCONST)) then\n! write(*,*)'3Z Link to a constant 1',&\n! link2,tpfuns(link2)%limits(1)\n becareful=link2\n nullify(nyrot)\n else\n call nested_tpfun(link2,tpval,nyrot)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'ct1efn nest 2: ',link2,nyrot\n endif\n! here we must push current values and start evaluating a new function nyrot\n! when that has been done one must return here ... how??\n! Well probably simplest by a new evaluation the same term again and when\n! finding the link one takes the newly evaluated numbers !!!\n! That means this function must save values in the tpfunction !!!\n level=level+1\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n! MEMORY LEAK\n nullify(temp)\n topsave%exprot=>exprot\n topsave%level=level\n topsave%saveic=ic-1; topsave%savenc=nc\n! write(*,22)'3Z wpow push 1: ',level,nc,ic,0,link4\n topsave%savetp=link2; topsave%savelink4=link4\n topsave%saveval=val\n link4=0\n val=zero\n if(becareful.gt.0) then\n! save the constant value in val(1), then jump to 900\n val(1)=tpfuns(becareful)%limits(1)\n becareful=0\n goto 900\n else\n exprot=>nyrot\n goto 100\n endif\n endif jpowev\n elseif(jpow.eq.0 .or. jpow.lt.-1000) then\n! jpow can be <-1000 if a symbol is multiplied with a unary function\n! Here we just extract the values of the function\n do i=1,6\n symval(i)=tpres(link)%results(i)\n enddo\n elseif(jpow.ne.0) then\n! this symbol is raised to a power, use chain rule for derivatives backward\n sym=tpres(link)%results(1)\n dsymdt=tpres(link)%results(2)\n dsymdp=tpres(link)%results(3)\n symval(6)=jpow*(jpow-1)*sym**(jpow-2)*dsymdp**2+&\n jpow*sym**(jpow-1)*tpres(link)%results(6)\n symval(5)=jpow*(jpow-1)*sym**(jpow-2)*dsymdp*dsymdt+&\n jpow*sym**(jpow-1)*tpres(link)%results(5)\n symval(4)=jpow*(jpow-1)*sym**(jpow-2)*dsymdt**2+&\n jpow*sym**(jpow-1)*tpres(link)%results(4)\n symval(3)=jpow*sym**(jpow-1)*dsymdp\n symval(2)=jpow*sym**(jpow-1)*dsymdt\n symval(1)=sym**jpow\n endif jpowif\n else\n! one must evaluaste the function in link, it is recursive through eval_tpfun\n! which will call ct1efn again but this is handelled automatically?????\n! One should add some check that two TP functions does not call each other\n! to infinite depth. Same as done above\n tpres(link)%forcenewcalc=tpfuns(link)%forcenewcalc\n if(btest(tpfuns(link)%status,TPCONST)) then\n! the function is a constant!!\n! write(*,*)'3Z Link to a constant 2',link,tpfuns(link)%limits(1)\n becareful=link\n else\n call nested_tpfun(link,tpval,nyrot)\n if(gx%bmperr.ne.0) goto 1000\n endif\n! here we must push current values and start evaluating a new function nyrot\n! when that has been done one must return here ... how??\n! Well probably simplest: new evaluation of the same term again and when\n! finding the link one takes the evaluated numbers !!!\n! That means this function must save values in the tpfunction !!!\n level=level+1\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n! MEMORY LEAK\n nullify(temp)\n topsave%exprot=>exprot\n topsave%level=level\n topsave%saveic=ic-1; topsave%savenc=nc\n! write(*,22)'3Z wpow push 2: ',level,nc,ic,0,link4\n topsave%savetp=link; topsave%savelink4=link4\n topsave%saveval=val\n link4=0\n val=zero\n if(becareful.gt.0) then\n! save the constant value in val(1), then jump to 900\n val(1)=tpfuns(becareful)%limits(1)\n becareful=0\n goto 900\n else\n exprot=>nyrot\n goto 100\n endif\n endif linkif\n! The symbol (or multiplied symbols) value in symval, apply chain rule\n d2fdp2=d2fdp2*symval(1)+2.0D0*dfdp*symval(3) &\n +ff*symval(6)\n d2fdtdp=d2fdtdp*symval(1)+dfdp*symval(2) &\n +dfdt*symval(3)+ff*symval(5)\n d2fdt2=d2fdt2*symval(1)+2.0D0*dfdt*symval(2) &\n +ff*symval(4)\n dfdp=dfdp*symval(1)+ff*symval(3)\n dfdt=dfdt*symval(1)+ff*symval(2)\n ff=ff*symval(1)\n elseif(link.lt.0) then\n!------------------------------------------------------\n! unary function, next term is argument, not very elegant ....\n! write(*,'(a,5i4,1pe12.4)')'3Z intein4: ',ic,ipow,link,link3,link4,ff\n unfun=link\n cc=exprot%coeffs(ic+1)\n! cc should never be zero here, if so bug in the parser\n if(cc.eq.zero) then\n gx%bmperr=4018; goto 1000\n endif\n ipow=exprot%tpow(ic+1)\n if(ipow.ne.0) then\n gg=cc*tpval(1)**ipow\n dgdt=cc*ipow*tpval(1)**(ipow-1)\n dgdp=zero\n d2gdt2=cc*ipow*(ipow-1)*tpval(1)**(ipow-2)\n d2gdtdp=zero\n d2gdp2=zero\n else\n gg=cc\n dgdt=zero\n dgdp=zero\n d2gdt2=zero\n d2gdtdp=zero\n d2gdp2=zero\n endif\n ipow=exprot%ppow(ic+1)\n if(ipow.ne.0) then\n d2gdp2=gg*ipow*(ipow-1)*tpval(2)**(ipow-2)\n d2gdtdp=dgdt*ipow*tpval(2)**(ipow-1)\n d2gdt2=d2gdt2*tpval(2)**ipow\n dgdp=gg*ipow*tpval(2)**(ipow-1)\n dgdt=dgdt*tpval(2)**ipow\n gg=gg*tpval(2)**ipow\n endif\n!...ignore these at present\n ipow=exprot%wpow(ic+1)\n if(ipow.ne.0) then\n write(*,*)'TP ipow error: ',ipow\n gx%bmperr=4019\n goto 1000\n endif\n link2=exprot%link(ic+1)\n if(link2.gt.0) then\n! link2, another symbol inside unary term, extract its value and use chain rule\n! extract the results from the symbol if already calculated\n if(abs(tpres(link2)%tpused(1)-tpval(1)).lt.&\n mini*tpres(link2)%tpused(1) .and. &\n abs(tpres(link2)%tpused(2)-tpval(2)).lt.&\n mini*tpres(link2)%tpused(2) .and. &\n! added this check as it seems new assessment coefficients are nor used!!\n tpres(link2)%forcenewcalc.eq.tpfuns(link2)%forcenewcalc) then\n symval=tpres(link2)%results\n else\n! one must evaluaste another function, it is recursive through eval_tpfun\n! which will call ct1efn again but this is handelled automatically?????\n! One should add some check that two TP functions does not call each other\n! to infinite depth\n tpres(link2)%forcenewcalc=tpfuns(link2)%forcenewcalc\n if(btest(tpfuns(link2)%status,TPCONST)) then\n! the function is a constant!!\n! write(*,*)'3Z link to a constant 3',link2,&\n! tpfuns(link2)%limits(1)\n becareful=link2\n else\n call nested_tpfun(link2,tpval,nyrot)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'ct1efn nest 1: ',link2\n endif\n! here we must push current values and start evaluating a new function nyrot\n! when that has been done one must return here ... how??\n! Well probably simplest ny evaluation the same term again and when\n! finding the link one takes the evaluated numbers !!!\n! That means this function must save values in the tpfunction !!!\n level=level+1\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n! MEMORY LEAK\n nullify(temp)\n topsave%exprot=>exprot\n topsave%level=level\n topsave%saveic=ic-1; topsave%savenc=nc\n! this searching for strange bug at midsummer 2018 ...\n! write(*,22)'3Z wpow push 3: ',level,nc,ic,0,link4\n topsave%savetp=link2; topsave%savelink4=link4\n topsave%saveval=val\n link4=0\n val=zero\n if(becareful.gt.0) then\n! save the constant value in val(1), then jump to 900\n val(1)=tpfuns(becareful)%limits(1)\n becareful=0\n goto 900\n else\n exprot=>nyrot\n goto 100\n endif\n endif\n if(exprot%wpow(ic+1).ne.0) then\n! it is illegal to have two symbols inside unary or power of symbol\n gx%bmperr=4016; goto 1000\n endif\n! the value of the another symbol in symval. use the chain rule\n d2gdp2=d2gdp2*symval(1)+2.0D0*dgdp*symval(3) &\n +gg*symval(6)\n d2gdtdp=d2gdtdp*symval(1)+dgdp*symval(2) &\n +dgdt*symval(3)+gg*symval(5)\n d2gdt2=d2gdt2*symval(1)+2.0D0*dgdt*symval(2) &\n +gg*symval(4)\n dgdp=dgdp*symval(1)+gg*symval(3)\n dgdt=dgdt*symval(1)+gg*symval(2)\n gg=gg*symval(1)\n endif\n! now combine term1 and term2 using chain rule. link values are\n! -1: LOG, -2: LN, -3: EXP, -4: ERF, only LN and EXP implemented below\n! -5: GEIN, is the Einstein function, integrated as a Gibbs energy\n! the argument is the Einstein theta, NO LONGER ln(theta)\n! -6: MAX1, if argument <0 ERROR, if >1 replace by 1\n! write(*,'(a,5i4,1pe12.4)')'3Z intein5: ',ic,ipow,link,link3,link4,ff\n evunfun: if(unfun.eq.-1) then\n! LOG base 10\n! ff=ff*Log10(gg) added by Sheng Yen Li\n if(gg.le.zero) then\n gx%bmperr=4020\n goto 1000\n endif\n d2fdp2=d2fdp2*log10(gg)+2.0d0*dfdp*dgdp/(gg*log(10d0)) &\n -(ff*(dgdp/gg)**2)/log(10d0)+ff*d2gdp2/(gg*log(10d0))\n d2fdtdp=d2fdtdp*log10(gg)+dfdt*dgdp/(gg*log(10d0)) &\n +dfdp*dgdt/(gg*log(10d0))-ff*dgdt*dgdp/((gg**2)*log(10d0)) &\n +ff*d2gdtdp/(gg*log(10d0))\n d2fdt2=d2fdt2*log10(gg)+2.0d0*dfdt*dgdt/(gg*log(10d0)) &\n -(ff*(dgdt/gg)**2)/log(10d0)+ff*d2gdt2/(gg*log(10d0))\n dfdp=dfdp*log10(gg)+ff*dgdp/(gg*log(10d0))\n dfdt=dfdt*log10(gg)+ff*dgdt/(gg*log(10d0))\n ff=ff*log10(gg)\n elseif(unfun.eq.-2) then\n! LN NATURAL LOGARITHM\n! ff=ff*LN(gg)\n if(gg.le.zero) then\n gx%bmperr=4020\n goto 1000\n endif\n d2fdp2=d2fdp2*log(gg)+2.0d0*dfdp*dgdp/gg &\n -ff*(dgdp/gg)**2+ff/gg*d2gdp2\n d2fdtdp=d2fdtdp*log(gg)+dfdt*dgdp/gg+dfdp*dgdt/gg &\n -ff*dgdt*dgdp/gg**2+ff*d2gdtdp/gg\n d2fdt2=d2fdt2*log(gg)+2.0d0*dfdt*dgdt/gg &\n -ff*(dgdt/gg)**2+ff/gg*d2gdt2\n dfdp=dfdp*log(gg)+ff*dgdp/gg\n dfdt=dfdt*log(gg)+ff*dgdt/gg\n ff=ff*log(gg)\n elseif(unfun.eq.-3) then\n! EXPonential\n! ff=ff*exp(gg)\n d2fdp2=exp(gg)*(d2fdp2+2.0D0*dfdp*dgdp+ff*d2gdp2+ff*(dgdp)**2)\n d2fdtdp=exp(gg)*(d2fdtdp+dfdt*dgdp+dfdp*dgdt+ff*d2gdtdp &\n +ff*dgdt*dgdp)\n d2fdt2=exp(gg)*(d2fdt2+2.0D0*dfdt*dgdt+ff*d2gdt2+ff*(dgdt)**2)\n dfdp=exp(gg)*(dfdp+ff*dgdp)\n dfdt=exp(gg)*(dfdt+ff*dgdt)\n ff=ff*exp(gg)\n elseif(unfun.eq.-4) then\n! ERROR FUNCTION or ABOVE not implemented\n write(*,*)'Error function not implemented'\n stop 71\n elseif(unfun.eq.-5) then\n! INTEGRATED EINSTEIN: GEIN = 1.5*R*THETA + 3*R*T*LN(EXP(THETA/T)+1), THETA=gg\n if(dfdt.ne.zero) then\n write(*,*)'3Z GEIN must not be multiplied with T!'\n gx%bmperr=4399; goto 1000\n endif\n! write(*,'(a,5i5,1pe12.4)')'3Z intein6: ',ic,ipow,link,link3,link4,ff\n! ff is the constant factor in front of the Einstein function\n! It is overwritten by the Einstein function (multiplied by original ff)\n call tpfun_geinstein(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2)\n! write(*,'(a,i3,6(1pe12.4))')'3Z call Einstein:',link,&\n! gg,ff,dfdt,d2fdt2\n! ff is the coefficient for the Einstein Functions, should be a constant ...?\n! write(*,*)'Einstein function not implemented'\n! stop 72\n if(gx%bmperr.ne.0) goto 1000\n elseif(unfun.eq.-6) then\n! MAX1 function, used for SRO .... function and derivatives in gg, dgdt etc.\n! write(*,*)'MAX1 function',gg\n if(gg.le.zero) then\n write(*,*)'MAX1 called with negative argument',gg\n stop 73\n endif\n if(gg.le.one) then\n! just copy values from g to f\n d2fdp2=d2gdp2; d2gdtdp=d2fdtdp; d2fdt2=d2gdt2\n dfdp=dgdp; dfdt=dgdt; ff=gg\n else\n! function value is 1 and all derivatives zero\n d2fdp2=zero; d2fdtdp=zero; d2fdt2=zero\n dfdp=zero; dfdt=zero; ff=one\n endif\n else\n! undefined function\n gx%bmperr=4021\n goto 1000\n endif evunfun\n ic=ic+1\n!----------------------------- end two-term unary function\n!>>>>>>>>>>>>> very uncertain code above here <<<<<<<<<<<<<<<<<<<<<<\n else\n! link=0, just continue\n continue\n endif evlink\n! adding terms together\n val(1)=val(1)+ff\n val(2)=val(2)+dfdt\n val(3)=val(3)+dfdp\n val(4)=val(4)+d2fdt2\n val(5)=val(5)+d2fdtdp\n val(6)=val(6)+d2fdp2\n enddo eval\n900 continue\n! If level>1 save the values of the TP function. The link to the\n! address of TP function is in savetp(level)\n if(level.gt.0) then\n! save calculated TP function values\n tprot=topsave%savetp\n do i=1,6\n tpres(tprot)%results(i)=val(i)\n enddo\n tpres(tprot)%tpused(1)=tpval(1)\n tpres(tprot)%tpused(2)=tpval(2)\n! then unpack saved values of val and derivatives\n symval=val\n val=topsave%saveval\n! POP the coefficients and the rest\n ic=topsave%saveic; nc=topsave%savenc\n link2=topsave%savetp; link4=topsave%savelink4\n! For some unknown reason topsave%saveic is ic-1 !!! correct below\n! write(*,22)'3Z wpow pop 1: ',level,nc,ic,0,link4\n exprot=>topsave%exprot\n! MEMORY LEAK avoided by deallocate topsave ??\n! write(*,*)'Trying to remove memory leak'\n temp=>topsave%previous\n deallocate(topsave)\n! write(*,*)'Deallocated topsave'\n! topsave=>topsave%previous\n topsave=>temp\n level=level-1\n! restart from coefficient ic, note the value saved is ic-1 !!\n if(ic.ge.0 .and. ic.lt.nc) then\n! restore value in %wpow !!!\n! without this an expression like VCRBCC*EXP(ZCRBCC) became\n! just EXP(ZRBCC) as the link to VCRBCC had been removed ...\n! BUT for macro step3 the link4 was inserted in the wrong term !!!\n! if(link4.gt.1000 .and. exprot%wpow(ic).lt.1000) then\n if(link4.gt.1000 .and. exprot%wpow(ic+1).lt.1000) then\n! write(*,22)'3Z wpow save: ',level+1,nc,ic,exprot%wpow(ic),link4\n! topsave%saveic is ic-1, I do not know why but this correction is added now!\n exprot%wpow(ic+1)=link4\n endif\n endif\n goto 200\n endif\n!\n1000 continue\n return\n end subroutine ct1efn !level %wpow link4\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tpfun_geinstein\n!\\begin{verbatim}\n subroutine tpfun_geinstein(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2)\n! evaluates the integrated Einstein function (including 1.5*R) INTEIN/GEIN\n! gg is the value of the Einstein THETA\n! ff is a constant factor which should be multiplied with all terms\n! ff is overwritten with the Einstein function (multiplied with ff in)\n! the other parameters are derivatives of the integrated Einstein function\n implicit none\n double precision tpval(*)\n double precision gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2\n!\\end{verbatim}\n double precision kvot,kvotexpkvotm1,expmkvot,lnexpkvot,ww,rgas,egg\n! return ff = 1.5*R*gg + 3*R*T*LN(1 - EXP(-gg/T)) and derivatives\n! NOTE gg is THETA, not LN(THETA) below\n! gg must be a constant >0\n rgas=globaldata%rgas\n! write(*,*)'3Z in Einstein function',gg,tpval(1)\n! in the call ff is a constant factor multiplied with the Einstein function\n! NOTE gg is the logarithm of the Einstein THETA, take the exponential!!\n ww=ff\n! if(gg.gt.8.0D1) then\n! write(*,'(a,F8.2)')'Einstein T in GEIN too large, use the logarithm!',gg\n! gx%bmperr=5399; goto 1000\n! endif\n! MODIFIED 2023.10.26/BoS the value of gg is THETA, not LN(THETA)\n if(gg.lt.1.0D1) then\n write(*,*)' *** Warning, Einstein THETA in GEIN less than 10,',&\n ' use THETA not LN(THETA)!'\n endif\n! egg=exp(gg)\n egg=gg\n kvot=egg/tpval(1)\n!write(*,'(a,5(1pE12.4))')'GEIN: ',gg,egg,kvot,tpval(1)\n! no risk for extreme values of eqq\n!- if(kvot.gt.2.0d2) then\n! handle extreme values of kvot, we divide by kvotexpkvotm1**2 by expmkvot bolw\n!- expmkvot=one\n!- kvotexpkvotm1=zero\n!- lnexpkvot=zero\n! write(*,'(a,5(1pe12.4))')'3Z Einetsin 1: ',kvot,expmkvot,&\n! kvotexpkvotm1,lnexpkvot\n!- else\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n lnexpkvot=log(one-expmkvot)\n! write(*,'(a,5(1pe12.4))')'3Z Einetsin 2: ',kvot,expmkvot,&\n! kvotexpkvotm1,lnexpkvot\n!- endif\n! this is the integral G contribution from an Einstein solid\n ff=1.5d0*rgas*egg*ww + 3.0D0*rgas*tpval(1)*lnexpkvot*ww\n dfdt=3.0d0*rgas*(lnexpkvot-kvotexpkvotm1)*ww\n! write(*,10)rgas,kvot,lnexpkvot,kvotexpkvotm1,dfdt\n!10 format('3Z bug: ',6(1pe12.4))\n dfdp=zero\n! this is the second derivative of G wrt T; i.e. the Einstein solid Cp equation\n d2fdt2=-3.0d0*rgas*kvotexpkvotm1**2/(expmkvot*tpval(1))*ww\n d2fdtdp=zero\n d2fdp2=zero\n1000 continue\n return\n end subroutine tpfun_geinstein\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tpfun_geinstein_ln\n!\\begin{verbatim}\n subroutine tpfun_geinstein_ln(tpval,gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2)\n! evaluates the integrated Einstein function (including 1.5*R) INTEIN/GEIN\n! gg is the value of the Einstein THETA, here provided as ln(THETA)\n! ff is a constant factor which should be multiplied with all terms\n! ff is overwritten with the Einstein function (multiplied with ff in)\n! the other parameters are derivatives of the integrated Einstein function\n implicit none\n double precision tpval(*)\n double precision gg,ff,dfdt,dfdp,d2fdt2,d2fdtdp,d2fdp2\n!\\end{verbatim}\n double precision kvot,kvotexpkvotm1,expmkvot,lnexpkvot,ww,rgas,egg\n! return ff = 1.5*R*gg + 3*R*T*LN(1 - EXP(-gg/T)) and derivatives\n! gg must be a constant >0\n rgas=globaldata%rgas\n! write(*,*)'3Z in Einstein function',gg,tpval(1)\n! in the call ff is a constant factor multiplied with the Einstein function\n! NOTE gg is the logarithm of the Einstein THETA, take the exponential!!\n ww=ff\n if(gg.gt.8.0D1) then\n write(*,'(a,F8.2)')'Einstein T in GEIN too large, use the logarithm!',gg\n gx%bmperr=5399; goto 1000\n endif\n! MODIFIED 2023.10.26/BoS the value of gg is THETA, not LN(THETA)\n egg=exp(gg)\n kvot=egg/tpval(1)\n!write(*,'(a,5(1pE12.4))')'GEIN: ',gg,egg,kvot,tpval(1)\n if(kvot.gt.2.0d2) then\n! handle extreme values of kvot, we divide by kvotexpkvotm1**2 by expmkvot bolw\n expmkvot=one\n kvotexpkvotm1=zero\n lnexpkvot=zero\n! write(*,'(a,5(1pe12.4))')'3Z Einetsin 1: ',kvot,expmkvot,&\n! kvotexpkvotm1,lnexpkvot\n else\n expmkvot=exp(-kvot)\n kvotexpkvotm1=kvot/(exp(kvot)-one)\n lnexpkvot=log(one-expmkvot)\n! write(*,'(a,5(1pe12.4))')'3Z Einetsin 2: ',kvot,expmkvot,&\n! kvotexpkvotm1,lnexpkvot\n endif\n! this is the integral G contribution from an Einstein solid\n ff=1.5d0*rgas*egg*ww + 3.0D0*rgas*tpval(1)*lnexpkvot*ww\n dfdt=3.0d0*rgas*(lnexpkvot-kvotexpkvotm1)*ww\n! write(*,10)rgas,kvot,lnexpkvot,kvotexpkvotm1,dfdt\n!10 format('3Z bug: ',6(1pe12.4))\n dfdp=zero\n! this is the second derivative of G wrt T; i.e. the Einstein solid Cp equation\n d2fdt2=-3.0d0*rgas*kvotexpkvotm1**2/(expmkvot*tpval(1))*ww\n d2fdtdp=zero\n d2fdp2=zero\n1000 continue\n return\n end subroutine tpfun_geinstein_ln\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1wfn\n!\\begin{verbatim}\n subroutine ct1wfn(exprot,tps,string,ip)\n!...writes an expression into string starting at ip\n! lrot is an index to an tpexpr record\n! implicit double precision (a-h,o-z)\n implicit none\n character tps(2)*(*)\n character string*(*)\n!\\end{verbatim} %+\n integer, parameter :: levl=5,nunary=6\n integer, parameter :: lenfnsym=16\n integer koder(5,levl),ip,jus,is,kk,kpow,level,lpar,mult,nc,nos,i,ic\n double precision coeff(levl)\n character ch1*1,cht*1,extsym*(lenfnsym),unary(nunary)*6\n TYPE(tpfun_expression), pointer :: exprot\n! these should be the same as in ct1xfn !!! ??\n DATA unary/'LOG ','LN ','EXP ','ERF ','GEIN ','MAX1 '/\n! DATA unary/'LOG ','LN ','EXP ','ERF ','INTEIN','MAX1 '/\n!\n if(.not.associated(exprot)) then\n string(ip:ip+2)='0; '\n ip=ip+2\n goto 1000\n endif\n nc=exprot%noofcoeffs\n ic=0\n level=1\n lpar=0\n! write(*,*)'in ct1wfn',nc\n200 ic=ic+1\n if(ic.gt.nc) goto 1000\n coeff(level)=exprot%coeffs(ic)\n! bug in the expression parser ... (fixed??)\n if(coeff(level).eq.zero .and. nc.eq.1) then\n! error in parser that such a function can exist, lrot should be zero\n string(ip:ip+1)='0 '\n ip=ip+1\n goto 1000\n elseif(coeff(level).eq.zero) then\n goto 200\n endif\n koder(1,level)=exprot%tpow(ic)\n koder(2,level)=exprot%ppow(ic)\n koder(3,level)=exprot%wpow(ic)\n koder(4,level)=exprot%plevel(ic)\n koder(5,level)=exprot%link(ic)\n!\n!71 format(A,I5,1PE15.6,5I5)\n is=koder(5,level)\n! write(*,202)'ct1wfn: ',ic,ip,is,koder(1,level),string(1:ip)\n!202 format(a,4i4,a)\n symbol: if(is.ne.0) then\n!...reference to symbol or unary function, write coefficient only if not one\n if(abs(coeff(level)).ne.one) then\n call wrinum(string,ip,12,6,coeff(level))\n string(ip:ip)='*'\n ip=ip+1\n nos=0\n if(coeff(level).eq.zero) write(*,*)'ct1wfn ',ip,string(1:ip)\n elseif(coeff(level).eq.one) then\n nos=1\n else\n nos=-1\n endif\n!230 continue\n unaryfun: if(is.lt.0) then\n!...write the T or P power before the unary function\n if(nos.eq.1) then\n string(ip:ip)='+'\n ip=ip+1\n elseif(nos.eq.-1) then\n string(ip:ip)='-'\n ip=ip+1\n endif\n! there can be a symbol link in koder(3,level)\n if(koder(3,level).gt.1000) then\n jus=koder(3,level)-1000\n kk=len_trim(tpfuns(jus)%symbol)\n string(ip:ip+kk-1)=tpfuns(jus)%symbol\n ip=ip+kk\n string(ip:ip)='*'\n ip=ip+1\n endif\n call ct1wpow(string,ip,tps(1),1,koder(1,level))\n call ct1wpow(string,ip,tps(2),1,koder(2,level))\n kk=len_trim(unary(-is))\n string(ip:)=unary(-is)(1:kk)//'('\n ip=ip+kk+1\n lpar=koder(4,level)\n! write(*,*)'lpar: ',string(1:ip),' ',lpar\n else\n! an external symbol, possibly a sign and power\n if(nos.eq.1) then\n string(ip:ip)='+'\n ip=ip+1\n elseif(nos.eq.-1) then\n string(ip:ip)='-'\n ip=ip+1\n endif\n kk=len_trim(tpfuns(is)%symbol)\n string(ip:ip+kk-1)=tpfuns(is)%symbol\n ip=ip+kk\n kpow=koder(3,level)\n if(kpow.gt.1000) then\n! this is a link to another symbol, two symbols multiplied\n jus=kpow-1000\n kk=len_trim(tpfuns(jus)%symbol)\n string(ip:ip+kk)='*'//tpfuns(jus)%symbol\n ip=ip+kk+1\n elseif(kpow.lt.0) then\n kpow=-kpow\n if(kpow.gt.9) then\n! power must be less than 99!!!\n ch1=char(ichar('0')+mod(kpow,10))\n cht=char(ichar('0')+kpow/10)\n string(ip:ip+6)='**(-'//cht//ch1//')'\n ip=ip+7\n else\n ch1=char(ichar('0')+kpow)\n string(ip:ip+5)='**(-'//ch1//')'\n ip=ip+6\n endif\n elseif(kpow.gt.0) then\n! power must be less than 99!!!\n if(kpow.gt.9) then\n ch1=char(ichar('0')+mod(kpow,10))\n cht=char(ichar('0')+kpow/10)\n string(ip:ip+3)='**'//cht//ch1\n ip=ip+4\n else\n ch1=char(ichar('0')+kpow)\n string(ip:ip+2)='**'//ch1\n ip=ip+3\n endif\n endif\n!...write the T or P power after the symbol and possible power\n call ct1wpow(string,ip,tps(1),-1,koder(1,level))\n call ct1wpow(string,ip,tps(2),-1,koder(2,level))\n! fixing missing ) after unary function of symbol like exp(s1)\n! write(*,*)'problem here??:',string(1:ip),' ',lpar\n! We got one extra ) as lpar not reset below\n if(lpar.gt.0) then\n string(ip:ip)=')'\n ip=ip+1\n lpar=0\n endif\n endif unaryfun\n goto 200\n endif symbol\n! no symbol or unary function, coefficient with possible powers\n if(coeff(level).ne.one) then\n! if 4th argument >0 then write a sign\n call wrinum(string,ip,12,6,coeff(level))\n mult=-1\n else\n! in the case of a single value exactly 1 without unary or T or P power\n! the number was never written\n! write(*,203)'ct1wfn2: ',(koder(i,level),i=1,4),coeff(level)\n!203 format(a,4i4,1pe12.4)\n do i=1,4\n if(koder(i,level).ne.0) goto 219\n enddo\n! without this the Inden magnetic function will miss its initial 1.0\n! call wrinum(string,ip,2,0,coeff(level))\n! changed 20.03.17/BoS because EXP(T)+1 missed the + between ) and 1\n! Force wrinum to write positive signs by 4th parameter positive\n call wrinum(string,ip,2,1,coeff(level))\n goto 220\n219 continue\n! missing coefficient discovered by Mauro, as the coefficient is unity\n! it is not written. Check with -1 maybe sign problems?\n! call wrinum(string,ip,2,1,coeff(level))\n string(ip:ip)='+'\n ip=ip+1\n220 continue\n mult=0\n endif\n!...write the T or P power after the coefficient\n call ct1wpow(string,ip,tps(1),mult,koder(1,level))\n call ct1wpow(string,ip,tps(2),mult,koder(2,level))\n if(koder(4,level).eq.1) then\n string(ip:ip)=')'\n ip=ip+1\n! lpar was not reset here causing an extra ) later in expression ...\n lpar=0\n! write(*,*)'lpar not reset?:',string(1:ip)\n! write(*,*)lpar,koder(4,level)\n endif\n goto 200\n1000 return\n end subroutine ct1wfn\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ct1wpow\n!\\begin{verbatim} %-\n subroutine ct1wpow(string,ip,tps,mult,npow)\n!...writes \"ips\" with a power if needed and a * before or after\n! implicit double precision (a-h,o-z)\n implicit none\n integer ip,mult,npow\n character string*(*),tps*(*)\n!\\end{verbatim}\n integer lentps\n if(npow.eq.0) goto 1000\n if(mult.lt.0) then\n string(ip:ip)='*'\n ip=ip+1\n endif\n lentps=len_trim(tps)\n string(ip:ip+lentps-1)=tps\n ip=ip+lentps\n if(npow.gt.9) then\n write(string(ip:ip+3),110)npow\n ip=ip+4\n elseif(npow.gt.1) then\n write(string(ip:ip+4),120)npow\n ip=ip+3\n elseif(npow.lt.-9) then\n write(string(ip:ip+6),140)npow\n ip=ip+7\n elseif(npow.lt.0) then\n write(string(ip:ip+5),150)npow\n ip=ip+6\n endif\n if(mult.gt.0) then\n string(ip:ip)='*'\n ip=ip+1\n endif\n110 format('**',i2)\n120 format('**',i1)\n140 format('**(',i3,')')\n150 format('**(',i2,')')\n1000 return\n end subroutine ct1wpow\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_tpfun_interactivly\n!\\begin{verbatim}\n subroutine enter_tpfun_interactivly(cline,ip,longline,jp)\n! interactive input of a TP expression, whole function returned in longline\n! implicit double precision (a-h,o-z)\n implicit none\n integer ip,jp\n character cline*(*),longline*(*)\n!\\end{verbatim}\n character line*80,ch1*1\n integer nexpr,lsc,kkp\n double precision xx\n! write(*,*)'Max ',len(longline),' characters'\n call gparrdx('Low temperature limit: ',cline,ip,xx,2.9815D2,'?Enter TPfun')\n if(buperr.ne.0) then\n! set default low limit\n buperr=0; longline=' 298.15 '\n jp=8\n else\n longline=' '\n jp=1\n call wrinum(longline,jp,8,0,xx)\n if(buperr.ne.0) goto 1000\n jp=jp+1\n endif\n nexpr=1\n lsc=1\n!-----------------------------------------------\n! return here for new expression in another range\n115 continue\n call gparcx('Give expression, end with \";\":',cline,ip,6,line,';',&\n '?Enter TPfun')\n if(buperr.ne.0) then\n buperr=0; line=';'\n endif\n120 continue\n longline(jp:)=line\n jp=len_trim(longline)+1\n! write(*,*)'tpfun: ',longline(1:jp)\n! lsc is position after the \";\" in any previous range\n if(index(longline(lsc:),';').le.0) then\n call gparcx('&',cline,ip,6,line,';','?Enter TPfun')\n if(buperr.ne.0) then\n buperr=0; line=';'\n endif\n goto 120\n endif\n!150 continue\n! make sure there is a ; at the end of each expression\n kkp=index(longline(nexpr:),';')\n! write(*,130)'3Z pos1: ',nexpr,kkp,lsc,jp,trim(longline)\n!130 format(a,4i4,': ',a/26x,'123456789.123456789.123456789.123456789.')\n! write(*,*)'tpfun add ;'\n if(kkp.le.0) then\n kkp=len_trim(longline)\n longline(kkp+1:)='; '\n jp=kkp+3\n nexpr=jp\n write(*,*)'3Z adding ; at position: ',kkp+1,nexpr\n else\n! nexpr=kkp+1\n nexpr=len_trim(longline)+2\n endif\n! lsc is position of ; for previous range\n! write(*,130)'3Z pos2: ',nexpr,kkp,lsc,jp,trim(longline)\n lsc=nexpr\n call gparrdx('Upper temperature limit ',cline,ip,xx,6.0D3,'?Enter TPfun')\n if(buperr.ne.0) then\n buperr=0; xx=6.0D3\n endif\n! enter a space after ;\n jp=jp+1\n call wrinum(longline,jp,8,0,xx)\n if(buperr.ne.0) goto 1000\n call gparcdx('Any more ranges',cline,ip,1,ch1,'N','?Enter TPfun')\n! write(*,*)'3Z ch1: ',ch1\n if(ch1.eq.'n' .or. ch1.eq.'N') then\n longline(jp:)=' N'\n jp=jp+3\n else\n longline(jp:)=' Y'\n jp=jp+3\n goto 115\n endif\n! remove any \"#\" (comes from TC functions)\n900 continue\n kkp=index(longline,'#')\n if(kkp.gt.0) then\n longline(kkp:kkp)=' '\n goto 900\n endif\n! write(*,910)'3Z tpf: ',jp,trim(longline)\n!910 format(a,i3,': ',a)\n!\n1000 continue\n return\n end subroutine enter_tpfun_interactivly\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tpfun_deallocate\n!\\begin{verbatim}\n subroutine tpfun_deallocate\n! deallocates all arrays associated with a TP function\n!\\end{verbatim}\n implicit none\n TYPE(tpfun_expression), pointer :: exprot\n integer j,nr,nexp,nc\n! write(*,*)'3Z freetpfun: ',freetpfun\n do j=1,freetpfun-1\n nr=tpfuns(j)%noofranges\n if(nr.gt.0) then\n! modified 170517 due to memory leaks when read/write unformatted\n do nc=1,nr\n exprot=>tpfuns(j)%funlinks(nc)\n! write(*,*)'3Z Deallocating TP function',j,nc\n deallocate(exprot%tpow)\n deallocate(exprot%ppow)\n deallocate(exprot%wpow)\n deallocate(exprot%plevel)\n deallocate(exprot%link)\n deallocate(exprot%coeffs)\n enddo\n!\n deallocate(tpfuns(j)%funlinks)\n deallocate(tpfuns(j)%limits)\n endif\n enddo\n deallocate(tpfuns)\n!1000 continue\n return\n end subroutine tpfun_deallocate\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine store_tpfun_dummy\n!\\begin{verbatim}\n subroutine store_tpfun_dummy(symbol)\n! creates a dummy entry for a TP function called symbol, used when entering \n! TPfuns from a TDB file where they are not in order\n implicit none\n character*(*) symbol\n!\\end{verbatim}\n! set the TPNOTENT bit of this symbol\n integer lrot\n character name*16\n lrot=freetpfun\n if(lrot.gt.0) then\n freetpfun=tpfuns(lrot)%nextorsymbol\n tpfuns(lrot)%nextorsymbol=0\n else\n write(*,*)'No space for TP functions: ',size(tpfuns)\n gx%bmperr=4014; goto 1000\n endif\n tpfuns(lrot)%noofranges=0\n name=symbol\n call capson(name)\n tpfuns(lrot)%symbol=name\n tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPNOTENT)\n tpfuns(lrot)%rewind=0\n1000 continue\n return\n end subroutine store_tpfun_dummy\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine store_tpfun\n!\\begin{verbatim}\n subroutine store_tpfun(symbol,text,lrot,rewind)\n! creates a data structure for a TP function called symbol with several ranges\n! text is whole expression\n! lrot is returned as index. If fromtdb is FALSE and lrot<0 it is a new\n! expression for an old symbol\n! if fromtdb is TRUE references to unknown functions are allowed\n! default low temperature limit is 298.16; high 6000\n implicit none\n integer lrot,rewind\n character*(*) text,symbol\n! logical fromtdb\n!\\end{verbatim}\n! max number of ranges, max number of coefficents in each range\n! integer, parameter :: mrange=20,mc=15\n! in a paper more than 15 terms were used for a TP function!\n integer, parameter :: mrange=20,mc=20\n integer jss,nc,ip,nrange,cbug\n real tlim(mrange)\n double precision coeff(mc),val\n integer koder(5,mc)\n! attempt to remove big memory leak\n! TYPE(tpfun_expression) :: links(mrange)\n! TYPE(tpfun_expression), target :: links(mrange)\n TYPE(tpfun_expression) :: links(mrange)\n! TYPE(tpfun_expression), pointer :: ltpexpr\n character ch1*1,lsym*(lenfnsym)\n logical already,fromtdb\n! check if function already entered, there are freetpfun-1 of them\n! ignore functions that start with a \"_\" as they are parameters\n! lrot=0\n! special when read unformatted or direct files, lrot<0 and this ??\n! must be the location for storing the function ...\n fromtdb=.TRUE.\n if(rewind.lt.0) fromtdb=.FALSE.\n already=.FALSE.\n if(symbol(1:1).ne.'_') then\n lsym=symbol\n call capson(lsym)\n! write(*,*)'3Z store_tpfun: ',trim(lsym),lrot,rewind\n do jss=1,freetpfun-1\n! write(*,17)jss,lsym,tpfuns(jss)%symbol\n!17 format('enter_tpfun: ',i5,' >,',a,'=',a,'?')\n if(lsym.eq.tpfuns(jss)%symbol) then\n if(btest(tpfuns(jss)%status,TPNOTENT)) then\n! function name already entered, now enter expression, this is from TDB files\n lrot=jss; already=.TRUE.\n! mark the expression was entered at current rewind\n tpfuns(jss)%rewind=rewind; goto 18\n else\n! write(*,*)'amend tpfun? ',trim(lsym),fromtdb,lrot\n if(.NOT.fromtdb .and. lrot.lt.0) then\n! this is an AMEND TPFUN, delete old expression to be able to store a new\n lrot=jss; already=.TRUE.\n nrange=tpfuns(lrot)%noofranges\n! write(*,*)'Deallocating: ',lrot,nrange\n deallocate(tpfuns(lrot)%limits)\n deallocate(tpfuns(lrot)%funlinks)\n tpfuns(lrot)%noofranges=0\n tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPNOTENT)\n! we should clear the stored values! But those are stored separatly in all ceq\n nrange=0; goto 18\n else\n write(*,*)'3Z A never never error again! ',trim(symbol)\n gx%bmperr=4026; goto 1000\n endif\n endif\n endif\n enddo\n endif\n!\n lrot=0\n18 continue\n! low T limit\n ip=1\n cbug=ip\n call getrel(text,ip,val)\n if(buperr.ne.0) then\n! A , has been used to select default low temperature limit\n if(text(ip:ip).eq.',') then\n buperr=0; val=298.15D0\n else\n write(*,*)'Illegal character for low temperature limit: ',text(ip:ip)\n val=298.15; buperr=0\n! write(*,19)ip,cbug,trim(text)\n!19 format('TPFUN: ',2i3,' >',a)\n endif\n! increement ip!\n ip=ip+1\n endif\n tlim(1)=val\n nrange=0\n ch1='Y'\n! parse and store expression for each temperature range\n ranges: do while(ch1.eq.'Y')\n nrange=nrange+1\n if(nrange.gt.mrange) then\n gx%bmperr=4025; goto 1000\n endif\n nc=mc\n call ct1xfn(text,ip,nc,coeff,koder,fromtdb)\n if(gx%bmperr.ne.0) then\n! write(*,*)'3E error ocurred for: ',trim(symbol)\n goto 1000\n endif\n! big memory leak ... still there ...\n! call ct1mexpr(nc,coeff,koder,ltpexpr)\n! links(nrange)=ltpexpr\n! ltpexpr=>links(nrange)\n! call ct1mexpr(nc,coeff,koder,ltpexpr)\n! write(*,*)'3Z calling ct1mexpr', nrange\n call ct1mexpr(nc,coeff,koder,links(nrange))\n! attempt to remove memory leak\n! bypass final ; of expression\n ip=ip+1\n call getrel(text,ip,val)\n if(buperr.ne.0) then\n! acceppt a , for default ...\n if(text(ip:ip).eq.',') then\n val=6.0D3; buperr=0\n else\n write(*,27)buperr,ip,text(1:ip+5)\n27 format(' *** Error in enter_tpfun 2: ',i5,', position ',i5/&\n '>',a,'<')\n endif\n endif\n tlim(nrange+1)=val\n if(.not.eolch(text,ip)) then\n ch1=biglet(text(ip:ip))\n ip=ip+1\n endif\n enddo ranges\n if(already) then\n! a function symbol already entered, lrot is location\n call ct2mfn(symbol,nrange,tlim,links,lrot)\n else\n! a new function record will be allocated\n call ct1mfn(symbol,nrange,tlim,links,lrot)\n endif\n! force functions to be recalculated\n! write(*,*)'3Z calling force_recalculate from enter_tpfun'\n call force_recalculate_tpfuns\n1000 continue\n return\n end subroutine store_tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine nested_tpfun\n!\\begin{verbatim}\n subroutine nested_tpfun(lrot,tpval,nyrot)\n! called from ct1efn when a it calls another TP function that must be\n! evaluated. nyrot is the link to the ct1efn in the correct range\n! implicit double precision (a-h,o-z)\n implicit none\n integer lrot\n double precision tpval(2)\n TYPE(tpfun_expression), pointer :: nyrot\n! use lowest range for all T values lower than first upper limit\n! and highest range for all T values higher than the next highest limit\n! one should signal if T is lower than lowest limit or higher than highest\n! used saved reults if same T and P\n!\\end{verbatim} %+\n integer nr,ns\n nullify(nyrot)\n if(lrot.le.0) goto 1000\n nr=tpfuns(lrot)%noofranges\n if(nr.eq.0) then\n! this is the case for constants! Does this work??\n if(btest(tpfuns(lrot)%status,TPCONST)) then\n write(*,*)'nested constant: ',nr,lrot\n else\n write(*,*)'A never never error evaluation a TP function',lrot\n write(*,*)'Function name: ',tpfuns(lrot)%symbol\n gx%bmperr=4350; goto 1000\n endif\n elseif(nr.eq.1) then\n nyrot=>tpfuns(lrot)%funlinks(1)\n else\n ns=1\n do while(ns.lt.nr)\n if(tpval(1).lt.tpfuns(lrot)%limits(ns+1)) then\n nyrot=>tpfuns(lrot)%funlinks(ns)\n goto 900\n endif\n ns=ns+1\n enddo\n nyrot=>tpfuns(lrot)%funlinks(nr)\n endif\n900 continue\n1000 continue\n return\n end subroutine nested_tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine enter_optvars\n!\\begin{verbatim}\n subroutine enter_optvars(firstindex)\n! enter variables for optimization A00-A99\n implicit none\n integer firstindex\n!\\end{verbatim} %+\n character symbol*(lenfnsym)\n integer jss,symix,lrot\n symbol='A00 '\n! check if any TP fun with name A00 already entered\n do jss=1,freetpfun-1\n if(symbol.eq.tpfuns(jss)%symbol) then\n write(kou,*)'Optimizing symbols already entered'\n goto 1000\n endif\n enddo\n firstindex=freetpfun\n do jss=1,100\n! create TPfun symbols with names A00 to A99 with value 0.0D0\n lrot=freetpfun\n if(lrot.eq.0) then\n gx%bmperr=4104; goto 1000\n else\n freetpfun=tpfuns(lrot)%nextorsymbol\n tpfuns(lrot)%nextorsymbol=0\n endif\n allocate(tpfuns(lrot)%limits(1))\n allocate(tpfuns(lrot)%funlinks(1))\n tpfuns(lrot)%symbol=symbol\n tpfuns(lrot)%limits(1)=zero\n! mark this is a single value and can be optimized\n tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPCONST)\n tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPOPTCON)\n! increment symbol\n symix=ichar(symbol(3:3))-ichar('0')\n symix=symix+1\n if(symix.eq.10) then\n symbol(3:3)='0'\n symbol(2:2)=char(ichar(symbol(2:2))+1)\n else\n symbol(3:3)=char(ichar(symbol(3:3))+1)\n endif\n! write(*,*)'Next symbol created: ',symbol(1:4),lrot\n enddo\n1000 continue\n return\n end subroutine enter_optvars\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_tpsymbol\n!\\begin{verbatim} %-\n subroutine find_tpsymbol(name,type,value)\n! enter variables \n implicit none\n! type=0 if function, 1 if variable, 2 if optimizing variable\n integer type\n character name*(lenfnsym)\n double precision value\n!\\end{verbatim} %+\n integer jss,symix,lrot\n character symbol*(lenfnsym)\n symbol=name\n call capson(symbol)\n! check if any TP fun with name symbol exists\n type=0\n do jss=1,freetpfun-1\n if(symbol.eq.tpfuns(jss)%symbol) then\n! found symbol\n if(btest(tpfuns(jss)%status,TPCONST)) then\n value=tpfuns(jss)%limits(1)\n if(btest(tpfuns(jss)%status,TPOPTCON)) then\n type=2\n else\n type=1\n endif\n endif\n goto 200\n endif\n enddo\n! no such symbol\n gx%bmperr=4351\n type=-1\n200 continue\n!1000 continue\n return\n end subroutine find_tpsymbol\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine store_tpconstant\n!\\begin{verbatim} %-\n subroutine store_tpconstant(symbol,value)\n! enter variables \n implicit none\n character symbol*(lenfnsym)\n double precision value\n!\\end{verbatim} %+\n integer jss,symix,lrot\n! check if any TP fun with name symbol already entered\n do jss=1,freetpfun-1\n if(symbol.eq.tpfuns(jss)%symbol) then\n! symbol already exist, just change value unless it is an optimizing coeff.\n if(btest(tpfuns(jss)%status,TPOPTCON)) then\n write(*,*)'Not allowed to change optimizing coefficents'\n goto 1000\n else\n lrot=jss\n goto 200\n endif\n endif\n enddo\n! create TPfun symbols with name symbol and value value\n lrot=freetpfun\n if(lrot.eq.0) then\n gx%bmperr=4104; goto 1000\n else\n freetpfun=tpfuns(lrot)%nextorsymbol\n tpfuns(lrot)%nextorsymbol=0\n endif\n allocate(tpfuns(lrot)%limits(1))\n allocate(tpfuns(lrot)%funlinks(1))\n call capson(symbol)\n tpfuns(lrot)%symbol=symbol\n! mark this is a single value\n tpfuns(lrot)%status=ibset(tpfuns(lrot)%status,TPCONST)\n200 continue\n! write(*,*)'3Z store tpconstant: ',lrot,value\n tpfuns(lrot)%limits(1)=value\n nullify(tpfuns(lrot)%funlinks)\n! OBS! calculate all tpfun after this to make sure value is propagated!!\n! This indicate for all TPFUN that they must be recalculated\n call force_recalculate_tpfuns\n1000 continue\n return\n end subroutine store_tpconstant\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine change_optcoeff\n!\\begin{verbatim} %-\n subroutine change_optcoeff(lrot,value)\n! change value of optimizing coefficient. lrot is index\n! -1 means just force recalculate\n implicit none\n integer lrot\n double precision value\n!\\end{verbatim} %+\n integer mrot\n if(lrot.gt.0 .and. lrot.lt.freetpfun-1) then\n if(.not.btest(tpfuns(lrot)%status,TPOPTCON)) then\n write(*,*)'Attempt to change non-existing coefficent',lrot\n gx%bmperr=7777; goto 1000\n endif\n tpfuns(lrot)%limits(1)=value\n endif\n! force recalculation of all functions. HOW? the force_... does not work ...\n call force_recalculate_tpfuns\n1000 continue\n return\n end subroutine change_optcoeff\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine force_recalculate_tpfuns\n!\\begin{verbatim} %-\n subroutine force_recalculate_tpfuns\n! force recalculation of all tpfuns by incrementing an integer in tpfuns\n!\\end{verbatim} %+\n implicit none\n integer mrot\n! it seems difficult to force recalculating all TP functions !!!\n! write(*,*)'3Z GLAVESCUMG: ',tpfuns(125)%forcenewcalc\n do mrot=1,freetpfun-1\n tpfuns(mrot)%forcenewcalc=tpfuns(mrot)%forcenewcalc+1\n! I have no access to tpres here so I cannot see any current value ...\n enddo\n! write(*,*)'3Z Force recalculate tpfuns: ',freetpfun-1\n! write(*,*)'3Z GLAVESCUMG: ',tpfuns(125)%forcenewcalc\n return\n end subroutine force_recalculate_tpfuns\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_value_of_constant_name\n!\\begin{verbatim} %-\n subroutine get_value_of_constant_name(symbol,lrot,value)\n! get value (and index) of a TP constant. lrot is index\n implicit none\n integer lrot\n character symbol*(*)\n double precision value\n!\\end{verbatim} %+\n write(*,*)'get_value_of_constant_name not implemented yet'\n! value=tpfuns(lrot)%limits(1)\n!1000 continue\n return\n end subroutine get_value_of_constant_name\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_value_of_constant_index\n!\\begin{verbatim} %-\n subroutine get_value_of_constant_index(lrot,value)\n! get value of a TP constant at known lrot\n implicit none\n integer lrot\n double precision value\n!\\end{verbatim} %+\n if(lrot.le.0 .or. lrot.gt.freetpfun-1) then\n write(kou,*)'Constant index outside limits',lrot\n else\n! unifished: check if it is really a constant ...\n value=tpfuns(lrot)%limits(1)\n endif\n!1000 continue\n return\n end subroutine get_value_of_constant_index\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_all_opt_coeff\n!\\begin{verbatim} %-\n subroutine get_all_opt_coeff(values)\n! get values of all optimizing coefficients\n implicit none\n double precision values(*)\n!\\end{verbatim} %+\n write(*,*)'Not yet implemeneted'\n!1000 continue\n return\n end subroutine get_all_opt_coeff\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine delete_all_tpfuns\n!\\begin{verbatim} %-\n subroutine delete_all_tpfuns\n! delete all TPFUNs. No error if some are already deleted ... \n! note: tpres is deallocated when deleting equilibrium record\n!\\end{verbatim}\n implicit none\n integer lrot,nrex\n TYPE(tpfun_expression), pointer :: expr\n! write(*,*)'In delete_all_tpfuns'\n deallocate(tpfuns)\n goto 1000\n! code below skipped as it created a lot of memory errors ...\n if(tpfun_expression_version.ne.1 .or. tpfun_root_version.ne.1 .or. &\n tpfun_parres_version.ne.1) then\n write(*,*)'Data structure error when deleting tpfuns',&\n tpfun_expression_version,tpfun_root_version,&\n tpfun_parres_version\n gx%bmperr=7777; goto 1000\n endif\n funloop: do lrot=1,freetpfun-1\n write(*,*)'TP Deleting TP function: ',lrot\n! if(tpfuns(lrot)%noofranges.eq.0) cycle\n if(tpfuns(lrot)%noofranges.eq.0) goto 200\n write(*,*)'TP deleting ranges 1-',tpfuns(lrot)%noofranges\n range: do nrex=1,tpfuns(lrot)%noofranges\n expr=>tpfuns(lrot)%funlinks(nrex)\n if(associated(expr)) then\n deallocate(expr%coeffs)\n deallocate(expr%tpow)\n deallocate(expr%ppow)\n deallocate(expr%wpow)\n deallocate(expr%plevel)\n deallocate(expr%link)\n deallocate(expr)\n else\n write(*,*)'TP delete; no expression? ',lrot,nrex\n endif\n enddo range\n200 continue\n write(*,*)'TP deleting limits ',size(tpfuns(lrot)%limits)\n deallocate(tpfuns(lrot)%limits)\n write(*,*)'TP deleting funlinks ',size(tpfuns(lrot)%funlinks)\n deallocate(tpfuns(lrot)%funlinks)\n enddo funloop\n write(*,*)'TP finally deleting roots'\n deallocate(tpfuns)\n1000 continue\n return\n end subroutine delete_all_tpfuns\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine save0tpfun\n!\\begin{verbatim}\n subroutine save0tpfun(lfun,iws,jfun)\n! save one tpfun (or parameter) with index jfun in workspace iws\n! implicit double precision (a-h,o-z)\n implicit none\n integer lfun,iws(*),jfun\n!\\end{verbatim} %+\n integer nr,i,kx,nc,displace,lexpr,rsize,mmz\n TYPE(tpfun_expression), pointer :: exprot\n double precision dummy,xxx\n! jfun can be zero meaning a parameter that is zero \n! unformatted\n if(jfun.eq.0) then\n iws(lfun)=0\n else\n nr=tpfuns(jfun)%noofranges\n rsize=4+nwch(16)+nr*(1+nwpr)+nwpr\n call wtake(lfun,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'Error reserving record for TPfun',buperr,rsize,nr\n gx%bmperr=4399; goto 1000\n endif\n! write(*,11)'3Z tpfun ',lfun,jfun,trim(tpfuns(jfun)%symbol),&\n! tpfuns(jfun)%noofranges,tpfuns(jfun)%status\n!11 format(a,2i7,2x,a,2x,5i7)\n iws(lfun+1)=tpfuns(jfun)%noofranges\n iws(lfun+2)=tpfuns(jfun)%status\n! what is nextfree??\n iws(lfun+3)=tpfuns(jfun)%nextorsymbol\n call storc(lfun+4,iws,tpfuns(jfun)%symbol)\n displace=4+nwch(16)\n call storrn(nr,iws(lfun+displace),tpfuns(jfun)%limits)\n! write(lut)(tpfuns(jfun)%limits(i),i=1,nr)\n call storr(lfun+displace+nr*nwpr,iws,tpfuns(jfun)%hightlimit)\n! store location of expressions from displace\n displace=displace+nwpr*(nr+1)\n! now the expressions, number of coefficients, nc, can be different\n! link them from lfun\n do kx=1,nr\n exprot=>tpfuns(jfun)%funlinks(kx)\n nc=exprot%noofcoeffs\n rsize=1+nc*(5+nwpr)\n call wtake(lexpr,rsize,iws)\n if(buperr.ne.0) then\n write(*,*)'Error reserving record for TPfun'\n gx%bmperr=4399; goto 1000\n endif\n iws(lfun+displace+kx-1)=lexpr\n iws(lexpr)=nc\n mmz=lexpr+1\n! The coefficients and the codes\n do i=1,nc\n iws(mmz)=exprot%link(i)\n iws(mmz+1)=exprot%tpow(i)\n iws(mmz+2)=exprot%ppow(i)\n iws(mmz+3)=exprot%wpow(i)\n iws(mmz+4)=exprot%plevel(i)\n call storr(mmz+5,iws,exprot%coeffs(i))\n call loadr(mmz+5,iws,xxx)\n mmz=mmz+5+nwpr\n enddo\n enddo\n endif\n1000 continue\n return\n end subroutine save0tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine read0tpfun\n!\\begin{verbatim} %-\n subroutine read0tpfun(lfun,iws,jfun)\n! read one TPfun from workspace\n implicit none\n integer lfun,jfun,iws(*)\n!\\end{verbatim}\n integer i,i2,kx,nc,nr,displace,lexpr,loklexpr,mmz\n TYPE(tpfun_expression), pointer :: exprot\n character*16 symbol\n double precision dummy\n! jfun can be sero meaning no link to a TPFUN\n! read(lut)jfun,symbol,nr,i2\n! the TPfuns are stored in an array, no need to allocate\n! if(iws(lfun).gt.0) then\n if(jfun.gt.0) then\n nr=iws(lfun+1)\n tpfuns(jfun)%noofranges=nr\n tpfuns(jfun)%status=iws(lfun+2)\n tpfuns(jfun)%nextorsymbol=iws(lfun+3)\n call loadc(lfun+4,iws,tpfuns(jfun)%symbol)\n else\n write(*,*)'not a function: ',lfun,jfun\n goto 1000\n endif\n! special for optimizing variables\n if(btest(tpfuns(jfun)%status,TPOPTCON)) then\n! write(*,*)'3Z allocating zero limit for ',tpfuns(jfun)%symbol\n allocate(tpfuns(jfun)%limits(1))\n tpfuns(jfun)%limits(1)=zero\n goto 1000\n endif\n! a TPfun can have different number of ranges, must be allocated\n displace=4+nwch(16)\n allocate(tpfuns(jfun)%limits(nr))\n allocate(tpfuns(jfun)%funlinks(nr))\n call loadrn(nr,iws(lfun+displace),tpfuns(jfun)%limits)\n call loadr(lfun+displace+nr*nwpr,iws,tpfuns(jfun)%hightlimit)\n! write(*,*)'3Z high T',tpfuns(jfun)%hightlimit\n! the expressions are linked from here, one per range\n displace=displace+(1+nr)*nwpr\n loklexpr=lfun+displace-1\n! extract the expressions\n do kx=1,nr\n lexpr=iws(loklexpr+kx)\n nc=iws(lexpr)\n! write(*,*)'3Z coeffs 1',kx,lfun,lexpr,nr,nc\n exprot=>tpfuns(jfun)%funlinks(kx)\n exprot%noofcoeffs=nc\n! if(nc.gt.20) stop\n allocate(exprot%tpow(nc))\n allocate(exprot%ppow(nc))\n allocate(exprot%wpow(nc))\n allocate(exprot%plevel(nc))\n allocate(exprot%link(nc))\n allocate(exprot%coeffs(nc))\n mmz=lexpr\n! write(*,*)'3Z coeffs 2',nc,iws(nc),mmz\n do i=1,nc\n exprot%link(i)=iws(mmz+1)\n exprot%tpow(i)=iws(mmz+2)\n exprot%ppow(i)=iws(mmz+3)\n exprot%wpow(i)=iws(mmz+4)\n exprot%plevel(i)=iws(mmz+5)\n call loadr(mmz+6,iws,exprot%coeffs(i))\n mmz=mmz+5+nwpr\n enddo\n enddo\n! if(jfun.gt.0) then\n! read(lut)tpfuns(jfun)%hightlimit\n! else\n! read(lut)dummy\n! endif\n1000 continue\n return\n end subroutine read0tpfun\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine makeoptvname\n!\\begin{verbatim}\n subroutine makeoptvname(name,indx)\n implicit none\n character name*(*)\n integer indx\n!\\end{verbatim} %+\n if(indx.lt.99) then\n if(indx.le.9) then \n name(1:2)='A0'\n name(3:3)=char(indx+ichar('0'))\n else\n name(1:1)='A'\n name(2:2)=char(indx/10+ichar('0'))\n name(3:3)=char(mod(indx,10)+ichar('0'))\n endif\n else\n name='A99'\n endif\n!1000 continue\n return\n end subroutine makeoptvname\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine findtpused\n!\\begin{verbatim}\n subroutine findtpused(lfun,string)\n! this routine finds which other TPFUNS (including parameters) that\n! use the TPFUN lfun. It is used when listing optimizing coefficients\n implicit none\n integer lfun\n character string*(*)\n!\\end{verbatim} %+\n integer jp,kfun,nr,nc,j1\n type(tpfun_expression), pointer :: exprot\n string=' '\n jp=1\n loop1: do kfun=1,freetpfun-1\n if(kfun.eq.lfun) cycle\n loop2: do nr=1,tpfuns(kfun)%noofranges\n exprot=>tpfuns(kfun)%funlinks(nr)\n if(.not.associated(exprot)) cycle loop2\n nc=exprot%noofcoeffs\n loop3: do j1=1,nc\n if(exprot%link(j1).eq.lfun) then\n! write(*,*)'3Z found: ',trim(tpfuns(kfun)%symbol),kfun\n string(jp:)=tpfuns(kfun)%symbol\n jp=len_trim(string)+2\n cycle loop1\n endif\n enddo loop3\n enddo loop2\n enddo loop1\n! write(*,*)'3Z where: ',trim(string)\n!1000 continue\n return\n end subroutine findtpused\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_tpfun_details\n!\\begin{verbatim}\n subroutine list_tpfun_details(lfun)\n! listing the internal datastructure of all tpfuns\n! converts all TP functions to arrays of coefficients with powers of T\n implicit none\n integer lfun\n!\\end{verbatim}\n integer j1,j2,j3,nc\n TYPE(tpfun_expression), pointer :: exprot\n if(lfun.lt.0) then\n! list all ...\n continue\n elseif(lfun.ge.freetpfun) then\n write(*,*)'No such function'\n else\n exprot=>tpfuns(lfun)%funlinks(1)\n nc=exprot%noofcoeffs\n write(*,100)tpfuns(lfun)%symbol,tpfuns(lfun)%noofranges,nc,&\n firsteq%eq_tpres(lfun)%results(1)\n100 format('Name: ',a,2i5,(1pe12.4)/&\n ' term coefficent tpow ppow wpow plevel link')\n do j1=1,nc\n write(*,110)j1,exprot%coeffs(j1),exprot%tpow(j1),exprot%ppow(j1),&\n exprot%wpow(j1),exprot%plevel(j1),exprot%link(j1)\n110 format('Term: ',i2,1pe12.4,2x,5i6)\n enddo\n endif\n!1000 continue\n return\n end subroutine list_tpfun_details\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n! Below are a couple of routines to generate SOLGASMIX DAT files\n! %debug=1 set in gtp3E\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n \n!\\addtotable subroutine tpfun2coef\n!\\begin{verbatim}\n subroutine tpfun2coef(ctpf,ntpf,npows,text)\n! called by saveadatformat in gtp3C to generate SOLGASMIX DAT files\n! converts all TP functions to arrays of coefficients with powers of T\n implicit none\n integer ntpf,npows\n type(gtp_tpfun2dat) :: ctpf(*)\n character text*(*)\n!\\end{verbatim} %+\n! powers are 0 1 100 2 3 -1 ; 7 -9 -2 -3 extra\n! Tln(T) these on extra line\n integer, parameter :: maxnc=15\n integer i1,i2,i3,usedpow(maxnc)\n character buffer*80\n logical done\n! write(*,*)'In tpfun2coef with ',ntpf,' ctpf records allocated'\n do i1=1,ntpf\n ctpf(i1)%nranges=-1\n enddo\n! this loop may have to be done several times as functions calling functions\n done=.false.\n do while(.not.done)\n done=.true.\n! skip the first two functions ... R and RTLNP\n do i1=3,ntpf\n! done is set false if the function ctpf(i1) is not converted\n if(ctpf(i1)%debug.ne.0) &\n write(*,*)'Converting: ',trim(tpfuns(i1)%symbol)\n ctpf(i1)%name=tpfuns(i1)%symbol\n call tpf2c(ctpf,i1,done)\n if(gx%bmperr.ne.0) goto 1000\n enddo\n enddo\n! here all TP functions are converted to coefficients\n! i1=19\n! call tpwrite('ee',i1,ctpf(i1)%nranges,ctpf(i1)%cfun)\n! extract the powers used\n npows=0\n do i1=3,ntpf\n do i2=1,ctpf(i1)%nranges\n call sortcoeffs(maxnc,i1,ctpf(i1)%cfun%coefs(1,i2),&\n ctpf(i1)%cfun%tpows(1,i2))\n call checkpowers(maxnc,i1,ctpf(i1)%cfun%tpows(1,i2),npows,usedpow)\n enddo\n enddo\n buffer=' '\n! write(*,12)npows,(usedpow(i1),i1=1,npows)\n! write(buffer,11)npows,(usedpow(i1),i1=1,npows)\n!11 format(12i5)\n!12 format('3Z power2: ',i3,12i4)\n text=buffer\n! do i1=3,ntpf\n! call tpwrite('ee',i1,ctpf(i1)%nranges,ctpf(i1)%cfun)\n! write(*,*)'Sorting function/range: ',i1,ctpf(i1)%nranges\n! write(*,699)i1,ctpf(i1)%nranges\n! do i2=1,ctpf(i1)%nranges\n! write(*,700)ctpf(i1)%cfun%tbreaks(i2),&\n! (ctpf(i1)%cfun%coefs(i3,i2),i3=1,npows)\n! enddo\n! enddo\n!800 format(a,2i3,3(1pe12.4,i5))\n!699 format('Function/parameter and ranges: ',2i4)\n!700 format(F11.4,4x,4(1x,G14.8)/5(1x,G14.8))\n1000 continue\n return\n end subroutine tpfun2coef\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_tpascoef\n!\\begin{verbatim} %-\n subroutine list_tpascoef(lut,text,paratyp,i1,npows,factor,ctpf)\n! writes a parameter in DAT format\n! text contains the stoichiometries written with the format 1x,F11.6\n! it can be very long if there are many coefficients.\n implicit none\n integer lut,i1,npows,paratyp\n character text*(*)\n! this is a factor that may be multiplied with all coefficients for\n! phases like sigma which has only a disordered part. Also ionic liquid\n double precision factor\n type(gtp_tpfun2dat) :: ctpf(*)\n!\\end{verbatim} %+\n integer i2,i3,ip,kk,mm\n ip=len_trim(text)\n! this is the endmember stoichiometry, 12 characters per value, 6x12=72\n! write(*,*)'3Z len_trim(text): ',ip\n if(ip.gt.72) then\n write(lut,698)paratyp,ctpf(i1)%nranges,text(1:72)\n i2=73\n do while(i2.lt.ip)\n write(lut,699)trim(text(i2:i2+71))\n i2=i2+72\n enddo\n else\n write(lut,698)paratyp,ctpf(i1)%nranges,trim(text)\n endif\n!698 format(i4,i3,a)\n! According to Ted\n698 format(i2,i3,1x,a)\n699 format(a)\n do i2=1,ctpf(i1)%nranges\n if(ctpf(i1)%cfun%coefs(7,i2).eq.zero .and. &\n ctpf(i1)%cfun%coefs(8,i2).eq.zero .and. &\n ctpf(i1)%cfun%coefs(9,i2).eq.zero .and. &\n ctpf(i1)%cfun%coefs(10,i2).eq.zero .and. &\n ctpf(i1)%cfun%coefs(11,i2).eq.zero) then\n write(lut,700)ctpf(i1)%cfun%tbreaks(i2),&\n (factor*ctpf(i1)%cfun%coefs(i3,i2),i3=1,6)\n else\n! There are some special powers, write only non-zero coefficients\n! write(lut,705)ctpf(i1)%cfun%tbreaks(i2),&\n! (ctpf(i1)%cfun%coefs(i3,i2),i3=1,6),&\n! (ctpf(i1)%cfun%coefs(i3,i2),&\n! ctpf(i1)%cfun%tpows(i3,i2),i3=7,npows)\n write(lut,710)ctpf(i1)%cfun%tbreaks(i2),&\n (factor*ctpf(i1)%cfun%coefs(i3,i2),i3=1,6)\n mm=0\n! The 6 first powers are the default 0 1 100 2 3 -1\n! Possible extra powers are 7 -9 -2 unknown1 unknown2 \n! uknown can be -3, 4, 5, -8 (for sqrt(T),\n do kk=7,npows\n if(ctpf(i1)%cfun%coefs(kk,i2).ne.zero) mm=mm+1\n enddo\n! write(*,719)'3Z powers: ',npows,mm,&\n! (ctpf(i1)%cfun%coefs(i3,i2),ctpf(i1)%cfun%tpows(i3,i2),i3=7,npows)\n! UNFINISHED\n write(lut,730,advance='no')mm\n do kk=7,npows\n if(ctpf(i1)%cfun%coefs(kk,i2).ne.zero) then\n if(mm.eq.1) then\n if(ctpf(i1)%cfun%tpows(kk,i2).eq.-8) then\n! this is the square root of T\n write(lut,733)factor*ctpf(i1)%cfun%coefs(kk,i2)\n else\n write(lut,731)factor*ctpf(i1)%cfun%coefs(kk,i2),&\n ctpf(i1)%cfun%tpows(kk,i2)\n endif\n mm=mm-1\n elseif(mm.lt.0) then\n write(*,*)'3Z wrong number of coefficeints!!!'\n else\n if(ctpf(i1)%cfun%tpows(kk,i2).eq.-8) then\n! this is the square root of T\n write(lut,733)factor*ctpf(i1)%cfun%coefs(kk,i2)\n else\n write(lut,731,advance='no')&\n factor*ctpf(i1)%cfun%coefs(kk,i2),&\n ctpf(i1)%cfun%tpows(kk,i2)\n endif\n mm=mm-1\n endif\n endif\n enddo\n endif\n enddo\n! according to Ted\n700 format(1x,F11.4,6(1x,G15.8)/' 1 0.00000000 0.00')\n!705 format(1x,F11.4,6(1x,G15.8)/' 3 ',3(1x,G15.8,i3,'.00'))\n710 format(1x,F11.4,6(1x,G15.8))\n!719 format(a,2i3,4(1x,G10.2,1x,i3,'.00'))\n!721 format(1x,i3,4(1x,G15.8,1x,F5.2))\n730 format(i3)\n731 format(1x,G15.8,1x,i3,'.00') \n733 format(1x,G15.8,1x,' 0.50')\n!1000 continue\n return\n end subroutine list_tpascoef\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine tpf2c\n!\\begin{verbatim} %-\n subroutine tpf2c(ctpf,lfun,done)\n! convert TPfun lfun to an array of coefficients with powers of T\n! if this TP function already converted just return\n! if this TP function calls another TP function not converted return error\n!\n implicit none\n integer lfun\n logical done\n type(gtp_tpfun2dat) :: ctpf(*)\n!\\end{verbatim} %+\n integer i1,i2,i3,nrange,nc,funref\n type(tpfun_root), pointer :: tpfroot\n type(tpfun_expression), pointer :: tpfexpr\n! return if already converted\n! write(*,*)'3Z in tpf2c ',lfun,tpfuns(lfun)%noofranges\n if(ctpf(lfun)%nranges.ge.0) goto 1000\n! This function not converted, check if it reference an unconverted TPfunction\n tpfroot=>tpfuns(lfun)\n if(btest(tpfuns(lfun)%status,TPCONST)) then\n write(*,*)'3Z this function is a constant, have to think about',lfun\n stop 18\n endif\n nrange=tpfroot%noofranges\n do i1=1,nrange\n tpfexpr=>tpfroot%funlinks(i1)\n nc=tpfexpr%noofcoeffs\n! skip the first two predefined functions, R and RTLNP\n do i2=1,nc\n funref=tpfexpr%link(i2)\n if(funref.eq.1) then\n! this is a constant R, multiply the coefficient with 8.31451 and set link=0\n! write(*,*)'3Z Replacing R with its value in function ',lfun\n tpfexpr%coeffs(i2)=8.31451*tpfexpr%coeffs(i2)\n tpfexpr%link(i2)=0\n elseif(funref.eq.2) then\n! write(*,*)'3Z Deleting use of RTLNP for gas in function ',lfun\n tpfexpr%link(i2)=0\n tpfexpr%coeffs(i2)=zero\n elseif(funref.gt.0) then\n if(ctpf(funref)%nranges.lt.0) then\n! this function has a reference to an unconverted TPfunction\n! write(*,*)'3Z TPfun ',lfun,' reference ',funref,&\n! ctpf(funref)%nranges\n done=.false.\n! write(*,*)'Skipping for the moment ',lfun,funref\n goto 1000\n endif\n endif\n enddo\n enddo\n! convert the TPfun \"lfun\" to coefficents and powers\n call tpf2cx(ctpf,lfun,nrange,ctpf(lfun)%cfun)\n! write(*,*)'3Z tp2c: ',tpfuns(lfun)%symbol,nrange\n! call tpwrite('z2',lfun,nrange,ctpf(lfun)%cfun)\n! do i1=1,nrange\n! write(*,200)(ctpf(lfun)%cfun%coefs(i2,i1),i2=1,6)\n! enddo\n!200 format(10F12.3)\n1000 continue\n return\n end subroutine tpf2c\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n! each term has a coefficent and an array of integers\n! tpow is power of T\n! ppow is power of P\n! wpow is power of linked symbol, the link is in link\n! plevel is level of parenthesis ??\n! link is link to another function if >0 or a unary function if <0\n! accept only -2 which is taken as LN(T)\n!\\addtotable subroutine tpf2cx\n!\\begin{verbatim} %-\n subroutine tpf2cx(ctpf,lfun,nrange,cfun1)\n! convert TPfun lfun to an array of coefficients with powers of T\n! if this TP function already converted just return\n! if this TP function calls another TP function not converted return error\n implicit none\n integer lfun,nrange\n type(gtp_tpfun_as_coeff) :: cfun1\n type(gtp_tpfun2dat) :: ctpf(*)\n! type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! max no of coefficent, max no of ranges ...\n integer, parameter :: maxnc=15,maxnr=20\n integer i1a,i1b,i2,i3,i4,nc1,funref,iadd,nrangeb,ncc,caddnr(maxnr),nrr,jadd\n integer caddid(maxnr),krange,klink\n type(tpfun_root), pointer :: tpfroot\n type(tpfun_expression), pointer :: tpfexpr\n type(gtp_tpfun_as_coeff), dimension(:), allocatable :: cadd\n double precision ccc\n logical skipnext,isqrt\n integer noofcadd,fsqrt\n!----------\n! TYPE gtp_tpfun_as_coeff\n! record for a TPFUN converted to coefficents without any references to other\n! functions. Note ranges may change when adding functions!!\n! double precision, dimension(:), allocatable :: tbreaks\n! double precision, dimension(:,:), allocatable :: coefs\n! integer, dimension(:,:), allocatable :: tpows\n! end type gtp_tpfun_as_coeff\n!----------\n! Now convert !!\n! allocate a record for all ranges and coefficients\n iadd=0\n tpfroot=>tpfuns(lfun)\n if(nrange.gt.maxnr) then\n write(*,*)'3Z too many T ranges!',nrange\n stop 13\n endif\n! write(*,*)'3Z converting ',lfun\n! allocate and zero cfun1 data\n allocate(cfun1%tbreaks(maxnr))\n allocate(cfun1%coefs(maxnc,maxnr))\n allocate(cfun1%tpows(maxnc,maxnr))\n cfun1%tbreaks=zero\n cfun1%coefs=zero\n cfun1%tpows=-100\n! T ranges, low T limit ignored. NOTE the number of ranges may change!\n do i1a=2,nrange\n cfun1%tbreaks(i1a-1)=tpfroot%limits(i1a)\n enddo\n cfun1%tbreaks(nrange)=tpfroot%hightlimit\n nrangeb=nrange\n! write(*,2)tpfuns(lfun)%symbol\n!2 format(/'Entering tpf2cx ---------------------------------: ',a)\n! functions\n! NOTE nrange may change below if referenced functions have a smaller range\n! not so good to have a loop ...\n! i1a is range index for original TPfun\n! i1b is range index for TPfun converted to coefficients as referenced\n! functions may have shorter range\n! do i1b=1,nrange\n! tpfexpr=>tpfroot%funlinks(i1b)\n! nc1=tpfexpr%noofcoeffs\n! do i1a=1,nc1\n! write(*,30)i1a,tpfexpr%coeffs(i1a),tpfexpr%tpow(i1a),&\n! tpfexpr%ppow(i1a),tpfexpr%wpow(i1a),tpfexpr%plevel(i1a),&\n! tpfexpr%link(i1a)\n! enddo\n! enddo\n!30 format('3Z term: ',i3,1pe12.4,5i7)\n i1a=0\n i1b=0\n jadd=0\n noofcadd=0\n krange=1\n isqrt=.false.\n100 continue\n i1a=i1a+1\n i1b=i1b+1\n if(i1a.gt.nrange) goto 700\n jadd=jadd+i1a\n tpfexpr=>tpfroot%funlinks(i1a)\n nc1=tpfexpr%noofcoeffs\n if(ctpf(1)%debug.ne.0) &\n write(*,107)'TPfun ranges: ',tpfuns(lfun)%symbol,i1a,i1b,nrangeb,jadd\n107 format(a,a,5i4)\n skipnext=.false.\n! maybe needed? YES!\n iadd=0\n trange: do i2=1,nc1\n cfun1%coefs(i2,i1b)=tpfexpr%coeffs(i2)\n cfun1%tpows(i2,i1b)=tpfexpr%tpow(i2)\n! assume link to unary LN function just means LN(T)\n funref=tpfexpr%link(i2)\n! write(*,113)'3Z cc: ',i1a,i1b,i2,funref,&\n! cfun1%coefs(i2,i1b),cfun1%tpows(i2,i1b)\n!113 format(a,4i4,E20.8,i5)\n if(skipnext) then\n! skip this term as it should just contain the ln(T)\n if(tpfexpr%plevel(i2).ne.1 .or. tpfexpr%link(i2).ne.0 &\n .or. tpfexpr%tpow(i2).ne.1) then\n! write(*,*)'3Z WARNING check if TPFUN error in: ',&\n! trim(tpfroot%symbol),lfun\n! gx%bmperr=4393; goto 1000\n endif\n cfun1%coefs(i2,i1b)=zero\n cfun1%tpows(i2,i1b)=-100\n skipnext=.false.\n if(isqrt) then\n! fixing a bug for T**2 as EXP(0.5*LN(T))\n isqrt=.false.\n cycle trange\n endif\n endif\n funrefif: if(funref.lt.0) then\n! this is assumed to be a link to LN(T) or SQRT\n if(funref.eq.-3) then\n! this is to handle sqrt(t) which in a TDB file is EXP(0.5LN(T))\n! check that link to function is SQRT\n fsqrt=tpfexpr%link(i2+1)\n! write(*,114)'Found SQRTT?: ',lfun,tpfuns(lfun)%symbol,&\n! fsqrt,tpfuns(fsqrt)%symbol\n!114 format(a,i5,2x,a,i5,2x,a)\n! set T power to -8; this will be converted to 0.5 when writing !!!\n cfun1%tpows(i2,i1b)=-8\n! write(*,*)'3Z sqrt coeff: ',cfun1%coefs(i2,i1b)\n isqrt=.true.\n skipnext=.true.\n elseif(funref.ne.-2) then\n! this is an unknown type of funref link (-2 means LN(T))\n write(*,*)'3Z TPFUN with other unary function than LN(T): ',&\n trim(tpfroot%symbol),lfun,funref\n gx%bmperr=4393; goto 1000\n elseif(tpfexpr%tpow(i2).eq.1) then\n! NOTE not elseif(funref ... just extract the power of T, could be 0?\n! Tln(T) will have tpows = 100, we skip the next term with the T\n cfun1%tpows(i2,i1b)=tpfexpr%tpow(i2)+99\n skipnext=.true.\n! else\n! This could be a LN(T) term?\n! write(*,'(a,a,5i5)')'3Z TPFUN with just LN(T)? ',&\n! trim(tpfroot%symbol),lfun,i2,funref,tpfexpr%tpow(i2)\n! gx%bmperr=4393; goto 1000\n endif\n elseif(funref.gt.0) then\n funrefranges: if(ctpf(funref)%nranges.gt.0) then\n! this range has a reference to a converted TPfunction,\n! store this separately, possibly multiplied with coefficent and T powers\n! and link all such functions to be added using cfun1%nextcrec\n! examples: +22*GHSERCR, ff*exp(qq*irt) ... the latter will not work ...\n ccc=tpfexpr%coeffs(i2)\n! write(*,32)'3Z link from: ',tpfuns(lfun)%symbol,&\n! i2,funref,ccc,trim(tpfuns(funref)%symbol)\n!32 format(a,a,2i4,F6.2,' to ',a)\n! write(*,333)'3Z term, link, factor: ',i2,funref,ccc,&\n! IMPORTRANT funref is also index in tpfuns!!!\n! trim(tpfroot%symbol),trim(tpfuns(funref)%symbol),&\n! ctpf(funref)%nranges,&\n! tpfuns(funref)%noofranges,size(tpfuns(funref)%limits)\n!333 format(a,2i4,1pe11.2,2x,a,2x,a,5i5)\n! only allow a constant coefficent, no T or P powers, no unary function ...\n if(tpfexpr%tpow(i2).ne.0 .or. tpfexpr%ppow(i2).ne.0 .or. &\n tpfexpr%wpow(i2).ne.0 .and. &\n (tpfexpr%plevel(i2).ne.0 .or. tpfexpr%plevel(i2).ne.1)) then\n! Above the function SQRT which has tpfexpr%plevel(i2)=1 is accepted ...\n if(tpfuns(funref)%noofranges.eq.1) then\n! Now check if funref is just a constant, then multiply ccc with that!\n! write(*,334)'3Z trying to handle MEV factor ... ',&\n! trim(tpfuns(funref)%symbol),&\n! tpfuns(funref)%funlinks(1)%noofcoeffs,&\n! tpfuns(funref)%funlinks(1)%coeffs(1)\n!334 format(a,a,i2,1pe11.2)\n! WOW wpow-1000 is link to another function!\n klink=tpfexpr%wpow(i2)-1000\n if(tpfuns(funref)%funlinks(1)%noofcoeffs.eq.1 .and.&\n tpfuns(klink)%funlinks(1)%noofcoeffs.eq.1) then\n ccc=ccc*tpfuns(funref)%funlinks(1)%coeffs(1)*&\n tpfuns(klink)%funlinks(1)%coeffs(1)\n! write(*,335)'3Z Wow! ',trim(tpfuns(funref)%symbol),&\n! trim(tpfuns(lfun)%symbol),i2,nc1,ccc,&\n! tpfuns(funref)%funlinks(1)%coeffs(1),&\n! klink,trim(tpfuns(klink)%symbol),&\n! tpfuns(klink)%funlinks(1)%coeffs(1)\n!335 format(a,2x,a,2x,a,2i3,2(1pe12.4),i3,2x,a,1pe12.4)\n! cfun1%coefs(i2,i1b)=ccc\n cfun1%coefs(i2,i1b)=ccc\n exit funrefif\n endif\n endif\n! else give up\n write(*,116)'3Z Too complicated function: ',&\n trim(tpfroot%symbol),tpfexpr%tpow(i2),&\n tpfexpr%ppow(i2),tpfexpr%wpow(i2),tpfexpr%plevel(i2),&\n funref,trim(tpfuns(funref)%symbol)\n116 format(a,a,5i5,2x,a)\n gx%bmperr=4399; goto 1000\n endif\n! this term should be ignored as it replaced by the function\n cfun1%coefs(i2,i1b)=zero\n cfun1%tpows(i2,i1b)=-100\n! we must create a new coefficient array with the funref coefficents\n! multiplied with the current coef within the current T-range\n! It may be necessary to increase the number of T-ranges\n if(.not.allocated(cadd)) then\n! we have more than 6 functions added in soma cases ...\n allocate(cadd(10))\n noofcadd=noofcadd+1\n! write(*,*)'Allocating cadd ',i2,noofcadd\n! ?? iadd=0\n caddnr=0\n endif\n! call a new function to add the coefficents of funref\n iadd=iadd+1\n if(iadd.gt.7) then\n write(*,*)'3Z many added functions in: ',&\n trim(tpfuns(lfun)%symbol),': ',iadd,funref\n endif\n cadd(iadd)=ctpf(funref)%cfun\n caddnr(iadd)=ctpf(funref)%nranges\n caddid(iadd)=funref\n! write(*,800)'3Z aa: ',funref,iadd,(cadd(iadd)%coefs(i3,1),&\n! cadd(iadd)%tpows(i3,1),i3=1,3)\n! multiply all terms in funref with the coefficient of this term\n! within the current T-range \n! It may be necessary to increase the T-ranges of ctpf\n! write(*,*)'3Z addranges: ',ctpf(funref)%nranges,ccc\n do i3=1,maxnc\n do i4=1,ctpf(funref)%nranges\n cadd(iadd)%coefs(i3,i4)=ccc*cadd(iadd)%coefs(i3,i4)\n enddo\n enddo\n! write(*,800)'3Z bb: ',funref,iadd,(cadd(iadd)%coefs(i3,1),&\n! cadd(iadd)%tpows(i3,1),i3=1,3)\n else\n! what about funref with no ranges?\n write(*,*)'3Z funref has no ranges? ',&\n trim(tpfuns(funref)%symbol),ctpf(funref)%nranges\n gx%bmperr=4399; goto 1000\n endif funrefranges\n! else\n! when funref=0 it is OK to do nothing !!\n endif funrefif\n!800 format(a,2i3,3(1pe12.4,i5))\n! we have gone through all terms for the TPfun for this range\n enddo trange\n! Check if there were function links in this range\n if(iadd.gt.0) then\n! If iadd>1 we must first add together all the different functions referenced\n! and possibly split the T range if these function have a different ranges\n \n ncc=3\n! write(*,*)'3Z adjusting ranges?',iadd\n! This loop only if there are two or more function references within a range\n do i3=iadd,2,-1\n nrr=caddnr(i3)\n! write(*,16)'3Z there are coefficients to add!!',i3,iadd,nrr\n16 format(a,6i4)\n! add terms and adjust all ranges in cadd(i3-1)\n call adjustranges(nrr,cadd(i3-1),caddnr(i3),cadd(i3),&\n ctpf(1)%debug, ctpf(lfun)%name)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error occured adding: ',caddid(i3-1),caddid(i3)\n goto 1000\n endif\n! note nrr may be updatad\n caddnr(i3-1)=nrr\n! we may have more functions to add ...\n enddo\n if(ctpf(lfun)%debug.ne.0) call tpwrite('++',0,caddnr(1),cadd(1))\n! we have now added all links, now add the sum of all cadd to cfun1 range i1a\n! adjust1ranges creates breakpoints only in the current range, i1a, of cfun1\n! and adds the coefficients from cadd(1) to this\n! write(*,*)'3Z calling adjust1: ',i1a,jadd,i1b,nrangeb\n if(ctpf(lfun)%debug.ne.0) then\n call tpwrite('>1',lfun,nrangeb,ctpf(lfun)%cfun)\n call tpwrite('>2',0,caddnr(1),cadd(1))\n endif\n call adjust_1range(lfun,jadd,nrangeb,krange,cfun1,caddnr(1),cadd(1),&\n ctpf(lfun)%debug)\n krange=krange+1\n! krange can have chnaged more then one ... make sure krange set correct\n! if additional ranges needed nrangeb changed \n! increment i1b but not i1a and nrange\n! why -1 ??\n jadd=nrangeb-i1a-1\n i1b=i1b+nrangeb-2\n if(ctpf(lfun)%debug.ne.0) then\n write(*,*)'3Z after adjust1x: ',i1a,jadd,i1b,nrangeb\n call tpwrite('<<',lfun,nrangeb,ctpf(lfun)%cfun)\n endif\n! write(*,*)'deallocating cadd'\n deallocate(cadd)\n endif\n goto 100\n! we have gone through all ranges\n700 continue\n! write(*,*)'3Z 700: ',i1a,nrange,nrangeb\n ctpf(lfun)%nranges=nrangeb\n! write(*,*)'3Z converted function with ranges: ',lfun,nrangeb\n! Listing the final function\n! call tpwrite('z1',lfun,nrange,ctpf(lfun)%cfun)\n1000 continue\n return\n end subroutine tpf2cx\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine tpwrite(c2,lfun,nrange,cfun)\n! temporary debug output\n! ************************* ATTENTION\n! IF I DO NOT CALL THIS THERE ARE BUGS !!\n IMPLICIT none\n integer nrange,lfun\n character c2*2\n type(gtp_tpfun_as_coeff) :: cfun\n! \n integer i1,i2\n do i1=1,nrange\n write(*,800)c2,lfun,i1,nrange,cfun%tbreaks(i1),&\n (cfun%coefs(i2,i1),cfun%tpows(i2,i1),i2=1,10)\n enddo\n800 format('3Z ',a,': ',i3,2i2,F9.2,3(1pe13.5,i5)/&\n (23x,e13.5,i5,e13.5,i5,e13.5,i5))\n write(*,*)'3Z end of function -----------------'\n return\n end subroutine tpwrite\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine tpmult(lfun,mfun,ccc,ctpf)\n! multiples all terms in cfpf(lfun) with the factor ccc and returns that\n! in ctpf(mfun)\n! cfun is not changed\n implicit none\n integer lfun,mfun\n double precision ccc\n type(gtp_tpfun2dat) :: ctpf(*)\n! type(gtp_tpfun_as_coeff) :: cfun\n! \n integer, parameter :: maxnc=15,maxnr=20\n integer i1,i2\n ctpf(mfun)%nranges=ctpf(lfun)%nranges\n if(.not.allocated(ctpf(mfun)%cfun%tbreaks)) then\n! write(*,*)'3Z allocating mfun'\n allocate(ctpf(mfun)%cfun%tbreaks(maxnr))\n allocate(ctpf(mfun)%cfun%coefs(maxnc,maxnr))\n allocate(ctpf(mfun)%cfun%tpows(maxnc,maxnr))\n endif\n ctpf(mfun)%cfun%tbreaks=zero\n ctpf(mfun)%cfun%coefs=zero\n ctpf(mfun)%cfun%tpows=0\n do i1=1,ctpf(mfun)%nranges\n ctpf(mfun)%cfun%tbreaks(i1)=ctpf(lfun)%cfun%tbreaks(i1)\n do i2=1,maxnc\n ctpf(mfun)%cfun%coefs(i2,i1)=ccc*ctpf(lfun)%cfun%coefs(i2,i1)\n ctpf(mfun)%cfun%tpows(i2,i1)=ctpf(lfun)%cfun%tpows(i2,i1)\n enddo\n enddo\n return\n end subroutine tpmult\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine adjust_1range\n!\\begin{verbatim} %-\n subroutine adjust_1range(lfun,nr1,nrange,krange,ctp1,nr2,ctp2,debug)\n! check if ctp1 range nr1 must be split in more ranges due to tbreaks in ctp2\n! nrange is the total number of ranges of ctp1\n! There are 10 ranges allocated for all, nr1 and nr2 are the used ranges\n implicit none\n integer lfun,nr1,nr2,krange,nrange,debug\n type(gtp_tpfun_as_coeff) :: ctp1,ctp2\n!\\end{verbatim} %+\n! TYPE gtp_tpfun_as_coeff\n! record for a TPFUN converted to coefficents without references to other funs\n! Note ranges may increase when adding functions!!\n! double precision, dimension(:), allocatable :: tbreaks\n! double precision, dimension(:,:), allocatable :: coefs\n! integer, dimension(:,:), allocatable :: tpows\n! end type gtp_tpfun_as_coeff\n double precision, parameter :: tenth=1.0D-1\n integer, parameter :: maxnc=15\n integer i1,i2,i3,k1,nr3,nr0,j2,j3,mrange,kk,kpow\n double precision tlow1,thigh1,tlow2,thigh2,tmax\n logical nosplit\n type(gtp_tpfun_as_coeff) :: ctp3\n!\n nr0=nr1\n if(debug.ne.0) then\n write(*,4)'3Z in adjust_1range 1: ',nr1,(ctp1%tbreaks(j2),j2=1,nr1)\n write(*,4)'3Z in adjust_1range 2: ',nr2,(ctp2%tbreaks(j2),j2=1,nr2)\n4 format(a,i3,10(F10.2))\n endif\n! check highest T ............ unchanged ?? below\n tmax=ctp1%tbreaks(1)\n do i1=2,nr1\n if(ctp1%tbreaks(i1).gt.tmax) tmax=ctp1%tbreaks(i1)\n enddo\n i2=nr2\n do i1=nr2,1,-1\n if(ctp2%tbreaks(i1).gt.tmax) then\n! reduce the number of ranges\n i2=i2-1\n endif\n enddo\n nr2=i2\n if(nr2.lt.1) then\n! high limit of ctp1 is lower than first breakpoint in ctp2\n nr2=1\n ctp2%tbreaks(nr2)=tmax\n endif\n tmax=ctp2%tbreaks(nr2)\n ctp1%tbreaks(nr1)=tmax\n if(debug.ne.0) write(*,'(a,2i3,F8.2)')'3Z coeffs and tmax: ',nr1,nr2,tmax\n if(nr1.eq.1) then\n tlow1=298.15\n thigh1=ctp1%tbreaks(nr1)\n j2=1\n else\n tlow1=ctp1%tbreaks(nr1-1)\n thigh1=ctp1%tbreaks(nr1)\n j2=nr1-1\n endif\n! \n if(debug.ne.0) write(*,7)'adjust_1range 3: ',nrange,nr1,nr2,j2,&\n ctp1%tbreaks(nr1),ctp2%tbreaks(nr2)\n7 format(a,4i4,2F10.2)\n allocate(ctp3%tbreaks(1))\n allocate(ctp3%coefs(maxnc,1))\n allocate(ctp3%tpows(maxnc,1))\n ctp3%tbreaks=zero\n nosplit=.true.\n! search ctp2 for tbreaks in the range tlow1 to thigh1\n i2=1\n! mrange=nrange-1\n if(debug.ne.0) write(*,16)'In adjust_1range 4: ',nr1,i2,krange,&\n tlow1,thigh1,ctp2%tbreaks(i2)\n16 format(/a,3i3,3F10.2)\n!100 continue\n split: do while(i2.lt.nr2)\n! fine-tuning needed when breakpoints identical in parameter and GHSERxx\n! write(*,*)'3Z in do while: ',i2,nr2,ctp2%tbreaks(i2),tlow1\n if(ctp2%tbreaks(i2)-tlow1.gt.tenth) then\n! write(*,16)'3Z check breakpoint ',nrange,i2,krange,&\n! ctp2%tbreaks(i2),thigh1\n! fine-tuning needed when breakpoints identical in parameter and GHSERxx\n if(abs(ctp2%tbreaks(i2)-thigh1).lt.tenth) then\n! breakpoints are identical\n mrange=nrange-1\n! write(*,*)'Identical breakpoints',ctp2%tbreaks(i2),thigh1\n goto 800\n elseif(ctp2%tbreaks(i2)-thigh1.lt.-tenth) then\n! fine-tuning needed when breakpoints identical in parameter and GHSERxx\n! there is a breakpoint in ctp2 between tlow1 and thigh1\n! we must add one range above nr1, shift the coefficients in higher ranges up \n if(debug.ne.0) then\n write(*,16)'3Z inserted new breakpoint ',&\n nrange,j2,0,ctp2%tbreaks(i2),thigh1\n call tpwrite('--',0,nrange,ctp1)\n endif\n do k1=nrange,j2,-1\n ctp1%tbreaks(k1+1)=ctp1%tbreaks(k1)\n do i3=1,maxnc\n! copy the coefficients to the new range\n ctp1%coefs(i3,k1+1)=ctp1%coefs(i3,k1)\n ctp1%tpows(i3,k1+1)=ctp1%tpows(i3,k1)\n enddo\n enddo\n! added coefficients to new range\n if(debug.ne.0) call tpwrite('-+',0,nrange,ctp1)\n nrange=nrange+1\n if(debug.ne.0) call tpwrite('up',0,nrange,ctp1)\n! now add coeffs from ctp1 range k1 and ctp2 in range i2 to ctp3 range 1\n! then replace range k1 in ctp1 by range 1 of ctp3\n ctp3%tpows=-100\n ctp3%coefs=zero\n! the range in ctp1 that should be added to is j2+1 ??\n! j2=j2+1\n if(debug.ne.0) then\n write(*,'(a,4i3,5F10.2)')'3Z add7: ',nr1,i2,nrange,j2,&\n (ctp1%tbreaks(j3),j3=1,nr1)\n call tpwrite('v1',0,nrange,ctp1)\n write(*,'(a,4i3,5F10.2)')'3Z add7: ',nr1,i2,nrange,j2,&\n (ctp1%tbreaks(j3),j3=1,nr1)\n call tpwrite('v2',0,nr2,ctp2)\n endif\n call add1tpcoeffs(j2,ctp1,i2,ctp2,1,ctp3)\n! call tpwrite('v3',0,1,ctp3)\n do j3=1,maxnc\n ctp1%coefs(j3,j2)=ctp3%coefs(j3,1)\n ctp1%tpows(j3,j2)=ctp3%tpows(j3,1)\n enddo\n! NEW: added a range to ctp1 !!!\n krange=krange+1\n tlow1=min(ctp2%tbreaks(i2),thigh1)\n ctp1%tbreaks(j2)=tlow1\n! call tpwrite('q1',0,nrange,ctp1)\n! we have added one range to ctp1\n nosplit=.false.\n! nrange=nrange+1\n if(debug.ne.0) write(*,*)'adjust_1range 6:',&\n nrange,j2,ctp1%tbreaks(j2)\n else\n mrange=nrange-1\n goto 800\n endif\n else\n continue\n if(debug.ne.0) write(*,731)'adjust_1range 7:',&\n i2,nr2,ctp2%tbreaks(i2),tlow1\n731 format(a,2i3,2F10.2)\n endif\n i2=i2+1\n j2=j2+1\n enddo split\n! flyttat till efter label 800\n!799 continue\n mrange=nrange\n800 continue\n! write(*,*)'Why??',nrange,mrange,nr1,nr2,nosplit\n if(debug.ne.0) call tpwrite('w0',0,nrange,ctp1)\n! just add the terms (for the last range)\n! ctp3%tpows=-100\n! ctp3%coefs=zero\n if(nosplit) then\n! we have not split the range, store cp3 in range nr1\n mrange=nr1\n endif\n! write(*,900)'3Z add8: ',nrange,i2,mrange,krange,&\n! ctp1%tbreaks(nrange),ctp2%tbreaks(i2)\n!900 format(/a,4i3,2F10.2)\n! these output w1..c4 are important for debugging\n if(debug.ne.0) then\n call tpwrite('w1',0,nrange,ctp1)\n call tpwrite('w2',0,nr2,ctp2)\n endif\n! call add1tpcoeffs(mrange,ctp1,i2,ctp2,1,ctp3)\n call add1tpcoeffs(nrange,ctp1,i2,ctp2,1,ctp3)\n if(debug.ne.0) call tpwrite('w3',0,1,ctp3)\n! skipping this loop\n if(krange.ne.nrange) then\n write(*,*)'3Z *** Check function: ',tpfuns(lfun)%symbol,nrange,krange\n! call tpwrite('w3',0,1,ctp3)\n endif\n! We need to know which range in ctp1 we should store ctp3 .... krange!!\n! to handle problems with G(LIQ,U+4:O-2) parameter\n do j3=1,maxnc\n ctp1%coefs(j3,krange)=ctp3%coefs(j3,1)\n ctp1%tpows(j3,krange)=ctp3%tpows(j3,1)\n enddo\n990 continue\n if(debug.ne.0) call tpwrite('w4',0,nrange,ctp1)\n!1000 continue\n! if(nr3.gt.nr0) then\n! write(*,*)'3Z inserted ',nrange-nr0,' ranges'\n! endif\n return\n end subroutine adjust_1range\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine adjustranges\n!\\begin{verbatim} %-\n subroutine adjustranges(nr1,ctp1,nr2,ctp2,debug,funame)\n! add ctp2 to ctp1 which to have the same ranges and breakpoints\n! nr1 and nr2 give the number of T-ranges and breakpoints\n! add coefficients of ctp1 and ctp2 for each range\n! NOTE these already multiplied with the coefficents!!\n! There are 10 coefficients allocated for all functions.\n! the added function is returned as ctp1\n implicit none\n integer nr1,nr2,debug\n type(gtp_tpfun_as_coeff) :: ctp1,ctp2\n character funame*(*)\n!\\end{verbatim} %+\n! TYPE gtp_tpfun_as_coeff\n! record for a TPFUN converted to coefficents without references to other funs\n! Note ranges may increase when adding functions!!\n! double precision, dimension(:), allocatable :: tbreaks\n! double precision, dimension(:,:), allocatable :: coefs\n! integer, dimension(:,:), allocatable :: tpows\n! end type gtp_tpfun_as_coeff\n! Max number of coefficients is maxnc, ranges is maxnr\n! Previously I have used a maximum of 11 for any specific function ... \n! I am not sure I can just allocate bigger .... but I will try\n integer, parameter :: maxnc=15,maxnr=20\n double precision, parameter :: tenth=1.0D-1\n integer i1,i2,i3,k1,k2,nr3\n double precision tmax,tbreak,tlimit,tlim1,tlim2\n type(gtp_tpfun_as_coeff) :: ctp3\n!\n if(debug.ne.0) then\n write(*,4)'3Z adjustranges 1: ',nr1,(ctp1%tbreaks(i1),i1=1,nr1)\n write(*,4)'3Z adjustranges 2: ',nr2,(ctp2%tbreaks(i1),i1=1,nr2)\n4 format(a,i2,10(F8.2))\n endif\n tmax=max(ctp1%tbreaks(nr1),ctp2%tbreaks(nr2))\n tbreak=tmax\n! tlimit can set a new tmax if some function has lower limit\n tlimit=min(ctp1%tbreaks(nr1),ctp2%tbreaks(nr2))\n! write(*,*)'3Z tmax: ',tmax\n i1=1\n i2=1\n i3=0\n allocate(ctp3%tbreaks(maxnr))\n allocate(ctp3%coefs(maxnc,maxnr))\n allocate(ctp3%tpows(maxnc,maxnr))\n ctp3%tpows=-100\n!----------------------------------------------------------------\n! write(*,79)'3Z adding and adjusting ranges: ',nr1,nr2,tlimit,tmax\n79 format(a,2i2,2F9.2)\n tlim1=ctp1%tbreaks(i1)\n tlim2=ctp2%tbreaks(i2)\n! LOOP HERE\n100 continue\n! sometimes the normal loop exit does not work correcrly ....\n if(tlim1.le.zero) goto 200\n i3=i3+1\n if(i3.gt.maxnr) then\n write(*,*)'3Z too many ranges is summation function',i3\n call tpwrite('!!',0,i3,ctp3)\n gx%bmperr=4391; goto 1000\n endif\n! new T-range\n ctp3%tbreaks(i3)=min(tlim1,tlim2)\n call add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3)\n if(gx%bmperr.ne.0) goto 1000\n if(debug.ne.0) then\n write(*,170)'3Z calling add1tp: ',i1,i2,i3,nr1,nr2,&\n ctp1%tbreaks(i1),ctp2%tbreaks(i2),ctp3%tbreaks(i3)\n170 format(a,5i5,3F10.2)\n call tpwrite('b1',0,i3,ctp3)\n endif\n if(abs(tlim1-tlim2).lt.one) then\n! Problem here with the SGTE inary breakpoint at liquidus\n! if the parameter has same breakpoints as the GHSER function\n if(tlim1.le.zero .or. tlim2.le.zero) then\n write(*,171)trim(funame)\n171 format('3Z **** Warning T limits out of range for: ',a)\n goto 200\n endif\n! write(*,180)'3Z same breakpoint',i1,i2,tlim1,tlim2\n180 format(a,2i3,2F10.2)\n ctp3%tbreaks(i3)=tlim1\n if(tlim1.ge.6.0D3) goto 200\n if(i1.lt.nr1) then\n i1=i1+1\n tlim1=ctp1%tbreaks(i1)\n else\n tlim1=5.9D3\n endif\n if(i2.lt.nr2) then\n i2=i2+1\n tlim2=ctp2%tbreaks(i2)\n else\n tlim2=5.8D3\n endif\n goto 100\n endif\n! bugfix around here 2021.10.15/BoS modified 2021.11.07\n if(i1.eq.nr1) then\n! no more ranges for ctp1\n if(i2.eq.nr2) then\n! no more ranges for ctp2 either, but there can a last range\n if(abs(tlim1-tlim2).gt.one) then\n i3=i3+1\n ctp3%tbreaks(i3)=max(tlim1,tlim2)\n call add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3)\n if(gx%bmperr.ne.0) goto 1000\n if(debug.ne.0) then\n write(*,170)'3Z calling add1tp: ',i1,i2,i3,nr1,nr2,&\n ctp1%tbreaks(i1),ctp2%tbreaks(i2),ctp3%tbreaks(i3)\n call tpwrite('b1',0,i3,ctp3)\n endif\n endif\n goto 200\n else\n! more ranges for ctp2, increment i2, set tlim1 same as tlim2\n i2=i2+1; tlim2=ctp2%tbreaks(i2); tlim1=tlim2; goto 100\n endif\n elseif(i2.eq.nr2) then\n! no more ranges for cp2 but there are more ranges for cpt1\n i1=i1+1; tlim1=ctp1%tbreaks(i1); tlim2=tlim1; goto 100\n elseif(tlim1.lt.tlim2) then\n! increment the function with lowest tlim, the other tlim same\n i1=i1+1; tlim1=ctp1%tbreaks(i1); goto 100\n else\n i2=i2+1; tlim2=ctp2%tbreaks(i2); goto 100\n endif\n!========================================================\n200 continue\n if(i3.le.0) then\n! evidently i3 can be less than 1 here ....\n write(*,209)'3Z T-range adjustment: ',i3,tmax,tlimit,ctp3%tbreaks(1)\n209 format(a,i3,5F10.2)\n i3=1\n endif\n tbreak=ctp3%tbreaks(i3)\n tlimit=tbreak\n! write(*,210)'3Z created ctp3 range: ',i3,ctp3%tbreaks(i3),tmax,tlimit\n210 format(a,i3,3F9.2)\n! How to know when we finished??\n! if(abs(ctp3%tbreaks(i3)-tmax).gt.tenth) goto 100\n!-------------------------------------------------------------\n if(debug.ne.0) then\n call tpwrite('!!',0,i3,ctp3)\n endif\n ctp1=ctp3\n nr1=i3\n! call tpwrite('hh',0,nr1,ctp1)\n! I assume the arrays allocated for ctp3 will be deallocated automatically\n1000 continue\n return\n end subroutine adjustranges\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine add1tpcoeffs\n!\\begin{verbatim} %-\n subroutine add1tpcoeffs(i1,ctp1,i2,ctp2,i3,ctp3)\n! ctp3 is created with added coefficents from range i1 in ctp1 \n! and range i2 in cp2 with same tpower. Normally i3=1\n implicit none\n integer i1,i2,i3\n type(gtp_tpfun_as_coeff) :: ctp1,ctp2,ctp3\n!\\end{verbatim} %+\n integer, parameter :: maxnc=15\n integer j1,j2,j3,k1\n! first copy ctp1 to ctp3. Then add ctp3 coefficients with same powers\n! write(*,16)'3Z add1tp1: ',i1,i2,i3,ctp1%coefs(1,i1),ctp2%coefs(1,i2)\n!16 format(a,3i3,2(1pe14.6))\n! write(*,17)(ctp1%tpows(j3,i1),j3=1,maxnc)\n! write(*,17)(ctp2%tpows(j3,i2),j3=1,maxnc)\n! write(*,17)(ctp3%tpows(j3,i3),j3=1,maxnc)\n!17 format('3Z tpows: ',10i5)\n j3=0\n! call tpwrite('x0',0,i1,ctp1)\n do j1=1,maxnc\n! if(ctp1%tpows(j1,i1).gt.-100) then\n j3=j3+1\n ctp3%coefs(j3,i3)=ctp1%coefs(j1,i1)\n ctp3%tpows(j3,i3)=ctp1%tpows(j1,i1)\n! endif\n enddo\n! call tpwrite('x1',0,1,ctp3)\n! call tpwrite('x2',0,i2,ctp2)\n! write(*,*)'3Z no terms in ctp1?',j3\n f2: do j2=1,maxnc\n if(ctp2%tpows(j2,i2).gt.-100) then\n do j1=1,maxnc\n if(ctp2%tpows(j2,i2).eq.ctp3%tpows(j1,i3)) then\n ctp3%coefs(j1,i3)=ctp3%coefs(j1,i3)+ctp2%coefs(j2,i2)\n cycle f2\n endif\n enddo\n! there is a t-power in ctp2 not already present in ctp3\n! write(*,*)'3Z have we managed to add?',j2,j3\n newpower: do j3=1,maxnc\n if(ctp3%tpows(j3,i3).le.-100) then\n! write(*,*)'3Z now we insert!',j3,ctp2%tpows(j2,i2),&\n! ctp2%coefs(j2,i2)\n ctp3%coefs(j3,i3)=ctp2%coefs(j2,i2)\n ctp3%tpows(j3,i3)=ctp2%tpows(j2,i2)\n exit newpower \n endif\n enddo newpower\n endif\n enddo f2\n! call tpwrite('x3',0,1,ctp3)\n! that is all??\n! write(*,16)'3Z add1tp7: ',i1,i2,i3,ctp3%coefs(1,i3),ctp2%coefs(1,i2)\n! the loops above may miss terms with same power ... suck\n! check all terms in ctp3 \n do j1=1,maxnc\n if(ctp3%tpows(j1,i3).gt.-100) then\n do j2=j1+1,maxnc\n if(ctp3%tpows(j2,i3).eq.ctp3%tpows(j1,i3)) then\n ctp3%coefs(j1,i3)=ctp3%coefs(j1,i3)+ctp3%coefs(j2,i3)\n ctp3%tpows(j2,i3)=-100\n ctp3%coefs(j2,i3)=zero\n endif\n enddo\n endif\n enddo\n! call tpwrite('x4',0,1,ctp3)\n!1000 continue\n! write(*,*)'3Z Exit add1tpcoefs'\n return\n end subroutine add1tpcoeffs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine checkpowers\n!\\begin{verbatim} %-\n subroutine checkpowers(nc1,lfun,tpow1,npow,usedpow)\n! check powers used in TP functions\n! There can be several terms with same power ...\n! nc1 is the maximal number of coefficients for each range (maxnc in fact)\n implicit none\n integer tpow1(*),nc1,lfun,usedpow(*),npow\n!\\end{verbatim} %+\n! if these powers changes change also in sortceffs\n! integer, parameter :: fixpows(9)=[0,1,100,2,3,-1,7,-9,4]\n integer, parameter :: mmm=10\n integer, parameter :: fixpows(mmm)=[0,1,100,2,3,-1,7,-9,-2,-3]\n! ANY CHANGE IN POWERS ALSO IN ... SORTCOEFFS\n integer i1,j1\n if(npow.eq.0) then\n do j1=1,nc1\n usedpow(j1)=-100\n enddo\n! npow=9\n npow=mmm\n do j1=1,npow\n usedpow(j1)=fixpows(j1)\n enddo\n! write(*,17)'3Z inititated usedpow: ',(usedpow(j1),j1=1,npow),lfun\n!17 format(a,10i5,i3)\n endif\n loop1: do i1=1,nc1\n if(tpow1(i1).gt.-100) then\n do j1=1,npow\n if(tpow1(i1).eq.usedpow(j1)) cycle loop1\n enddo\n! we have a non standard power\n npow=npow+1\n usedpow(npow)=tpow1(i1)\n! write(*,11)'3Z non-standard power: ',lfun,tpfuns(lfun)%symbol,&\n! npow,tpow1(i1)\n!11 format(a,i5,2x,a,2i4)\n endif\n enddo loop1\n1000 continue\n return\n end subroutine checkpowers\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine sortcoeffs\n!\\begin{verbatim} %-\n subroutine sortcoeffs(nc1,lfun,coeff1,tpow1)\n! sort the coefficients in order power: 0 1 TlnT 2 3 -1; 7 -9 -2 other1 other2\n! 1 2 3 4 5 6; 7 8 9 10 11\n! other powers are 3, 4, -8 (meaning sqrt(t)) and maybe more\n! tpowi is array giving the T power for coeffi, 101 means T*ln(T)\n! ANY CHANGE OF POWERS MUST BE MADE ALSO IN ... CHECKPOWERS\n! There can be several terms with same power ...\n! nc1 is the maximal number of coefficients for each range (maxnc in fact)\n implicit none\n integer tpow1(*),nc1,lfun\n double precision coeff1(*)\n!\\end{verbatim}\n integer, parameter :: maxnc=15\n integer z1,i2,lastc,rare,free(3)\n double precision xxx,cord(maxnc)\n cord=zero\n lastc=0\n rare=0\n free=0\n! write(*,80)'3Z sort: ',tpfuns(lfun)%symbol,nc1,(tpow1(z1),z1=1,nc1)\n loop1: do z1=1,nc1\n if(tpow1(z1).eq.0) then\n cord(1)=cord(1)+coeff1(z1)\n if(lastc.lt.1) lastc=1\n elseif(tpow1(z1).eq.1) then\n cord(2)=cord(2)+coeff1(z1)\n if(lastc.lt.2) lastc=2\n elseif(tpow1(z1).eq.100) then\n cord(3)=cord(3)+coeff1(z1)\n if(lastc.lt.3) lastc=3\n elseif(tpow1(z1).eq.2) then\n cord(4)=cord(4)+coeff1(z1)\n if(lastc.lt.4) lastc=4\n elseif(tpow1(z1).eq.3) then\n cord(5)=cord(5)+coeff1(z1)\n if(lastc.lt.5) lastc=5\n elseif(tpow1(z1).eq.-1) then\n cord(6)=cord(6)+coeff1(z1)\n if(lastc.lt.6) lastc=6\n elseif(tpow1(z1).eq.7) then\n! all powers from here are special ... if coeff(z1)=zero ignore on output\n cord(7)=cord(7)+coeff1(z1)\n! write(*,77)z1,7,tpfuns(lfun)%symbol\n!77 format('3Z moving coefficient ',i2,' to ',i2,': ',a)\n coeff1(z1)=zero\n if(lastc.lt.7) lastc=7\n elseif(tpow1(z1).eq.-9) then\n cord(8)=cord(8)+coeff1(z1)\n! write(*,77)z1,8,tpfuns(lfun)%symbol\n coeff1(z1)=zero\n if(lastc.lt.8) lastc=8\n elseif(tpow1(z1).eq.-2) then\n! it seems power -2 occors in the TAFID database\n cord(9)=cord(9)+coeff1(z1)\n! write(*,77)z1,9,tpfuns(lfun)%symbol\n coeff1(z1)=zero\n if(lastc.lt.9) lastc=9\n elseif(tpow1(z1).le.-100) then\n! ignore this term\n continue\n elseif(coeff1(z1).ne.zero) then\n! here tpow1(z1) cannot be -100: max 2 rare or unusual power like 3, 4, -8 ...\n if(free(1).eq.0 .or. tpow1(z1).eq.tpow1(10)) then\n! store in unused or add to to same rare power position in position 10\n! write(*,90)tpfuns(lfun)%symbol,&\n! lfun,10,z1,tpow1(z1),coeff1(z1)\n!90 format('3Z function: ',a,' extra power: ',4i4,2x,1pe12.4)\n cord(10)=cord(10)+coeff1(z1)\n coeff1(z1)=zero\n tpow1(10)=tpow1(z1)\n free(1)=1\n if(lastc.lt.10) lastc=10\n elseif(free(2).eq.0 .or. tpow1(z1).eq.tpow1(11)) then\n! store in unused or add to to same rare power position in position 11\n! same special power in position 11\n! write(*,90)tpfuns(lfun)%symbol,&\n! lfun,11,z1,tpow1(z1),coeff1(z1)\n cord(11)=cord(11)+coeff1(z1)\n coeff1(z1)=zero\n tpow1(11)=tpow1(z1)\n free(2)=1\n if(lastc.lt.11) lastc=11\n elseif(free(3).eq.0 .or. tpow1(z1).eq.tpow1(12)) then\n! store in unused or add to to same rare power position in position 12\n! same special power in position 12\n! write(*,90)tpfuns(lfun)%symbol,&\n! lfun,11,z1,tpow1(z1),coeff1(z1)\n cord(12)=cord(12)+coeff1(z1)\n coeff1(z1)=zero\n tpow1(12)=tpow1(z1)\n free(3)=1\n if(lastc.lt.11) lastc=11\n else\n! Too many rare powers in this expression\n write(*,89)tpfuns(lfun)%symbol,&\n tpow1(10),tpow1(11),tpow1(12),tpow1(z1)\n89 format('3Z Cannot handle four different rare powers: ',a,3i4)\n stop ' *** power problems!'\n endif\n endif\n enddo loop1\n! write(*,91)'3Z powers 1: ',(tpow1(z1),z1=1,lastc)\n91 format(a,11i5)\n! return coefficients in order\n do z1=1,9\n tpow1(z1)=-100\n enddo\n do z1=1,nc1\n coeff1(z1)=cord(z1)\n enddo\n tpow1(1)=0\n tpow1(2)=1\n tpow1(3)=100\n tpow1(4)=2\n tpow1(5)=3\n tpow1(6)=-1\n tpow1(7)=7\n tpow1(8)=-9\n tpow1(9)=-2\n! latsc is the last used power position \n if(lastc.lt.10) tpow1(10)=-100\n if(lastc.lt.11) tpow1(11)=-100\n if(lastc.lt.12) tpow1(12)=-100\n tpow1(13)=-100; tpow1(13)=-100; tpow1(13)=-100\n! tpow1(10), 11 and 12 are free\n! write(*,91)'3Z powers 2: ',(tpow1(z1),z1=1,lastc)\n! write(*,80)'3Z sorted: ',tpfuns(lfun)%symbol,nc1,(tpow1(z1),z1=1,lastc)\n!80 format(a,1x,a,': ',i3,11i5)\n! tpow1(11) keep its value. No provision for more than one extra power!!\n!1000 continue\n return\n end subroutine sortcoeffs\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n! END MODULE TPFUNLIB\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/models/gtp3_dd1.F90", "content": "!\n! Data structures for the TPFUN package\n!\n!=================================================================\n! VARIABLES and STRUCTURES originally in TPFUN\n! length of a function symbol\n integer, parameter :: lenfnsym=16\n integer, private :: freetpfun\n!\n! \\begin{verbatim}\n! ************* this declaration moved to metlib4\n! TYPE gtp_parerr\n! This record contains the global error code. In parallel processing each\n! parallel processes has its own error code copied to this if nonzero\n! it should be replaced by gtperr for separate errors in treads\n! INTEGER :: bmperr\n! END TYPE gtp_parerr\n! TYPE(gtp_parerr) :: gx\n! needed to have error code as private in threads, also moved to metlib4\n!--- $OMP threadprivate(gx)\n! \\end{verbatim}\n!-----------------------------------------------------------------\n!\n!\\begin{verbatim}\n integer, parameter :: tpfun_expression_version=1\n TYPE tpfun_expression\n! Coefficients, T and P powers, unary functions and links to other functions\n integer noofcoeffs,nextfrex\n double precision, dimension(:), pointer :: coeffs\n! each coefficient kan have powers of T and P/V and links to other TPFUNS\n! and be multiplied with a following LOG or EXP term. \n! wpow USED FOR MULTIPLYING WITH ANOTHER FUNCTION!!\n integer, dimension(:), pointer :: tpow\n integer, dimension(:), pointer :: ppow\n integer, dimension(:), pointer :: wpow\n integer, dimension(:), pointer :: plevel\n integer, dimension(:), pointer :: link\n END TYPE tpfun_expression\n! These records are allocated when needed, not stored in arrays\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! BITS in TPFUN\n! TPCONST set if a constant value\n! TPOPTCON set if optimizing value\n! TPNOTENT set if referenced but not entered (when reading TDB files)\n! TPVALUE set if evaluated only explicitly (keeping its value)\n! TPEXPORT set if value should be exported to symbol\n! TPIMPORT set if value should be imported from symbol (only for constants)\n! TPINTEIN set if value should always be calculated\n integer, parameter :: &\n TPCONST=0, TPOPTCON=1, TPNOTENT=2, TPVALUE=3, &\n TPEXPORT=4, TPIMPORT=5\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n integer, parameter :: tpfun_root_version=1\n TYPE tpfun_root\n! Root of a TP function including name with links to coefficients and codes\n! and results. Note that during calculations which can be parallelized\n! the results can be different for each parallel process\n character*(lenfnsym) symbol\n! Why are limits declared as pointers?? They cannot be properly deallocated\n! limits are the low temperature limit for each range\n! funlinks links to expression records for each range\n! each range can have its own function, status indicate if T and P or T and V\n! nextorsymbol is initiated to next index, then possible symbol link!\n! forcenewcalc force new calculation when optimizing variable changed\n! rewind is used to check for duplicates reading from TDB file\n! not saved on unformatted files\n! If bit TPIMPORT set the function must be a constant\n! and nextorsymbol is index of symbol\n! If bit TPEXPORT set then the value of the function (not the derivatives)\n! and nextorsymbol is index of symbol\n! integer noofranges,nextfree,status,forcenewcalc\n integer noofranges,nextorsymbol,status,forcenewcalc,rewind\n double precision, dimension(:), pointer :: limits\n TYPE(tpfun_expression), dimension(:), pointer :: funlinks\n double precision hightlimit\n END TYPE tpfun_root\n! These records are stored in arrays as the actual function is global but each\n! equilibrium has its own result array (tpfun_parres) depending on the local\n! values of T and P/V. The same indiex is used in the global and local arrays.\n! allocated in init_gtp\n TYPE(tpfun_root), private, dimension(:), pointer :: tpfuns\n!\\end{verbatim}\n\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n integer, parameter :: tpfun_parres_version=1\n TYPE tpfun_parres\n! Contains TP results, 6 double for results and 2 doubles for T and P \n! values used to calculate the results\n! Note that during calculations which can be parallelized the\n! results can be different for each tread\n integer forcenewcalc\n double precision, dimension(2) :: tpused\n double precision, dimension(6) :: results\n END TYPE tpfun_parres\n! This array is local to the gtp_equilibrium_data record\n! index is the same as the function\n!\\end{verbatim}\n!\n! =============================== end of TPFUN data structures\n!\n" }, { "path": "src/models/gtp3_dd2.F90", "content": "!**************************************************************\n! General Thermodynamic Package (GTP)\n! for thermodynamic modelling and calculations\n!\n! MODULE GENERAL_THERMODYNAMIC_PACKAGE\n!\n! Copyright 2011-2022, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n! contact person: bo.sundman@gmail.com\n!\n!-----------------------------------------------------------------------\n!\n! for known unfinished/unchecked bugs and parallelization problems\n! look for BEWARE\n!\n!-----------------------------------------------------------------------\n!\n! Description of data structure\n!\n! For all elements, species and phases there are two arrays defined.\n! The first (data) array contains the elements species etc and all their data\n! in the order they were entered and the data are never moved.\n! The second (index) array contain the elements, species etc in alphabetical \n! (or whatever) order and is updated whenever a new element, species etc \n! is added. This array is an integer array with the index of the data array.\n! Most links inside the different records to elements, species etc\n! are indices to the data array which is never changed. \n! TPFUNS used in parameters are also stored in an array and the index\n! to this array is stored in the property record to specify the function.\n!\n! For parameters inside each phase record there is one (or 2 if disordered set)\n! lists with endmember parameters. Each endmember record can be the root\n! of a binary tree with interaction parameters. Each of these records\n! can have a property list with various data like G, TC, MQ etc. These\n! records are created dynamically and can only be found by following the links.\n!\n! Each phase has one or more composition sets. These are part of the\n! equilibrium data structure which also contains conditions,\n! calculated values of TP functions and other symbols. To identify a\n! phase+comp.set a phasetuple has been intoduced. This contains two\n! integers, the first is the phase number, the second the composition\n! set number. The second or higher composition set of a phase will\n! have a tupel index higher than the number of phases(?).\n!\n! One equilibrium record is created in init_gtp and it is called\n! FIRSTEQ which is a global variable. There is also an array EQLISTA\n! which should contain all allocated equilibrium records, FIRSTEQ is a\n! pointer to the first element in this array. More equilibrium\n! records can be initiated by the enter_equilibrium subroutine. This\n! copies the relevant data from FIRSTEQ. After a second equilibrium\n! is created it is forbidden to enter elements, species and phases and\n! create additional fraction sets, i.e. one must not change the data\n! structure except to add/remove composition sets (but this should\n! anyway be avoided). Composition sets must be created in all\n! equilibrium records at the same time (if done in a thread then all\n! threads must stop while this is done). During step/map calculation\n! each calculated equilibria is saved for later use in plotting och\n! other postprocessing. These saved equilibria may have different\n! number of composition sets so great care must be taken using them.\n!\n! The equilibrium data record is \"stand alone\" and contains all necessary\n! data to describe the equilibrium (except the model parameters and other\n! static data). In parallel processing each thread will have its own\n! equilibrium data record.\n!\n! The intention is that several equilibra can be created both to store\n! individual experimental data in assessments and for each thread in\n! parallel. In the equilibrium record there are conditions,\n! components (with chemical potentials) and an error code and most\n! important, the phase_varres record array with one or more record for\n! each phase. This array must be identical in all equilibria recods.\n! Each composition set has a phase_varres record and they are linked\n! from the phase record by the LIKTOCS array. As the phase_varres\n! records are in an array the link is simply an integer index of this\n! array. There is a free list (in FIRSTEQ) in the phase_varres array\n! to be used when adding or removing a composition set. The EQ_TPRES\n! array is declared inside the equilibrium record for calculated\n! results of the TPFUNS as these can be different in each equilibria.\n! The index to a function in EQ_TPRES is the same as the index to the\n! TPFUN array declared globally in TPFUN. The TPFUN array has the\n! actual expression, and EQ_TPRES has the last calculated results,\n! which can be different in each equilibrium. The TPFUN index is used\n! in property records to specify the function of a parameter.\n! \n! In many subroutines the equilibrium record called CEQ (Current EQilibrium)\n! is an argument which means it operates on the data in that \n! equilibrium record only.\n!\n! In the record array PHASE_VARRES (including disordered) each phase \n! and composition set has a record. If no parallel calculation and no\n! experiments the equilibrium record FIRSTEQ is enough.\n!\n! In programming for parallel processing THREADPRIVATE\n! should be avoided as it usually has a very slow implementation.\n!\n! Some routines exist both with and without the CEQ argument. A programmer\n! can create his own array of equilibrium data records and use any of\n! them in such calls. ???? Maybe not, then how to update when a new\n! composition set is needed???\n!\n! Thread specific data are needed for conditions, phase status, constitution,\n! function values and calc results like G and derivatives for each phase,\n! amounts of phases etc. When calling a subroutine to get mole frations etc \n! the equilibrium record CEQ must be supplied.\n!\n! The global error code is defined in tpfunlib, that is not very good. There\n! must be an error code specific to each equilibrium. Or can one declare\n! the error code as \"local\" to the thread?\n!\n!--------------------------------------------------------------------------\n!\n!CCI\n!use ocparam\n!CCI\n! EXTERNAL MODULES\n! metlib package for user i/f and various utilities\n! use metlib\n!\n! routines for inverting matrix, solving system of eqs, eigenvalues etc\n! use lukasnum ! for Lukas solver\n! use ocnum ! for LAPACK and BLAS\n!\n!=================================================================\n!\n! error messages\n! numbers 4000 to 4220 defined. gx%bmperr is set to message index\n! A lot of error flags set have no messages ....\n integer, parameter :: nooferm=4399\n!--------------------------------------------------------------------------\n!\n! Versions\n! date item\n! 2013.03.01 Release version 1\n! 2015.01.07 Release version 2\n! 2016.02.14 Release version 3\n! 2017.02.10 Release version 4\n! 2018.03.02 Release version 5\n! 2020.03.12 Release version 6\n! 2025.11.09 Still updating version 6 \n!---------------------------------------------------------------------------\n character (len=64), dimension(4000:nooferm) :: bmperrmess\n! The first 30 error messages mainly for TP functions\n data bmperrmess(4000:4199)&\n /'Too many coefficients in a TP function. ',&\n 'Illegal character in a TP function, digit expected. ',&\n 'Unknown symbol in TP function ',&\n 'Expected ( after unary function ',&\n 'Too many ) in a TP function ',&\n 'Illegal character in a TP function ',&\n 'Too few ) in a TP function ',&\n 'Too many ( in exponent ',&\n 'Illegally placed ( in the exponent of a TP function ',&\n 'No digits after ( in the exponent of a TP function ',&\n! 4010:\n 'Illegally placed ) in exponent in TP function ',&\n 'Too high power in a TP function, max 99, min -99 ',&\n 'Missing ( or power or ) in the exponent of a TP function ',&\n 'Illegal termination of a TP function reading a TDB file ',&\n 'No more free TP root records ',&\n 'No more free TP expression records ',&\n 'Illegal expression inside unary argument of a TP function ',&\n 'Illegal code found when evaluating a TP function ',&\n 'Found a coefficent zero in a term of a TP function ',&\n 'Illegal code in a TP function ',&\n! 4020:\n 'Negative argument to logarithm in a TP function ',&\n 'Unknown unary function in evaluation for a TP function ',&\n 'Too many symbols in a TP function term ',&\n 'Two unary functions in a TP function term ',&\n 'Too complicated TP function term ',&\n 'Too many temperature ranges in a TP function ',&\n 'TP function with same name already entered ',&\n 'Symbol referenced in a parameter does not exist ',&\n 'Missing separator between phase and constituent array in paramet',&\n 'Cannot enter disordered fraction set when several composition se',&\n! These error mainly in GTP\n! 4030\n 'Cannot enter disordered fraction set when suspended constituents',&\n 'Wildcards in interaction parameters not yet implemented ',&\n 'Interaction between 2 wildcards are illegal ',&\n 'Illegal character in element symbol ',&\n 'Element with this symbol already entered ',&\n 'Element symbol and name must start with letter A-Z ',&\n 'Reference state must start with letter A-Z ',&\n 'Element mass must not be negative ',&\n 'Enthalpy difference H298-H0 must be positive ',&\n 'Entropy at 298.15 must be positive ',&\n! 4040\n 'Too many elements ',&\n 'Too many species ',&\n 'No such element ',&\n 'Text position outside text ',&\n 'Species symbol contain illegal letter or not letter A-Z as first',&\n 'No elements or too many elements in species formula ',&\n 'Unknown element in species formula ',&\n 'Negative stoichiometric factor in species ',&\n 'The charge must be the final \"element\" ',&\n 'Species already entered ',&\n! 4050\n 'No such phase ',&\n 'Unknown or ambiguous species name ',&\n 'No such constituent ',&\n 'Phase name must start with letter A-Z ',&\n 'Phase already entered ',&\n 'Model not implemented yet ',&\n 'Too few or too many sublattices ',&\n 'Sites on a sublattice must be positive ',&\n 'Too few or too many constituents in a sublattice ',&\n 'Too many constituents ',&\n! 4060\n 'No such TP function ',&\n 'Expected constituent array, found nothing ',&\n 'Illegal character in constituent array ',&\n 'Illegal degree of parameter, must be 0-9 ',&\n 'No free interaction records ',&\n 'Wrong number of sublattices ',&\n 'No such constituent in a sublattice ',&\n 'No such interacting constituent ',&\n 'This phase has no disordered fraction set ',&\n 'Wrong number of sublattices in disordered fraction set ',&\n! 4070\n 'No free endmember records ',&\n 'No free property records ',&\n 'No such composition set ',&\n 'Inconsistent composition set specifications ',&\n 'Overflow in push ',&\n 'Undeflow in pop ',&\n 'Sublattice out of range for entering disordered fraction set ',&\n 'Disordered fraction set already entered ',&\n 'Not implemented yet ',&\n 'Ionic liquid Not implemented yet ',&\n! 4080\n 'Suspended constituents not implemented yet ',&\n 'Stability factor not implemented yet ',&\n 'No such composition dependent property parameter ',&\n 'Empty line, expected species stoichiometry ',&\n 'No element in species stoichiometry ',&\n 'Species cannot be entered as it is implicitly suspended ',&\n 'Excess model not implemented yet ',&\n 'Bad name for a symbol ',&\n 'Too deeply nested TP functions ',&\n 'Reading unknown addition type from file ',&\n! 4090\n 'Addition already entered ',&\n 'No more addition records ',&\n 'Maximum 9 composition sets ',&\n 'Illegal composition set number ',&\n 'No more records for phases or composition sets. ',&\n 'Hidden phase cannot be ENTERED, SUSPENDED, DORMANT or FIXED ',&\n 'Ambiguous or unknown constituent ',&\n 'Too many argument to a state variable ',&\n 'This state variable must have two arguments ',&\n 'First character of a state variable is wrong ',&\n! 4100\n 'State variable starting with M not followed by U ',&\n 'State variable starting with L not followed by NAC ',&\n 'Missing ( for arguments of state variable ',&\n 'Missing ) after arguments of state variable ',&\n 'Unknown phase used as state variable argument ',&\n 'Unknown constituent used as state variable argument ',&\n 'Unknown component used as state variable argument ',&\n 'State variable starting with D not followed by G ',&\n 'State variable starting with T follwed by other character than C',&\n 'State variable starting with B missing P, MAG, M, V, W or F ',&\n! 4110\n 'This state variable cannot not have two arguments ',&\n 'This state variable must have an argument ',&\n 'Impossible reference state for this component ',&\n 'No such property calculated for this phase ',&\n 'Property normallized by volume impossible as no volume data ',&\n 'Property per formula unit is phase specific ',&\n 'State variable number must be larger than zero ',&\n 'Only state variable Y can have 3 indices ',&\n 'Illegal normalization of state variable ',&\n 'Phase is hidden ',&\n! 4120\n 'Wrong syntax for mobility variable ',&\n 'Ambiguous phase name ',&\n 'Illegal name for an equilibrium ',&\n 'Equilibrium with this name already entered ',&\n 'No such equilibrium ',&\n 'Not allowed to enter more model data ',&\n 'No state variable supplied ',&\n 'Illegal state variable for conditions ',&\n 'Only one kind of state variable in expressions ',&\n 'Illegal value for a state variable ',&\n! 4130 line below\n 'Factor in front of a condition must be followed by * ',&\n 'No such condition or experiment ',&\n 'Function name must start with a letter A-Z ',&\n 'Function name and expression must be separated by \"=\" ',&\n 'Error in function expression (putfun) ',&\n 'Unknown symbol used in function ',&\n 'Symbol with this name already entered ',&\n 'Symbol name must start with letter A-Z and not be reserved ',&\n 'Illegal character in symbol name ',&\n 'Cannot check name of unknown kind of symbol ',&\n! 4140\n 'No such symbol ',&\n 'Error evaluating symbol value ',&\n 'Error listing symbol expression ',&\n 'No conditions at all ',&\n 'Degrees of freedom not zero ',&\n 'Unknown type of addition ',&\n 'Quitting due to repeated input error ',&\n 'Gridminimizer found gridpoint outside range ',&\n 'Gridminimizer error when generating endmember values ',&\n 'Gridminimizer found an element without gridpoint ',&\n! 4150 next line\n 'Gridminimizer have no gridpoint for a pure element ',&\n 'Conditions not only T, P and massbalance ',&\n 'Illegal to set all phases as fix ',&\n 'Cannot enter a new equilibrium if there are no phases ',&\n 'Trying to enter an illegal reference ',&\n 'A reference must have an identifier ',&\n 'Reference identifier already exists ',&\n 'Error in TDB file, species terminator error ',&\n 'Unknown potential ',&\n 'Cannot calculate potentials for charged constituents ',&\n! 4160 next line\n 'Illegal endmember for reference state ',&\n 'End member without atoms ',&\n 'Same species twice in component list ',&\n 'Component stoichiometry matrix singular ',&\n 'Too many interaction levels ',&\n 'Error reading save file ',&\n 'Error reading save file at EOF ',&\n 'Composition set prefix must start with a letter ',&\n 'This property has no specifier ',&\n 'Parameter specifier missing ',&\n! 4170\n 'Properties needed for Inden magnetic model not defined ',&\n 'Request for non-existing chemical potential ',&\n 'Removing current data not implemented ',&\n 'Grid minimization not allowed ',&\n 'Grid minimizer cannot be used with the current set of conditions',&\n 'Too many gridpoints ',&\n 'No phases and no gridpoints for grid minimization ',&\n 'Grid minimizer wants but must not create composition sets ',&\n 'Non-existing fix phase ',&\n 'N, X, B or W cannot have two indices for use of grid minimizer ',&\n! 4180\n 'Condition on B is not allowed for grid minimizer ',&\n 'An element has no composition in grid minimizer ',&\n 'Too complicated mass balance conditions ',&\n 'Two mass balance conditions for same element ',&\n 'Cannot handle conditions on both N and B ',&\n 'No mole fractions when summing composition ',&\n 'Error in TDB file, missing function ',&\n 'Temperature (K) or pressure (Pa) values must be larger than 0.1 ',&\n 'No such state variable ',&\n 'Too many conditions on potentials ',&\n! 4190\n 'File already exist, overwriting not allowed ',&\n 'Activity conditions must be larger than zero ',&\n 'Cannot handle two fix phases ',&\n 'Too many stable phases ',&\n 'This phase must not be stable ',&\n 'Attempt to remove the only stable phase ',&\n 'Enthalpy condition on unstable phase ',&\n 'Illegal wildcard constituent in ionic liquid model ',&\n 'No equilibrium calculated, cannot calculate dot derivative ',&\n 'Error calculating equilibrium matrix for dot derivative '/\n! 4200 mainly errors in minimizer\n data bmperrmess(4200:4399)&\n /'No phase that can be set stable ',&\n 'Attempt to set too many phases as stable ',&\n 'Total amount is negative ',&\n 'Error solving equilibrium matrix ',&\n 'Too many iterations ',&\n 'Phase matrix singular ',&\n 'Cannot handle models without analytical second derivativatives ',&\n 'This type of condition not yet implemented ',&\n 'This type of condition is not allowed ',&\n 'Error setting up system matrix, too many equations ',&\n! 4210\n 'Phase change not allowed ',&\n 'Attempt to delete composition sets when many equilibria ',&\n 'Too many equation in equilibrium matrix ',&\n 'Derivatives with respect to T and P only are allowed ',&\n 'Error creating system matrix in initiate meqrec subroutine ',&\n 'This dot derivative not yet implemented ',&\n 'Wildcard not allowed in dot derivative ',&\n 'Use \"calculate symbol\" for state variable symbols ',&\n 'This experiment is not acivated ',&\n 'Too many equilibria in STEP/MAP, save on file not implemented ',&\n! mainly errors in STEP/MAP\n! 4220 step/map\n 'STEP/MAP error calculating node point, trying to decrease step ',&\n 'STEP/MAP error calculating node point, axis condition not found ',&\n 'STEP/MAP error calculating node point, another phase stable ',&\n 'STEP/MAP error calculating node point, too many stable phases ',&\n 'Cannot find start equilibrium for step/map ',&\n 'Startpoint for step/map outside axis limits ',&\n 'Cannot yet handle nodepoints with more than 2 exits ',&\n 'Phase set changed in start point ',&\n 'Only two axis implemented currently ',&\n 'Axis direction error, no such axis ',&\n! 4230\n 'STEP/MAP tries to set the only stable phase as fix ',&\n 'Too many stable phases during mapping ',&\n 'Another phase wants to be stable at node point ',&\n 'No phase change searching along an axis for a start point ',&\n 'Internal error handling fix phases at node point ',&\n 'Too many phases set fix during mapping ',&\n 'Mapping cannot handle expressions as conditions ',&\n 'Node with no exit lines ',&\n 'Attempt to remove the only stable phase ',&\n 'A never never error ',&\n! 4240\n 'Too many fix phases during mapping ',&\n 'More than one entered phase ',&\n 'Not a single entered phase ',&\n 'Whops, mapping without conditions ... ',&\n 'I give up on this line ',&\n 'Unknown problem ',&\n 'Two phases compete to be stable ',&\n 'Nothing to plot in ocplot ',&\n 'No data so no plot ',&\n 'No experiments ',&\n! more error messages for GTP and other modules\n! 4250\n 'Too many parameter identifiers, increase maxprop ',&\n 'Calling mass_of with illegal component number ',&\n 'No such phase tuple index ',&\n 'Internal error, not a single lattice for a phase ',&\n 'Illegal phase index ',&\n 'The partially ionic liquid model must have two sublattices ',&\n 'This phase cannot be reference phase for this component ',&\n 'Internal error, constituent index outside range ',&\n 'Same constituent twice in one sublattice ',&\n 'Too many phases, increase dimension of phlista ',&\n! 4260\n 'The partially ionic liquid model has only cations in first subl.',&\n 'Illegal parameter with wildcards mixed with cations ',&\n 'The partially ionic liquid model not only wildcard on 2nd subl. ',&\n 'The partially ionic liquid model has no catioons on 2nd subl. ',&\n 'Only neutrals on 2nd sublattice of I2SL if wildcard on first ',&\n 'Illegal interaction parameter ',&\n 'Same constituent twice in interaction parameter ',&\n 'There must be at least 4 sublattices for a phase with F/B option',&\n 'Maximum two interaction levels using the F option ',&\n 'Internal error, unknown case for endmember permutation ',&\n! 4270\n 'Interaction must be on first sublattice using option F or B ',&\n 'Cannot find endmember element for permutation ',&\n 'Internal error, unknown case for permutations ',&\n 'Internal error, too complicated ',&\n 'Internal error generating fcc permutations ',&\n 'This excess parameter not yet implemented in option F or B ',&\n 'Internal error generating permutations for option F ',&\n 'BCC permutations (TDB option B) not yet fully implemented ',&\n 'Subcommand error when enter many_equilibria ',&\n 'Too many columns when entering many_equilibria row ',&\n! 4280\n 'Table row missing in column when entering many_equilbria ',&\n 'Number expected after specifying fix phase ',&\n 'Phase name expected after status command ',&\n 'Too many equilibra, increase dimension of eqlista ',&\n 'Equilibrium name must start with a letter A-Z ',&\n 'Cannot overwrite the default equilibrium ',&\n 'Illegal use of wildcard ',&\n 'Error in constituent dependence for parameter idenifier ',&\n 'Yet another never never error ',&\n 'Charge must be given as /+ or /- ',&\n! 4290\n 'Error in parameter identifier ',&\n 'Phase missing in parameter ',&\n 'No such property name or index ',&\n 'Illegal to have a symbol as value of T or P ',&\n 'Illegal to set a fix phase as experiment ',&\n 'Calling locate_condition with illegal index ',&\n 'Calling apply_condition with illegal option ',&\n 'Species names must be surrounded by ( ) for set input_amounts ',&\n 'Illegal to enter property to a species that is an element ',&\n 'Saved file not same version as program ',&\n! 4300\n 'Data record format on save file not the same as in program ',&\n 'Bibliographic record too long on save file ',&\n 'Error reading records for a phase from save file ',&\n 'Failed entering function from save file ',&\n 'Too long line on save file ',&\n 'No element symbol after ELEMENT keyword in TDB file ',&\n 'No information after SPECIES keyword on TDB file ',&\n 'No terminator after FUNCTION keyword on TDB file ',&\n 'The CONSTITUENT keyword must follow directly after PHASE keyword',&\n 'Error extracting constituents for a phase ',&\n! 4310\n 'Error that final : for constituents missing ',&\n 'Empty line after FUNCTION keyword ',&\n 'Line with PARAMETER keyword does not finish with ! ',&\n 'Empty reference line on TDB file ',&\n 'References must be surrounded by citation marks ',&\n 'Function name must be on same line as FUNCTION keyword ',&\n 'End of file while searching for end of keyword in TDB file ',&\n 'Indices error in old state variable format ',&\n 'Unknown state variable or property ',&\n 'Character variable length insufficient for output of values ',&\n! 4320\n 'State variable has illegal argument type ',&\n 'Error calculating eigenvalues of phase matrix ',&\n 'Only a single symbol allowed ',&\n 'Symbol must be a constant ',&\n 'Value of PHSTATE not correct ',&\n 'Illegal bit number for phase status ',&\n 'Illegal phase for setting status bit ',&\n 'Illegal selection of old phase status ',&\n 'Condition specified by number must be followed by := ',&\n 'Calling create_interaction with too many permutations ',&\n! 4330\n 'No such addition type ',&\n 'Cp model not yet implemented ',&\n 'Magnetic model with separate Curie and Neel T not yet implement ',&\n 'Addition model not yet implemented ',&\n 'Not implemented this way ',&\n 'Model parameter identifier not found ',&\n 'Value for model parameter identifier not found ',&\n 'Flory-Huggins model must have one lattice and site ',&\n 'Too many parameter properties for this phase ',&\n 'Internal error, listprop not allocated ',&\n! 4340\n 'Max two levels of interactions allowed ',&\n 'Wildcard parameters not allowed in 2nd sublattice of I2SL model ',&\n 'Composition dependent ternary parameter must have 3 degrees ',&\n 'Ternary cation interactions not yet implemented in I2SL ',&\n 'Too many phases for the global gridminimizer ',&\n 'Global minimization with a fix phase not possible ',&\n 'Internal problems in grid minimizer ',&\n 'Interaction levels more than 5 levels deep ',&\n 'A TP function with this name already entered ',&\n 'Illegal value of TP function index ',&\n! 4350\n 'A never never error evaluating a TP function ',&\n 'Cannot find this TP function ',&\n 'Current equilibrium not global, gridmin found gridpoint below ',&\n 'Nodepoint not global, line ignored ',&\n 'Illegal numerical value in equilibrium matrix ',&\n 'Wrong version of data on unformatted file ',&\n 'Error reserving space for unformatted save ',&\n 'Error saving unformatted data file ',&\n 'Recalculate as gridpoint below current equilibrium ',&\n 'Slow convergence with same set of stable phases ',&\n! 4360\n 'Too large change on axis, terminating mapping ',&\n 'Model parameter value not calculated ',&\n 'New set of components are not independent ',&\n 'No equilibrium, a restored phase should be stable ',&\n 'Two phases with same composition stable at nodepoint ',&\n 'Gridtest indicate global minimization needed ',&\n 'Gridtest request recalculation without gridminimizer ',&\n 'Missing property for calculating addition ',&\n 'Tried halfstep 3 times, giving up on this line ',&\n 'Repeated error calling map_calcnode, line terminated ',&\n! 4370\n 'Error allocating data, no free memory ',&\n 'Nonlinear equation solver HYBRD1 error ',&\n 'Error from DGETRS/F generating isopleth invariant exits ',&\n 'Supressed value due to special circumstances ',&\n 'Mobility parameters must not have wildcard constituents ',&\n 'No EET temperature calculated for this system ',&\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n! 4380\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n '5 ',&\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n! 4390\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n '5 ',&\n ' ',&\n ' ',&\n ' ',&\n 'No message assigned '/\n! last used error codes above\n!\n!=================================================================\n!\n!\\begin{verbatim}\n! STATUS BITS are numbered 0-31\n!-Bits in GLOBAL status word (GS) in globaldata record\n! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc\n! NOMERGE: no merge of gridmin result, \n! NODATA: not any data, \n! NOPHASE: no phase in system, \n! NOACS: no automatic creation of composition set for any phase\n! NOREMCS: do not remove any redundant unstable composition sets\n! NOSAVE: data changed after last save command\n! VERBOSE: maximum of listing\n! SETVERB: permanent setting of verbose\n! SILENT: as little output as possible\n! NOAFTEREQ: no manipulations of results after equilibrium calculation\n! XGRID: extra dense grid for all phases\n! NOPAR: do not run in parallel\n! NOSMGLOB do not test global equilibrium at node points\n! NOTELCOMP the elements are not the components\n! TGRID use grid minimizer to test if global after calculating equilibrium\n! OGRID use old grid generator\n! NORECALC do not recalculate equilibria even if global test after fails\n! OLDMAP use old map algorithm\n! NOAUTOSP do not generate automatic start points for mapping\n! YGRID extra dense grid\n! VIRTUAL (CCI) enables calculations with a virtual element\n! >>>> some of these should be moved to the gtp_equilibrium_data record\n integer, parameter :: &\n GSBEG=0, GSOCC=1, GSADV=2, GSNOGLOB=3, &\n GSNOMERGE=4, GSNODATA=5, GSNOPHASE=6, GSNOACS=7, &\n GSNOREMCS=8, GSNOSAVE=9, GSVERBOSE=10, GSSETVERB=11,&\n GSSILENT=12, GSNOAFTEREQ=13, GSXGRID=14, GSNOPAR=15, &\n GSNOSMGLOB=16, GSNOTELCOMP=17, GSTGRID=18, GSOGRID=19, &\n GSNORECALC=20, GSOLDMAP=21, GSNOAUTOSP=22,GSYGRID=23, &\n GSVIRTUAL=24\n!----------------------------------------------------------------\n!-Bits in ELEMENT record\n integer, parameter :: &\n ELSUS=0, ELDEL=1\n!----------------------------------------------------------------\n!-Bits in SPECIES record\n! SUS Suspended,\n! IMSUS implicitly suspended (when element suspended)\n! EL species is element, \n! VA species is the vacancy\n! ION species have charge, \n! SYS species is (system) component\n! UQAC species used in uniquac model (2 extra reals for area and volume)\n integer, parameter :: &\n SPSUS=0, SPIMSUS=1, SPEL=2, SPVA=3, &\n SPION=4, SPSYS=5, SPUQC=6\n!\\end{verbatim}\n!----------------------------------------------------------------\n! Many not implemented\n!\\begin{verbatim}\n!-Bits in PHASE record STATUS1 there are also bits in each phase_varres record!\n! HID phase is hidden (not implemented)\n! IMHID phase is implictly hidden (not implemented)\n! ID phase is ideal, substitutional and no interaction\n! NOCV phase has no concentration variation\n! HASP phase has at least one parameter entered\n! FORD phase has 4 sublattice FCC ordering with parameter permutations\n! BORD phase has 4 sublattice BCC ordering with parameter permutations\n! SORD phase has TCP type ordering (do not subract ordered as disordered, NEVER)\n! MFS phase has a disordered fraction set\n! GAS this is the gas phase (first in phase list) \n! LIQ phase is liquid (can be several but listed directly after gas)\n! IONLIQ phase has ionic liquid model (I2SL)\n! MQMQX phase with the MQMQA model with asymmetric excess (also MQMQA set)\n! 2STATE elemental liquid twostate model parameters (not same as I2SL!)\n! QCE phase has corrected quasichemical entropy (Hillerst-Selleby-Sundman)\n! CVMCE phase has some CVM ordering entropy (used?)\n! EXCB phase need explicit charge balance (has ions)\n! XGRID use extra dense grid for this phase\n! MQMQA (old FACTCE) phase has FACT quasichem SRO model - implementation pending\n! NOCS not allowed to create composition sets for this phase\n! HELM parameters are for a Helmholz energy model (not implemented),\n! PHNODGDY2 phase has model with no analytical 2nd derivatives (not implemented)\n! not implemented ELMA phase has elastic model A (not implemented)\n! EECLIQ this is the condensed phase (liquid) that should have highest entropy\n! PHSUBO special use testing models DO NOT USE\n! PALM interaction records numbered by PALMTREE NEEDED FOR PERMUTATIONS !!!\n! MULTI may be used with care\n! BMAV Xion magnetic model with average Bohr magneton number\n! UNIQUAC The UNIQUAC fluid model\n! TISR phase has the TSIR entropy model (E Kremer)\n! PHSSRO phase has the tetrahedral FCC model for SRO\n! SROT phase has the tetrahedron quasichemical model ?? not MQMQMA ?? NOT USED\n! CVMTFL phase has the tetrahedral FCC for LRO and SRO\n integer, parameter :: &\n PHHID=0, PHIMHID=1, PHID=2, PHNOCV=3, & ! 1 2 4 8 : 0/F\n PHHASP=4, PHFORD=5, PHBORD=6, PHSORD=7, & ! \n PHMFS=8, PHGAS=9, PHLIQ=10, PHIONLIQ=11, & ! \n PHMQMQX=12, PH2STATE=13, PHQCE=14, PHCVMCE=15,& ! \n PHEXCB=16, PHXGRID=17, PHMQMQA=18, PHNOCS=19,& !\n PHHELM=20, PHNODGDY2=21, PHEECLIQ=22, PHSUBO=23,& ! \n PHPALM=24, PHMULTI=25, PHBMAV=26, PHUNIQUAC=27, & !\n PHTISR=28, PHSSRO=29, PHSROT=30, PHCVMTFL=31 !\n!\n!----------------------------------------------------------------\n!-Bits in PHASE_VARRES (constituent fraction) record STATUS2\n! CSDFS is set if record is for disordred fraction set, then one must use\n! sublattices from fraction_set record\n! CSDLNK: a disordred fraction set in this phase_varres record\n! CSDUM2 and CSDUM3 not used\n! CSCONSUS set if one or more constituents suspended (status array constat\n! specify constituent status)\n! CSORDER: set if fractions are ordered (only used for BCC/FCC ordering\n! with a disordered fraction set).\n! CSABLE: set if phase is stable after an equilibrium calculation ?? needed\n! CSAUTO set if composition set created during calculations\n! CSDEFCON set if there is a default constitution\n! CSTEMPAR set if created by grid minimizer and can be suspended afterwards\n! when running parallel\n! CSDEL set if record is not used but has been and then deleted (by gridmin)\n! CSADDG means there are terms to be added to G \n! CSTEMPDOR means this compset was temporarily set dormant at an \n! equilibrium calculation\n integer, parameter :: &\n CSDFS=0, CSDLNK=1, CSDUM2=2, CSDUM3=3, &\n CSCONSUS=4, CSORDER=5, CSABLE=6, CSAUTO=7, &\n CSDEFCON=8, CSTEMPAR=9,CSDEL=10, CSADDG=11,&\n CSTEMPDOR=12\n!\\end{verbatim}\n!----------------------------------------------------------------\n!\\begin{verbatim}\n!-Bits in CONSTAT array for each constituent\n! For each constituent: \n! SUS constituent is suspended (not implemented)\n! IMSUS is implicitly suspended, \n! VA is vacancy\n! QCBOND the constituent is a binary quasichemical cluster\n integer, parameter :: &\n CONSUS=0, CONIMSUS=1, CONVA=2, CONQCBOND=3\n!----------------------------------------------------------------\n!-Bits in STATE VARIABLE FUNCTIONS (svflista)\n! SVFVAL V symbol evaluated only when explicitly referenced (mode=1 in call)\n! SVFEXT X symbol value taken from equilibrium %eqnoval\n! SVCONST C symbol is a constant (can be changed with AMEND)\n! SVFTPF - bit not used, replaced by export/import\n! SVFDOT D symbol is a DOT function, like cp=h.t (also SVFVAL bit)\n! SVFNOAM N symbol cannot be amended (only R, RT and T_C)\n! SVEXPORT E symbol value exported to assessment coeff (TP constant)\n! SVIMPORT I symbol value imported from TP-function (incl assessment coeff)\n! ONLY ONE BIT CAN BE SET except for D and C+I and C+E,\n! OTHER COMBINATIONS ARE NOT ALLOWED!!\n!\n integer, parameter :: &\n SVFVAL=0, SVFEXT=1, SVCONST=2, SVFTPF=3,&\n SVFDOT=4, SVNOAM=5, SVEXPORT=6, SVIMPORT=7\n!----------------------------------------------------------------\n!-Bits in CEQ record (gtp_equilibrium_data)\n! EQNOTHREAD set if equilibrium must be calculated before threading \n! (in assessment) for example if a symbol must be evaluated in this \n! equilibrium before used in another like H(T)-H298\n! EQNOGLOB set if no global minimization\n! EQNOEQCAL set if no successful equilibrium calculation made\n! EQINCON set if current conditions inconsistent with last calculation\n! EQFAIL set if last calculation failed\n! EQNOACS set if no automatic composition sets ?? not used !! see GSNOACS\n! EQGRIDTEST set if grid minimizer should be used after equilibrium\n! EQGRIDCAL set if last calculation was using only gridminimizer\n! EQMIXED set if mixed reference state for the elements\n integer, parameter :: &\n EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, &\n EQFAIL=4, EQNOACS=5, EQGRIDTEST=6, EQGRIDCAL=7, &\n EQMIXED=8\n!----------------------------------------------------------------\n!-Bits in parameter property type record (gtp_propid)\n! no T or P dependence (constant)\n! only P dependence\n! only T dependence\n! there is an element suffix (like mobility),\n! there is a constituent suffix\n! Property has no addition (used when entering and listing data)\n integer, parameter :: &\n IDNOTP=0, IDONLYP=1, IDONLYT=2, IDELSUFFIX=3, IDCONSUFFIX=4,&\n IDNOADD=5\n!----------------------------------------------------------------\n!- Bits in condition status word (some set in onther ways??)\n! singlevar means T=, x(el)= etc, singlevalue means value is a number\n! phase means the condition is a fix phase\n integer, parameter :: &\n ACTIVE=0, SINGLEVAR=1, SINGLEVALUE=2, PHASE=3\n!----------------------------------------------------------------\n!- Bits in assessment head record status\n! ahcoef set means coefficients are entered\n integer, parameter :: &\n AHCOEF=0\n!\n!----------------------------------------------------------------\n!- Bits in addition record status word gtp_phase_add\n! havepar set if the phase has parameters for this addition\n! if not set the addition is not listed\n! permol set if addition should be muliplied with number of atoms\n integer, parameter :: &\n ADDHAVEPAR=0, ADDPERMOL=1,ADDBCCMAG=2\n!\n! >>> Bits for symbols and TP functions missing ???\n!\\end{verbatim}\n!\n!----------------------------------------------------------------------\n!\n! Defining the phase status is very important, maybe a status for MAPFIX\n! should be added. Added EECDORM for solids with higher entropy than liquid\n!\\begin{verbatim}\n! some constants, phase status\n integer, parameter :: EECDORM=-5\n integer, parameter :: PHHIDDEN=-4\n integer, parameter :: PHSUS=-3\n integer, parameter :: PHDORM=-2\n integer, parameter :: PHENTUNST=-1\n integer, parameter :: PHENTERED=0\n integer, parameter :: PHENTSTAB=1\n integer, parameter :: PHFIXED=2\n character (len=12), dimension(-5:2), parameter :: phstate=&\n (/'EEC_DORMANT ','HIDDEN ','SUSPENDED ','DORMANT ',&\n 'ENTERED UNST','ENTERED ','ENTERED STBL','FIXED '/)\n!\\end{verbatim}\n!\n!----------------------------------------------------------------------\n!\n!=================================================================\n!\\begin{verbatim}\n! The number of additions to the Gibbs energy of a phase is increasing\n! This is a way to try to organize them. Each addtion has a unique\n! number identifying it when created, listed or calculated. These\n! numbers are defined here\n integer, public, parameter :: INDENMAGNETIC=1\n integer, public, parameter :: XIONGMAGNETIC=2\n integer, public, parameter :: DEBYECP=3\n integer, public, parameter :: EINSTEINCP=4\n integer, public, parameter :: TWOSTATEMODEL1=5\n integer, public, parameter :: ELASTICMODEL1=6\n integer, public, parameter :: VOLMOD1=7\n integer, public, parameter :: UNUSED_CRYSTALBREAKDOWNMOD=8\n integer, public, parameter :: SECONDEINSTEIN=9\n integer, public, parameter :: SCHOTTKYANOMALY=10\n integer, public, parameter :: DIFFCOEFS=11\n! with composition independent G2 parameter NOT USED\n integer, public, parameter :: TWOSTATEMODEL2=12\n! name of additions:\n character(len=24) , public, dimension(12), parameter :: additioname=&\n ['Inden-Hillert magn model','Inden-Xiong magn model ',&\n 'Debye CP model ','Einstein Cp model ',&\n 'Liquid 2-state model ','Elastic model A ',&\n 'Volume model A ','Unused CBT model ',&\n 'Smooth CP step ','Schottky Anomaly ',&\n 'Diffusion coefficients ',' ']\n! 123456789.123456789.1234 123456789.123456789.1234\n! Note that additions often use extra parameters like Curie or Debye\n! temperatures defined by model parameter identifiers stored in gtp_propid\n!\\end{verbatim}\n! =================================================================\n!\n! below here are data structures and global data in this module\n!\n! Those belonging to the TPFUN package are in gtp3_dd1.F90\n!\n! Below here are thermodynamic model data structures\n!\n!=================================================================\n!\n!\\begin{verbatim}\n TYPE gtp_global_data\n! status should contain bits how advanced the user is and other defaults\n! it also contain bits if new data can be entered (if more than one equilib)\n! sysparam are variables for different things\n! sysparam(1) unused\n! sysparam(2) number of equilibria between each check of spinodal at STEP/MAP??\n! sysparam(3-10) unused ...\n! sysreal(1) is the minimum T for EET check (equi-entopy T, Hickel)\n! if zero no EET check\n! sysreal(2..10) unused ... some used in debug\n integer status\n integer :: encrypted=0\n character name*24\n double precision rgas,rgasuser,pnorm,mqmqa1\n! these are explicitly set to zero in new_gtp\n double precision, dimension(10) :: sysreal=zero\n integer :: sysparam(10)=0\n END TYPE gtp_global_data\n TYPE(gtp_global_data) :: globaldata\n!\\end{verbatim}\n!==========================================\n!\\begin{verbatim}\n! In the data structure the gtp_xxx_version must be updated at any change\n! It is saves together with the record data at unformatted save in gtp3E.F90\n! and tested on reading to avoid reading incompatible saved files\n! ==========================================\n! this constant must be incremented whenever a change is made in gtp_element\n INTEGER, parameter :: gtp_element_version=1\n TYPE gtp_element\n! data for each element: symbol, name, reference state, mass, h298-h0, s298\n character :: symbol*2,name*12,ref_state*24\n double precision :: mass,h298_h0,s298\n! splink: index of corresponding species in array splink\n! Status bits are stored in the integer status\n! alphaindex: the alphabetical order of this elements\n! refstatesymbol: indicates H0 (1), H298 (0, default) or G (2) for endmembers\n integer :: splink,status,alphaindex,refstatesymbol\n END TYPE gtp_element\n! allocated in init_gtp\n TYPE(gtp_element), private, allocatable :: ellista(:)\n! elements are in alpabetical order ... ???\n INTEGER, private, allocatable :: ELEMENTS(:)\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented whenever a change is made in gtp_species\n! INTEGER, parameter :: gtp_species_version=3\n INTEGER, parameter :: gtp_species_version=2\n TYPE gtp_species\n! data for each species: symbol, mass, charge, extra, status\n! mass is in principle redundant as calculated from element mass\n character :: symbol*24\n double precision :: mass,charge\n! alphaindex: the alphabetical order of this species\n! noofel: number of elements\n! nextra: number of extra properties (size of spextra)\n integer :: noofel,status,alphaindex\n! Use an integer array ellinks to indicate the elements in the species\n! The corresponing stoichiometry is in the array stochiometry\n integer, dimension(:), allocatable :: ellinks\n double precision, dimension(:), allocatable :: stoichiometry\n! Can be used for extra species properties as in UNIQUAC models (area, volume)\n double precision, dimension(:), allocatable :: spextra\n! new property, not included in unformatted save NEVER USED\n character(len=:), allocatable :: mqmqa1\n! Index in mqmqa_data%contyp ... must be updated after reading a database\n integer :: quadindex\n END TYPE gtp_species\n! allocated in init_gtp\n TYPE(gtp_species), private, allocatable :: splista(:)\n INTEGER, private, allocatable :: SPECIES(:)\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented whenever a change is made in gtp_component\n INTEGER, parameter :: gtp_component_version=1\n TYPE gtp_components\n! The components are simply an array of indices to species records\n! the components must be \"orthogonal\". There is always a set of \"systems\n! components\" that by default is the elements.\n! Later one may implement that the user can define a different \"user set\"\n! and maybe also specific sets for each phase.\n! The reference state is set as a phase and value of T and P.\n! The name of the phase and its link and the link to the constituent is stored\n! the endmember array is for the reference phase to calculate GREF\n! The last calculated values of the chemical potentials (for user defined\n! and default reference states) should be stored here.\n! molat is the number of moles of components in the defined reference state\n integer :: splink,phlink,status\n character*16 :: refstate\n integer, dimension(:), allocatable :: endmember\n double precision, dimension(2) :: tpref\n double precision, dimension(2) :: chempot\n double precision mass,molat\n END TYPE gtp_components\n! allocated in gtp_equilibrium_data\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented whenever a change is made in gtp_endmember\n INTEGER, parameter :: gtp_endmember_version=1\n TYPE gtp_endmember\n! end member parameter record, note ordered phases can have\n! several permutations of fraction pointers like for B2: (Al:Fe) and (Fe:Al).\n! There are links (i.e. indices) to next end member and to the interactio tree\n! and to a list of property record\n! The phase link is needed for SAVE/READ as one cannot know the number of\n! sublattices otherwise. One could just store nsl but a link back to the\n! phase record might be useful in other cases.\n! noofpermut: number of permutations (for ordered phases: (Al:Fe) and (Fe:Al)\n! phaselink: index of phase record\n! antalem: sequenial order of creation, not used for anything exept \n! for MQMQA it is the index in %contyp of endmember\n! propointer: link to properties for this endmember\n! nextem: link to next endmember\n! intponter: root of interaction tree of parameters\n! fraclinks: indices of fractions to be multiplied with the parameter\n integer :: noofpermut,phaselink,antalem\n TYPE(gtp_property), pointer :: propointer\n TYPE(gtp_endmember), pointer :: nextem\n TYPE(gtp_interaction), pointer :: intpointer\n! there is at least one fraclinks per sublattice\n! the second index of fraclinks is the permutation (normally only one)\n! the first indec of fraclinks points to a fraction for each sublattice.\n! The fractions are numbered sequentially independent of sublattices, a\n! sigma phase with (FE:CR,MO:CR,FE,MO) has 6 fractions (incl one for FE in\n! first sublattice) and the end member (FE:MO:CR) has the fraclinks 1,3,4\n! This means these values can be used as index to the array with fractions.\n! The actual species can be found via the sublattice record\n! integer, dimension(:,:), pointer :: fraclinks\n integer, dimension(:,:), allocatable :: fraclinks\n END TYPE gtp_endmember\n! dynamically allocated when entering a parameter\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_interaction\n INTEGER, parameter :: gtp_interaction_version=1\n TYPE gtp_interaction\n! this record constitutes the parameter tree. There are links to NEXT\n! interaction on the same level (i.e. replace current fraction) and\n! to HIGHER interactions (i.e. includes current fraction)\n! There can be several permutations of the interactions (both sublattice\n! and fraction permuted, like interaction in B2 (Al:Al,Fe) and (Al,Fe:Al))\n! The number of permutations of interactions can be the same, more or fewer\n! comparared to the lower order parameter (endmember or other interaction).\n! The necessary information is stored in noofip. It is not easy to keep\n! track of permutations during calculations, the smart way to store the last\n! permutation calculated is in this record ... but that will not work for\n! parallel calculations as this record is static ...\n! status: may be useful eventually\n! antalint: sequential number of interaction record, to follow the structure\n! order: for permutations one must have a sequential number in each node\n! propointer: link to properties for this parameter\n! nextlink: link to interaction on same level (replace interaction)\n! highlink: link to interaction on higher level (include this interaction)\n! tooprec: if the interaction involved in TOOP or KOHLER extrapolation\n! sublattice: (array of) sublattices with interaction fraction\n! fraclink: (array of) index of fraction to be multiplied with this parameter\n! noofip: (array of) number of permutations, see above.\n integer status,antalint,order\n TYPE(gtp_property), pointer :: propointer\n TYPE(gtp_interaction), pointer :: nextlink,highlink\n TYPE(gtp_tooprec), pointer :: tooprec\n integer, dimension(:), allocatable :: sublattice,fraclink,noofip\n END TYPE gtp_interaction\n! allocated dynamically and linked from endmember records and other\n! interaction records (in a binary tree)\n!\\end{verbatim}\n!\n!\\begin{verbatim}\n! for storing interaction records when traversiong a parameter tree\n TYPE gtp_intstack\n type(gtp_interaction), pointer :: saved\n end type gtp_intstack\n!\\end{verbatim}\n!---------------------\n! Below some structures needed for MQMQA excess model\n!-------------------\n!\\begin{verbatim}\n! type terdata\n type gtp_terdata\n! use function findtersys(i,j,k,ncat) to find a ternary cation system\n! a linear structure for ternary data, indexing by element order i>> added \"listid\" as a conection to the \"state variable\" listing here.\n! This replaces TC, BMAG, MQ etc included as \"state variables\" in order to\n! list their values. In this way all propids become available\n end TYPE gtp_propid\n! the value TYPTY stored in property records is \"idprop\" or\n! if IDELSUFFIX set then 100*\"idprop\"+ellista index of element\n! if IDCONSUFFIX set then 100*\"idprop\"+constituent index\n! When the parameter is read the suffix symbol is translated to the\n! current element or constituent index\n TYPE(gtp_propid), dimension(:), private, allocatable :: propid\n! These are the properties defined 2020-11-27/BoS defined in init_gtp\n! 1 G T P 0 Energy\n! 2 TC - P 2 Combined Curie/Neel T\n! 3 BMAG - - 1 Average Bohr magneton numb\n! 4 CTA - P 2 Curie temperature\n! 5 NTA - P 2 Neel temperature\n! 6 IBM - P &; 12 Individual Bohr magneton num\n! 7 THET - P 2 Debye or Einstein temp\n! 8 V0 - - 1 Volume at T0, P0\n! 9 VA T - 4 Thermal expansion\n! 10 VB T P 0 Bulk modulus\n! 11 VC T P 0 Alternative volume parameter\n! 12 VS T P 0 Diffusion volume parameter\n! 13 MQ T P &; 10 Mobility activation energy\n! 14 MF T P &; 10 RT*ln(mobility freq.fact.)\n! 15 MG T P &; 10 Magnetic mobility factor\n! 16 G2 T P 0 Liquid two state parameter\n! 17 THT2 - P 2 Smooth step function T\n! 18 DCP2 - P 2 Smooth step function value\n! 19 LPX T P 0 Lattice param X axis\n! 20 LPY T P 0 Lattice param Y axis\n! 21 LPZ T P 0 Lattice param Z axis\n! 22 LPTH T P 0 Lattice angle TH\n! 23 EC11 T P 0 Elastic const C11\n! 24 EC12 T P 0 Elastic const C12\n! 25 EC44 T P 0 Elastic const C44\n! 26 UQT T P &; 10 UNIQUAC residual parameter\n! 27 RHO T P 0 Electric resistivity\n! 28 VISC T P 0 Viscosity\n! 29 LAMB T P 0 Thermal conductivity\n! 30 HMVA T P 0 Enthalpy of vacancy form.\n! 31 TSCH - P 2 Schottky anomaly T\n! 32 CSCH - P 2 Schottky anomaly Cp/R.\n! 33 QCM - - 1 Modif Quasichem model ratio\n! 34 GG - - 0 MQMQA excess\n! 35 GQ - - 0 MQMQA excess\n! 36 GB - - 0 MQMQA excess\n! \n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_phase_add\n INTEGER, parameter :: gtp_phase_add_version=2\n TYPE gtp_phase_add\n! record for additions to the Gibbs energy for a phase like magnetism\n! addrecno: ?\n! aff: antiferomagnetic factor (Inden model)\n! constants: for some constants needed ?? NEW\n! status: BIT 0 set if there are parameters\n! BIT 1 set if magnetic model is for BCC\n! need_property: depend on these properties (like Curie T)\n! explink: function to calculate with the properties it need (not allocatable?)\n! nextadd: link to another addition\n integer type,addrecno,aff,status\n integer, dimension(:), allocatable :: need_property\n double precision, dimension(:), allocatable :: constants\n TYPE(tpfun_expression), dimension(:), pointer :: explink\n! The following declaration is illegal ... but above OK and I can allocate\n! TYPE(tpfun_expression), dimension(:), allocatable, pointer :: explink\n TYPE(gtp_phase_add), pointer :: nextadd\n type(gtp_elastic_modela), pointer :: elastica\n type(gtp_diffusion_model), pointer :: diffcoefs\n! ternary asymmetry record\n type(gtp_ternary_asymmetry), pointer :: asym3\n! calculated contribution to G, G.T, G.P, G.T.T, G.T.P and G.P.P\n double precision, dimension(6) :: propval\n END TYPE gtp_phase_add\n! allocated when needed and linked from phase record\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! Ternary asymmetry record. One or more sets of 3 constituent indices\n! and an asymmetry code. codes are 3 letters T K and many M\n! Used for the MQMQA phase but can be use for other phases\n! There can be several sets\n integer, parameter :: gtp_ternary_asymmetry_version=1\n type gtp_ternary_asymmetry\n integer, dimension(:,:), allocatable :: constindex\n character*3, dimension(:), allocatable :: asymcode\n end type gtp_ternary_asymmetry\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! addition record to calculate the elastic energy contribution\n! declared as allocatable in gtp_phase_add\n! this constant must be incremented when a change is made in gtp_elastic_modela\n INTEGER, parameter :: gtp_elastic_modela_version=1\n TYPE gtp_elastic_modela\n! lattice parameters (configuration) in 3 dimensions\n double precision, dimension(3,3) :: latticepar\n! epsilon in Voigt notation\n double precision, dimension(6) :: epsa\n! elastic constant matrix in Voigt notation\n double precision, dimension(6,6) :: cmat\n! calculated elastic energy addition (with derivative to T and P?)\n double precision, dimension(6) :: eeadd\n! maybe more ...\n end TYPE gtp_elastic_modela\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! addition record to calculate diffusion coefficients\n! declared as allocatable in gtp_phase_add\n! this constant must be incremented when a change is made in gtp_elastic_modela\n INTEGER, parameter :: gtp_diffusion_model_version=1\n TYPE gtp_diffusion_model\n! status bit 0 set means no calculation of this record\n! dilute, simple or magnetic\n integer difftypemodel,status\n! alpha values for magnetic diffusion (for interstitials in constituent order)\n double precision, allocatable, dimension(:) :: alpha\n! indices of dependent constituent in each sublattices\n integer, allocatable, dimension(:) :: depcon\n! indices of constituents with zerovolume\n integer, allocatable, dimension(:) :: zvcon\n! calculated diffusion matrix\n double precision, allocatable, dimension(:,:) :: dcoef\n! Maybe we need one for each composition set?? at least to save the matrix\n type(gtp_diffusion_model), pointer :: nextcompset\n! maybe more ...\n end TYPE gtp_diffusion_model\n!\\end{verbatim}\n!------------------------------------------------------------------\n!\\begin{verbatim}\n TYPE gtp_tpfun_as_coeff\n! this is a TPFUN converted to coefficents without any references to other\n! functions. Each function can have several T ranges and coefficents for T**n\n! USED FOR SOLGASMIX\n double precision, dimension(:), allocatable :: tbreaks\n double precision, dimension(:,:), allocatable :: coefs\n integer, dimension(:,:), allocatable :: tpows\n! this is used only during conversion\n! type(gtp_tpfun_as_coeff), pointer :: nextcrec\n end type gtp_tpfun_as_coeff\n!\n!--------------------------------------------------------------------------\n INTEGER, parameter :: gtp_tpfun2dat_version=1\n TYPE gtp_tpfun2dat\n! this is a temporary storage of TP functions converted to arrays of\n! coefficients. Allocated as an array when necessary and the index in\n! this array is the same index as for the TPfun\n! USED FOR SOLGASMIX calculations and it is very messily implemented \n! if debug is nonzero there is additional output and name is displayed\n integer nranges,debug\n! type(gtp_tpfun_as_coeff) :: tpfuncoef\n type(gtp_tpfun_as_coeff) :: cfun\n character*16 :: name\n end type gtp_tpfun2dat\n!\\end{verbatim}\n!--------------------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_phasetuple\n INTEGER, parameter :: gtp_phasetuple_version=1\n TYPE gtp_phasetuple\n! for handling a single array with phases and composition sets\n! ixphase is phase index (often lokph), compset is composition set index\n! ADDED also index in phlista (lokph) and phase_varres (lokvares) and\n! nextcs which is nonzero if there is a higher composition set of the phase\n! A tuplet index always refer to the same phase+compset. New tuples with\n! the same phase and other compsets are added at the end.\n! BUT if a compset>1 is deleted tuples with higher index will be shifted down!\n! CONFUSING ixphase is usually iph, phases in alphabetical order in phases\n! lokph is usually lokph, location in phlista\n integer lokph,compset,ixphase,lokvares,nextcs\n! >>>>>>>>>>>> old integer phaseix,compset,ixphase,lokvares,nextcs\n end TYPE gtp_phasetuple\n!\\end{verbatim}\n TYPE(gtp_phasetuple), target, allocatable :: PHASETUPLE(:)\n! -----------------------------------------------------------------\n! NOTE: if one wants to model bond energies beteween sites in a phase\n! like in a 3 sublattice sigma one can enter parameters like\n! G(sigma,A:B:*) which will mean the bond energy between an A atom in\n! first sublattice and B in the second. The parameter G(sigma,B:A:*)\n! will be different. Such parameters, multiplied with the fractions of\n! the constutuents, are added to the Gibbs energy even if there are \n! also endmember parameters like G(sigma,A:B:C)\n! -----------------------------------------------------------------\n!\\begin{verbatim}\n! a smart way to have an array of pointers used in gtp_phase\n TYPE endmemrecarray \n type(gtp_endmember), pointer :: p1\n end TYPE endmemrecarray\n!-----------------------------------------------------------------\n! this constant must be incremented when a change is made in gtp_phase\n INTEGER, parameter :: gtp_phase_version=1\n TYPE gtp_phaserecord\n! this is the record for phase model data. It points to many other records.\n! Phases are stored in order of creation in phlista(i) and can be found\n! in alphabetical order through the array phases(i)\n! sublista is now removed and all data included in phlista\n! sublattice and constituent data (they should be merged)\n! The constituent link is the index to the splista(i), same function\n! as LOKSP in iws. Species in alphabetcal order is in species(i)\n! One can allocate a dynamic array for the constituent list, done\n! by subroutine create_constitlist.\n! Note that the phase has a dynamic status word status2 in gtp_phase_varres\n! which can be differnt in different parallel calculations.\n! This status word has the FIX/ENT/SUS/DORM status bits for example\n! name: phase name, note composition sets can have pre and suffixes\n! model: free text\n! phletter: G for gas, L for liquid\n! alphaindex: the alphabetcal order of the phase (gas and liquids first)\n character name*24,models*72,phletter*1\n integer status1,alphaindex\n! noofcs: number of composition sets, \n! nooffs: number of fraction sets (replaces partitioned phases in TC)\n integer noofcs,nooffs\n! additions: link to addition record list\n! ordered: link to endmember record list\n! disordered: link to endmember list for disordered fractions (if any)\n TYPE(gtp_phase_add), pointer :: additions\n TYPE(gtp_endmember), pointer :: ordered,disordered\n! The Toop/Kohler record for each phase with such ternary extrapolation\n! This is a link connecting all Toop/Kohler records for a phase.\n! TYPE(gtp_tooprec), pointer :: tooplist\n! integer lasttoopid\n! TYPE(gtp_tooprec), pointer :: tooprec,tooplist\n! To allow parallel processing of endmembers, store a pointer to each here\n integer noemr,ndemr\n TYPE(endmemrecarray), dimension(:), allocatable :: oendmemarr,dendmemarr\n! noofsubl: number if sublattices\n! tnooffr: total number of fractions (constituents)\n! linktocs: array with indices to phase_varres records\n! nooffr: array with number of constituents in each sublattice \n! Note that sites are stored in phase_varres as they may vary with the\n! constitution (for ionic liquid)\n integer noofsubl,tnooffr\n integer, dimension(9) :: linktocs\n integer, dimension(:), allocatable :: nooffr\n! number of sites in phase_varres record as it can vary with composition\n! constitlist: indices of species that are constituents (in all sublattices)\n integer, dimension(:), allocatable :: constitlist\n! used in ionic liquid:\n! i2slx(1) is index of Va, i2slx(2) is index if last anion (both can be zero)\n integer, dimension(2) :: i2slx\n! Needed to list all Toop/Kohler ternary models\n! The one used for calculations is the pointer in gtp_intrec (tooprec)\n TYPE(gtp_tooprec), pointer :: tooplast,toopfirst\n integer :: lasttoopid\n! allocated in init_gtp.\n END TYPE gtp_phaserecord\n! NOTE phase with index 0 is the reference phase for the elements\n! allocated in init_gtp\n TYPE(gtp_phaserecord), private, allocatable :: phlista(:)\n INTEGER, private, allocatable :: PHASES(:)\n!\\end{verbatim}\n!-----------------------------------------------------------------\n! data for liquid phase with mqmqa model (only one but maybe composition sets)\n TYPE gtp_mqmqa\n! contains special STATIC information for liquid MQMQA model\n! nconst is number of phase const (quads), ncon1, ncon2 in subl, npair #of pairs\n! nconst does not include anions ... these variables are used for the entropy\n integer nconst,ncon1,ncon2,npair,lcat\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n! MUST be careful with ncat and nan !!! USED IN MQMQA\n! this is dangerous .... duplicates of nconst,ncon1,ncon2 also declared locally\n! integer :: nquad,ncat,nan,lcat,lan\n integer :: nquad,ncat,nan,lan\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! some variables are also defined globally as ncat,nan,nquad ... confusing\n! 2025/11/06 This seems OK but a lot of data missing for excess\n! contyp(1..4,const) 1,2 species in first sublattice, -1,-2 in second sublattice\n! contyp(5,const) non-zero for PAIR AA/XX, value same as pair index YES !!\n! contyp(6,7,const) for PAIR species index \n! contyp(6..9,const) index of constituent PAIRs\n! contyp(10,const) index of itself\n! contyp(11..14,const) index of sublattice constituent except:\n! contyp(13..14,const) FOR PAIRS: species index of constituent\n integer, allocatable, dimension(:,:) :: contyp\n! quady(i,j) indices of sublattice fractions ( replaced by 11..14 in contyp)\n! integer, allocatable :: quady(:,:)\n! for each pair, its index in %contyp is in PINQ\n! integer, allocatable, dimension(:,:) :: pinq(:)\n integer, allocatable, dimension(:) :: pinq\n! constoi(1..4,const) real with stoichiometry of species in quadrupole\n! NOTE for pairs (with one constituent in each sublattice) only two values\n! are needed for the stoichiometry. 2, 3 or 4 values\n! Pairs initially have a third value, \\zeta needed for entropy pair entropy\n double precision, allocatable, dimension(:,:) :: constoi\n! ratio FCC/SNN for pairs, needed for pair entropy, copied from %constoi(3,q1)\n double precision, allocatable ::qfnnsnn(:)\n! totstoi(const) double with real number of species (excl vacancies) in quad\n! maybe not needed? Well it is used.\n double precision, allocatable :: totstoi(:)\n! for each pair in a quad, needed for pair fraction and refstate %pp(1..4,quad)\n! pp(i=1..4,jj) is stoichiometric factor of element i in constituent jj etc\n double precision, allocatable :: pp(:,:) \n! At present excess only on cation sublattice, a single anion\n! For binary excess parameters we need fractions:\n! ksi1(AB) = ksi_AB/C= x_AA/(x_AA+x_AB+x_BB) and\n! ksi2(AB) = ksi_BA/C= x_BB/(x_AA+x_AB+x_BB); these are ksi\n! and derivatives wrt the constituents (2nd deriv are symmetric)\n! double precision, allocatable :: ksi1(:),ksi2(:)\n! double precision, allocatable :: dksi1(:,:),dksi2(:,:)\n! double precision, allocatable :: d2ksi1(:,:),d2ksi2(:,:)\n! no need for indexing ksi1 and ksi2 ...???\n! integer, allocatable :: ksiix(:)\n! New implementation of mqmqa excess model started 2025/11/05 <<<<<<<<<<<<<<<\n! if mqmqax=0 then old excess model\n integer :: exlevel=0\n! more data may be added later ...\n! Ternary asymmetry is in a separate record gtp_asym_ternary\n! linked in phase additions list. Several phases can have such a feature\n! FNN/SNN ratio is qfnnsnn(:) \n!\n! for element j if el2ancat(j)>0 it is a cation index\n! if -el2catan(j)>0 is is an anion index NOT USED\n! ONLY ONE ANION ALLOWED, \n! (positive) OC element index of the single anion as link and alpabetical\n integer xanione,xanionalpha\n! index of element as cation (-1 for anion)\n integer, dimension(:), allocatable :: el2ancat\n! xquad is declaraed as global but maybe it belongs to the mqmqa phase\n! double precision, dimension(:), allocatable :: xquad only one mqmqaphase \n! but there can be miscibility gaps\n! convert from xquad index to constarray index and back\n! in xquad the order is sequentail in the cation order:\n! 1 2 3 4 .. n ! n+1 n+2 .. 2n-1 ! 2n ! ... ! n(n+1)/2\n! 1 1 1 1 1 ! 2 2 .. 2 ! 3 3 .. ! ... ! n \n! 1 2 3 4 n ! 2 3 .. n ! 3 4 .. ! ... ! n \n! where 1..n are cation indices i.e. element indices ignoring anions\n! transfer of fractions from OC yfr to quad use\n integer, dimension(:), allocatable :: con2quad ! transfer y to quad order\n! this is the indices of A/X quads in quad, 1, n, 2n-1 etc.\n integer, dimension(:), allocatable :: emquad \n! emquad has indices of quads (i,i). \n! Index of a quad (i,j) where j>=i is emquad(i)+j-i\n!------------------------------------------------------ NEW\n! I realize I need an array tranforming quad indices to compvar indices\n integer, dimension(:), allocatable :: quad2compvar\n! because the quad index is stored with the parameter and I need\n! to convert this to an index for compvar to know the two cations\n!------------------------------------------------------ NEW\n! these are constants depending of the elements in the quad\n double precision, dimension(:,:), allocatable :: dy_ik\n! transfer of fractions from OC fraction array to xquad not needed\n! integer, dimension(:), allocatable :: quad2con not needed\n! end new stuff .... but more records below for example allinone\n end TYPE gtp_mqmqa\n!-----------------------------------------------------------------\n! it should be made private when everything work and removed from pmon6\n TYPE(gtp_mqmqa) :: mqmqa_data\n! it is reset in pmon6 when a NEW command\n integer :: mqmqanend=-100\n! probably only one of these needed ...\n integer, parameter :: maxmqmqa=200\n integer, parameter :: maxquads=99 ! because only 2 digits\n!\n!-----------------------------------------------------------------\n! data for liquid phase with mqmqa model (part of phase_varres record)\n! separate records for each compset because the liquid may have miscibility gaps\n TYPE gtp_mqmqa_var \n! The quadruplet fractions are the \"normal\" constituent fractions\n! but in a differt order form the alphabetical species names.\n! it is part of the phase_varres record\n! size of arrays\n integer nquad,npair,ns1,ns2\n!------------------------------------------ data for MQMQA new excess\n! these are the quad fractions, same as mole fractions but ordered differntly\n! used together with the compvar asymmetrical variables\n! compvar has values of asymmetrical variables for excess\n! in xquad the element index of corresponding quad index is in quadel_ijkl\n! xquad index 1 2 3 .. n ! n+1 n+2 .. 2n-1 ! 2n .. ! n(n+1)/2\n! quadel_i e1 e1 e1 .. e1 ! e2 e2 e2 ! e3 .. ! en cations 1..n\n! quadel_j e1 e2 e3 .. en ! e2 e3 .. en ! e3 .. ! en cations 1..n\n! quadel_k el el el .. el ! el el .. el ! el .. ! el anion 1\n! function ijklx translates from cation/anion indices (i,j,k,l) to quad index\n! The e1, e2 etc and el are saved in quadel_i _j _l\n! The order of xquads is to simplify the handling of Toop/Kohler asymmetries\n double precision, allocatable, dimension(:) :: xquad\n! The fractions in xquad are the same as in yfr but in differnt order!\n type(gtp_allinone), dimension(:), allocatable :: compvar\n! the arrays above should be in the record (type) mqmqa_var\n! y_ik are the fraction of each cation\n double precision, dimension(:), allocatable :: y_ik\n! double precision, dimension(:,:), allocatable :: dy_ik in gtp_mqmqa\n!-----------------------------------------------------------------\n! needed for access to phase data\n type(gtp_phase_varres), pointer :: phresq\n!\n! the variables below until the end of this TYPE are (probably) not used\n! (dynamic) site fractions and derivatives\n double precision, allocatable :: yy1(:),yy2(:),dyy1(:,:),dyy2(:,:)\n double precision, allocatable :: d2yy1(:,:),d2yy2(:,:)\n! charge equivalent fractions (per sublattice)\n double precision, allocatable :: ceqf1(:),ceqf2(:),dceqf1(:,:),dceqf2(:,:)\n! normallized pair fractions and derivatives\n double precision, allocatable :: pair(:),dpair(:,:)\n! constituent equivalent fractions, needed for excess parameters (NEW)\n double precision, allocatable :: eqf1(:),deqf1(:,:),d2eqf1(:,:)\n double precision, allocatable :: eqf2(:),deqf2(:,:),d2eqf2(:,:)\n end type gtp_mqmqa_var\n!===================================================================\n!\n! below here are data structures for equilibrium description\n!\n!===================================================================\n!\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_state_variable\n INTEGER, parameter :: gtp_state_variable_version=1\n TYPE gtp_state_variable\n! this is to specify a formal or real argument to a function of state variables\n! statevarid/istv: state variable index >=9 is extensive\n! phref/iref: if a specified reference state (for chemical potential\n! unit/iunit: 100 for percent, no other defined at present\n! argtyp together with the next 4 integers represent the indices(4), only 0-4\n! argtyp=0: no indices (T or P)\n! argtyp=1: component\n! argtyp=2: phase and compset\n! argtyp=3: phase and compset and component\n! argtyp=4: phase and compset and constituent\n! ?? what is norm ?? normalizing like M in HM ?\n integer statevarid,norm,unit,phref,argtyp\n! these integers represent the previous indices(4)\n integer phase,compset,component,constituent\n! a state variable can be part of an expression with coefficients\n! the coefficient can be stored here. Default value is unity.\n! In many cases it is ignored\n double precision coeff\n! NOTE this is also used to store a condition of a fix phase\n! In such a case statev is negative and the absolute value of statev\n! is the phase index. The phase and compset indices are also stored in\n! \"phase\" and \"compset\" ??\n! This is a temporary storage of the old state variable identifier\n integer oldstv\n end TYPE gtp_state_variable\n! used for state variables/properties in various subroutines\n!\\end{verbatim}\n! statevarid: defined in decode_state_variable3 in gtp3F.F90\n! potentials: 1=T; 2=P; 3=MU; 4=AC; 5=LNAC\n! extensive: 6=U; 7=S; 8=V; 9=H; 10=A; 11=G;\n! phase: 12=NP; 13=BP; 14=Q ; 15=DG\n! amounts: 16=N; 17=X; 18=B; 19=W; 20=Y\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_condition\n! NOTE on unformatted SAVE files the conditions are written as texts\n INTEGER, parameter :: gtp_condition_version=1\n TYPE gtp_condition\n! these records form a circular list linked from gtp_equilibrium_data records\n! each record contains a condition to be used for calculation\n! it is a state variable equation or a phase to be fixed\n! The state variable is stored as an integer with indices\n! NOTE: some state variables cannot be used as conditions: Q=18, DG=19, 25, 26\n! There can be several terms in a condition (like x(liq,c)-x(fcc,c)=0)\n! noofterms: number of terms in condition expression\n! statev: the type of state variable (must be the same in all terms)\n! negative value of statev means phase index for fix phase\n! active: zero if condition is active, nonzero for other cases\n! unit: is 100 if value in percent, can also be used for temperature unit etc.\n! nid: identification sequential number (in order of creation), redundant\n! iref: part of the state variable (iref can be comp.set number)\n! iunit: ? confused with unit?\n! seqz is a sequential index of conditions, used for axis variables\n! experimettype: inequality (< 0 or > 0) and/or percentage (-101, 100 or 101)\n! symlink: index of symbol for prescribed value (1) and uncertainty (2)\n! condcoeff: there is a coefficient and set of indices for each term\n! prescribed: the prescribed value\n! NOTE: if there is a symlink value that is the prescribed value\n! current: the current value (not used?)\n! uncertainty: the uncertainty (for experiments)\n integer :: noofterms,statev,active,iunit,nid,iref,seqz,experimenttype\n! TYPE(putfun_node), pointer :: symlink1,symlink2\n! better to let condition symbol be index in svflista array\n integer symlink1,symlink2\n integer, dimension(:,:), allocatable :: indices\n double precision, dimension(:), allocatable :: condcoeff\n double precision prescribed, current, uncertainty\n! confusing with record statevar and integer statev\n TYPE(gtp_state_variable), dimension(:), allocatable :: statvar\n TYPE(gtp_condition), pointer :: next, previous\n end TYPE gtp_condition\n! used inside the gtp_equilibrium_data record and elsewhere\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_putfun_lista\n INTEGER, parameter :: gtp_putfun_lista_version=2\n TYPE gtp_putfun_lista\n! these are records for STATE VARIABLE FUNCTIONS. The function itself\n! is handelled by the putfun package.\n! linkpnode: pointer to start node of putfun expression\n! narg: number of symbols in the function\n! nactarg: number of actual parameter specifications needed in call\n! (like @P, @C and @S\n! status: can be used for various things\n! status bit SVFVAL set means value evaluated only when called with mode=1\n! SVCONST bit set if symbol is just a constant value (linknode is zero)\n! eqnoval: used to specify the equilibrium the value should be taken from\n! (for handling what is called \"variables\" in TC, SVFEXT set also)\n! SVFTPF set if symbol is a TP function, eqnoval is TPFUN index\n! if SVIMPORT set then the symbol is set equal to a TP function (only value\n! no derivatives). TP function index is in TPLINK\n! if SVEXPORT set the the value of the symbol is copied to a TP function\n! (must be a constant). TP function index is in TPLINK\n! name: name of symbol\n integer narg,nactarg,status,eqnoval,tplink\n type(putfun_node), pointer :: linkpnode\n character name*16\n! THIS IS OLY USED FOR CONSTANTS, VALUES ARE ALSO STORED IN CEQ%SVFUNRES\n double precision svfv\n! this array has identification of state variable (and other function) symbols \n! It is allocated in various subroutines, maybe be allocatable? 2020-08-31/BoS\n integer, dimension(:,:), pointer :: formal_arguments\n end TYPE gtp_putfun_lista\n! this is the global array with state variable functions, \"symbols\"\n TYPE(gtp_putfun_lista), dimension(:), allocatable :: svflista\n! NOTE the value of a function is stored locally in each equilibrium record\n! in array svfunres.\n! The number of entered state variable functions. Used when a new one stored\n integer, private :: nsvfun\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_fraction_set\n INTEGER, parameter :: gtp_fraction_set_version=1\n TYPE gtp_fraction_set\n! info about disordered fractions for some phases like ordered fcc, sigma etc\n! latd: the number of sublattices added to first disordred sublattice\n! ndd: sublattices for this fraction set, \n! tnoofxfr: number of disordered fractions\n! tnoofyfr: same for ordered fractions (=same as in phlista).\n! varreslink: index of disordered phase_varres, \n! totdis: 0 indicates no total disorder (sigma), 1=fcc, bcc or hcp\n! id: parameter suffix, D for disordered\n! dsites: number of sites in sublattices, disordred fractions stored in\n! another phase_varres record with index varreslink (above)\n! splink: indices of species record for the constituents\n! nooffr: the number of fractions in each sublattice\n! y2x: the conversion from sublattice constituents to disordered and\n! dxidyj: are the the coeff to multiply the y fractions to get the disordered\n! xfra(y2x(i))=xfra(y2x(i))+dxidyj(i)*yfra(i)\n! disordered fractions stored in the phase_varres record with index varreslink\n! arrays originally declared as pointers now changed to allocatable\n integer latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis\n character*1 id\n double precision, dimension(:), allocatable :: dsites\n integer, dimension(:), allocatable :: nooffr\n integer, dimension(:), allocatable :: splink\n integer, dimension(:), allocatable :: y2x\n double precision, dimension(:), allocatable :: dxidyj\n! formula unit factor needed when calculating G for disordered sigma etc\n double precision fsites\n END TYPE gtp_fraction_set\n! these records are declared in the phase_varres record as DISFRA for \n! each composition set and linked from the phase_varres record\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_phase_varres\n! added quasichemical bonds\n INTEGER, parameter :: gtp_phase_varres_version=2\n TYPE gtp_phase_varres\n! Data here must be different in equilibria representing different experiments\n! or calculated in parallel or results saved from step or map.\n! nextfree: In unused phase_varres record it is the index to next free record\n! The global integer csfree is the index of the first free record\n! The global integer highcs is the higest varres index used\n! phlink: is index of phase record for this phase_varres record\n! status2: has composition set status bits CSxyz\n! phstate: indicate state: fix/stable/entered/unknown/dormant/suspended/hidden\n! 2 1 0 -1 -2 -3 -4\n! phtupx: phase tuple index\n integer nextfree,phlink,status2,phstate,phtupx\n! abnorm(1): moles of components per formula unit of the phase/composition set\n! abnorm(2): mass of components per formula unit\n! abnorm(3): moles atoms per formula unit (all abnorm set by SET_CONSTITUTION)\n! prefix and suffix are added to the name for composition sets 2 and higher\n double precision, dimension(3) :: abnorm\n character*4 prefix,suffix\n! constat: array with status word for each constituent, any can be suspended\n! yfr: the site fraction array\n! mmyfr: min/max fractions, negative is a minumum\n! sites: site ratios (which can vary for ionic liquids)\n integer, dimension(:), allocatable :: constat\n double precision, dimension(:), allocatable :: yfr\n real, dimension(:), allocatable :: mmyfr\n double precision, dimension(:), allocatable :: sites\n! for ionic liquid derivatives of sites wrt fractions (it is the charge), \n! 2nd derivates only when one constituent is vacancy\n! 1st sublattice P=\\sum_j (-v_j)*y_j + Qy_Va\n! 2nd sublattice Q=\\sum_i v_i*y_i\n! dpqdy is the abs(valency) of the species, set in set_constitution\n! for the vacancy it is the same as the number of sites on second subl.\n! used in the minimizer and maybe elsewhere\n double precision, dimension(:), allocatable :: dpqdy\n double precision, dimension(:), allocatable :: d2pqdvay\n! disfra: a structure describing the disordered fraction set (if any)\n! for extra fraction sets, better to go via phase record index above\n! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this\n! way means the record is stored inside this record.\n type(gtp_fraction_set) :: disfra\n!-------------------------------------------- IMPORTANT for MQMQA excess\n! this is for saving fractions in the mqmqa liquid model\n type(gtp_mqmqa_var) :: mqmqaf\n! ---\n! stored calculated results for each phase (composition set)\n! amfu: is amount formula units of the composition set (calculated result)\n! netcharge: is net charge of phase\n! dgm: driving force\n! qcbonds: quasichemical bonds (NOT SAVED ON UNFORMATTED)\n double precision amfu,netcharge,dgm,qcbonds\n! qcsro: current value of SRO (for quasichemical model) ??\n double precision, allocatable, dimension(:) :: qcsro\n! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop\n! nprop: the number of different properties (set in allocate)\n! listprop(1): is number of calculated properties\n! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc\n! 2=TC, 3=BMAG. Properties defined in the gtp_propid record\n integer nprop\n integer, dimension(:), allocatable :: listprop\n! gval etc are for all composition dependent properties, gval(*,1) for G\n! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P\n! dgval(1,j,1): is first derivatives of G wrt fractions j\n! dgval(2,j,1): is second derivatives of G wrt fractions j and T\n! dgval(3,j,1): is second derivatives of G wrt fractions j and P\n! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j\n double precision, dimension(:,:), allocatable :: gval\n double precision, dimension(:,:,:), allocatable :: dgval\n double precision, dimension(:,:), allocatable :: d2gval\n! added for strain/stress, current values of lattice parameters\n double precision, dimension(3,3) :: curlat\n! saved values from last equilibrium for dot derivative calculations\n double precision, dimension(:,:), allocatable :: cinvy\n double precision, dimension(:), allocatable :: cxmol\n double precision, dimension(:,:), allocatable :: cdxmol\n! terms added to G if bit CSADDG nonzero\n double precision, dimension(:), allocatable :: addg\n! integer containing the iteration when invsaved updated\n integer invsavediter\n! arrays to save time in calc_dgdyterms, do not need to be saved on unformatted\n double precision, dimension(:,:), allocatable ::invsaved\n! added to initiate calculations for CVMSRO model, maybe used elsewhere also?\n integer volatile\n END TYPE gtp_phase_varres\n! this record is created inside the gtp_equilibrium_data record\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! this must be incremented when a change is made in gtp_equilibrium_data\n INTEGER, parameter :: gtp_equilibrium_data_version=1\n TYPE gtp_equilibrium_data\n! this contains all data specific to an equilibrium like conditions,\n! status, constitution and calculated values of all phases etc\n! Several equilibria may be calculated simultaneously in parallel threads\n! SO EACH EQUILIBRIUM MUST BE INDEPENDENT \n! NOTE: the error code must be local to each equilibria!!!!\n! During step and map each equilibrium record with results is saved\n! values of T and P, conditions etc.\n! Values here are normally set by external conditions or calculated from model\n! local list of components, phase_varres with amounts and constitution\n! lists of element, species, phases and thermodynamic parameters are global\n! status: not used yet?\n! multiuse: used for various things like direction in start equilibria\n! eqno: sequential number assigned when created\n! next: index of next free equilibrium record\n! also index of next equilibrium in a list during step/map calculation.\n! eqname: name of equilibrium\n! comment: a free text, for example reference for experimental data.\n! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T\n! rtn: value of R*T\n! weight: weight value for this experiment, default unity\n! integer status,multiuse,eqno,next\n integer status,multiuse,eqno,nexteq\n character eqname*24,comment*72\n double precision tpval(2),rtn\n double precision :: weight=one\n! svfunres: the values of state variable functions valid for this equilibrium\n double precision, dimension(:), allocatable :: svfunres\n! the experiments are used in assessments and stored like conditions \n! lastcondition: link to condition list\n! lastexperiment: link to experiment list\n TYPE(gtp_condition), pointer :: lastcondition,lastexperiment\n! components and conversion matrix from components to elements\n! complist: array with components (species index or location)??\n! compstoi: stoichiometric matrix of compoents relative to elements\n! invcompstoi: inverted stoichiometric matrix\n TYPE(gtp_components), dimension(:), allocatable :: complist\n double precision, dimension(:,:), allocatable :: compstoi\n double precision, dimension(:,:), allocatable :: invcompstoi\n! one record for each phase+composition set that can be calculated\n! phase_varres: here all calculated data for the phases are stored\n TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres\n! index to the tpfun_parres array is the same as in the global array tpres \n! eq_tpres: here local calculated values of TP functions are stored\n! should be allocatable, not a pointer\n TYPE(tpfun_parres), dimension(:), allocatable :: eq_tpres\n! current values of chemical potentials stored in component record but\n! duplicated here for easy acces by application software\n double precision, dimension(:), allocatable :: cmuval\n! xconv: convergence criteria for constituent fractions and other things\n! dgconv(1) is controlling decrease of DGM for unstable phases\n! dgconv(2) not used (yet)\n double precision xconv,gdconv(2)\n! delta-G value for merging gridpoints in grid minimizer\n! smaller value creates problem for test step3.OCM, MC and austenite merged\n! double precision :: gmindif=-5.0D-2\n! testing merging again 190604/BoS\n!CCI\n double precision :: gmindif\n!CCI\n! maxiter: maximum number of iterations allowed\n integer :: maxiter\n! CCI\n! New parameters based on the work of Joao Pedro Teuber Carvalho (12/2020)\n! To scale all changes in phase amount with total number of atoms.\n integer :: type_change_phase_amount\n double precision :: scale_change_phase_amount\n\n! splitsolver : flag to allow the splitting resolution when conditions\n! lead to a square mass matrix\n! precondsolver : flag to allow the preconditionning of the matrix \n! before solving linear system\n integer :: precondsolver\n integer :: splitsolver\n!CCI\n! CCI number of iterations needed for the equilibrium calculation\n integer :: conv_iter\n! This is to store additional things not really invented yet ...\n! It may be used in ENTER MANY_EQUIL for things to calculate and list\n character (len=80), dimension(:), allocatable :: eqextra\n! this is to save a copy of the last calculated system matrix, needed ??\n! to calculate dot derivatives, initiate to zero\n integer :: sysmatdim=0,nfixmu=0,nfixph=0\n integer, allocatable :: fixmu(:)\n integer, allocatable :: fixph(:,:)\n double precision, allocatable :: savesysmat(:,:)\n! This is temporary data for EEC but must be separate for parallelization\n! index of phase_varres for liquid\n integer eecliq\n double precision eecliqs\n! temporary array to handle converge problems with change of stable phase set\n integer, dimension(:,:), allocatable :: phaseremoved\n END TYPE gtp_equilibrium_data\n! The primary copy of this structures is declared globally as FIRSTEQ here\n! Others may be created when needed for storing experimental data or\n! for parallel processing. A global array of these are\n TYPE(gtp_equilibrium_data), dimension(:), allocatable, target :: eqlista\n TYPE(gtp_equilibrium_data), pointer :: firsteq\n! This array of equilibrium records are used for storing results during\n! STEP and MAP calculations.\n TYPE(gtp_equilibrium_data), dimension(:), allocatable :: eqlines\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n! for each permutation in the binary interaction tree of an endmember one must\n! keep track of the permutation and the permutation limit.\n! It is not possible to push the value on pystack as one must remember\n! them when changing the endmember permutation\n! integer, parameter :: permstacklimit=150\n! this constant must be incremented when a change is made in gtp_parcalc\n INTEGER, parameter :: gtp_parcalc_version=1\n TYPE gtp_parcalc\n! This record contains temporary data that must be separate in different\n! parallel processes when calculating G and derivatives for any phase.\n! There is nothing here that need to be saved after the calculation is finished\n! global variables used when calculating G and derivaties\n! sublattice with interaction, interacting constituent, endmember constituents\n! PRIVATE inside this structure not liked by some compilers....\n! endcon must have maxsubl dimension as it is used for all phases\n integer :: intlat(maxinter),intcon(maxinter),endcon(maxsubl)\n! interaction level and number of fraction variables\n integer :: intlevel,nofc\n! interacting constituents (max 4) for composition dependent interaction\n! iq(j) indicate interacting constituents\n! for binary RK+Muggianu iq(3)=iq(4)=iq(5)=0\n! for ternary Muggianu in same sublattice iq(4)=iq(5)=0\n! for reciprocal composition dependent iq(5)=0\n! 2020/BoS not used: Toop, Kohler and simular iq(5) non-zero (not implemented) \n integer :: iq(5)\n! fraction variables in endmember (why +2?) and interaction\n double precision :: yfrem(maxsubl+2),yfrint(maxinter)\n! local copy of T, P and RT for this equilibrium\n double precision :: tpv(2),rgast\n! double precision :: ymin=1.0D-30\n end TYPE gtp_parcalc\n! this record is declared locally in subroutine calcg_nocheck\n!\\end{verbatim}\n!-------------------------------------------------------------------\n!\\begin{verbatim}\n! this constant must be incremented when a change is made in gtp_pystack\n INTEGER, parameter :: gtp_pystack_version=1\n TYPE gtp_pystack\n! records created inside the subroutine push/pop_pystack\n! data stored during calculations when entering an interaction record\n! previous: link to previous record in stack\n! ipermutsave: permutation must be saved\n! intrecsave: link to interaction record\n! pysave: saved value of product of all constituent fractions\n! dpysave: saved value of product of all derivatives of constituent fractions\n! d2pysave: saved value of product of all 2nd derivatives of constit fractions\n TYPE(gtp_pystack), pointer :: previous\n integer :: pmqsave\n TYPE(gtp_interaction), pointer :: intrecsave\n double precision :: pysave\n double precision, dimension(:), allocatable :: dpysave\n double precision, dimension(:), allocatable :: d2pysave\n end TYPE gtp_pystack\n! declared inside the calcg_internal subroutine\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\n!===================================================================\n!\n! below here are data structures for various applications\n! They indicate data that may need to be saved together with\n! the thermodynamic data. Exactly how this will be handelled\n! will have to be solved later\n!\n!===================================================================\n!\n!-----------------------------------------------------------------\n!\\begin{verbatim}\n INTEGER, parameter :: gtp_eqnode_version=1\n TYPE gtp_eqnode\n! This record is to arrange calculated equilibria, for example results\n! from a STEP or MAP calculation, in an ordered way. The equilibrium records\n! linked from an eqnode record should normally represent one or more lines\n! in a diagram but may be used for other purposes.\n! ident is to be able to find a specific node\n! nodedtype is to specify invariant, middle, end etc.\n! status can be used to supress a line\n! color can be used to sepecify color or linetypes (dotted, thick ... etc)\n! exits are the number of lines that should exit from the node\n! done are the number of calculated lines currently exiting from the node\n integer ident,nodetype,status,color,exits,done\n! this node can be in a multilayerd list of eqnodes\n type(gtp_eqnode), pointer :: top,up,down,next,prev\n! nodeq is a pointer to the equilibrium record at the node\n type(gtp_equilibrium_data), pointer :: nodeq\n! eqlista are pointers to line of equilibria starting or ending at the node\n! The equilibrium records are linked with a pointer inside themselves\n type(gtp_equilibrium_data), dimension(:), pointer :: eqlista\n! axis is the independent axis variable for the line, negative means decrement\n! noeqs gives the number of equilibria in each eqlista, a negative value\n! indicates that the node is an endpoint (each line normally has a\n! start point and an end point)\n integer, dimension(:), allocatable :: axis,noeqs\n! This is a possibility to specify a status for each equilibria in each line\n! integer, dimension(:,:), allocatable :: eqstatus\n end TYPE gtp_eqnode\n! can be allocated in a gtp_applicationhead record\n!\\end{verbatim}\n!------------------------------------------------------------------\n!\\begin{verbatim}\n! a smart way to have an array of pointers used in gtp_assessmenthead\n TYPE equilibrium_array\n type(gtp_equilibrium_data), pointer :: p1\n end TYPE equilibrium_array\n INTEGER, parameter :: gtp_assessment_version=1\n TYPE gtp_assessmenthead\n! This record should summarize the essential information about assessment data\n! using GTP. How it should link to other information is not clear. \n! status is status word, AHCOEF is used\n! varcoef is the number of variable coefficients\n! firstexpeq is the first equilibrium with experimental data\n! lwam is allocated workspace at last call to lmdif1\n integer status,varcoef,firstexpeq,lwam\n character*64 general,special\n type(gtp_assessmenthead), pointer :: nextash,prevash\n! This is list of pointers to equilibria to be used in the assessnent\n! size(eqlista) is the number of equilibria with experimental data\n type(equilibrium_array), dimension(:), allocatable :: eqlista\n! These are the coefficients values that are optimized,\n! current values, scaling, start values, RSD and optionally min and max\n double precision, dimension(:), allocatable :: coeffvalues\n double precision, dimension(:), allocatable :: coeffscale\n double precision, dimension(:), allocatable :: coeffstart\n double precision, dimension(:), allocatable :: coeffrsd\n double precision, dimension(:), allocatable :: coeffmin\n double precision, dimension(:), allocatable :: coeffmax\n! These are the corresponding TP-function constants indices\n integer, dimension(:), allocatable :: coeffindex\n! This array indicate currently optimized variables:\n! -1=unused, 0=fix, 1=fix with min, 2=fix with max, 3=fix with min and max\n! 10=optimized, 11=opt with min, 12=opt with max, 13=opt with min and max\n integer, dimension(:), allocatable :: coeffstate\n! Work arrays ...\n double precision, dimension(:), allocatable :: wopt\n end TYPE gtp_assessmenthead\n! this record should be allocated for assessments when necessary\n type(gtp_assessmenthead), allocatable :: ashrecord\n! type(gtp_assessmenthead), pointer :: firstash,lastash\n! but this is later allocated, to avoid memory loss ashrecord should be used\n! and then this pointer should be set to that record\n type(gtp_assessmenthead), pointer :: firstash\n!\\end{verbatim}\n!------------------------------------------------------------------\n!\\begin{verbatim}\n INTEGER, parameter :: gtp_applicationhead_version=1\n TYPE gtp_applicationhead\n! This record should summarize the essential information about an application\n! using GTP. How it should link to other information is not clear. \n! The character variables should be used to indicate that.\n integer apptyp,status\n character*64 general,special\n! These can be used to define axis and other things\n integer, dimension(:), allocatable :: ivals\n double precision, dimension(:), allocatable :: rvals\n character*64, dimension(:), allocatable :: cvals\n type(gtp_applicationhead), pointer :: nextapp,prevapp\n! The headnode can be the start of a structure of eqnodes with lines\n type(gtp_eqnode) :: headnode\n! this is the start of a list of nodes with calculated lines or\n! single equilibria that belong to the application.\n type(gtp_eqnode), dimension(:), allocatable :: nodlista\n end TYPE gtp_applicationhead\n! this record is allocated when necessary\n type(gtp_applicationhead), pointer :: firstapp,lastapp\n!\\end{verbatim}\n!-----------------------------------------------------------------\n!\n!======================================================================= \n!\n! Below are private global variables like free lists etc.\n!\n!===================================================================\n!\n! Several arrays with lists have a free list: csfree,addrecs,eqfree,reffree\n! it is not really consistent how to handle deleted equilibria etc\n! as the eqlista or phase_varres arrays may have \"holes\" with deleted data\n!\n!\\begin{verbatim}\n! counters for elements, species and phases initiated to zero\n integer, private :: noofel=0,noofsp=0,noofph=0\n! counter for phase tuples (combination of phase+compset)\n integer, private :: nooftuples=0\n! counters for property and interaction records, just for fun\n integer, private :: noofprop,noofint,noofem\n! free lists in phase_varres records and addition records\n integer, private :: csfree,addrecs\n! free list of references and equilibria\n integer, private :: reffree,eqfree\n! maximum number of properties calculated for a phase\n integer, private :: maxcalcprop=20\n! highcs is highest used phase_varres record (for copy equil etc)\n integer, private :: highcs\n! Trace for debugging (not used)\n logical, private :: ttrace\n! Output for debugging gridmin\n integer, private :: lutbug=0\n! used for notallowlisting\n double precision :: proda=zero,privilege=zero\n! minimum constituent fraction\n double precision :: bmpymin\n! number of defined property types like TC, BMAG etc\n integer, private :: ndefprop\n! this is the index of mobility data, set in init_gtp in subroutine gtp3A\n integer, private :: mqindex\n! quasichemical model type, 1=classic, 2=corrceted type 1, 3=corrected type 2\n integer :: qcmodel=1\n! this is to remember how manytimes find_gridmeen needs to search all gridp\n integer :: ngridseek\n! this is to handle EEC in the grid minimizer NOT GOOD FOR PARALLELIZATION\n! integer :: neecgrid\n double precision :: sliqmax,sliqmin,gliqeec,sliqeec\n! this is for warnings about using unkown model parameter identifiers\n integer, parameter :: mundefmpi=10\n integer nundefmpi\n character undefmpi(mundefmpi)*4\n! this is to give some debug information when reading a database\n logical :: dbcheck=.FALSE.\n! this is set zero by new_gtp and incremented each time a Toop record\n! is created in any phase\n! REMOVED as global variable 241012/BoS Now local for each phase\n! integer uniqid\n! this is to allow to select_phases from database files\n integer nselph\n character (len=24), allocatable, dimension(:) :: seltdbph\n! This is to indicate mobility parameters, no wildcared fractions allowed\n integer nowildcard(3)\n! trying to extract configurational entropy\n double precision :: sconfmqmqa\n!\\end{verbatim}\n\n! undocumented debug indicator\n integer :: gtpdebug=0\n!====================================================\n! This verbatim section is an Appendix about model parameter identifiers\n! The actual models where these are used are explained elsewhere.\n!\\begin{verbatim} \n! Model parameter identifiers entered in gtp3A.F90 and used mainly in gtp3H\n! to calculate additions. Used also in gtp3B when entering parameters\n! Index Name Used in addition/model\n! 1 G Gibbs energy for endmembers or interactions\n! 2 TC Curie T in Inden-Hillert-Jarl magnetic model\n! 3 BMAG - - 1 Average Bohr magneton numb\n! 4 CTA - P 2 Curie temperature\n! 5 NTA - P 2 Neel temperature\n! 6 IBM - P &; 12 Individual Bohr magneton num\n! 7 LNTH - P 2 ln(Debye or Einstein temp)\n! 8 V0 - - 1 Volume at T0, P0\n! 9 VA T - 4 Thermal expansion\n! 10 VB T P 0 Bulk modulus\n! 11 VC T P 0 Alternative volume parameter\n! 12 VS T P 0 Diffusion volume parameter\n! 13 MQ T P &; 10 Mobility activation energy\n! 14 MF T P &; 10 RT*ln(mobility freq.fact.)\n! 15 MG T P &; 10 Magnetic mobility factor\n! 16 G2 T P 0 Liquid two state parameter\n! 17 THT2 - P 2 Smooth step function Tcrit\n! 18 DCP2 - P 2 Smooth step function increm.\n! 19 LPX T P 0 Lattice param X axis\n! 20 LPY T P 0 Lattice param Y axis\n! 21 LPZ T P 0 Lattice param Z axis\n! 22 LPTH T P 0 Lattice angle TH\n! 23 EC11 T P 0 Elastic const C11\n! 24 EC12 T P 0 Elastic const C12\n! 25 EC44 T P 0 Elastic const C44\n! 26 UQT T P &; 10 UNIQUAC residual parameter\n! 27 RHO T P 0 Electric resistivity\n! 28 VISC T P 0 Viscosity\n! 29 LAMB T P 0 Thermal conductivity\n! 30 HMVA T P 0 Enthalpy of vacancy form.\n! 31 TSCH - P 2 Schottky anomaly T\n! 32 CSCH - P 2 Schottky anomaly Cp/R.\n! 33 QCZ - - 1 MQMQA cluster coord factor\n! 34 GG - - 1 MQMQA excess maybe redundant\n! 35 GQ - - 1 MQMQA excess maybe redundant\n! 36 GB - - 1 MQMQA excess maybe redundant\n! DO NOT CHANGE THE ORDER in gtp3A, that would require changes elsewhere too\n! The table below is the current definition of model parameters!!\n character (len=4), dimension(40) :: MODPARID=&\n ['G ','TC ','BMAG','CTA ','NTA ','IBM ','LNTH','V0 ','VA ','VB ',&\n 'VC ','VS ','MQ ','MF ','MG ','G2 ','THT2','DCP2','LPX ','LPY ',&\n 'LPZ ','LPTH','EC11','EC12','EC44','UQT ','RHO ','VISC','LAMB','HMVA',&\n 'TSCH','CSCH','QCZ ','GG ','GQ ','GB ',' ',' ',' ',' ']\n! 1 2 3 4 5 6 7 8 9 10\n! ['G ','LNTH','BMAG','TC ','NT ','G2 ','V0 ','VA ','VB ','XX ',&\n! 'VC ','VS ','MQ ','MF ','MG ','YY ','THT2','DCP2','LPX ','LPY ',&\n! 'LPZ ','LPTH','EC11','EC12','EC44','UQT ','RHO ','VISC','LAMB','HMVA',&\n! 'TSCH','CSCH','QCZ ',' ',' ',' ',' ',' ',' ',' ']\n! 1 2 3 4 5 6 7 8 9 10\n! The meaning of the model parameters is entered in init_gtp in gtp3A.F90\n!\\end{verbatim} \n!==========================================\n! See gtp3_xml.F90 for new definition of model parameter identifiers\n" }, { "path": "src/models/gtp3_xml.F90", "content": "!***************************************************************\n! General Thermodynamic Package (GTP)\n! for thermodynamic modelling and calculations\n!\n! MODULE GENERAL_THERMODYNAMIC_PACKAGE\n!\n! Copyright 2011-2022, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n! contact person: bo.sundman@gmail.com\n!\n!-----------------------------------------------------------------------\n!\n! for known unfinished/unchecked bugs and parallelization problems\n! look for BEWARE\n!\n!-----------------------------------------------------------------------\n!\n! Description of the XTDB data structure\n! definition of xml elements and attributes for XTDB files\n!\n! Versions\n! 2024.11.19 Begun revise previous XTDB structure using TYPE\n! 2025.01.13 Integrate with OC\n!\n! Some default values for the XTDB file, can be changed by user or read_xtdb\n! These are also set in pmon6 when NEW Y command\n character (len=8), parameter :: XTDBversion='0.1.14 '\n character (len=8) :: lowtdef ='298.15 '\n character (len=8) :: hightdef ='6000 '\n character (len=64) :: bibrefdef ='U.N. Known '\n character (len=16) :: eldef ='VA /-'\n! character (len=52) :: ModelAppendXTDB='C:\\Users\\bosun\\Documents\\OCHOME\\ModelAppendXTDB.XTDB'\n character (len=20) :: ModelAppendXTDB='.\\ModelOCAppend.XTDB'\n logical :: unary1991=.TRUE., includemodels=.FALSE.\n integer xtdberr\n! this is set TRUE when MQMQA quads entered as species. If constituents .false.\n logical :: xtdbmqmqa=.true.\n!\n! Number of XDB tags \n integer, parameter :: nxtdbtags=36\n! contains all tag names in no particular order\n! if tags extend 18 characters changes may be needed in gtp3EX.F90\n character (len=18), dimension(nxtdbtags), parameter :: xtdbtags=&\n! 123456789.123456789.123456789.123456789.123456789.123456789.\n ['XTDB ',&\n 'Defaults ',&\n 'DatabaseInfo ',&\n 'AppendXTDB ',& ! path to extra TDB file\n 'Element ',&\n 'Species ',& \n 'TPfun ',& \n 'Trange ',& \n! 8 above ------------------------------------------\n 'Phase ',& ! With several nested tags\n 'Sublattices ',& \n 'Constituents ',&\n 'CrystalStructure ',&\n 'AmendPhase ',& ! can have models as magnetic etc\n 'Appendix ',& ! Surround tags in an AppendXTDB file \n 'DisorderedPart ',& ! as TC DISORDERED_PART and/or NEVER model\n ' ',& ! chanded Disordered_3Part to attribute\n! 16 above end of phase tags------------------\n 'Parameter ',& ! if moved edit xmlpartag in gtp3EX.F90\n 'Parameter2 ',& ! maybe never implemented in OC, need more tags\n 'Bibliography ',&\n 'Bibitem ',& ! inside Bibliography\n! 20 above Models ----------------------------\n 'Models ',& ! With model tags following\n 'Magnetic ',& ! The modelss Model Parameter Identifiers MPID\n 'Einstein ',&\n 'Liquid2state ',&\n 'Volume ',&\n 'EEC ',& !\n 'TernaryXpol ',& ! Ternary extrapolation tag\n! 27 above I think EBEF is not needed as a model, it is defined the parameters\n 'UnarySystems ',& ! These tags are optional for arrangeing data\n 'BinarySystem ',&\n 'TernarySystem ',&\n! 30 above, ------------------- add new tags below\n ' ',& ! Free\n ' ',&\n ' ',&\n ' ',&\n ' ',&\n ' '] !36\n!------------------------------------\n!\n! All tag attributes are defined below to be easy to modify\n! They are in the order of the tags\n! XTDB tag attributes\n! character (len=18), dimension(nxmltags), parameter :: xmltags=&\n integer, parameter :: nxtdbatt=4\n character (len=9), dimension(nxtdbatt), parameter :: xtdbatt=&\n ['Version ','Software ','Date ','Signature']\n!...........\n! Defaults 2\n integer, parameter :: ndefatt=9\n character (len=18), dimension(ndefatt), parameter :: defatt=&\n ['LowT ','HighT ','Bibref ',&\n 'Elements ','DefaultModels ','EEC ',&\n ' ',' ',' ']\n!.............\n! DatabaseInfo 3\n integer, parameter :: ninfoatt=3\n character (len=16), dimension(ninfoatt), parameter :: infoatt=&\n ['Software ','Date ','Signature ']\n! 123456789.123456...123456789.123456---123456789.123456\n!...........\n! AppendXTDB 4\n integer, parameter :: nappatt=5,lenappatt=16\n character (len=lenappatt), dimension(nappatt), parameter :: appatt=&\n ['Models ','Parameters ','TPfuns ',&\n 'Bibligraphy ','Miscellaneous '] \n! 123456789.123456...123456789.123456---123456789.123456\n!............\n! Element 5\n integer, parameter :: nelatt=5\n character (len=8), dimension(nelatt), parameter :: elatt=&\n ['Id ','Refstate','Mass ','H298 ','S298 ']\n! 12345678...12345678---12345678---12345678---12345678\n!................\n! Species 6\n integer, parameter :: nspatt=4\n character (len=16), dimension(nspatt), parameter :: spatt=&\n ['Id ','Stoichiometry ','MQMQA ',&\n 'UNIQUAC ']\n!................\n! Tpfun attributes 7\n integer, parameter :: ntpatt=4\n character (len=8),dimension(ntpatt), parameter :: tpatt=&\n ['Id ','LowT ','Expr ','HighT ']\n! 12345678...12345678---12345678---12345678\n! Trange attributes 8\n integer, parameter :: ntratt=2\n character (len=8),dimension(ntratt), parameter :: tratt=&\n ['Expr ','HighT ']\n!.............\n! Phase attributes 9\n integer, parameter :: nphatt=3\n character (len=16),dimension(nphatt), parameter :: phatt=&\n ['Id ','Configuration ','State ']\n! 123456789.123456...123456789.123456---123456789.123456\n!.............\n! Sublattice attributes (nested in the Phase element) 10\n integer, parameter :: nsubatt=3 \n character (len=16),dimension(nsubatt), parameter :: subatt=&\n ['NumberOf ','Multiplicities ','WyckoffPosition ']\n! 123456789.123456...123456789.123456---123456789.123456\n!.............\n! Constituents attributes (used inside Phase element) maybe add NN index 11\n integer, parameter :: nconatt=2\n character (len=16),dimension(nconatt), parameter :: conatt=&\n ['Sublattice ','List ']\n!...............\n! CrystalStructure attributes (used inside Phase element) 12\n integer, parameter :: ncrystatt=4\n character (len=16),dimension(ncrystatt), parameter :: crystatt=&\n ['Prototype ','PearsonSymbol ','SpaceGroup ',&\n 'StructurBericht ']\n!.............\n! AmendPhase attributes 13\n integer, parameter :: namphatt=2\n character (len=12),dimension(namphatt), parameter :: amphatt=&\n ['Model ','Permutation ']\n! 123456789.12---123456789.12---123456789.12\n!..............\n! Appendix tag 14\n! Begin and end tag in an appended XTDB file (except Bibliograpy)\n! integer, parameter :: npermatt=0\n! character (len=8),dimension(npermatt), parameter :: permatt=&\n!...............\n! DisorderedPart tag both NEVER model and Disordered_3Parts with Subtract 15\n integer, parameter :: ndis=3\n character (len=12),dimension(ndis), parameter :: disatt=&\n ['Disordered ','Sum ','Subtract ']\n! 123456789.12---123456789.12---123456789.12\n!...\n! Unused 16\n! integer, parameter :: ndis3=2\n! character (len=12),dimension(ndis3), parameter :: dis3att=&\n!................\n! Parameter attributes, Id is as in TDB files 17\n integer, parameter :: npar=5\n character (len=8),dimension(npar), parameter :: paratt=&\n ['Id ','LowT ','Expr ','HighT ','Bibref ']\n!..........\n! Parameter2 attributes (not supported by OC) 18\n integer, parameter :: npar2=7\n character (len=8),dimension(npar2), parameter :: par2att=&\n ['Id ','MPID ','Phase ','LowT ','Expr ',&\n 'HighT ','Bibref ']\n! 12345678---12345678...12345678---12345678---12345678\n!................\n! Bibliography has no attributes contains only Bibitem elements\n!................\n! Bibitem attributes. They provide reference to parameters and models 19\n integer, parameter :: nbibatt=4\n character (len=8),dimension(nbibatt), parameter :: bibattt=&\n ['Id ','Text ','Date ','Sign ']\n! 12345678---12345678...12345678---12345678---12345678\n!...................\n! UnarySystem 20\n integer, parameter :: nuniatt=2\n character (len=8), dimension(nuniatt), parameter :: uniatt=&\n ['Element ','Bibref ']\n!....................\n! BinarySystem attributes. The Species is two elements separated by a space 21\n! The CalcDia attribute is a software depenednt command string\n integer, parameter :: nbinatt=3\n character (len=8),dimension(nbinatt), parameter :: binatt=&\n ['Species ','Bibref ','CalcDia ']\n! 12345678---12345678...12345678---12345678---12345678\n!....................\n! TernarySystem attributes. The Species is 3 elements separated by a space 22\n! The CalcDia attribute is a software depenednt command string\n integer, parameter :: nteratt=3\n character (len=8),dimension(nteratt), parameter :: teratt=&\n ['Species ','Bibref ','CalcDia ']\n! 12345678---12345678...12345678---12345678---12345678\n!================================================================\n! Attributes:\n!================================================================\n! The AmedPhase model attribute has these values\n!......................\n! Magnetic model attributes Id=\"IHJBCC\" or IHJREST or IHJQX\n integer, parameter :: nmagatt=5\n character (len=8),dimension(nmagatt), parameter :: magatt=&\n ['Id ','MPID1 ','MPID2 ','MPID3 ','Bibref ']\n! 12345678---12345678...12345678---12345678---12345678\n!......................\n! Einstein attributes Id=\"GEIN\"\n integer, parameter :: ngeinatt=3\n character (len=8),dimension(ngeinatt), parameter :: geinatt=&\n ['Id ','MPID ','Bibref ']\n! 12345678---12345678...12345678\n!.....................\n! Liquid2state attributes, Id=\"LIQ2STATE\"\n integer, parameter :: nliq2att=4\n character (len=8), dimension(nliq2att), parameter :: liq2att=&\n ['Id ','MPID1 ','MPID2 ','Bibref ']\n!.......................\n! Volume, ID=\"XGL05\" not implemented in OC\n integer, parameter :: nvolatt=5\n character (len=8),dimension(nvolatt), parameter :: volattt=&\n ['Id ','MPID1 ','MPID2 ','MPID3 ','Bibref ']\n! 12345678...12345678...12345678...12345678...12345678\n!................... \n! EEC attributes, Id=\"EEC\"\n integer, parameter :: neccatt=2\n character (len=8), dimension(neccatt), parameter :: eecatt=&\n ['Id ','Bibref ']\n!..................\n! TernaryXpol attributes. \n integer, parameter :: nterxpolatt=3\n character (len=8), dimension(nterxpolatt), parameter :: terxpolatt=&\n ['Phase ','System ','Xmode ']\n! 12345678---12345678...12345678---12345678---12345678\n!....................\n!=========================================================\n!\n! Current list of MPID in OC, related to the models\n integer, parameter :: noofmpid=9\n character (len=8), dimension(noofmpid), parameter :: mpidok=&\n ['G ','TC ','BMAG ','CT ','NT ','IBM ',&\n 'LNTH ','G2 ','L ']\n! 8 12345678---12345678...12345678---12345678---12345678---12345678\n! The L is in princple allowed only for excess G parameters but treated as G\n! IBM was intended for element specific magneton number ....\n! model MPID index\n! IHJBCC 2 3\n! IHJREST 2 3\n! IHJQX 3 4 5\n! GEIN 7\n! LIQUD2STATE 7 8\n! \n! OLD list of MPID, some may have a constituent/element \n! character (len=8), dimension(36), parameter :: mpidw=&\n! ['G ','TC ','BMAG ','CT ','NT ','IBM ',&\n! 'LNTH ','V0 ','VA ','VB ','VC ','VS ',&\n! 'MQ ','MF ','MG ','G2 ','THT2 ','DCP2 ',&\n! 'LPX ','LPY ','LPZ ','LPTH ','EC11 ','EC12 ',&\n! 'RHO ','VISC ','LAMB ','HMVA ','TSCH ','CSCH ',&\n! ' ',' ',' ',' ',' ',' ']\n! 8 12345678---12345678...12345678---12345678---12345678---12345678\n!\n! The meaning of the model parameters is entered in init_gtp in gtp3A.F90\n!\n! An attempt to reconcile XTDB handling of models and additions with OC\n! Some models/additions has no parameters. Those which has are listed below.\n! - DisorderdPart and EBEF has 2 separate sets of parameters (software)\n! - Permutations usually use wildcard parameters (with *) to reduce the\n! number of duplicate model parameters (software)\n! - EBEF is the same as DisorderedPart\n!\n! All parameters i OC has an MPID index, The parameters for the Gibbs energy\n! G (or L) has index 1 (one)\n!------------------------------------------------\n!\n! In OC each parameter has an MPID index stored which is summed\n! independently and later used to calculate the addition.\n!\n! XTDB identifier and MPID OC MPID index and name\n! IHJBCC and IHJREST Inden-Hillert-Jarl magnetic model, AFF=-1 and AFF=-3\n! TC 2 TC 4 Curie/Neel T\n! BMAGN 3 BMAG 3 Bohr magneton number\n! IHJQX Inden-Hillert-Jarl-Qing-Xiong magnetic model, AFF=0\n! CT 4 CTA 4 Curie T\n! NT 5 NTA 5 Neel T\n! BMAGN 3 BMAG 3 Aver. Bohr magneton num\n! GEIN Einstein low T vibrational energy \n! LNTH 7 LNTH 2 Einstein T\n! LIQ2STATE Merging amorphous low T phase and liguid\n! LNTH 7 LNTH 2 Einstein T for amorph.\n! GD 16 G2 6 Melting energy of amorph\n! FCC4PERM\n! BCC4PERM\n! FCC4PERM\n! FCC4PERM\n!==================================================\n! For the moment we have 9 models ...?\n INTEGER, parameter :: gtp_xtdbcompatibility_version=1\n type gtp_xtdbcompatibility\n character(len=:), allocatable :: modelid\n! this character has the MPID used in the xtdb file\n character*8, dimension(:), allocatable :: mpid\n integer nmpid\n! this character has the default MPID used by oc\n character*8, dimension(:), allocatable :: ocmpid\n integer, dimension(:), allocatable :: ocix\n end type gtp_xtdbcompatibility\n type(gtp_xtdbcompatibility), dimension(:), allocatable :: xtdbmodel\n integer, parameter :: nxtdbmpids=9\n!\n!-------------------------- old below\n! Models accepted by OC in the AmendPhase tag\n integer, parameter ::noofmodels=5\n character (len=16), dimension(noofmodels), parameter :: amphmodel=&\n! 8 123456789.123456---123456789.123456---123456789.123456\n ['IHJBCC ','IHJREST ','IHJQX ',&\n 'GEIN ','LIQ2STATE ']\n! Permutations accepted by OC in the AmendPhase tag\n integer, parameter :: noofpermut=2\n character (len=16), dimension(noofpermut), parameter :: amphpermut=&\n ['FCC4PERM ','BCC4PERM ']\n!\n! IHJBCC 1 Inden-Hillert-Jarl for BCC with Aff=-1\n! IHJREST 1 Inden-Hillert-Jarl for other with Aff=-3\n! IHJQX 2 Inden-Hillert-Jarl-Qing-Xiong with Aff=0\n! GEIN 4 Einstein low T \n! LIQ2STATE 5 Liquid 2 state model\n! VLOWP1 7 Low P volome model according to Lu?\n!\n! These have no parameters and are treated in another way\n! DISORDEREDPART same as TDB file DISORDERED_PART and NEVER\n! FCC4PERM FCC symmetric tetrahedron permutations\n! BCC4PERM BCC asymmetric tetrahedron permutations\n! EEC Equi Entropy Criterion is set by Delfaults\n! EBEF Effective Bond Energy Formalism may use \"species@sublattice\"\n!\n!--------------- end of old\n\n!=========================================================\n! Predefined functions in TPfuns\n integer, parameter :: predeftpfun=5\n character*8, dimension(predeftpfun), parameter :: nottpfun= &\n ['LN ','LOG ','EXP ','ERF ','GEIN ']\n! LN and LOG is the same thing, LOG10 is not used. \n! TPfun have these hardcoded in xmlmake\n!\n!========================================================= \n! There is a need to handle the Model feature of XTDB with different\n! software and data structure in applocation software. The data structures\n! here and below is for temporary use reading xtdb file\n!========================================================\n!\n type const\n! list of constituents in each sublattice of a phase, used in phnest\n character (len=:), allocatable :: subx\n character (len=:), allocatable :: list\n end type const\n! type(const), allocatable, target :: constrec\n type phnest\n! all data needed to create the phase record before entering parameters\n integer ncon\n character*1 state\n character (len=:), allocatable :: id\n character (len=:), allocatable :: confent\n! when reading Noof here one allocates the dimension of clist !!\n character (len=:), allocatable :: Noof\n! The mult remain character until the phase recond is allocated\n character (len=:), allocatable :: mult\n! for each sublattice clist will be allocated with the constituents! \n! Each array element can have a differnt number of characters!!\n type(const), dimension(:), pointer :: clist \n character (len=:), allocatable :: crystal\n! The model Id is the amendph\n character (len=:), allocatable :: amendph\n! this is the attributes from the XTDB file for disordered part\n! disordered phase, sublattices to sum and if subtract ordered as disordered\n character (len=:), allocatable :: dispar\n end type phnest\n type(phnest), allocatable :: phrec\n!\n! Attributes for AppendXTDB files. The *appy indicate if todo (-1) or done 1\n character*64 modelappx,parappx,tpfunappx,biblioappx,miscappx\n integer modelappy,parappy,tpfunappy,biblioappy,miscappy,allappy\n!\n \n!------------------------------------------------------------\n! global parameter copied from modile xtdblib in xtdbread.F90 itself\n!\n!\n! used positions in attpos ?? line number in current file\n integer attpos,fline\n! maximum number of nested tags\n integer, parameter :: maxlevels=10,commenttag=999\n! tagnest(level) is negative, -tagno, if more attributes for tagno to read \n integer, dimension(maxlevels) :: tagnest\n! tagnames have max length 18, the endoftag is set to ''\n character(len=21), dimension(maxlevels) :: endoftag\n! \n! an expression will be concatinated from TPfun/Trange and Parameter/Trange tags\n character(len=:), allocatable :: wholexpr\n\n character(len=:), allocatable :: cc\n\n! set to .true. when reading subsets of the XTDB file\n logical ignorEOT\n\n! TPfuns are used in parameters. All TPfun for entered parameters must be found\n integer, parameter :: maxtpfun=500\n integer ntp,missingtp,missingbib\n! alltpfun are names of all tpfuns missing or entered\n\n! the extracted data for software stored in these records\n! these integers are the last entered element, species etc.\n! integer nselel,nselsp,nselph,nselpar,nseltp,nselbib\n! nselph already defined in gtp3\n integer nselel,nselsp,nselpar,nseltp,nselbib\n\n type ocelement\n character*2 elname\n character(len=:), allocatable :: data\n end type ocelement\n type(ocelement), dimension(:), allocatable :: selel\n \n type ocspecies\n character*24 species\n character(len=:), allocatable :: data\n character*2, dimension(:), allocatable :: elnames\n double precision, dimension(:), allocatable :: stoicc\n! electric charge\n double precision :: charge\n! mqmqa or uniquac\n character(len=:), allocatable :: extra\n end type ocspecies\n type(ocspecies), dimension(:), allocatable :: selsp\n! this array will have the selsp indices in alpahetical order\n integer, dimension(:), allocatable :: selspord\n \n type ocphases\n character*24 phasename\n integer nsublat\n! in this array only selected constituents are entered\n character(len=:), allocatable :: mult\n character(len=:), allocatable :: const\n character(len=:), allocatable :: confent\n character(len=:), allocatable :: amendph\n character(len=:), allocatable :: dispar\n character(len=:), allocatable :: data\n type(octerxpol), pointer :: terxpol\n end type ocphases\n type(ocphases), dimension(:), allocatable :: selph\n\n type ocxparam\n character*64 parname\n character(len=:), allocatable :: data\n end type ocxparam\n type(ocxparam), dimension(:), allocatable :: selpar\n \n type octpfun\n character*16 tpfunname\n character(len=:), allocatable :: data\n! seltp(*)%tatus is negative if missing\n integer status\n end type octpfun\n type(octpfun), dimension(:), allocatable :: seltpfun\n \n type ocbib\n character*8 bibitem\n character(len=:), allocatable :: data\n integer status\n end type ocbib\n type(ocbib), dimension(:), allocatable :: selbib\n\n character(len=:), allocatable :: defaultbib\n\n type octerxpol\n! ternary extrapolation linked from the phase\n! The ternaryXpol tags with selected constituents are stored in these records.\n! If the phase is already selected they are added to the texpol list\n! otherwise kept in the firstxpol list until the phase is entered\n character(len=:), allocatable :: phase\n character(len=:), allocatable :: sps\n character(len=:), allocatable :: xpol\n type(octerxpol), pointer :: next\n end type octerxpol\n logical debug\n\n! this is the start of a linked list of ternary extrapolations\n! waiting for the phase to be selected. Typically it contains TernaryXpol\n! what are defined inside the Phase tag itself\n type(octerxpol), pointer :: firstxpol,lastxpol,xpol\n\n! When first phase entered we must not enter more elements/species\n logical nomorelements\n! for dimensioning these arrays and amount used\n integer maxtdbel, maxtdbsp, maxtdbph, maxpar, maxtp, maxbib\n\n \n" }, { "path": "src/models/ocparam.F90", "content": "\nMODULE OCPARAM\n\t\nIMPLICIT NONE\n!\\begin{verbatim}\n!----------------------------------------------------------------------\n! Version numbers\n!----------------------------------------------------------------------\n! version number of GTP (not OC)\ncharacter*8, parameter :: gtpversion='GTP-3.31'\n! THIS MUST BE CHANGED WHENEVER THE UNFORMATTED FILE FORMAT CHANGES!!!\ncharacter*8, parameter :: savefile='OCF-3.20'\n!\n!----------------------------------------------------------------------\n!\n! Parameters defining the size of arrays etc.\n! max elements, species, phases, sublattices, constituents (ideal phase)\n! NOTE increasing maxph to 600 and maxtpf to 80*maxph made the equilibrium\n! record very big and created problems storing equilibria at STEP/MAP!!!\ninteger, parameter :: maxel=100,maxsp=1000,maxph=600,maxsubl=10,maxconst=1000\n! maximum number of constituents in non-ideal phase\ninteger, parameter :: maxcons2=300\n! maximum number of elements in a species\ninteger, parameter :: maxspel=10\n! maximum number of references\ninteger, parameter :: maxrefs=1000\n! maximum number of equilibria\ninteger, parameter :: maxeq=900\n! some dp values, default precision of Y and default minimum value of Y\n! zero and one set in tpfun\ndouble precision, parameter :: YPRECD=1.0D-6,YMIND=1.0D-30\n! dimension for push/pop in calcg, max composition dependent interaction\ninteger, parameter :: maxpp=1000,maxinter=3\n! max number of TP symbols, TOO BIG VALUE MAKES SAVE AT STEP/MAP DIFFICULT\ninteger, parameter :: maxtpf=20*maxph\n! integer, private, parameter :: maxtpf=80*maxph\n! max number of properties (G, TC, BMAG MQ%(...) etc)\ninteger, parameter :: maxprop=50\n! max number of state variable functions\ninteger, parameter :: maxsvfun=500\n\ndouble precision, parameter :: zero=0.0D0,one=1.0D0,two=2.0D0,ten=1.D1\n\n\n!----------------------------------------------------------------------\n! Numerical parameters\n!----------------------------------------------------------------------\ninteger, parameter :: default_splitsolver = 0\n! 1 to allow to split the linear system when conditions leads to square matrix\ninteger, parameter :: default_precondsolver = 0\n! 1 to allow to use a Jacobi preconditionner for solving the linear system\n!\n!----------------------------------------------------------------------\n! convergence criteria used in matsmin.F90\n!----------------------------------------------------------------------\n!\n!!!!!!!\n!! meq_phaseset subroutine\n!!!!!!!\ninteger, parameter :: default_nochange = 4\n! minimum number of iterations between a change of the set of stable phases\n! should not be smaller than default_minadd/default_minrem\ninteger, parameter :: default_minadd=4\ninteger, parameter :: default_minrem=4\n!\ndouble precision, parameter :: default_addchargedphase = 1.D-2\n!Used to verify: charge(phase) > 1.0D-2\n!That is, checking that the phase to be added does not have a net charge\n!\n!!!!!!!\n!! meq_sameset subroutine\n!!!!!!!\ninteger, parameter :: default_typechangephaseamount = 0\n! By default, 0 leads to default_scalechangephaseamount=1.0\n! 1 leads to default_scalechangephaseamount=sum of prescribed conditions -/+ 1\n! 2 leads to default_scalechangephaseamount=max of (1, max of prescribed conditions)\n\ndouble precision, parameter :: default_scalechangephaseamount = 1.0\n! scale all changes in phase amount with total number of atoms. By default,\n! assume this is unity.\n\n\ndouble precision, parameter :: default_ylow = 1.D-3\n! parameter added to avoid too drastic jumps in small site fractions\n! normalizing factor, if y < ylow ....\n!\ndouble precision, parameter :: default_ymin = 1.D-12\n! parameter added to avoid too drastic jumps in small site fractions\n!\ndouble precision, parameter :: default_ymingas = 1.D-30\n! parameter added for gases, since the phase one must allow smaller\n! constituent fracs normalizing factor, if y < critymingas then y = cirtymingas\n!\ndouble precision, parameter :: default_ionliqyfact = 3.D-1\n! this is an emergecy fix to improve convergence for ionic liquid\n! correction to site fractions in ionic liquids\n!\ndouble precision, parameter :: default_deltaTycond=2.5D1\n! this is set each time the set of phases changes, controls change in T\n! when there is a condition on y\n!\ninteger, parameter :: default_nophasechange = 100\n!Criterion on the maximum number of iterations that should go by with \n! no change in the set of phases. That is, the system should have at least\n! one phase change every default_nophasechange iterations\n!\ndouble precision, parameter :: default_maxphaseamountchange = 1.0E-10\n!Criterion on the minimum of amount of phase change (DeltaN) vis-a-vis \n! slow convergence. That is, if the set of stable phases doesn't change, \n! and the change in stable phases is lower than default_maxphaseamountchange, \n! then this is considered a 'slow convergence case'\n!\ndouble precision, parameter :: default_bigvalues = 1.0D+50\n!Criterion on the maximum element of smat matrix\n! Most probably, if something in smat is bigger than default_bigvalues,\n! a calculation error has occurred\ndouble precision, parameter :: default_minimalchangesT = 1.0D-2\n! minimal change in Temperature allowed when Temperature is variable\n!\ndouble precision, parameter :: default_limitchangesT = 0.2D0\ndouble precision, parameter :: default_deltaT = 1.0D1\n!modified xconv criterion CHECK\n!Used to verify: DeltaT > default_delatT*%xconv (converged = 8)\n!Case where T is variable\n!\ndouble precision, parameter :: default_limitchangesP = 0.2D0\ndouble precision, parameter :: default_deltaP = 1.0D4\n!modified xconv criterion CHECK\n!Used to verify: DeltaP > default_deltaP*%xconv (converged = 8)\n!Case where P is variable\n!\ndouble precision, parameter :: default_minimalchangesP = 1.0D-2\n! minimal change in Pressure allowed when Pressure is variable\n!\ndouble precision, parameter :: default_chargefact = 1.0\n! term added to the correction in site fraction due to electric charge\n!\ninteger, parameter :: default_noremove=3\n!Criterion on the minimum number of iterations with\n! N-DeltaN<0 Before removing the phase in question\n! That is, the phase must have a negative quantity for default_noremove\n! iterations before being removed\n!\ndouble precision, parameter :: default_yvar1 = 1.0D-4\n! first limitation to change in site fraction\n!\ndouble precision, parameter :: default_yvar2 = 1.0D-13\n! second limitation to change in site fraction\n!\ndouble precision, parameter :: default_upperyvar1 = 1.0D-3\n! limitation to change in site fraction\n! normalizing factor, if yvar1 > default_upperyvar1 ....\n! then yvar1 = default_upperyvar1\n!\ndouble precision, parameter :: default_upperyvar2 = 1.0D-13\n! limitation to change in site fraction\n! normalizing factor, if yvar2 > default_upperyvar2 ....\n! then yvar2 = default_upperyvar2\n!\ndouble precision, parameter :: default_correctionfactorYS = 1.0D1\n!multiplier in a criterion\n!Used to verify:\n!|Delta y(phase, constituent)(recursion =k)| >\n! default_correctionfactorYS*|Delta y(phase, constituent)(recursion =k-1)|\n! (converged = 3)\n!\ndouble precision, parameter :: default_correctionfactorXCONV = 1.0D2\n!multiplier in a criterion CHECK\n!Used to verify: In an unstable phase:\n! Delta y(phase, constituent) > default_correctionfactorXCONV*%xconv(converged = 4)\n!\ndouble precision, parameter :: default_correctionfactorDGM = 1.0\n!default_correctionfactorDGM criterion\n!Used to verify:\n! dgm(recursion=k) - dgm(recursion=k-1) > default_correctionfactorDGM\n! *gdconv(1) (converged = 4)\n!Case where more than 10 constituents in the phases are present,\n! (apparently) warranting a bigger gdconv(1)\n!\ndouble precision, parameter :: default_upperycormax2 = 1.0D-4\n! check on max stepsize, determining whether or not it is too small\n!\ninteger, parameter :: default_minimaliterations = 4\n!Criterion on the minimum number of iterations for the code as a whole\n!\n!!!!!!!\n!! userif/pmon6.F90, gtp3A.F90 Fortran files\n!!!!!!!\ndouble precision, parameter :: default_maxiter = 500\n! default maximum number of iteration\n!\ndouble precision, parameter :: default_xconv = 1.D-6\ndouble precision, parameter :: default_minxconv = 1.D-30\n! default and minimal values for ceq%xconv criterion\n!\ndouble precision, parameter :: default_mingdconv = 1.D-5\ndouble precision, parameter :: default_gdconv1 = 4.D-3\ndouble precision, parameter :: default_gdconv2 = 0.D0\n! default and minimal value for ceq%gdconv(1) criterion\n!\ndouble precision, parameter :: default_mingridmin = -1.D-2\n! minimal value for ceq%gmindif criterion\n!\n\n!----------------------------------------------------------------------\n! Physical parameters\n!----------------------------------------------------------------------\ndouble precision, parameter :: PI = 3.141592653589793D0\n!\\end{verbatim}\n\nEND MODULE OCPARAM\n\n" }, { "path": "src/numlib/minpack1.F90", "content": "! This extract from MINPACK contains:\n! LMDIF1: least square routine\n! HYBRD1: solving systems of non-linear equations\n! and some support routines\n! and calfun calling OC for assessment_calfun for optimization\n!\n!MODULE LIBOCEQPLUS\n!\nMODULE MINPACK\n!\n! use liboceq\n! use minpack2\n!\n!\n! Minpack Copyright Notice (1999) University of Chicago. All rights reserved\n! \n! Redistribution and use in source and binary forms, with or\n! without modification, are permitted provided that the\n! following conditions are met:\n! \n! 1. Redistributions of source code must retain the above\n! copyright notice, this list of conditions and the following\n! disclaimer.\n! \n! 2. Redistributions in binary form must reproduce the above\n! copyright notice, this list of conditions and the following\n! disclaimer in the documentation and/or other materials\n! provided with the distribution.\n! \n! 3. The end-user documentation included with the\n! redistribution, if any, must include the following\n! acknowledgment:\n! \n! \"This product includes software developed by the\n! University of Chicago, as Operator of Argonne National\n! Laboratory.\n! \n! Alternately, this acknowledgment may appear in the software\n! itself, if and wherever such third-party acknowledgments\n! normally appear.\n! \n! 4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED \"AS IS\"\n! WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE\n! UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND\n! THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR\n! IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES\n! OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE\n! OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY\n! OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR\n! USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF\n! THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4)\n! DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION\n! UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL\n! BE CORRECTED.\n! \n! 5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT\n! HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF\n! ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT,\n! INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF\n! ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF\n! PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER\n! SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT\n! (INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE,\n! EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE\n! POSSIBILITY OF SUCH LOSS OR DAMAGES.\n!\n implicit none\n double precision, parameter, private :: zero=0.0d0\n!\ncontains\n!\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine lmdif1(fcn,m,n,x,fvec,tol,info,nfev,iwa,wa,lwa,fjac,err0)\n! call modified by Bo Sundman 2017, modified again 2018 to include fcn\n! nfev is number of calls to fcn\n! subroutine lmdif1( m,n,x,fvec,tol,info,nfev,iwa,wa,lwa,fjac,err0)\n! original:\n! subroutine lmdif1(fcn,m,n,x,fvec,tol,info, iwa,wa,lwa)\n implicit none\n integer m,n,info,lwa\n integer iwa(n)\n double precision tol\n double precision x(n),fvec(m),wa(lwa),fjac(m,*)\n external fcn\n! **********\n!\n! subroutine lmdif1\n!\n! the purpose of lmdif1 is to minimize the sum of the squares of\n! m nonlinear functions in n variables by a modification of the\n! levenberg-marquardt algorithm. this is done by using the more\n! general least-squares solver lmdif. the user must provide a\n! subroutine which calculates the functions. the jacobian is\n! then calculated by a forward-difference approximation.\n!\n! the subroutine statement is\n!\n! subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(m,n,x,fvec,iflag)\n! modified to include iterations: subroutine fcn(m,n,x,fvec,iflag,nfev)\n! integer m,n,iflag,nfev\n! double precision x(n),fvec(m)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ----------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of lmdif1.\n! in this case set iflag to a negative integer.\n!\n! m is a positive integer input variable set to the number\n! of functions.\n!\n! n is a positive integer input variable set to the number\n! of variables. n must not exceed m.\n!\n! x is an array of length n. on input x must contain\n! an initial estimate of the solution vector. on output x\n! contains the final estimate of the solution vector.\n!\n! fvec is an output array of length m which contains\n! the functions evaluated at the output x.\n!\n! tol is a nonnegative input variable. termination occurs\n! when the algorithm estimates either that the relative\n! error in the sum of squares is at most tol or that\n! the relative error between x and the solution is at\n! most tol.\n!\n! info is an integer output variable. if the user has\n! terminated execution, info is set to the (negative)\n! value of iflag. see description of fcn. otherwise,\n! info is set as follows.\n!\n! info = 0 improper input parameters.\n!\n! info = 1 algorithm estimates that the relative error\n! in the sum of squares is at most tol.\n!\n! info = 2 algorithm estimates that the relative error\n! between x and the solution is at most tol.\n!\n! info = 3 conditions for info = 1 and info = 2 both hold.\n!\n! info = 4 fvec is orthogonal to the columns of the\n! jacobian to machine precision.\n!\n! info = 5 number of calls to fcn has reached or\n! exceeded 200*(n+1).\n!\n! info = 6 tol is too small. no further reduction in\n! the sum of squares is possible.\n!\n! info = 7 tol is too small. no further improvement in\n! the approximate solution x is possible.\n!\n! iwa is an integer work array of length n.\n!\n! wa is a work array of length lwa.\n!\n! lwa is a positive integer input variable not less than\n! m*n+5*n+m.\n!\n! fjac added to calculate relative standard deviation (SD)\n!\n! subprograms called\n!\n! user-supplied ...... fcn\n!\n! minpack-supplied ... lmdif\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer maxfev,mode,mp5n,nfev,nprint\n! double precision epsfcn,factor,ftol,gtol,xtol,zero\n! err0 contains intitial sum of error and last sum of errors\n double precision epsfcn,ftol,gtol,xtol,err0(*)\n! data factor,zero /1.0d2,0.0d0/\n! zero already defined globally\n double precision :: factor=1.0D2,zero=0.0D0\n! number of iterations passed through infor\n maxfev=info\n info = 0\n! write(*,*)'in lmdif1',maxfev,m,n\n!\n! check the input parameters for errors.\n!\n if (n .le. 0 .or. m .lt. n .or. tol .lt. zero &\n .or. lwa .lt. m*n + 5*n + m) then\n write(*,12)n,m,lwa,m*n+5*n+m,tol\n12 format(' *** LMDIF1 error: illegal call: ',4i6,1pe12.4)\n go to 10\n endif\n!\n! call lmdif.\n!\n info=0\n! several of these moved to lmdif ... as well as allocating workspace\n ftol = tol\n xtol = tol\n gtol = zero\n epsfcn = zero\n mode = 1\n! This controls output during optimization, output must be added to calfun\n! nprint = 0\n nprint=1\n mp5n = m + 5*n\n! write(*,*)'Calling lmdif1',maxfev\n! call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), &\n! mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, &\n! wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))\n! remove fcn and reduce number of arguments and linker chokes ...\n! write(*,*)'minpack: lmdif1 call lmdif',m,n\n call lmdif(fcn,m,n,x,fvec,tol,maxfev, &\n mode,factor,nprint,info,nfev,fjac,iwa,err0)\n! call lmdif(m,n,x,fvec,tol,maxfev, &\n! mode,factor,nprint,info,nfev,fjac,iwa,err0)\n if (info .eq. 8) info = 4\n! write(*,*)'Return from lmdif with info= ',info\n10 continue\n return\n!\n! last card of subroutine lmdif1.\n!\n end subroutine lmdif1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n! subroutine fdjac2(m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)\n subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)\n implicit none\n integer m,n,ldfjac,iflag\n double precision epsfcn\n double precision x(n),fvec(m),fjac(ldfjac,n),wa(m)\n! **********\n!\n! subroutine fdjac2\n!\n! this subroutine computes a forward-difference approximation\n! to the m by n jacobian matrix associated with a specified\n! problem of m functions in n variables.\n!\n! the subroutine statement is\n!\n! subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(m,n,x,fvec,iflag)\n! BOSSE modified to include iterations: subroutine fcn(m,n,x,fvec,iflag,nfevdum)\n! integer m,n,iflag,niter\n! double precision x(n),fvec(m)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ----------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of fdjac2.\n! in this case set iflag to a negative integer.\n!\n! m is a positive integer input variable set to the number\n! of functions.\n!\n! n is a positive integer input variable set to the number\n! of variables. n must not exceed m.\n!\n! x is an input array of length n.\n!\n! fvec is an input array of length m which must contain the\n! functions evaluated at x.\n!\n! fjac is an output m by n array which contains the\n! approximation to the jacobian matrix evaluated at x.\n!\n! ldfjac is a positive integer input variable not less than m\n! which specifies the leading dimension of the array fjac.\n!\n! iflag is an integer variable which can be used to terminate\n! the execution of fdjac2. see description of fcn.\n!\n! epsfcn is an input variable used in determining a suitable\n! step length for the forward-difference approximation. this\n! approximation assumes that the relative errors in the\n! functions are of the order of epsfcn. if epsfcn is less\n! than the machine precision, it is assumed that the relative\n! errors in the functions are of the order of the machine\n! precision.\n!\n! wa is a work array of length m.\n!\n! subprograms called\n!\n! user-supplied ...... fcn\n!\n! minpack-supplied ... dpmpar\n!\n! fortran-supplied ... dabs,dmax1,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j\n double precision eps,epsmch,h,temp\n! double precision eps,epsmch,h,temp,zero\n! integer, parameter :: niter=0\n! added as argumnet added to fcn but treated as dummy in fcn ...\n integer :: nfevdum=-100\n! missing external declaration\n external fcn\n! double precision dpmpar\n! data zero /0.0d0/\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n eps = dsqrt(dmax1(epsfcn,epsmch))\n! write(*,17)'epsis: ',0,epsfcn,epsmch,eps\n! eps=1.0D-4\n! do 20 j = 1, n\n do j = 1, n\n temp = x(j)\n h = eps*dabs(temp)\n if (h .eq. zero) h = eps\n! write(*,17)'In fdjac2: ',j,temp,h,eps\n!17 format(a,i2,6(1pe12.4))\n x(j) = temp + h\n! call fcn(m,n,x,wa,iflag) <<<<<<<<<<<< original\n! NOTE dummy should be ignored when -100 in fcn (CALFUN)\n call fcn(m,n,x,wa,iflag,nfevdum)\n! call calfun(m,n,x,wa,iflag,niter)\n if (iflag .lt. 0) go to 30\n x(j) = temp\n! do 10 i = 1, m\n do i = 1, m\n fjac(i,j) = (wa(i) - fvec(i))/h\n enddo\n enddo\n! 10 continue\n! 20 continue\n30 continue\n return\n!\n! last card of subroutine fdjac2.\n!\n end subroutine fdjac2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n! subroutine lmdif(m,n,x,fvec,xtol,maxfev, &\n subroutine lmdif(fcn,m,n,x,fvec,xtol,maxfev, &\n mode,factor,nprint,info,nfev,fjac,ipvt,err0)\n! removed arguments as linker chokes ...\n! subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,diag, &\n! mode,factor,nprint,info,nfev,fjac,ldfjac, &\n! ipvt,qtf,wa1,wa2,wa3,wa4)\n implicit none\n integer m,n,maxfev,mode,nprint,info,nfev,ldfjac\n integer ipvt(n)\n double precision ftol,xtol,gtol,epsfcn,factor,err0(*)\n double precision x(n),fvec(m),fjac(m,*)\n! double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), &\n! double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), &\n! wa1(n),wa2(n),wa3(n),wa4(m)\n external fcn\n! **********\n double precision, dimension(:), allocatable :: diag,qtf,wa1,wa2,wa3,wa4\n! double precision, dimension(:,:), allocatable :: fjac\n!\n! subroutine lmdif\n!\n! the purpose of lmdif is to minimize the sum of the squares of\n! m nonlinear functions in n variables by a modification of\n! the levenberg-marquardt algorithm. the user must provide a\n! subroutine which calculates the functions. the jacobian is\n! then calculated by a forward-difference approximation.\n!\n! the subroutine statement is\n!\n! subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,\n! diag,mode,factor,nprint,info,nfev,fjac,\n! ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(m,n,x,fvec,iflag)\n! modified to iiterations: subroutine fcn(m,n,x,fvec,iflag,niter)\n! integer m,n,iflag,niter\n! double precision x(n),fvec(m)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ----------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of lmdif.\n! in this case set iflag to a negative integer.\n!\n! m is a positive integer input variable set to the number\n! of functions.\n!\n! n is a positive integer input variable set to the number\n! of variables. n must not exceed m.\n!\n! x is an array of length n. on input x must contain\n! an initial estimate of the solution vector. on output x\n! contains the final estimate of the solution vector.\n!\n! fvec is an output array of length m which contains\n! the functions evaluated at the output x.\n!\n! ftol is a nonnegative input variable. termination\n! occurs when both the actual and predicted relative\n! reductions in the sum of squares are at most ftol.\n! therefore, ftol measures the relative error desired\n! in the sum of squares.\n!\n! xtol is a nonnegative input variable. termination\n! occurs when the relative error between two consecutive\n! iterates is at most xtol. therefore, xtol measures the\n! relative error desired in the approximate solution.\n!\n! gtol is a nonnegative input variable. termination\n! occurs when the cosine of the angle between fvec and\n! any column of the jacobian is at most gtol in absolute\n! value. therefore, gtol measures the orthogonality\n! desired between the function vector and the columns\n! of the jacobian.\n!\n! maxfev is a positive integer input variable. termination\n! occurs when the number of calls to fcn is at least\n! maxfev by the end of an iteration.\n!\n! epsfcn is an input variable used in determining a suitable\n! step length for the forward-difference approximation. this\n! approximation assumes that the relative errors in the\n! functions are of the order of epsfcn. if epsfcn is less\n! than the machine precision, it is assumed that the relative\n! errors in the functions are of the order of the machine\n! precision.\n!\n! diag is an array of length n. if mode = 1 (see\n! below), diag is internally set. if mode = 2, diag\n! must contain positive entries that serve as\n! multiplicative scale factors for the variables.\n!\n! mode is an integer input variable. if mode = 1, the\n! variables will be scaled internally. if mode = 2,\n! the scaling is specified by the input diag. other\n! values of mode are equivalent to mode = 1.\n!\n! factor is a positive input variable used in determining the\n! initial step bound. this bound is set to the product of\n! factor and the euclidean norm of diag*x if nonzero, or else\n! to factor itself. in most cases factor should lie in the\n! interval (.1,100.). 100. is a generally recommended value.\n!\n! nprint is an integer input variable that enables controlled\n! printing of iterates if it is positive. in this case,\n! fcn is called with iflag = 0 at the beginning of the first\n! iteration and every nprint iterations thereafter and\n! immediately prior to return, with x and fvec available\n! for printing. if nprint is not positive, no special calls\n! of fcn with iflag = 0 are made.\n!\n! info is an integer output variable. if the user has\n! terminated execution, info is set to the (negative)\n! value of iflag. see description of fcn. otherwise,\n! info is set as follows.\n!\n! info = 0 improper input parameters.\n!\n! info = 1 both actual and predicted relative reductions\n! in the sum of squares are at most ftol.\n!\n! info = 2 relative error between two consecutive iterates\n! is at most xtol.\n!\n! info = 3 conditions for info = 1 and info = 2 both hold.\n!\n! info = 4 the cosine of the angle between fvec and any\n! column of the jacobian is at most gtol in\n! absolute value.\n!\n! info = 5 number of calls to fcn has reached or\n! exceeded maxfev.\n!\n! info = 6 ftol is too small. no further reduction in\n! the sum of squares is possible.\n!\n! info = 7 xtol is too small. no further improvement in\n! the approximate solution x is possible.\n!\n! info = 8 gtol is too small. fvec is orthogonal to the\n! columns of the jacobian to machine precision.\n!\n! nfev is an integer output variable set to the number of\n! calls to fcn.\n!\n! fjac is an output m by n array. the upper n by n submatrix\n! of fjac contains an upper triangular matrix r with\n! diagonal elements of nonincreasing magnitude such that\n!\n! t t t\n! p *(jac *jac)*p = r *r,\n!\n! where p is a permutation matrix and jac is the final\n! calculated jacobian. column j of p is column ipvt(j)\n! (see below) of the identity matrix. the lower trapezoidal\n! part of fjac contains information generated during\n! the computation of r.\n!\n! ldfjac is a positive integer input variable not less than m\n! which specifies the leading dimension of the array fjac.\n!\n! ipvt is an integer output array of length n. ipvt\n! defines a permutation matrix p such that jac*p = q*r,\n! where jac is the final calculated jacobian, q is\n! orthogonal (not stored), and r is upper triangular\n! with diagonal elements of nonincreasing magnitude.\n! column j of p is column ipvt(j) of the identity matrix.\n!\n! qtf is an output array of length n which contains\n! the first n elements of the vector (q transpose)*fvec.\n!\n! wa1, wa2, and wa3 are work arrays of length n.\n!\n! wa4 is a work array of length m.\n!\n! subprograms called\n!\n! user-supplied ...... fcn\n!\n! minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac\n!\n! fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,iflag,iter,j,l\n double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, &\n par,pnorm,prered,ratio, &\n sum,temp,temp1,temp2,xnorm,bosum\n! removed variables one line above \n! one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, &\n! if the functions dpmpar and enorm are declared here strange link error ...\n! double precision dpmpar,enorm\n! data one,p1,p5,p25,p75,p0001,zero &\n! /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/\n double precision :: one=1.0D0\n double precision :: p1=1.0D-1,p5=5.0D-1,p25=2.5D-1,p75=7.5D-1,p0001=1.0D-4\n!\n! write(*,*)'minpack: in lmdif A: ',n,m\n! replace removed arguments\n ldfjac=m\n ftol=xtol\n gtol=zero\n epsfcn=zero\n allocate(diag(n)) \n allocate(qtf(n)) \n allocate(wa1(n))\n allocate(wa2(n))\n allocate(wa3(n))\n allocate(wa4(m))\n! now included in call\n! allocate(fjac(ldfjac,n))\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n info = 0\n iflag = 0\n nfev = 0\n!\n! check the input parameters for errors.\n!\n! modified to run once if maxfev=0 (dry run)\n! write(*,*)'In lmdif C: maxfev=',maxfev,m,n\n if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m &\n .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero &\n .or. maxfev .lt. 0 .or. factor .le. zero) go to 300\n if (mode .ne. 2) go to 20\n do j = 1, n\n if (diag(j) .le. zero) go to 300\n enddo\n! 10 continue\n20 continue\n!\n! evaluate the function at the starting point\n! and calculate its norm.\n!\n iflag = 1\n! call fcn(m,n,x,fvec,iflag) <<<<<<<<<<< original\n! call calfun(m,n,x,fvec,iflag,nfev)\n! write(*,*)'minpack: lmdif call fcn 1: ',n,m\n call fcn(m,n,x,fvec,iflag,nfev)\n! calculate intial sum of errors\n! write(*,*)'lmdif back from calfun',nfev\n bosum=zero\n do j=1,m\n bosum=bosum+fvec(j)**2\n enddo\n err0(1)=bosum\n!--------------------------\n nfev = 1\n if (iflag .lt. 0) go to 300\n if(maxfev .eq. 0) goto 300\n fnorm = enorm(m,fvec)\n!\n! initialize levenberg-marquardt parameter and iteration counter.\n!\n par = zero\n iter = 1\n!\n! beginning of the outer loop.\n!\n30 continue\n!\n! calculate the jacobian matrix.\n!\n iflag = 2\n! write(*,*)'minpack: lmdif call fdjac2 1: ',n,m\n call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)\n! call fdjac2(m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)\n nfev = nfev + n\n if (iflag .lt. 0) go to 300\n!\n! if requested, call fcn to enable printing of iterates.\n!\n if (nprint .le. 0) go to 40\n iflag = 0\n if (mod(iter-1,nprint) .eq. 0) then\n! call calfun(m,n,x,fvec,iflag,nfev)\n! write(*,*)'minpack: lmdif call fcn 3: ',n,m\n call fcn(m,n,x,fvec,iflag,nfev)\n endif\n! if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag)\n if (iflag .lt. 0) go to 300\n40 continue\n!\n! compute the qr factorization of the jacobian.\n!\n call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)\n!\n! on the first iteration and if mode is 1, scale according\n! to the norms of the columns of the initial jacobian.\n!\n if (iter .ne. 1) go to 80\n if (mode .eq. 2) go to 60\n! do 50 j = 1, n\n do j = 1, n\n diag(j) = wa2(j)\n if (wa2(j) .eq. zero) diag(j) = one\n enddo\n! 50 continue\n60 continue\n!\n! on the first iteration, calculate the norm of the scaled x\n! and initialize the step bound delta.\n!\n do j = 1, n\n wa3(j) = diag(j)*x(j)\n enddo\n! 70 continue\n xnorm = enorm(n,wa3)\n delta = factor*xnorm\n if (delta .eq. zero) delta = factor\n80 continue\n!\n! form (q transpose)*fvec and store the first n components in\n! qtf.\n!\n do i = 1, m\n wa4(i) = fvec(i)\n enddo\n!90 continue\n! do 130 j = 1, n\n do j = 1, n\n if (fjac(j,j) .eq. zero) go to 120\n sum = zero\n! do 100 i = j, m\n do i = j, m\n sum = sum + fjac(i,j)*wa4(i)\n enddo\n!100 continue\n temp = -sum/fjac(j,j)\n do i = j, m\n wa4(i) = wa4(i) + fjac(i,j)*temp\n enddo\n! 110 continue\n120 continue\n fjac(j,j) = wa1(j)\n qtf(j) = wa4(j)\n enddo\n!130 continue\n!\n! compute the norm of the scaled gradient.\n!\n gnorm = zero\n if (fnorm .eq. zero) go to 170\n! do 160 j = 1, n\n do j = 1, n\n l = ipvt(j)\n if (wa2(l) .eq. zero) go to 150\n sum = zero\n do i = 1, j\n sum = sum + fjac(i,j)*(qtf(i)/fnorm)\n enddo\n! 140 continue\n gnorm = dmax1(gnorm,dabs(sum/wa2(l)))\n150 continue\n enddo\n!160 continue\n170 continue\n!\n! test for convergence of the gradient norm.\n!\n if (gnorm .le. gtol) info = 4\n if (info .ne. 0) go to 300\n!\n! rescale if necessary.\n!\n if (mode .eq. 2) go to 190\n do j = 1, n\n diag(j) = dmax1(diag(j),wa2(j))\n enddo\n!180 continue\n190 continue\n!\n! beginning of the inner loop.\n!\n200 continue\n!\n! determine the levenberg-marquardt parameter.\n!\n call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, &\n wa3,wa4)\n!\n! store the direction p and x + p. calculate the norm of p.\n!\n! do 210 j = 1, n\n do j = 1, n\n wa1(j) = -wa1(j)\n wa2(j) = x(j) + wa1(j)\n wa3(j) = diag(j)*wa1(j)\n enddo\n!210 continue\n pnorm = enorm(n,wa3)\n!\n! on the first iteration, adjust the initial step bound.\n!\n if (iter .eq. 1) delta = dmin1(delta,pnorm)\n!\n! evaluate the function at x + p and calculate its norm.\n!\n iflag = 1\n! call fcn(m,n,wa2,wa4,iflag)\n! call calfun(m,n,wa2,wa4,iflag,nfev)\n! write(*,*)'minpack: lmdif call fcn 3: ',n,m\n call fcn(m,n,wa2,wa4,iflag,nfev)\n nfev = nfev + 1\n if (iflag .lt. 0) go to 300\n fnorm1 = enorm(m,wa4)\n!\n! compute the scaled actual reduction.\n!\n actred = -one\n if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2\n!\n! compute the scaled predicted reduction and\n! the scaled directional derivative.\n!\n! do 230 j = 1, n\n do j = 1, n\n wa3(j) = zero\n l = ipvt(j)\n temp = wa1(l)\n do i = 1, j\n wa3(i) = wa3(i) + fjac(i,j)*temp\n enddo\n enddo\n!220 continue\n!230 continue\n temp1 = enorm(n,wa3)/fnorm\n temp2 = (dsqrt(par)*pnorm)/fnorm\n prered = temp1**2 + temp2**2/p5\n dirder = -(temp1**2 + temp2**2)\n!\n! compute the ratio of the actual to the predicted\n! reduction.\n!\n ratio = zero\n if (prered .ne. zero) ratio = actred/prered\n!\n! update the step bound.\n!\n if (ratio .gt. p25) go to 240\n if (actred .ge. zero) temp = p5\n if (actred .lt. zero) &\n temp = p5*dirder/(dirder + p5*actred)\n if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1\n delta = temp*dmin1(delta,pnorm/p1)\n par = par/temp\n go to 260\n240 continue\n if (par .ne. zero .and. ratio .lt. p75) go to 250\n delta = pnorm/p5\n par = p5*par\n250 continue\n260 continue\n!\n! test for successful iteration.\n!\n if (ratio .lt. p0001) go to 290\n!\n! successful iteration. update x, fvec, and their norms.\n!\n do j = 1, n\n x(j) = wa2(j)\n wa2(j) = diag(j)*x(j)\n enddo\n!270 continue\n do i = 1, m\n fvec(i) = wa4(i)\n enddo\n!280 continue\n xnorm = enorm(n,wa2)\n fnorm = fnorm1\n iter = iter + 1\n290 continue\n!\n! tests for convergence.\n!\n if (dabs(actred) .le. ftol .and. prered .le. ftol &\n .and. p5*ratio .le. one) info = 1\n if (delta .le. xtol*xnorm) info = 2\n if (dabs(actred) .le. ftol .and. prered .le. ftol &\n .and. p5*ratio .le. one .and. info .eq. 2) info = 3\n if (info .ne. 0) go to 300\n!\n! tests for termination and stringent tolerances.\n!\n if (nfev .ge. maxfev) info = 5\n if (dabs(actred) .le. epsmch .and. prered .le. epsmch &\n .and. p5*ratio .le. one) info = 6\n if (delta .le. epsmch*xnorm) info = 7\n if (gnorm .le. epsmch) info = 8\n if (info .ne. 0) go to 300\n!\n! end of the inner loop. repeat if iteration unsuccessful.\n!\n if (ratio .lt. p0001) go to 200\n!\n! end of the outer loop.\n!\n go to 30\n300 continue\n!\n! termination, either normal or user imposed.\n!\n if (iflag .lt. 0) info = iflag\n iflag = 0\n! write(*,*)'minpack: lmdif call fcn 4: ',n,m,info,maxfev\n if(maxfev.gt.0) then\n! Bosse corrected missing nfev argument 2022.07.12\n if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag,nfev)\n! if (nprint .gt. 0) call calfun(m,n,x,fvec,iflag,-nfev)\n else\n! Add that calfun called once if maxfev=0 to calculate all errors\n! if (maxfev .eq. 0) call calfun(m,n,x,fvec,1,0)\n call fcn(m,n,x,fvec,1,0)\n endif\n! write(*,*)'minpack: lmdif call fcn 5: ',n,m,maxfev\n return\n!\n! last card of subroutine lmdif.\n!\n end subroutine lmdif\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, &\n wa2)\n implicit none\n integer n,ldr\n integer ipvt(n)\n double precision delta,par\n double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), &\n wa2(n)\n! **********\n!\n! subroutine lmpar\n!\n! given an m by n matrix a, an n by n nonsingular diagonal\n! matrix d, an m-vector b, and a positive number delta,\n! the problem is to determine a value for the parameter\n! par such that if x solves the system\n!\n! a*x = b , sqrt(par)*d*x = 0 ,\n!\n! in the least squares sense, and dxnorm is the euclidean\n! norm of d*x, then either par is zero and\n!\n! (dxnorm-delta) .le. 0.1*delta ,\n!\n! or par is positive and\n!\n! abs(dxnorm-delta) .le. 0.1*delta .\n!\n! this subroutine completes the solution of the problem\n! if it is provided with the necessary information from the\n! qr factorization, with column pivoting, of a. that is, if\n! a*p = q*r, where p is a permutation matrix, q has orthogonal\n! columns, and r is an upper triangular matrix with diagonal\n! elements of nonincreasing magnitude, then lmpar expects\n! the full upper triangle of r, the permutation matrix p,\n! and the first n components of (q transpose)*b. on output\n! lmpar also provides an upper triangular matrix s such that\n!\n! t t t\n! p *(a *a + par*d*d)*p = s *s .\n!\n! s is employed within lmpar and may be of separate interest.\n!\n! only a few iterations are generally needed for convergence\n! of the algorithm. if, however, the limit of 10 iterations\n! is reached, then the output par will contain the best\n! value obtained so far.\n!\n! the subroutine statement is\n!\n! subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,\n! wa1,wa2)\n!\n! where\n!\n! n is a positive integer input variable set to the order of r.\n!\n! r is an n by n array. on input the full upper triangle\n! must contain the full upper triangle of the matrix r.\n! on output the full upper triangle is unaltered, and the\n! strict lower triangle contains the strict upper triangle\n! (transposed) of the upper triangular matrix s.\n!\n! ldr is a positive integer input variable not less than n\n! which specifies the leading dimension of the array r.\n!\n! ipvt is an integer input array of length n which defines the\n! permutation matrix p such that a*p = q*r. column j of p\n! is column ipvt(j) of the identity matrix.\n!\n! diag is an input array of length n which must contain the\n! diagonal elements of the matrix d.\n!\n! qtb is an input array of length n which must contain the first\n! n elements of the vector (q transpose)*b.\n!\n! delta is a positive input variable which specifies an upper\n! bound on the euclidean norm of d*x.\n!\n! par is a nonnegative variable. on input par contains an\n! initial estimate of the levenberg-marquardt parameter.\n! on output par contains the final estimate.\n!\n! x is an output array of length n which contains the least\n! squares solution of the system a*x = b, sqrt(par)*d*x = 0,\n! for the output par.\n!\n! sdiag is an output array of length n which contains the\n! diagonal elements of the upper triangular matrix s.\n!\n! wa1 and wa2 are work arrays of length n.\n!\n! subprograms called\n!\n! minpack-supplied ... dpmpar,enorm,qrsolv\n!\n! fortran-supplied ... dabs,dmax1,dmin1,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,iter,j,jm1,jp1,k,l,nsing\n double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, &\n sum,temp,zero\n! double precision dpmpar,enorm\n data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/\n!\n! dwarf is the smallest positive magnitude.\n!\n dwarf = dpmpar(2)\n!\n! compute and store in x the gauss-newton direction. if the\n! jacobian is rank-deficient, obtain a least squares solution.\n!\n nsing = n\n do j = 1, n\n wa1(j) = qtb(j)\n if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1\n if (nsing .lt. n) wa1(j) = zero\n enddo\n! 10 continue\n if (nsing .lt. 1) go to 50\n! do 40 k = 1, nsing\n do k = 1, nsing\n j = nsing - k + 1\n wa1(j) = wa1(j)/r(j,j)\n temp = wa1(j)\n jm1 = j - 1\n if (jm1 .lt. 1) go to 30\n do i = 1, jm1\n wa1(i) = wa1(i) - r(i,j)*temp\n enddo\n!20 continue\n30 continue\n enddo\n!40 continue\n50 continue\n do j = 1, n\n l = ipvt(j)\n x(l) = wa1(j)\n enddo\n!60 continue\n!\n! initialize the iteration counter.\n! evaluate the function at the origin, and test\n! for acceptance of the gauss-newton direction.\n!\n iter = 0\n do j = 1, n\n wa2(j) = diag(j)*x(j)\n enddo\n!70 continue\n dxnorm = enorm(n,wa2)\n fp = dxnorm - delta\n if (fp .le. p1*delta) go to 220\n!\n! if the jacobian is not rank deficient, the newton\n! step provides a lower bound, parl, for the zero of\n! the function. otherwise set this bound to zero.\n!\n parl = zero\n if (nsing .lt. n) go to 120\n do j = 1, n\n l = ipvt(j)\n wa1(j) = diag(l)*(wa2(l)/dxnorm)\n enddo\n!80 continue\n! do 110 j = 1, n\n do j = 1, n\n sum = zero\n jm1 = j - 1\n if (jm1 .lt. 1) go to 100\n do i = 1, jm1\n sum = sum + r(i,j)*wa1(i)\n enddo\n!90 continue\n100 continue\n wa1(j) = (wa1(j) - sum)/r(j,j)\n enddo\n!110 continue\n temp = enorm(n,wa1)\n parl = ((fp/delta)/temp)/temp\n120 continue\n!\n! calculate an upper bound, paru, for the zero of the function.\n!\n! do 140 j = 1, n\n do j = 1, n\n sum = zero\n do i = 1, j\n sum = sum + r(i,j)*qtb(i)\n enddo\n!130 continue\n l = ipvt(j)\n wa1(j) = sum/diag(l)\n enddo\n!140 continue\n gnorm = enorm(n,wa1)\n paru = gnorm/delta\n if (paru .eq. zero) paru = dwarf/dmin1(delta,p1)\n!\n! if the input par lies outside of the interval (parl,paru),\n! set par to the closer endpoint.\n!\n par = dmax1(par,parl)\n par = dmin1(par,paru)\n if (par .eq. zero) par = gnorm/dxnorm\n!\n! beginning of an iteration.\n!\n150 continue\n iter = iter + 1\n!\n! evaluate the function at the current value of par.\n!\n if (par .eq. zero) par = dmax1(dwarf,p001*paru)\n temp = dsqrt(par)\n do j = 1, n\n wa1(j) = temp*diag(j)\n enddo\n!160 continue\n call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2)\n do j = 1, n\n wa2(j) = diag(j)*x(j)\n enddo\n!170 continue\n dxnorm = enorm(n,wa2)\n temp = fp\n fp = dxnorm - delta\n!\n! if the function is small enough, accept the current value\n! of par. also test for the exceptional cases where parl\n! is zero or the number of iterations has reached 10.\n!\n if (dabs(fp) .le. p1*delta &\n .or. parl .eq. zero .and. fp .le. temp &\n .and. temp .lt. zero .or. iter .eq. 10) go to 220\n!\n! compute the newton correction.\n!\n do j = 1, n\n l = ipvt(j)\n wa1(j) = diag(l)*(wa2(l)/dxnorm)\n enddo\n!180 continue\n! do 210 j = 1, n\n do j = 1, n\n wa1(j) = wa1(j)/sdiag(j)\n temp = wa1(j)\n jp1 = j + 1\n if (n .lt. jp1) go to 200\n do i = jp1, n\n wa1(i) = wa1(i) - r(i,j)*temp\n enddo\n!190 continue\n200 continue\n enddo\n!210 continue\n temp = enorm(n,wa1)\n parc = ((fp/delta)/temp)/temp\n!\n! depending on the sign of the function, update parl or paru.\n!\n if (fp .gt. zero) parl = dmax1(parl,par)\n if (fp .lt. zero) paru = dmin1(paru,par)\n!\n! compute an improved estimate for par.\n!\n par = dmax1(parl,par+parc)\n!\n! end of an iteration.\n!\n go to 150\n220 continue\n!\n! termination.\n!\n if (iter .eq. 0) par = zero\n return\n!\n! last card of subroutine lmpar.\n!\n end subroutine lmpar\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)\n implicit none\n integer n,ldr\n integer ipvt(n)\n double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)\n! **********\n!\n! subroutine qrsolv\n!\n! given an m by n matrix a, an n by n diagonal matrix d,\n! and an m-vector b, the problem is to determine an x which\n! solves the system\n!\n! a*x = b , d*x = 0 ,\n!\n! in the least squares sense.\n!\n! this subroutine completes the solution of the problem\n! if it is provided with the necessary information from the\n! qr factorization, with column pivoting, of a. that is, if\n! a*p = q*r, where p is a permutation matrix, q has orthogonal\n! columns, and r is an upper triangular matrix with diagonal\n! elements of nonincreasing magnitude, then qrsolv expects\n! the full upper triangle of r, the permutation matrix p,\n! and the first n components of (q transpose)*b. the system\n! a*x = b, d*x = 0, is then equivalent to\n!\n! t t\n! r*z = q *b , p *d*p*z = 0 ,\n!\n! where x = p*z. if this system does not have full rank,\n! then a least squares solution is obtained. on output qrsolv\n! also provides an upper triangular matrix s such that\n!\n! t t t\n! p *(a *a + d*d)*p = s *s .\n!\n! s is computed within qrsolv and may be of separate interest.\n!\n! the subroutine statement is\n!\n! subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)\n!\n! where\n!\n! n is a positive integer input variable set to the order of r.\n!\n! r is an n by n array. on input the full upper triangle\n! must contain the full upper triangle of the matrix r.\n! on output the full upper triangle is unaltered, and the\n! strict lower triangle contains the strict upper triangle\n! (transposed) of the upper triangular matrix s.\n!\n! ldr is a positive integer input variable not less than n\n! which specifies the leading dimension of the array r.\n!\n! ipvt is an integer input array of length n which defines the\n! permutation matrix p such that a*p = q*r. column j of p\n! is column ipvt(j) of the identity matrix.\n!\n! diag is an input array of length n which must contain the\n! diagonal elements of the matrix d.\n!\n! qtb is an input array of length n which must contain the first\n! n elements of the vector (q transpose)*b.\n!\n! x is an output array of length n which contains the least\n! squares solution of the system a*x = b, d*x = 0.\n!\n! sdiag is an output array of length n which contains the\n! diagonal elements of the upper triangular matrix s.\n!\n! wa is a work array of length n.\n!\n! subprograms called\n!\n! fortran-supplied ... dabs,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,jp1,k,kp1,l,nsing\n double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero\n data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/\n!\n! copy r and (q transpose)*b to preserve input and initialize s.\n! in particular, save the diagonal elements of r in x.\n!\n! do 20 j = 1, n\n do j = 1, n\n do i = j, n\n r(i,j) = r(j,i)\n enddo\n!10 continue\n x(j) = r(j,j)\n wa(j) = qtb(j)\n enddo\n!20 continue\n!\n! eliminate the diagonal matrix d using a givens rotation.\n!\n! do 100 j = 1, n\n do j = 1, n\n!\n! prepare the row of d to be eliminated, locating the\n! diagonal element using p from the qr factorization.\n!\n l = ipvt(j)\n if (diag(l) .eq. zero) go to 90\n do k = j, n\n sdiag(k) = zero\n enddo\n!30 continue\n sdiag(j) = diag(l)\n!\n! the transformations to eliminate the row of d\n! modify only a single element of (q transpose)*b\n! beyond the first n, which is initially zero.\n!\n qtbpj = zero\n! do 80 k = j, n\n do k = j, n\n!\n! determine a givens rotation which eliminates the\n! appropriate element in the current row of d.\n!\n if (sdiag(k) .eq. zero) go to 70\n if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40\n cotan = r(k,k)/sdiag(k)\n sin = p5/dsqrt(p25+p25*cotan**2)\n cos = sin*cotan\n go to 50\n40 continue\n tan = sdiag(k)/r(k,k)\n cos = p5/dsqrt(p25+p25*tan**2)\n sin = cos*tan\n50 continue\n!\n! compute the modified diagonal element of r and\n! the modified element of ((q transpose)*b,0).\n!\n r(k,k) = cos*r(k,k) + sin*sdiag(k)\n temp = cos*wa(k) + sin*qtbpj\n qtbpj = -sin*wa(k) + cos*qtbpj\n wa(k) = temp\n!\n! accumulate the tranformation in the row of s.\n!\n kp1 = k + 1\n if (n .lt. kp1) go to 70\n do i = kp1, n\n temp = cos*r(i,k) + sin*sdiag(i)\n sdiag(i) = -sin*r(i,k) + cos*sdiag(i)\n r(i,k) = temp\n enddo\n!60 continue\n70 continue\n enddo\n!80 continue\n90 continue\n!\n! store the diagonal element of s and restore\n! the corresponding diagonal element of r.\n!\n sdiag(j) = r(j,j)\n r(j,j) = x(j)\n enddo\n100 continue\n!\n! solve the triangular system for z. if the system is\n! singular, then obtain a least squares solution.\n!\n nsing = n\n do j = 1, n\n if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1\n if (nsing .lt. n) wa(j) = zero\n enddo\n!110 continue\n if (nsing .lt. 1) go to 150\n! do 140 k = 1, nsing\n do k = 1, nsing\n j = nsing - k + 1\n sum = zero\n jp1 = j + 1\n if (nsing .lt. jp1) go to 130\n do i = jp1, nsing\n sum = sum + r(i,j)*wa(i)\n enddo\n!120 continue\n130 continue\n wa(j) = (wa(j) - sum)/sdiag(j)\n enddo\n!140 continue\n150 continue\n!\n! permute the components of z back to components of x.\n!\n do j = 1, n\n l = ipvt(j)\n x(l) = wa(j)\n enddo\n!160 continue\n return\n!\n! last card of subroutine qrsolv.\n!\n end subroutine qrsolv\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n\n subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)\n implicit none\n integer n,info,lwa\n double precision tol\n double precision x(n),fvec(n),wa(lwa)\n external fcn\n! **********\n!\n! subroutine hybrd1\n!\n! the purpose of hybrd1 is to find a zero of a system of\n! n nonlinear functions in n variables by a modification\n! of the powell hybrid method. this is done by using the\n! more general nonlinear equation solver hybrd. the user\n! must provide a subroutine which calculates the functions.\n! the jacobian is then calculated by a forward-difference\n! approximation.\n!\n! the subroutine statement is\n!\n! subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(n,x,fvec,iflag)\n! integer n,iflag\n! double precision x(n),fvec(n)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ---------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of hybrd1.\n! in this case set iflag to a negative integer.\n!\n! n is a positive integer input variable set to the number\n! of functions and variables.\n!\n! x is an array of length n. on input x must contain\n! an initial estimate of the solution vector. on output x\n! contains the final estimate of the solution vector.\n!\n! fvec is an output array of length n which contains\n! the functions evaluated at the output x.\n!\n! tol is a nonnegative input variable. termination occurs\n! when the algorithm estimates that the relative error\n! between x and the solution is at most tol.\n!\n! info is an integer output variable. if the user has\n! terminated execution, info is set to the (negative)\n! value of iflag. see description of fcn. otherwise,\n! info is set as follows.\n!\n! info = 0 improper input parameters.\n!\n! info = 1 algorithm estimates that the relative error\n! between x and the solution is at most tol.\n!\n! info = 2 number of calls to fcn has reached or exceeded\n! 200*(n+1).\n!\n! info = 3 tol is too small. no further improvement in\n! the approximate solution x is possible.\n!\n! info = 4 iteration is not making good progress.\n!\n! wa is a work array of length lwa.\n!\n! lwa is a positive integer input variable not less than\n! (n*(3*n+13))/2.\n!\n! subprograms called\n!\n! user-supplied ...... fcn\n!\n! minpack-supplied ... hybrd\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint\n double precision epsfcn,factor,one,xtol,zero\n data factor,one,zero /1.0d2,1.0d0,0.0d0/\n info = 0\n!\n! check the input parameters for errors.\n!\n if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) &\n go to 20\n!\n! call hybrd.\n!\n maxfev = 200*(n + 1)\n xtol = tol\n ml = n - 1\n mu = n - 1\n epsfcn = zero\n mode = 2\n do j = 1, n\n wa(j) = one\n enddo\n nprint = 0\n lr = (n*(n + 1))/2\n index = 6*n + lr\n call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, &\n factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, &\n wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))\n if (info .eq. 5) info = 4\n20 continue\n return\n!\n! last card of subroutine hybrd1.\n! \n end subroutine hybrd1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, &\n mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, &\n qtf,wa1,wa2,wa3,wa4)\n implicit none\n integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr\n double precision xtol,epsfcn,factor\n double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), &\n qtf(n),wa1(n),wa2(n),wa3(n),wa4(n)\n external fcn\n! **********\n!\n! subroutine hybrd\n!\n! the purpose of hybrd is to find a zero of a system of\n! n nonlinear functions in n variables by a modification\n! of the powell hybrid method. the user must provide a\n! subroutine which calculates the functions. the jacobian is\n! then calculated by a forward-difference approximation.\n!\n! the subroutine statement is\n!\n! subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,\n! diag,mode,factor,nprint,info,nfev,fjac,\n! ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(n,x,fvec,iflag)\n! integer n,iflag\n! double precision x(n),fvec(n)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ---------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of hybrd.\n! in this case set iflag to a negative integer.\n!\n! n is a positive integer input variable set to the number\n! of functions and variables.\n!\n! x is an array of length n. on input x must contain\n! an initial estimate of the solution vector. on output x\n! contains the final estimate of the solution vector.\n!\n! fvec is an output array of length n which contains\n! the functions evaluated at the output x.\n!\n! xtol is a nonnegative input variable. termination\n! occurs when the relative error between two consecutive\n! iterates is at most xtol.\n!\n! maxfev is a positive integer input variable. termination\n! occurs when the number of calls to fcn is at least maxfev\n! by the end of an iteration.\n!\n! ml is a nonnegative integer input variable which specifies\n! the number of subdiagonals within the band of the\n! jacobian matrix. if the jacobian is not banded, set\n! ml to at least n - 1.\n!\n! mu is a nonnegative integer input variable which specifies\n! the number of superdiagonals within the band of the\n! jacobian matrix. if the jacobian is not banded, set\n! mu to at least n - 1.\n!\n! epsfcn is an input variable used in determining a suitable\n! step length for the forward-difference approximation. this\n! approximation assumes that the relative errors in the\n! functions are of the order of epsfcn. if epsfcn is less\n! than the machine precision, it is assumed that the relative\n! errors in the functions are of the order of the machine\n! precision.\n!\n! diag is an array of length n. if mode = 1 (see\n! below), diag is internally set. if mode = 2, diag\n! must contain positive entries that serve as\n! multiplicative scale factors for the variables.\n!\n! mode is an integer input variable. if mode = 1, the\n! variables will be scaled internally. if mode = 2,\n! the scaling is specified by the input diag. other\n! values of mode are equivalent to mode = 1.\n!\n! factor is a positive input variable used in determining the\n! initial step bound. this bound is set to the product of\n! factor and the euclidean norm of diag*x if nonzero, or else\n! to factor itself. in most cases factor should lie in the\n! interval (.1,100.). 100. is a generally recommended value.\n!\n! nprint is an integer input variable that enables controlled\n! printing of iterates if it is positive. in this case,\n! fcn is called with iflag = 0 at the beginning of the first\n! iteration and every nprint iterations thereafter and\n! immediately prior to return, with x and fvec available\n! for printing. if nprint is not positive, no special calls\n! of fcn with iflag = 0 are made.\n!\n! info is an integer output variable. if the user has\n! terminated execution, info is set to the (negative)\n! value of iflag. see description of fcn. otherwise,\n! info is set as follows.\n!\n! info = 0 improper input parameters.\n!\n! info = 1 relative error between two consecutive iterates\n! is at most xtol.\n!\n! info = 2 number of calls to fcn has reached or exceeded\n! maxfev.\n!\n! info = 3 xtol is too small. no further improvement in\n! the approximate solution x is possible.\n!\n! info = 4 iteration is not making good progress, as\n! measured by the improvement from the last\n! five jacobian evaluations.\n!\n! info = 5 iteration is not making good progress, as\n! measured by the improvement from the last\n! ten iterations.\n!\n! nfev is an integer output variable set to the number of\n! calls to fcn.\n!\n! fjac is an output n by n array which contains the\n! orthogonal matrix q produced by the qr factorization\n! of the final approximate jacobian.\n!\n! ldfjac is a positive integer input variable not less than n\n! which specifies the leading dimension of the array fjac.\n!\n! r is an output array of length lr which contains the\n! upper triangular matrix produced by the qr factorization\n! of the final approximate jacobian, stored rowwise.\n!\n! lr is a positive integer input variable not less than\n! (n*(n+1))/2.\n!\n! qtf is an output array of length n which contains\n! the vector (q transpose)*fvec.\n!\n! wa1, wa2, wa3, and wa4 are work arrays of length n.\n!\n! subprograms called\n!\n! user-supplied ...... fcn\n!\n! minpack-supplied ... dogleg,dpmpar,enorm,fdjac1,\n! qform,qrfac,r1mpyq,r1updt\n!\n! fortran-supplied ... dabs,dmax1,dmin1,min0,mod\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2\n integer iwa(1)\n logical jeval,sing\n double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, &\n prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, &\n zero\n! double precision dpmpar,enorm\n data one,p1,p5,p001,p0001,zero &\n /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n info = 0\n iflag = 0\n nfev = 0\n!\n! check the input parameters for errors.\n!\n if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 &\n .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero &\n .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300\n if (mode .ne. 2) go to 20\n do j = 1, n\n if (diag(j) .le. zero) go to 300\n enddo\n20 continue\n!\n! evaluate the function at the starting point\n! and calculate its norm.\n!\n iflag = 1\n! This is not CALFUN for assessments\n call fcn(n,x,fvec,iflag)\n nfev = 1\n if (iflag .lt. 0) go to 300\n fnorm = enorm(n,fvec)\n!\n! determine the number of calls to fcn needed to compute\n! the jacobian matrix.\n!\n msum = min0(ml+mu+1,n)\n!\n! initialize iteration counter and monitors.\n!\n iter = 1\n ncsuc = 0\n ncfail = 0\n nslow1 = 0\n nslow2 = 0\n!\n! beginning of the outer loop.\n!\n30 continue\n jeval = .true.\n!\n! calculate the jacobian matrix.\n!\n iflag = 2\n call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, &\n wa2)\n nfev = nfev + msum\n if (iflag .lt. 0) go to 300\n!\n! compute the qr factorization of the jacobian.\n!\n call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)\n!\n! on the first iteration and if mode is 1, scale according\n! to the norms of the columns of the initial jacobian.\n!\n if (iter .ne. 1) go to 70\n if (mode .eq. 2) go to 50\n do j = 1, n\n diag(j) = wa2(j)\n if (wa2(j) .eq. zero) diag(j) = one\n enddo\n50 continue\n!\n! on the first iteration, calculate the norm of the scaled x\n! and initialize the step bound delta.\n!\n do j = 1, n\n wa3(j) = diag(j)*x(j)\n enddo\n xnorm = enorm(n,wa3)\n delta = factor*xnorm\n if (delta .eq. zero) delta = factor\n70 continue\n!\n! form (q transpose)*fvec and store in qtf.\n!\n do i = 1, n\n qtf(i) = fvec(i)\n enddo\n do j = 1, n\n if (fjac(j,j) .eq. zero) go to 110\n sum = zero\n do i = j, n\n sum = sum + fjac(i,j)*qtf(i)\n enddo\n temp = -sum/fjac(j,j)\n do i = j, n\n qtf(i) = qtf(i) + fjac(i,j)*temp\n enddo\n110 continue\n enddo\n!\n! copy the triangular factor of the qr factorization into r.\n!\n sing = .false.\n do j = 1, n\n l = j\n jm1 = j - 1\n if (jm1 .lt. 1) go to 140\n do i = 1, jm1\n r(l) = fjac(i,j)\n l = l + n - i\n enddo\n140 continue\n r(l) = wa1(j)\n if (wa1(j) .eq. zero) sing = .true.\n enddo\n!\n! accumulate the orthogonal factor in fjac.\n!\n call qform(n,n,fjac,ldfjac,wa1)\n!\n! rescale if necessary.\n!\n if (mode .eq. 2) go to 170\n do j = 1, n\n diag(j) = dmax1(diag(j),wa2(j))\n enddo\n170 continue\n!\n! beginning of the inner loop.\n!\n180 continue\n!\n! if requested, call fcn to enable printing of iterates.\n!\n if (nprint .le. 0) go to 190\n iflag = 0\n! This is not CALFUN for assessments\n if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag)\n if (iflag .lt. 0) go to 300\n190 continue\n!\n! determine the direction p.\n!\n call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)\n!\n! store the direction p and x + p. calculate the norm of p.\n!\n do j = 1, n\n wa1(j) = -wa1(j)\n wa2(j) = x(j) + wa1(j)\n wa3(j) = diag(j)*wa1(j)\n enddo\n pnorm = enorm(n,wa3)\n!\n! on the first iteration, adjust the initial step bound.\n!\n if (iter .eq. 1) delta = dmin1(delta,pnorm)\n!\n! evaluate the function at x + p and calculate its norm.\n!\n iflag = 1\n! This is not CALFUN \n call fcn(n,wa2,wa4,iflag)\n nfev = nfev + 1\n if (iflag .lt. 0) go to 300\n fnorm1 = enorm(n,wa4)\n!\n! compute the scaled actual reduction.\n!\n actred = -one\n if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2\n!\n! compute the scaled predicted reduction.\n!\n l = 1\n do i = 1, n\n sum = zero\n do j = i, n\n sum = sum + r(l)*wa1(j)\n l = l + 1\n enddo\n wa3(i) = qtf(i) + sum\n enddo\n temp = enorm(n,wa3)\n prered = zero\n if (temp .lt. fnorm) prered = one - (temp/fnorm)**2\n!\n! compute the ratio of the actual to the predicted\n! reduction.\n!\n ratio = zero\n if (prered .gt. zero) ratio = actred/prered\n!\n! update the step bound.\n!\n if (ratio .ge. p1) go to 230\n ncsuc = 0\n ncfail = ncfail + 1\n delta = p5*delta\n go to 240\n230 continue\n ncfail = 0\n ncsuc = ncsuc + 1\n if (ratio .ge. p5 .or. ncsuc .gt. 1) &\n delta = dmax1(delta,pnorm/p5)\n if (dabs(ratio-one) .le. p1) delta = pnorm/p5\n240 continue\n!\n! test for successful iteration.\n!\n if (ratio .lt. p0001) go to 260\n!\n! successful iteration. update x, fvec, and their norms.\n!\n do j = 1, n\n x(j) = wa2(j)\n wa2(j) = diag(j)*x(j)\n fvec(j) = wa4(j)\n enddo\n xnorm = enorm(n,wa2)\n fnorm = fnorm1\n iter = iter + 1\n260 continue\n!\n! determine the progress of the iteration.\n!\n nslow1 = nslow1 + 1\n if (actred .ge. p001) nslow1 = 0\n if (jeval) nslow2 = nslow2 + 1\n if (actred .ge. p1) nslow2 = 0\n!\n! test for convergence.\n!\n if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1\n if (info .ne. 0) go to 300\n!\n! tests for termination and stringent tolerances.\n!\n if (nfev .ge. maxfev) info = 2\n if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3\n if (nslow2 .eq. 5) info = 4\n if (nslow1 .eq. 10) info = 5\n if (info .ne. 0) go to 300\n!\n! criterion for recalculating jacobian approximation\n! by forward differences.\n!\n if (ncfail .eq. 2) go to 290\n!\n! calculate the rank one modification to the jacobian\n! and update qtf if necessary.\n!\n do j = 1, n\n sum = zero\n do i = 1, n\n sum = sum + fjac(i,j)*wa4(i)\n enddo\n wa2(j) = (sum - wa3(j))/pnorm\n wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)\n if (ratio .ge. p0001) qtf(j) = sum\n enddo\n!\n! compute the qr factorization of the updated jacobian.\n!\n call r1updt(n,n,r,lr,wa1,wa2,wa3,sing)\n call r1mpyq(n,n,fjac,ldfjac,wa2,wa3)\n call r1mpyq(1,n,qtf,1,wa2,wa3)\n!\n! end of the inner loop.\n!\n jeval = .false.\n go to 180\n290 continue\n!\n! end of the outer loop.\n!\n go to 30\n300 continue\n!\n! termination, either normal or user imposed.\n!\n if (iflag .lt. 0) info = iflag\n iflag = 0\n! this is not CALFUN\n if (nprint .gt. 0) call fcn(n,x,fvec,iflag)\n return\n!\n! last card of subroutine hybrd.\n!\n end subroutine hybrd\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n\n subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)\n implicit none\n integer n,lr\n double precision delta\n double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n)\n! **********\n!\n! subroutine dogleg\n!\n! given an m by n matrix a, an n by n nonsingular diagonal\n! matrix d, an m-vector b, and a positive number delta, the\n! problem is to determine the convex combination x of the\n! gauss-newton and scaled gradient directions that minimizes\n! (a*x - b) in the least squares sense, subject to the\n! restriction that the euclidean norm of d*x be at most delta.\n!\n! this subroutine completes the solution of the problem\n! if it is provided with the necessary information from the\n! qr factorization of a. that is, if a = q*r, where q has\n! orthogonal columns and r is an upper triangular matrix,\n! then dogleg expects the full upper triangle of r and\n! the first n components of (q transpose)*b.\n!\n! the subroutine statement is\n!\n! subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)\n!\n! where\n!\n! n is a positive integer input variable set to the order of r.\n!\n! r is an input array of length lr which must contain the upper\n! triangular matrix r stored by rows.\n!\n! lr is a positive integer input variable not less than\n! (n*(n+1))/2.\n!\n! diag is an input array of length n which must contain the\n! diagonal elements of the matrix d.\n!\n! qtb is an input array of length n which must contain the first\n! n elements of the vector (q transpose)*b.\n!\n! delta is a positive input variable which specifies an upper\n! bound on the euclidean norm of d*x.\n!\n! x is an output array of length n which contains the desired\n! convex combination of the gauss-newton direction and the\n! scaled gradient direction.\n!\n! wa1 and wa2 are work arrays of length n.\n!\n! subprograms called\n!\n! minpack-supplied ... dpmpar,enorm\n!\n! fortran-supplied ... dabs,dmax1,dmin1,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,jj,jp1,k,l\n double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, &\n temp,zero\n! double precision dpmpar,enorm\n data one,zero /1.0d0,0.0d0/\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n! first, calculate the gauss-newton direction.\n!\n jj = (n*(n + 1))/2 + 1\n do k = 1, n\n j = n - k + 1\n jp1 = j + 1\n jj = jj - k\n l = jj + 1\n sum = zero\n if (n .lt. jp1) go to 20\n do i = jp1, n\n sum = sum + r(l)*x(i)\n l = l + 1\n enddo\n20 continue\n temp = r(jj)\n if (temp .ne. zero) go to 40\n l = j\n do i = 1, j\n temp = dmax1(temp,dabs(r(l)))\n l = l + n - i\n enddo\n temp = epsmch*temp\n if (temp .eq. zero) temp = epsmch\n40 continue\n x(j) = (qtb(j) - sum)/temp\n enddo\n!\n! test whether the gauss-newton direction is acceptable.\n!\n do j = 1, n\n wa1(j) = zero\n wa2(j) = diag(j)*x(j)\n enddo\n qnorm = enorm(n,wa2)\n if (qnorm .le. delta) go to 140\n!\n! the gauss-newton direction is not acceptable.\n! next, calculate the scaled gradient direction.\n!\n l = 1\n do j = 1, n\n temp = qtb(j)\n do i = j, n\n wa1(i) = wa1(i) + r(l)*temp\n l = l + 1\n enddo\n wa1(j) = wa1(j)/diag(j)\n enddo\n!\n! calculate the norm of the scaled gradient and test for\n! the special case in which the scaled gradient is zero.\n!\n gnorm = enorm(n,wa1)\n sgnorm = zero\n alpha = delta/qnorm\n if (gnorm .eq. zero) go to 120\n!\n! calculate the point along the scaled gradient\n! at which the quadratic is minimized.\n!\n do j = 1, n\n wa1(j) = (wa1(j)/gnorm)/diag(j)\n enddo\n l = 1\n do j = 1, n\n sum = zero\n do i = j, n\n sum = sum + r(l)*wa1(i)\n l = l + 1\n enddo\n wa2(j) = sum\n enddo\n temp = enorm(n,wa2)\n sgnorm = (gnorm/temp)/temp\n!\n! test whether the scaled gradient direction is acceptable.\n!\n alpha = zero\n if (sgnorm .ge. delta) go to 120\n!\n! the scaled gradient direction is not acceptable.\n! finally, calculate the point along the dogleg\n! at which the quadratic is minimized.\n!\n bnorm = enorm(n,qtb)\n temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta)\n temp = temp - (delta/qnorm)*(sgnorm/delta)**2 &\n + dsqrt((temp-(delta/qnorm))**2 &\n +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2))\n alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp\n120 continue\n!\n! form appropriate convex combination of the gauss-newton\n! direction and the scaled gradient direction.\n!\n temp = (one - alpha)*dmin1(sgnorm,delta)\n do j = 1, n\n x(j) = temp*wa1(j) + alpha*x(j)\n enddo\n140 continue\n return\n!\n! last card of subroutine dogleg.\n!\n end subroutine dogleg\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,&\n wa1,wa2)\n implicit none\n integer n,ldfjac,iflag,ml,mu\n double precision epsfcn\n double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n)\n! added external fcn\n external fcn\n! **********\n!\n! subroutine fdjac1\n!\n! this subroutine computes a forward-difference approximation\n! to the n by n jacobian matrix associated with a specified\n! problem of n functions in n variables. if the jacobian has\n! a banded form, then function evaluations are saved by only\n! approximating the nonzero terms.\n!\n! the subroutine statement is\n!\n! subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,\n! wa1,wa2)\n!\n! where\n!\n! fcn is the name of the user-supplied subroutine which\n! calculates the functions. fcn must be declared\n! in an external statement in the user calling\n! program, and should be written as follows.\n!\n! subroutine fcn(n,x,fvec,iflag)\n! integer n,iflag\n! double precision x(n),fvec(n)\n! ----------\n! calculate the functions at x and\n! return this vector in fvec.\n! ----------\n! return\n! end\n!\n! the value of iflag should not be changed by fcn unless\n! the user wants to terminate execution of fdjac1.\n! in this case set iflag to a negative integer.\n!\n! n is a positive integer input variable set to the number\n! of functions and variables.\n!\n! x is an input array of length n.\n!\n! fvec is an input array of length n which must contain the\n! functions evaluated at x.\n!\n! fjac is an output n by n array which contains the\n! approximation to the jacobian matrix evaluated at x.\n!\n! ldfjac is a positive integer input variable not less than n\n! which specifies the leading dimension of the array fjac.\n!\n! iflag is an integer variable which can be used to terminate\n! the execution of fdjac1. see description of fcn.\n!\n! ml is a nonnegative integer input variable which specifies\n! the number of subdiagonals within the band of the\n! jacobian matrix. if the jacobian is not banded, set\n! ml to at least n - 1.\n!\n! epsfcn is an input variable used in determining a suitable\n! step length for the forward-difference approximation. this\n! approximation assumes that the relative errors in the\n! functions are of the order of epsfcn. if epsfcn is less\n! than the machine precision, it is assumed that the relative\n! errors in the functions are of the order of the machine\n! precision.\n!\n! mu is a nonnegative integer input variable which specifies\n! the number of superdiagonals within the band of the\n! jacobian matrix. if the jacobian is not banded, set\n! mu to at least n - 1.\n!\n! wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at\n! least n, then the jacobian is considered dense, and wa2 is\n! not referenced.\n!\n! subprograms called\n!\n! minpack-supplied ... dpmpar\n!\n! fortran-supplied ... dabs,dmax1,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,k,msum\n double precision eps,epsmch,h,temp,zero\n! double precision dpmpar\n data zero /0.0d0/\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n eps = dsqrt(dmax1(epsfcn,epsmch))\n msum = ml + mu + 1\n if (msum .lt. n) go to 40\n!\n! computation of dense approximate jacobian.\n!\n do j = 1, n\n temp = x(j)\n h = eps*dabs(temp)\n if (h .eq. zero) h = eps\n x(j) = temp + h\n! This is not CALFUN for assessments\n call fcn(n,x,wa1,iflag)\n if (iflag .lt. 0) go to 30\n x(j) = temp\n do i = 1, n\n fjac(i,j) = (wa1(i) - fvec(i))/h\n enddo\n enddo\n30 continue\n go to 110\n40 continue\n!\n! computation of banded approximate jacobian.\n!\n do k = 1, msum\n do j = k, n, msum\n wa2(j) = x(j)\n h = eps*dabs(wa2(j))\n if (h .eq. zero) h = eps\n x(j) = wa2(j) + h\n enddo\n! This is not CALFUN for assessments\n call fcn(n,x,wa1,iflag)\n if (iflag .lt. 0) go to 100\n do j = k, n, msum\n x(j) = wa2(j)\n h = eps*dabs(wa2(j))\n if (h .eq. zero) h = eps\n do i = 1, n\n fjac(i,j) = zero\n if (i .ge. j - mu .and. i .le. j + ml) &\n fjac(i,j) = (wa1(i) - fvec(i))/h\n enddo\n enddo\n enddo\n100 continue\n110 continue\n return\n!\n! last card of subroutine fdjac1.\n!\n end subroutine fdjac1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine qform(m,n,q,ldq,wa)\n implicit none\n integer m,n,ldq\n double precision q(ldq,m),wa(m)\n! **********\n!\n! subroutine qform\n!\n! this subroutine proceeds from the computed qr factorization of\n! an m by n matrix a to accumulate the m by m orthogonal matrix\n! q from its factored form.\n!\n! the subroutine statement is\n!\n! subroutine qform(m,n,q,ldq,wa)\n!\n! where\n!\n! m is a positive integer input variable set to the number\n! of rows of a and the order of q.\n!\n! n is a positive integer input variable set to the number\n! of columns of a.\n!\n! q is an m by m array. on input the full lower trapezoid in\n! the first min(m,n) columns of q contains the factored form.\n! on output q has been accumulated into a square matrix.\n!\n! ldq is a positive integer input variable not less than m\n! which specifies the leading dimension of the array q.\n!\n! wa is a work array of length m.\n!\n! subprograms called\n!\n! fortran-supplied ... min0\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,jm1,k,l,minmn,np1\n double precision one,sum,temp,zero\n data one,zero /1.0d0,0.0d0/\n!\n! zero out upper triangle of q in the first min(m,n) columns.\n!\n minmn = min0(m,n)\n if (minmn .lt. 2) go to 30\n do j = 2, minmn\n jm1 = j - 1\n do i = 1, jm1\n q(i,j) = zero\n enddo\n enddo\n30 continue\n!\n! initialize remaining columns to those of the identity matrix.\n!\n np1 = n + 1\n if (m .lt. np1) go to 60\n do j = np1, m\n do i = 1, m\n q(i,j) = zero\n enddo\n q(j,j) = one\n enddo\n60 continue\n!\n! accumulate q from its factored form.\n!\n do l = 1, minmn\n k = minmn - l + 1\n do i = k, m\n wa(i) = q(i,k)\n q(i,k) = zero\n enddo\n q(k,k) = one\n if (wa(k) .eq. zero) go to 110\n do j = k, m\n sum = zero\n do i = k, m\n sum = sum + q(i,j)*wa(i)\n enddo\n temp = sum/wa(k)\n do i = k, m\n q(i,j) = q(i,j) - temp*wa(i)\n enddo\n enddo\n110 continue\n enddo\n return\n!\n! last card of subroutine qform.\n!\n end subroutine qform\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)\n implicit none\n integer m,n,lda,lipvt\n integer ipvt(lipvt)\n logical pivot\n double precision a(lda,n),rdiag(n),acnorm(n),wa(n)\n! **********\n!\n! subroutine qrfac\n!\n! this subroutine uses householder transformations with column\n! pivoting (optional) to compute a qr factorization of the\n! m by n matrix a. that is, qrfac determines an orthogonal\n! matrix q, a permutation matrix p, and an upper trapezoidal\n! matrix r with diagonal elements of nonincreasing magnitude,\n! such that a*p = q*r. the householder transformation for\n! column k, k = 1,2,...,min(m,n), is of the form\n!\n! t\n! i - (1/u(k))*u*u\n!\n! where u has zeros in the first k-1 positions. the form of\n! this transformation and the method of pivoting first\n! appeared in the corresponding linpack subroutine.\n!\n! the subroutine statement is\n!\n! subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)\n!\n! where\n!\n! m is a positive integer input variable set to the number\n! of rows of a.\n!\n! n is a positive integer input variable set to the number\n! of columns of a.\n!\n! a is an m by n array. on input a contains the matrix for\n! which the qr factorization is to be computed. on output\n! the strict upper trapezoidal part of a contains the strict\n! upper trapezoidal part of r, and the lower trapezoidal\n! part of a contains a factored form of q (the non-trivial\n! elements of the u vectors described above).\n!\n! lda is a positive integer input variable not less than m\n! which specifies the leading dimension of the array a.\n!\n! pivot is a logical input variable. if pivot is set true,\n! then column pivoting is enforced. if pivot is set false,\n! then no column pivoting is done.\n!\n! ipvt is an integer output array of length lipvt. ipvt\n! defines the permutation matrix p such that a*p = q*r.\n! column j of p is column ipvt(j) of the identity matrix.\n! if pivot is false, ipvt is not referenced.\n!\n! lipvt is a positive integer input variable. if pivot is false,\n! then lipvt may be as small as 1. if pivot is true, then\n! lipvt must be at least n.\n!\n! rdiag is an output array of length n which contains the\n! diagonal elements of r.\n!\n! acnorm is an output array of length n which contains the\n! norms of the corresponding columns of the input matrix a.\n! if this information is not needed, then acnorm can coincide\n! with rdiag.\n!\n! wa is a work array of length n. if pivot is false, then wa\n! can coincide with rdiag.\n!\n! subprograms called\n!\n! minpack-supplied ... dpmpar,enorm\n!\n! fortran-supplied ... dmax1,dsqrt,min0\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,jp1,k,kmax,minmn\n double precision ajnorm,epsmch,one,p05,sum,temp,zero\n! double precision dpmpar,enorm\n data one,p05,zero /1.0d0,5.0d-2,0.0d0/\n!\n! epsmch is the machine precision.\n!\n epsmch = dpmpar(1)\n!\n! compute the initial column norms and initialize several arrays.\n!\n do j = 1, n\n acnorm(j) = enorm(m,a(1,j))\n rdiag(j) = acnorm(j)\n wa(j) = rdiag(j)\n if (pivot) ipvt(j) = j\n enddo\n!10 continue\n!\n! reduce a to r with householder transformations.\n!\n minmn = min0(m,n)\n! do 110 j = 1, minmn\n do j = 1, minmn\n if (.not.pivot) go to 40\n!\n! bring the column of largest norm into the pivot position.\n!\n kmax = j\n do k = j, n\n if (rdiag(k) .gt. rdiag(kmax)) kmax = k\n enddo\n!20 continue\n if (kmax .eq. j) go to 40\n do i = 1, m\n temp = a(i,j)\n a(i,j) = a(i,kmax)\n a(i,kmax) = temp\n enddo\n!30 continue\n rdiag(kmax) = rdiag(j)\n wa(kmax) = wa(j)\n k = ipvt(j)\n ipvt(j) = ipvt(kmax)\n ipvt(kmax) = k\n40 continue\n!\n! compute the householder transformation to reduce the\n! j-th column of a to a multiple of the j-th unit vector.\n!\n ajnorm = enorm(m-j+1,a(j,j))\n if (ajnorm .eq. zero) go to 100\n if (a(j,j) .lt. zero) ajnorm = -ajnorm\n do i = j, m\n a(i,j) = a(i,j)/ajnorm\n enddo\n!50 continue\n a(j,j) = a(j,j) + one\n!\n! apply the transformation to the remaining columns\n! and update the norms.\n!\n jp1 = j + 1\n if (n .lt. jp1) go to 100\n! do 90 k = jp1, n\n do k = jp1, n\n sum = zero\n do i = j, m\n sum = sum + a(i,j)*a(i,k)\n enddo\n!60 continue\n temp = sum/a(j,j)\n do i = j, m\n a(i,k) = a(i,k) - temp*a(i,j)\n enddo\n!70 continue\n if (.not.pivot .or. rdiag(k) .eq. zero) go to 80\n temp = a(j,k)/rdiag(k)\n rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2))\n if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80\n rdiag(k) = enorm(m-j,a(jp1,k))\n wa(k) = rdiag(k)\n80 continue\n enddo\n!90 continue\n100 continue\n rdiag(j) = -ajnorm\n enddo\n!110 continue\n return\n!\n! last card of subroutine qrfac.\n!\n end subroutine qrfac\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n \n subroutine r1mpyq(m,n,a,lda,v,w)\n implicit none\n integer m,n,lda\n double precision a(lda,n),v(n),w(n)\n! **********\n!\n! subroutine r1mpyq\n!\n! given an m by n matrix a, this subroutine computes a*q where\n! q is the product of 2*(n - 1) transformations\n!\n! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)\n!\n! and gv(i), gw(i) are givens rotations in the (i,n) plane which\n! eliminate elements in the i-th and n-th planes, respectively.\n! q itself is not given, rather the information to recover the\n! gv, gw rotations is supplied.\n!\n! the subroutine statement is\n!\n! subroutine r1mpyq(m,n,a,lda,v,w)\n!\n! where\n!\n! m is a positive integer input variable set to the number\n! of rows of a.\n!\n! n is a positive integer input variable set to the number\n! of columns of a.\n!\n! a is an m by n array. on input a must contain the matrix\n! to be postmultiplied by the orthogonal matrix q\n! described above. on output a*q has replaced a.\n!\n! lda is a positive integer input variable not less than m\n! which specifies the leading dimension of the array a.\n!\n! v is an input array of length n. v(i) must contain the\n! information necessary to recover the givens rotation gv(i)\n! described above.\n!\n! w is an input array of length n. w(i) must contain the\n! information necessary to recover the givens rotation gw(i)\n! described above.\n!\n! subroutines called\n!\n! fortran-supplied ... dabs,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i,j,nmj,nm1\n double precision cos,one,sin,temp\n data one /1.0d0/\n!\n! apply the first set of givens rotations to a.\n!\n nm1 = n - 1\n if (nm1 .lt. 1) go to 50\n do nmj = 1, nm1\n j = n - nmj\n if (dabs(v(j)) .gt. one) cos = one/v(j)\n if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2)\n if (dabs(v(j)) .le. one) sin = v(j)\n if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2)\n do i = 1, m\n temp = cos*a(i,j) - sin*a(i,n)\n a(i,n) = sin*a(i,j) + cos*a(i,n)\n a(i,j) = temp\n enddo\n enddo\n!\n! apply the second set of givens rotations to a.\n!\n do j = 1, nm1\n if (dabs(w(j)) .gt. one) cos = one/w(j)\n if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2)\n if (dabs(w(j)) .le. one) sin = w(j)\n if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2)\n do i = 1, m\n temp = cos*a(i,j) + sin*a(i,n)\n a(i,n) = -sin*a(i,j) + cos*a(i,n)\n a(i,j) = temp\n enddo\n enddo\n50 continue\n return\n!\n! last card of subroutine r1mpyq.\n!\n end subroutine r1mpyq\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n\n subroutine r1updt(m,n,s,ls,u,v,w,sing)\n implicit none\n integer m,n,ls\n logical sing\n double precision s(ls),u(m),v(n),w(m)\n! **********\n!\n! subroutine r1updt\n!\n! given an m by n lower trapezoidal matrix s, an m-vector u,\n! and an n-vector v, the problem is to determine an\n! orthogonal matrix q such that\n!\n! t\n! (s + u*v )*q\n!\n! is again lower trapezoidal.\n!\n! this subroutine determines q as the product of 2*(n - 1)\n! transformations\n!\n! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)\n!\n! where gv(i), gw(i) are givens rotations in the (i,n) plane\n! which eliminate elements in the i-th and n-th planes,\n! respectively. q itself is not accumulated, rather the\n! information to recover the gv, gw rotations is returned.\n!\n! the subroutine statement is\n!\n! subroutine r1updt(m,n,s,ls,u,v,w,sing)\n!\n! where\n!\n! m is a positive integer input variable set to the number\n! of rows of s.\n!\n! n is a positive integer input variable set to the number\n! of columns of s. n must not exceed m.\n!\n! s is an array of length ls. on input s must contain the lower\n! trapezoidal matrix s stored by columns. on output s contains\n! the lower trapezoidal matrix produced as described above.\n!\n! ls is a positive integer input variable not less than\n! (n*(2*m-n+1))/2.\n!\n! u is an input array of length m which must contain the\n! vector u.\n!\n! v is an array of length n. on input v must contain the vector\n! v. on output v(i) contains the information necessary to\n! recover the givens rotation gv(i) described above.\n!\n! w is an output array of length m. w(i) contains information\n! necessary to recover the givens rotation gw(i) described\n! above.\n!\n! sing is a logical output variable. sing is set true if any\n! of the diagonal elements of the output s are zero. otherwise\n! sing is set false.\n!\n! subprograms called\n!\n! minpack-supplied ... dpmpar\n!\n! fortran-supplied ... dabs,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more,\n! john l. nazareth\n!\n! **********\n integer i,j,jj,l,nmj,nm1\n double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, &\n zero\n! double precision dpmpar\n data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/\n!\n! giant is the largest magnitude.\n!\n giant = dpmpar(3)\n!\n! initialize the diagonal element pointer.\n!\n jj = (n*(2*m - n + 1))/2 - (m - n)\n!\n! move the nontrivial part of the last column of s into w.\n!\n l = jj\n do i = n, m\n w(i) = s(l)\n l = l + 1\n enddo\n!\n! rotate the vector v into a multiple of the n-th unit vector\n! in such a way that a spike is introduced into w.\n!\n nm1 = n - 1\n if (nm1 .lt. 1) go to 70\n do nmj = 1, nm1\n j = n - nmj\n jj = jj - (m - j + 1)\n w(j) = zero\n if (v(j) .eq. zero) go to 50\n!\n! determine a givens rotation which eliminates the\n! j-th element of v.\n!\n if (dabs(v(n)) .ge. dabs(v(j))) go to 20\n cotan = v(n)/v(j)\n sin = p5/dsqrt(p25+p25*cotan**2)\n cos = sin*cotan\n tau = one\n if (dabs(cos)*giant .gt. one) tau = one/cos\n go to 30\n20 continue\n tan = v(j)/v(n)\n cos = p5/dsqrt(p25+p25*tan**2)\n sin = cos*tan\n tau = sin\n30 continue\n!\n! apply the transformation to v and store the information\n! necessary to recover the givens rotation.\n!\n v(n) = sin*v(j) + cos*v(n)\n v(j) = tau\n!\n! apply the transformation to s and extend the spike in w.\n!\n l = jj\n do i = j, m\n temp = cos*s(l) - sin*w(i)\n w(i) = sin*s(l) + cos*w(i)\n s(l) = temp\n l = l + 1\n enddo\n50 continue\n enddo\n70 continue\n!\n! add the spike from the rank 1 update to w.\n!\n do i = 1, m\n w(i) = w(i) + v(n)*u(i)\n enddo\n!\n! eliminate the spike.\n!\n sing = .false.\n if (nm1 .lt. 1) go to 140\n do j = 1, nm1\n if (w(j) .eq. zero) go to 120\n!\n! determine a givens rotation which eliminates the\n! j-th element of the spike.\n!\n if (dabs(s(jj)) .ge. dabs(w(j))) go to 90\n cotan = s(jj)/w(j)\n sin = p5/dsqrt(p25+p25*cotan**2)\n cos = sin*cotan\n tau = one\n if (dabs(cos)*giant .gt. one) tau = one/cos\n go to 100\n90 continue\n tan = w(j)/s(jj)\n cos = p5/dsqrt(p25+p25*tan**2)\n sin = cos*tan\n tau = sin\n100 continue\n!\n! apply the transformation to s and reduce the spike in w.\n!\n l = jj\n do i = j, m\n temp = cos*s(l) + sin*w(i)\n w(i) = -sin*s(l) + cos*w(i)\n s(l) = temp\n l = l + 1\n enddo\n!\n! store the information necessary to recover the\n! givens rotation.\n!\n w(j) = tau\n120 continue\n!\n! test for zero diagonal elements in the output s.\n!\n if (s(jj) .eq. zero) sing = .true.\n jj = jj + (m - j + 1)\n enddo\n140 continue\n!\n! move w back into the last column of the output s.\n!\n l = jj\n do i = n, m\n s(l) = w(i)\n l = l + 1\n enddo\n if (s(jj) .eq. zero) sing = .true.\n return\n!\n! last card of subroutine r1updt.\n!\n end subroutine r1updt\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n double precision function dpmpar(i)\n implicit none\n integer i\n! **********\n!\n! Function dpmpar\n!\n! This function provides double precision machine parameters\n! when the appropriate set of data statements is activated (by\n! removing the c from column 1) and all other data statements are\n! rendered inactive. Most of the parameter values were obtained\n! from the corresponding Bell Laboratories Port Library function.\n!\n! The function statement is\n!\n! double precision function dpmpar(i)\n!\n! where\n!\n! i is an integer input variable set to 1, 2, or 3 which\n! selects the desired machine parameter. If the machine has\n! t base b digits and its smallest and largest exponents are\n! emin and emax, respectively, then these parameters are\n!\n! dpmpar(1) = b**(1 - t), the machine precision,\n!\n! dpmpar(2) = b**(emin - 1), the smallest magnitude,\n!\n! dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.\n!\n! Argonne National Laboratory. MINPACK Project. November 1996.\n! Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More'\n!\n! **********\n integer mcheps(4)\n integer minmag(4)\n integer maxmag(4)\n double precision dmach(3)\n equivalence (dmach(1),mcheps(1))\n equivalence (dmach(2),minmag(1))\n equivalence (dmach(3),maxmag(1))\n!\n! Machine constants for the IBM 360/370 series,\n! the Amdahl 470/V6, the ICL 2900, the Itel AS/6,\n! the Xerox Sigma 5/7/9 and the Sel systems 85/86.\n!\n! data mcheps(1),mcheps(2) / z34100000, z00000000 /\n! data minmag(1),minmag(2) / z00100000, z00000000 /\n! data maxmag(1),maxmag(2) / z7fffffff, zffffffff /\n!\n! Machine constants for the Honeywell 600/6000 series.\n!\n! data mcheps(1),mcheps(2) / o606400000000, o000000000000 /\n! data minmag(1),minmag(2) / o402400000000, o000000000000 /\n! data maxmag(1),maxmag(2) / o376777777777, o777777777777 /\n!\n! Machine constants for the CDC 6000/7000 series.\n!\n! data mcheps(1) / 15614000000000000000b /\n! data mcheps(2) / 15010000000000000000b /\n!\n! data minmag(1) / 00604000000000000000b /\n! data minmag(2) / 00000000000000000000b /\n!\n! data maxmag(1) / 37767777777777777777b /\n! data maxmag(2) / 37167777777777777777b /\n!\n! Machine constants for the PDP-10 (KA processor).\n!\n! data mcheps(1),mcheps(2) / \"114400000000, \"000000000000 /\n! data minmag(1),minmag(2) / \"033400000000, \"000000000000 /\n! data maxmag(1),maxmag(2) / \"377777777777, \"344777777777 /\n!\n! Machine constants for the PDP-10 (KI processor).\n!\n! data mcheps(1),mcheps(2) / \"104400000000, \"000000000000 /\n! data minmag(1),minmag(2) / \"000400000000, \"000000000000 /\n! data maxmag(1),maxmag(2) / \"377777777777, \"377777777777 /\n!\n! Machine constants for the PDP-11. \n!\n! data mcheps(1),mcheps(2) / 9472, 0 /\n! data mcheps(3),mcheps(4) / 0, 0 /\n!\n! data minmag(1),minmag(2) / 128, 0 /\n! data minmag(3),minmag(4) / 0, 0 /\n!\n! data maxmag(1),maxmag(2) / 32767, -1 /\n! data maxmag(3),maxmag(4) / -1, -1 /\n!\n! Machine constants for the Burroughs 6700/7700 systems.\n!\n! data mcheps(1) / o1451000000000000 /\n! data mcheps(2) / o0000000000000000 /\n!\n! data minmag(1) / o1771000000000000 /\n! data minmag(2) / o7770000000000000 /\n!\n! data maxmag(1) / o0777777777777777 /\n! data maxmag(2) / o7777777777777777 /\n!\n! Machine constants for the Burroughs 5700 system.\n!\n! data mcheps(1) / o1451000000000000 /\n! data mcheps(2) / o0000000000000000 /\n!\n! data minmag(1) / o1771000000000000 /\n! data minmag(2) / o0000000000000000 /\n!\n! data maxmag(1) / o0777777777777777 /\n! data maxmag(2) / o0007777777777777 /\n!\n! Machine constants for the Burroughs 1700 system.\n!\n! data mcheps(1) / zcc6800000 /\n! data mcheps(2) / z000000000 /\n!\n! data minmag(1) / zc00800000 /\n! data minmag(2) / z000000000 /\n!\n! data maxmag(1) / zdffffffff /\n! data maxmag(2) / zfffffffff /\n!\n! Machine constants for the Univac 1100 series.\n!\n! data mcheps(1),mcheps(2) / o170640000000, o000000000000 /\n! data minmag(1),minmag(2) / o000040000000, o000000000000 /\n! data maxmag(1),maxmag(2) / o377777777777, o777777777777 /\n!\n! Machine constants for the Data General Eclipse S/200.\n!\n! Note - it may be appropriate to include the following card -\n! static dmach(3)\n!\n! data minmag/20k,3*0/,maxmag/77777k,3*177777k/\n! data mcheps/32020k,3*0/\n!\n! Machine constants for the Harris 220.\n!\n! data mcheps(1),mcheps(2) / '20000000, '00000334 /\n! data minmag(1),minmag(2) / '20000000, '00000201 /\n! data maxmag(1),maxmag(2) / '37777777, '37777577 /\n!\n! Machine constants for the Cray-1.\n!\n! data mcheps(1) / 0376424000000000000000b /\n! data mcheps(2) / 0000000000000000000000b /\n!\n! data minmag(1) / 0200034000000000000000b /\n! data minmag(2) / 0000000000000000000000b /\n!\n! data maxmag(1) / 0577777777777777777777b /\n! data maxmag(2) / 0000007777777777777776b /\n!\n! Machine constants for the Prime 400.\n!\n! data mcheps(1),mcheps(2) / :10000000000, :00000000123 /\n! data minmag(1),minmag(2) / :10000000000, :00000100000 /\n! data maxmag(1),maxmag(2) / :17777777777, :37777677776 /\n!\n! Machine constants for the VAX-11.\n!\n! data mcheps(1),mcheps(2) / 9472, 0 /\n! data minmag(1),minmag(2) / 128, 0 /\n! data maxmag(1),maxmag(2) / -32769, -1 /\n!\n! Machine constants for IEEE machines.\n!\n data dmach(1) /2.22044604926d-16/\n data dmach(2) /2.22507385852d-308/\n data dmach(3) /1.79769313485d+308/\n!\n dpmpar = dmach(i)\n return\n!\n! Last card of function dpmpar.\n!\n end function dpmpar\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n double precision function enorm(n,x)\n implicit none\n integer n\n double precision x(n)\n! **********\n!\n! function enorm\n!\n! given an n-vector x, this function calculates the\n! euclidean norm of x.\n!\n! the euclidean norm is computed by accumulating the sum of\n! squares in three different sums. the sums of squares for the\n! small and large components are scaled so that no overflows\n! occur. non-destructive underflows are permitted. underflows\n! and overflows do not occur in the computation of the unscaled\n! sum of squares for the intermediate components.\n! the definitions of small, intermediate and large components\n! depend on two constants, rdwarf and rgiant. the main\n! restrictions on these constants are that rdwarf**2 not\n! underflow and rgiant**2 not overflow. the constants\n! given here are suitable for every known computer.\n!\n! the function statement is\n!\n! double precision function enorm(n,x)\n!\n! where\n!\n! n is a positive integer input variable.\n!\n! x is an input array of length n.\n!\n! subprograms called\n!\n! fortran-supplied ... dabs,dsqrt\n!\n! argonne national laboratory. minpack project. march 1980.\n! burton s. garbow, kenneth e. hillstrom, jorge j. more\n!\n! **********\n integer i\n double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, &\n x1max,x3max,zero\n data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/\n s1 = zero\n s2 = zero\n s3 = zero\n x1max = zero\n x3max = zero\n floatn = n\n agiant = rgiant/floatn\n! do 90 i = 1, n\n do i = 1, n\n xabs = dabs(x(i))\n if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70\n if (xabs .le. rdwarf) go to 30\n!\n! sum for large components.\n!\n if (xabs .le. x1max) go to 10\n s1 = one + s1*(x1max/xabs)**2\n x1max = xabs\n go to 20\n10 continue\n s1 = s1 + (xabs/x1max)**2\n20 continue\n go to 60\n30 continue\n!\n! sum for small components.\n!\n if (xabs .le. x3max) go to 40\n s3 = one + s3*(x3max/xabs)**2\n x3max = xabs\n go to 50\n40 continue\n if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2\n50 continue\n60 continue\n go to 80\n70 continue\n!\n! sum for intermediate components.\n!\n s2 = s2 + xabs**2\n80 continue\n enddo\n!90 continue\n!\n! calculation of norm.\n!\n if (s1 .eq. zero) go to 100\n enorm = x1max*dsqrt(s1+(s2/x1max)/x1max)\n go to 130\n100 continue\n if (s2 .eq. zero) go to 110\n if (s2 .ge. x3max) &\n enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) \n if (s2 .lt. x3max) &\n enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3)))\n go to 120\n110 continue\n enorm = x3max*dsqrt(s3)\n120 continue\n130 continue\n return\n!\n! last card of function enorm.\n!\n end function enorm\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nend MODULE MINPACK\n" }, { "path": "src/numlib/oclablas.F90", "content": "!\nMODULE OCLABLAS\n!\n! This is an extract of a fews routines from LAPACK and BLAS version 3.6.0\n! used to invert a symmetric matrix and to solve a system of linear equations\n! and some more things in DOUBLE PRECISION used in OpenCalphad\n!\n! LAPACk and BLAS are free software libraries\n! Both converted from F77 to F90 in a minimal way (comments and \n! continuation lines modified).\n!\nCONTAINS\n!\n! list of all subroutines/functions at the end\n!\n! -------------------------------------------------------------------------\n!\n! LAPACK/BLAS routines converted from F77 to F90 below\n!\n!\n!> \\brief \\b DGETRI\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DGETRI + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, LDA, LWORK, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGETRI computes the inverse of a matrix using the LU factorization\n!> computed by DGETRF.\n!>\n!> This method inverts U and then computes inv(A) by solving the system\n!> inv(A)*L = inv(U) for inv(A).\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the factors L and U from the factorization\n!> A = P*L*U as computed by DGETRF.\n!> On exit, if INFO = 0, the inverse of the original matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> The pivot indices from DGETRF; for 1<=i<=N, row i of the\n!> matrix was interchanged with row IPIV(i).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n!> On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LWORK\n!> \\verbatim\n!> LWORK is INTEGER\n!> The dimension of the array WORK. LWORK >= max(1,N).\n!> For optimal performance LWORK >= N*NB, where NB is\n!> the optimal blocksize returned by ILAENV.\n!>\n!> If LWORK = -1, then a workspace query is assumed; the routine\n!> only calculates the optimal size of the WORK array, returns\n!> this value as the first entry of the WORK array, and no error\n!> message related to LWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n!> singular and its inverse could not be computed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleGEcomputational\n!\n! =====================================================================\n SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INFO, LDA, LWORK, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,&\n NBMIN, NN\n! ..\n! .. External Functions ..\n! INTEGER ILAENV\n! EXTERNAL ILAENV\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )\n LWKOPT = N*NB\n WORK( 1 ) = LWKOPT\n LQUERY = ( LWORK.EQ.-1 )\n IF( N.LT.0 ) THEN\n INFO = -1\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -3\n ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN\n INFO = -6\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DGETRI', -INFO )\n RETURN\n ELSE IF( LQUERY ) THEN\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! Form inv(U). If INFO > 0 from DTRTRI, then U is singular,\n! and the inverse is not computed.\n!\n CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )\n IF( INFO.GT.0 ) RETURN\n!\n NBMIN = 2\n LDWORK = N\n IF( NB.GT.1 .AND. NB.LT.N ) THEN\n IWS = MAX( LDWORK*NB, 1 )\n IF( LWORK.LT.IWS ) THEN\n NB = LWORK / LDWORK\n NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )\n END IF\n ELSE\n IWS = N\n END IF\n!\n! Solve the equation inv(A)*L = inv(U) for inv(A).\n!\n IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN\n!\n! Use unblocked code.\n!\n DO 20 J = N, 1, -1\n!\n! Copy current column of L to WORK and replace with zeros.\n!\n DO 10 I = J + 1, N\n WORK( I ) = A( I, J )\n A( I, J ) = ZERO\n10 CONTINUE\n!\n! Compute current column of inv(A).\n!\n IF( J.LT.N ) &\n CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),&\n LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )\n20 CONTINUE\n ELSE\n!\n! Use blocked code.\n!\n NN = ( ( N-1 ) / NB )*NB + 1\n DO 50 J = NN, 1, -NB\n JB = MIN( NB, N-J+1 )\n!\n! Copy current block column of L to WORK and replace with\n! zeros.\n!\n DO 40 JJ = J, J + JB - 1\n DO 30 I = JJ + 1, N\n WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )\n A( I, JJ ) = ZERO\n30 CONTINUE\n40 CONTINUE\n!\n! Compute current block column of inv(A).\n!\n IF( J+JB.LE.N ) &\n CALL DGEMM( 'No transpose', 'No transpose', N, JB,&\n N-J-JB+1, -ONE, A( 1, J+JB ), LDA,&\n WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )\n CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,&\n ONE, WORK( J ), LDWORK, A( 1, J ), LDA )\n50 CONTINUE\n END IF\n!\n! Apply column interchanges.\n!\n DO 60 J = N - 1, 1, -1\n JP = IPIV( J )\n IF( JP.NE.J ) CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )\n60 CONTINUE\n!\n WORK( 1 ) = IWS\n RETURN\n!\n! End of DGETRI\n!\n END SUBROUTINE DGETRI\n!\n!=\n!\n!> \\brief \\b DTRTRI\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DTRTRI + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER DIAG, UPLO\n! INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTRTRI computes the inverse of a real upper or lower triangular\n!> matrix A.\n!>\n!> This is the Level 3 BLAS version of the algorithm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': A is upper triangular;\n!> = 'L': A is lower triangular.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> = 'N': A is non-unit triangular;\n!> = 'U': A is unit triangular.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the triangular matrix A. If UPLO = 'U', the\n!> leading N-by-N upper triangular part of the array A contains\n!> the upper triangular matrix, and the strictly lower\n!> triangular part of A is not referenced. If UPLO = 'L', the\n!> leading N-by-N lower triangular part of the array A contains\n!> the lower triangular matrix, and the strictly upper\n!> triangular part of A is not referenced. If DIAG = 'U', the\n!> diagonal elements of A are also not referenced and are\n!> assumed to be 1.\n!> On exit, the (triangular) inverse of the original matrix, in\n!> the same storage format.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, A(i,i) is exactly zero. The triangular\n!> matrix is singular and its inverse can not be computed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER DIAG, UPLO\n INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL NOUNIT, UPPER\n INTEGER J, JB, NB, NN\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! INTEGER ILAENV\n! EXTERNAL LSAME, ILAENV\n! ..\n! .. External Subroutines ..\n! EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n NOUNIT = LSAME( DIAG, 'N' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -5\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DTRTRI', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! Check for singularity if non-unit.\n!\n IF( NOUNIT ) THEN\n DO 10 INFO = 1, N\n IF( A( INFO, INFO ).EQ.ZERO ) RETURN\n10 CONTINUE\n INFO = 0\n END IF\n!\n! Determine the block size for this environment.\n!\n NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )\n IF( NB.LE.1 .OR. NB.GE.N ) THEN\n!\n! Use unblocked code\n!\n CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n ELSE\n!\n! Use blocked code\n!\n IF( UPPER ) THEN\n!\n! Compute inverse of upper triangular matrix\n!\n DO 20 J = 1, N, NB\n JB = MIN( NB, N-J+1 )\n!\n! Compute rows 1:j-1 of current block column\n!\n CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,&\n JB, ONE, A, LDA, A( 1, J ), LDA )\n CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,&\n JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )\n!\n! Compute inverse of current diagonal block\n!\n CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )\n20 CONTINUE\n ELSE\n!\n! Compute inverse of lower triangular matrix\n!\n NN = ( ( N-1 ) / NB )*NB + 1\n DO 30 J = NN, 1, -NB\n JB = MIN( NB, N-J+1 )\n IF( J+JB.LE.N ) THEN\n!\n! Compute rows j+jb:n of current block column\n!\n CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,&\n N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,&\n A( J+JB, J ), LDA )\n CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,&\n N-J-JB+1, JB, -ONE, A( J, J ), LDA,&\n A( J+JB, J ), LDA )\n END IF\n!\n! Compute inverse of current diagonal block\n!\n CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )\n30 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DTRTRI\n!\n END SUBROUTINE DTRTRI\n!\n!=\n!\n!> \\brief \\b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DTRTI2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER DIAG, UPLO\n! INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTRTI2 computes the inverse of a real upper or lower triangular\n!> matrix.\n!>\n!> This is the Level 2 BLAS version of the algorithm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies whether the matrix A is upper or lower triangular.\n!> = 'U': Upper triangular\n!> = 'L': Lower triangular\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> Specifies whether or not the matrix A is unit triangular.\n!> = 'N': Non-unit triangular\n!> = 'U': Unit triangular\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the triangular matrix A. If UPLO = 'U', the\n!> leading n by n upper triangular part of the array A contains\n!> the upper triangular matrix, and the strictly lower\n!> triangular part of A is not referenced. If UPLO = 'L', the\n!> leading n by n lower triangular part of the array A contains\n!> the lower triangular matrix, and the strictly upper\n!> triangular part of A is not referenced. If DIAG = 'U', the\n!> diagonal elements of A are also not referenced and are\n!> assumed to be 1.\n!>\n!> On exit, the (triangular) inverse of the original matrix, in\n!> the same storage format.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -k, the k-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER DIAG, UPLO\n INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL NOUNIT, UPPER\n INTEGER J\n DOUBLE PRECISION AJJ\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL, DTRMV, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n NOUNIT = LSAME( DIAG, 'N' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -5\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DTRTI2', -INFO )\n RETURN\n END IF\n!\n IF( UPPER ) THEN\n!\n! Compute inverse of upper triangular matrix.\n!\n DO 10 J = 1, N\n IF( NOUNIT ) THEN\n A( J, J ) = ONE / A( J, J )\n AJJ = -A( J, J )\n ELSE\n AJJ = -ONE\n END IF\n!\n! Compute elements 1:j-1 of j-th column.\n!\n CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,&\n A( 1, J ), 1 )\n CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )\n10 CONTINUE\n ELSE\n!\n! Compute inverse of lower triangular matrix.\n!\n DO 20 J = N, 1, -1\n IF( NOUNIT ) THEN\n A( J, J ) = ONE / A( J, J )\n AJJ = -A( J, J )\n ELSE\n AJJ = -ONE\n END IF\n IF( J.LT.N ) THEN\n!\n! Compute elements j+1:n of j-th column.\n!\n CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,&\n A( J+1, J+1 ), LDA, A( J+1, J ), 1 )\n CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )\n END IF\n20 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DTRTI2\n!\n END SUBROUTINE DTRTI2\n!\n!=\n!\n!> \\brief \\b DCOPY\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*),DY(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DCOPY copies a vector, x, to a vector, y.\n!> uses unrolled loops for increments equal to one.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*),DY(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I,IX,IY,M,MP1\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MOD\n! ..\n IF (N.LE.0) RETURN\n IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN\n!\n! code for both increments equal to 1\n!\n!\n! clean-up loop\n!\n M = MOD(N,7)\n IF (M.NE.0) THEN\n DO I = 1,M\n DY(I) = DX(I)\n END DO\n IF (N.LT.7) RETURN\n END IF\n MP1 = M + 1\n DO I = MP1,N,7\n DY(I) = DX(I)\n DY(I+1) = DX(I+1)\n DY(I+2) = DX(I+2)\n DY(I+3) = DX(I+3)\n DY(I+4) = DX(I+4)\n DY(I+5) = DX(I+5)\n DY(I+6) = DX(I+6)\n END DO\n ELSE \n!\n! code for unequal increments or equal increments\n! not equal to 1\n!\n IX = 1\n IY = 1\n IF (INCX.LT.0) IX = (-N+1)*INCX + 1\n IF (INCY.LT.0) IY = (-N+1)*INCY + 1\n DO I = 1,N\n DY(IY) = DX(IX)\n IX = IX + INCX\n IY = IY + INCY\n END DO\n END IF\n RETURN\n END SUBROUTINE DCOPY\n!> \\brief \\b DDOT\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*),DY(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DDOT forms the dot product of two vectors.\n!> uses unrolled loops for increments equal to one.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*),DY(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n DOUBLE PRECISION DTEMP\n INTEGER I,IX,IY,M,MP1\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MOD\n! ..\n DDOT = 0.0d0\n DTEMP = 0.0d0\n IF (N.LE.0) RETURN\n IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN\n!\n! code for both increments equal to 1\n!\n!\n! clean-up loop\n!\n M = MOD(N,5)\n IF (M.NE.0) THEN\n DO I = 1,M\n DTEMP = DTEMP + DX(I)*DY(I)\n END DO\n IF (N.LT.5) THEN\n DDOT=DTEMP\n RETURN\n END IF\n END IF\n MP1 = M + 1\n DO I = MP1,N,5\n DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + &\n DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)\n END DO\n ELSE\n!\n! code for unequal increments or equal increments\n! not equal to 1\n!\n IX = 1\n IY = 1\n IF (INCX.LT.0) IX = (-N+1)*INCX + 1\n IF (INCY.LT.0) IY = (-N+1)*INCY + 1\n DO I = 1,N\n DTEMP = DTEMP + DX(IX)*DY(IY)\n IX = IX + INCX\n IY = IY + INCY\n END DO\n END IF\n DDOT = DTEMP\n RETURN\n END FUNCTION DDOT\n!\n!> \\brief \\b DGEMM\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA,BETA\n! INTEGER K,LDA,LDB,LDC,M,N\n! CHARACTER TRANSA,TRANSB\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGEMM performs one of the matrix-matrix operations\n!>\n!> C := alpha*op( A )*op( B ) + beta*C,\n!>\n!> where op( X ) is one of\n!>\n!> op( X ) = X or op( X ) = X**T,\n!>\n!> alpha and beta are scalars, and A, B and C are matrices, with op( A )\n!> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] TRANSA\n!> \\verbatim\n!> TRANSA is CHARACTER*1\n!> On entry, TRANSA specifies the form of op( A ) to be used in\n!> the matrix multiplication as follows:\n!>\n!> TRANSA = 'N' or 'n', op( A ) = A.\n!>\n!> TRANSA = 'T' or 't', op( A ) = A**T.\n!>\n!> TRANSA = 'C' or 'c', op( A ) = A**T.\n!> \\endverbatim\n!>\n!> \\param[in] TRANSB\n!> \\verbatim\n!> TRANSB is CHARACTER*1\n!> On entry, TRANSB specifies the form of op( B ) to be used in\n!> the matrix multiplication as follows:\n!>\n!> TRANSB = 'N' or 'n', op( B ) = B.\n!>\n!> TRANSB = 'T' or 't', op( B ) = B**T.\n!>\n!> TRANSB = 'C' or 'c', op( B ) = B**T.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> On entry, M specifies the number of rows of the matrix\n!> op( A ) and of the matrix C. M must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the number of columns of the matrix\n!> op( B ) and the number of columns of the matrix C. N must be\n!> at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] K\n!> \\verbatim\n!> K is INTEGER\n!> On entry, K specifies the number of columns of the matrix\n!> op( A ) and the number of rows of the matrix op( B ). K must\n!> be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is\n!> k when TRANSA = 'N' or 'n', and is m otherwise.\n!> Before entry with TRANSA = 'N' or 'n', the leading m by k\n!> part of the array A must contain the matrix A, otherwise\n!> the leading k by m part of the array A must contain the\n!> matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. When TRANSA = 'N' or 'n' then\n!> LDA must be at least max( 1, m ), otherwise LDA must be at\n!> least max( 1, k ).\n!> \\endverbatim\n!>\n!> \\param[in] B\n!> \\verbatim\n!> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is\n!> n when TRANSB = 'N' or 'n', and is k otherwise.\n!> Before entry with TRANSB = 'N' or 'n', the leading k by n\n!> part of the array B must contain the matrix B, otherwise\n!> the leading n by k part of the array B must contain the\n!> matrix B.\n!> \\endverbatim\n!>\n!> \\param[in] LDB\n!> \\verbatim\n!> LDB is INTEGER\n!> On entry, LDB specifies the first dimension of B as declared\n!> in the calling (sub) program. When TRANSB = 'N' or 'n' then\n!> LDB must be at least max( 1, k ), otherwise LDB must be at\n!> least max( 1, n ).\n!> \\endverbatim\n!>\n!> \\param[in] BETA\n!> \\verbatim\n!> BETA is DOUBLE PRECISION.\n!> On entry, BETA specifies the scalar beta. When BETA is\n!> supplied as zero then C need not be set on input.\n!> \\endverbatim\n!>\n!> \\param[in,out] C\n!> \\verbatim\n!> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).\n!> Before entry, the leading m by n part of the array C must\n!> contain the matrix C, except when beta is zero, in which\n!> case C need not be set on entry.\n!> On exit, the array C is overwritten by the m by n matrix\n!> ( alpha*op( A )*op( B ) + beta*C ).\n!> \\endverbatim\n!>\n!> \\param[in] LDC\n!> \\verbatim\n!> LDC is INTEGER\n!> On entry, LDC specifies the first dimension of C as declared\n!> in the calling (sub) program. LDC must be at least\n!> max( 1, m ).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup double_blas_level3\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 3 Blas routine.\n!>\n!> -- Written on 8-February-1989.\n!> Jack Dongarra, Argonne National Laboratory.\n!> Iain Duff, AERE Harwell.\n!> Jeremy Du Croz, Numerical Algorithms Group Ltd.\n!> Sven Hammarling, Numerical Algorithms Group Ltd.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)\n!\n! -- Reference BLAS level3 routine (version 3.6.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA,BETA\n INTEGER K,LDA,LDB,LDC,M,N\n CHARACTER TRANSA,TRANSB\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)\n! ..\n!\n! =====================================================================\n!\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB\n LOGICAL NOTA,NOTB\n! ..\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n!\n! Set NOTA and NOTB as true if A and B respectively are not\n! transposed and set NROWA, NCOLA and NROWB as the number of rows\n! and columns of A and the number of rows of B respectively.\n!\n NOTA = LSAME(TRANSA,'N')\n NOTB = LSAME(TRANSB,'N')\n IF (NOTA) THEN\n NROWA = M\n NCOLA = K\n ELSE\n NROWA = K\n NCOLA = M\n END IF\n IF (NOTB) THEN\n NROWB = K\n ELSE\n NROWB = N\n END IF\n!\n! Test the input parameters.\n!\n INFO = 0\n IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. &\n (.NOT.LSAME(TRANSA,'T'))) THEN\n INFO = 1\n ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. &\n (.NOT.LSAME(TRANSB,'T'))) THEN\n INFO = 2\n ELSE IF (M.LT.0) THEN\n INFO = 3\n ELSE IF (N.LT.0) THEN\n INFO = 4\n ELSE IF (K.LT.0) THEN\n INFO = 5\n ELSE IF (LDA.LT.MAX(1,NROWA)) THEN\n INFO = 8\n ELSE IF (LDB.LT.MAX(1,NROWB)) THEN\n INFO = 10\n ELSE IF (LDC.LT.MAX(1,M)) THEN\n INFO = 13\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DGEMM ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((M.EQ.0) .OR. (N.EQ.0) .OR. &\n (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN\n!\n! And if alpha.eq.zero.\n!\n IF (ALPHA.EQ.ZERO) THEN\n IF (BETA.EQ.ZERO) THEN\n DO 20 J = 1,N\n DO 10 I = 1,M\n C(I,J) = ZERO\n 10 CONTINUE\n 20 CONTINUE\n ELSE\n DO 40 J = 1,N\n DO 30 I = 1,M\n C(I,J) = BETA*C(I,J)\n 30 CONTINUE\n 40 CONTINUE\n END IF\n RETURN\n END IF\n!\n! Start the operations.\n!\n IF (NOTB) THEN\n IF (NOTA) THEN\n!\n! Form C := alpha*A*B + beta*C.\n!\n DO 90 J = 1,N\n IF (BETA.EQ.ZERO) THEN\n DO 50 I = 1,M\n C(I,J) = ZERO\n 50 CONTINUE\n ELSE IF (BETA.NE.ONE) THEN\n DO 60 I = 1,M\n C(I,J) = BETA*C(I,J)\n 60 CONTINUE\n END IF\n DO 80 L = 1,K\n TEMP = ALPHA*B(L,J)\n DO 70 I = 1,M\n C(I,J) = C(I,J) + TEMP*A(I,L)\n 70 CONTINUE\n 80 CONTINUE\n 90 CONTINUE\n ELSE\n!\n! Form C := alpha*A**T*B + beta*C\n!\n DO 120 J = 1,N\n DO 110 I = 1,M\n TEMP = ZERO\n DO 100 L = 1,K\n TEMP = TEMP + A(L,I)*B(L,J)\n 100 CONTINUE\n IF (BETA.EQ.ZERO) THEN\n C(I,J) = ALPHA*TEMP\n ELSE\n C(I,J) = ALPHA*TEMP + BETA*C(I,J)\n END IF\n 110 CONTINUE\n 120 CONTINUE\n END IF\n ELSE\n IF (NOTA) THEN\n!\n! Form C := alpha*A*B**T + beta*C\n!\n DO 170 J = 1,N\n IF (BETA.EQ.ZERO) THEN\n DO 130 I = 1,M\n C(I,J) = ZERO\n 130 CONTINUE\n ELSE IF (BETA.NE.ONE) THEN\n DO 140 I = 1,M\n C(I,J) = BETA*C(I,J)\n 140 CONTINUE\n END IF\n DO 160 L = 1,K\n TEMP = ALPHA*B(J,L)\n DO 150 I = 1,M\n C(I,J) = C(I,J) + TEMP*A(I,L)\n 150 CONTINUE\n 160 CONTINUE\n 170 CONTINUE\n ELSE\n!\n! Form C := alpha*A**T*B**T + beta*C\n!\n DO 200 J = 1,N\n DO 190 I = 1,M\n TEMP = ZERO\n DO 180 L = 1,K\n TEMP = TEMP + A(L,I)*B(J,L)\n 180 CONTINUE\n IF (BETA.EQ.ZERO) THEN\n C(I,J) = ALPHA*TEMP\n ELSE\n C(I,J) = ALPHA*TEMP + BETA*C(I,J)\n END IF\n 190 CONTINUE\n 200 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DGEMM .\n!\n END SUBROUTINE DGEMM\n!\n!> \\brief \\b DGEMV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA,BETA\n! INTEGER INCX,INCY,LDA,M,N\n! CHARACTER TRANS\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGEMV performs one of the matrix-vector operations\n!>\n!> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,\n!>\n!> where alpha and beta are scalars, x and y are vectors and A is an\n!> m by n matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> On entry, TRANS specifies the operation to be performed as\n!> follows:\n!>\n!> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.\n!>\n!> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.\n!>\n!> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> On entry, M specifies the number of rows of the matrix A.\n!> M must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the number of columns of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n!> Before entry, the leading m by n part of the array A must\n!> contain the matrix of coefficients.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. LDA must be at least\n!> max( 1, m ).\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of DIMENSION at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n!> and at least\n!> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n!> Before entry, the incremented array X must contain the\n!> vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in] BETA\n!> \\verbatim\n!> BETA is DOUBLE PRECISION.\n!> On entry, BETA specifies the scalar beta. When BETA is\n!> supplied as zero then Y need not be set on input.\n!> \\endverbatim\n!>\n!> \\param[in,out] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION array of DIMENSION at least\n!> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n!> and at least\n!> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n!> Before entry with BETA non-zero, the incremented array Y\n!> must contain the vector y. On exit, Y is overwritten by the\n!> updated vector y.\n!> \\endverbatim\n!>\n!> \\param[in] INCY\n!> \\verbatim\n!> INCY is INTEGER\n!> On entry, INCY specifies the increment for the elements of\n!> Y. INCY must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!> The vector and matrix arguments are not referenced when N = 0, or M = 0\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)\n!\n! -- Reference BLAS level2 routine (version 3.6.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA,BETA\n INTEGER INCX,INCY,LDA,M,N\n CHARACTER TRANS\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. &\n .NOT.LSAME(TRANS,'C')) THEN\n INFO = 1\n ELSE IF (M.LT.0) THEN\n INFO = 2\n ELSE IF (N.LT.0) THEN\n INFO = 3\n ELSE IF (LDA.LT.MAX(1,M)) THEN\n INFO = 6\n ELSE IF (INCX.EQ.0) THEN\n INFO = 8\n ELSE IF (INCY.EQ.0) THEN\n INFO = 11\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DGEMV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((M.EQ.0) .OR. (N.EQ.0) .OR. &\n ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN\n!\n! Set LENX and LENY, the lengths of the vectors x and y, and set\n! up the start points in X and Y.\n!\n IF (LSAME(TRANS,'N')) THEN\n LENX = N\n LENY = M\n ELSE\n LENX = M\n LENY = N\n END IF\n IF (INCX.GT.0) THEN\n KX = 1\n ELSE\n KX = 1 - (LENX-1)*INCX\n END IF\n IF (INCY.GT.0) THEN\n KY = 1\n ELSE\n KY = 1 - (LENY-1)*INCY\n END IF\n!\n! Start the operations. In this version the elements of A are\n! accessed sequentially with one pass through A.\n!\n! First form y := beta*y.\n!\n IF (BETA.NE.ONE) THEN\n IF (INCY.EQ.1) THEN\n IF (BETA.EQ.ZERO) THEN\n DO 10 I = 1,LENY\n Y(I) = ZERO\n 10 CONTINUE\n ELSE\n DO 20 I = 1,LENY\n Y(I) = BETA*Y(I)\n 20 CONTINUE\n END IF\n ELSE\n IY = KY\n IF (BETA.EQ.ZERO) THEN\n DO 30 I = 1,LENY\n Y(IY) = ZERO\n IY = IY + INCY\n 30 CONTINUE\n ELSE\n DO 40 I = 1,LENY\n Y(IY) = BETA*Y(IY)\n IY = IY + INCY\n 40 CONTINUE\n END IF\n END IF\n END IF\n IF (ALPHA.EQ.ZERO) RETURN\n IF (LSAME(TRANS,'N')) THEN\n!\n! Form y := alpha*A*x + y.\n!\n JX = KX\n IF (INCY.EQ.1) THEN\n DO 60 J = 1,N\n TEMP = ALPHA*X(JX)\n DO 50 I = 1,M\n Y(I) = Y(I) + TEMP*A(I,J)\n 50 CONTINUE\n JX = JX + INCX\n 60 CONTINUE\n ELSE\n DO 80 J = 1,N\n TEMP = ALPHA*X(JX)\n IY = KY\n DO 70 I = 1,M\n Y(IY) = Y(IY) + TEMP*A(I,J)\n IY = IY + INCY\n 70 CONTINUE\n JX = JX + INCX\n 80 CONTINUE\n END IF\n ELSE\n!\n! Form y := alpha*A**T*x + y.\n!\n JY = KY\n IF (INCX.EQ.1) THEN\n DO 100 J = 1,N\n TEMP = ZERO\n DO 90 I = 1,M\n TEMP = TEMP + A(I,J)*X(I)\n 90 CONTINUE\n Y(JY) = Y(JY) + ALPHA*TEMP\n JY = JY + INCY\n 100 CONTINUE\n ELSE\n DO 120 J = 1,N\n TEMP = ZERO\n IX = KX\n DO 110 I = 1,M\n TEMP = TEMP + A(I,J)*X(IX)\n IX = IX + INCX\n 110 CONTINUE\n Y(JY) = Y(JY) + ALPHA*TEMP\n JY = JY + INCY\n 120 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DGEMV .\n!\n END SUBROUTINE DGEMV\n!\n!> \\brief \\b DGETRF\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DGETRF + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGETRF computes an LU factorization of a general M-by-N matrix A\n!> using partial pivoting with row interchanges.\n!>\n!> The factorization has the form\n!> A = P * L * U\n!> where P is a permutation matrix, L is lower triangular with unit\n!> diagonal elements (lower trapezoidal if m > n), and U is upper\n!> triangular (upper trapezoidal if m < n).\n!>\n!> This is the right-looking Level 3 BLAS version of the algorithm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the M-by-N matrix to be factored.\n!> On exit, the factors L and U from the factorization\n!> A = P*L*U; the unit diagonal elements of L are not stored.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (min(M,N))\n!> The pivot indices; for 1 <= i <= min(M,N), row i of the\n!> matrix was interchanged with row IPIV(i).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n!> has been completed, but the factor U is exactly\n!> singular, and division by zero will occur if it is used\n!> to solve a system of equations.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup doubleGEcomputational\n!\n! =====================================================================\n SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n!\n! -- LAPACK computational routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, IINFO, J, JB, NB\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA\n! ..\n! .. External Functions ..\n! INTEGER ILAENV\n! EXTERNAL ILAENV\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF( M.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = -4\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DGETRF', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( M.EQ.0 .OR. N.EQ.0 ) RETURN\n!\n! Determine the block size for this environment.\n!\n NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )\n IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN\n!\n! Use unblocked code.\n!\n CALL DGETRF2( M, N, A, LDA, IPIV, INFO )\n ELSE\n!\n! Use blocked code.\n!\n DO 20 J = 1, MIN( M, N ), NB\n JB = MIN( MIN( M, N )-J+1, NB )\n!\n! Factor diagonal and subdiagonal blocks and test for exact\n! singularity.\n!\n CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )\n!\n! Adjust INFO and the pivot indices.\n!\n IF( INFO.EQ.0 .AND. IINFO.GT.0 ) &\n INFO = IINFO + J - 1\n DO 10 I = J, MIN( M, J+JB-1 )\n IPIV( I ) = J - 1 + IPIV( I )\n 10 CONTINUE\n!\n! Apply interchanges to columns 1:J-1.\n!\n CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )\n!\n IF( J+JB.LE.N ) THEN\n!\n! Apply interchanges to columns J+JB:N.\n!\n CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, &\n IPIV, 1 )\n!\n! Compute block row of U.\n!\n CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &\n N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &\n LDA )\n IF( J+JB.LE.M ) THEN\n!\n! Update trailing submatrix.\n!\n CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, &\n N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, &\n A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), &\n LDA )\n END IF\n END IF\n 20 CONTINUE\n END IF\n RETURN\n!\n! End of DGETRF\n!\n END SUBROUTINE DGETRF\n!\n!> \\brief \\b DGETRF2\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGETRF2 computes an LU factorization of a general M-by-N matrix A\n!> using partial pivoting with row interchanges.\n!>\n!> The factorization has the form\n!> A = P * L * U\n!> where P is a permutation matrix, L is lower triangular with unit\n!> diagonal elements (lower trapezoidal if m > n), and U is upper\n!> triangular (upper trapezoidal if m < n).\n!>\n!> This is the recursive version of the algorithm. It divides\n!> the matrix into four submatrices:\n!> \n!> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2\n!> A = [ -----|----- ] with n1 = min(m,n)\n!> [ A21 | A22 ] n2 = n-n1\n!> \n!> [ A11 ]\n!> The subroutine calls itself to factor [ --- ],\n!> [ A12 ]\n!> [ A12 ]\n!> do the swaps on [ --- ], solve A12, update A22,\n!> [ A22 ]\n!>\n!> then calls itself to factor A22 and do the swaps on A21.\n!>\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the M-by-N matrix to be factored.\n!> On exit, the factors L and U from the factorization\n!> A = P*L*U; the unit diagonal elements of L are not stored.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (min(M,N))\n!> The pivot indices; for 1 <= i <= min(M,N), row i of the\n!> matrix was interchanged with row IPIV(i).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n!> has been completed, but the factor U is exactly\n!> singular, and division by zero will occur if it is used\n!> to solve a system of equations.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup doubleGEcomputational\n!\n! =====================================================================\n RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO )\n!\n! -- LAPACK computational routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION SFMIN, TEMP\n INTEGER I, IINFO, N1, N2\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMCH\n! INTEGER IDAMAX\n! EXTERNAL DLAMCH, IDAMAX\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters\n!\n INFO = 0\n IF( M.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = -4\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DGETRF2', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( M.EQ.0 .OR. N.EQ.0 ) RETURN\n\n IF ( M.EQ.1 ) THEN\n!\n! Use unblocked code for one row case\n! Just need to handle IPIV and INFO\n!\n IPIV( 1 ) = 1\n IF ( A(1,1).EQ.ZERO ) INFO = 1\n!\n ELSE IF( N.EQ.1 ) THEN\n!\n! Use unblocked code for one column case\n!\n!\n! Compute machine safe minimum\n!\n SFMIN = DLAMCH('S')\n!\n! Find pivot and test for singularity\n!\n I = IDAMAX( M, A( 1, 1 ), 1 )\n IPIV( 1 ) = I\n IF( A( I, 1 ).NE.ZERO ) THEN\n!\n! Apply the interchange\n!\n IF( I.NE.1 ) THEN\n TEMP = A( 1, 1 )\n A( 1, 1 ) = A( I, 1 )\n A( I, 1 ) = TEMP\n END IF\n!\n! Compute elements 2:M of the column\n!\n IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN\n CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )\n ELSE\n DO 10 I = 1, M-1\n A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )\n 10 CONTINUE\n END IF\n!\n ELSE\n INFO = 1\n END IF\n!\n ELSE\n!\n! Use recursive code\n!\n N1 = MIN( M, N ) / 2\n N2 = N-N1\n!\n! [ A11 ]\n! Factor [ --- ]\n! [ A21 ]\n!\n CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO )\n\n IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO\n!\n! [ A12 ]\n! Apply interchanges to [ --- ]\n! [ A22 ]\n!\n CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )\n!\n! Solve A12\n!\n CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, &\n A( 1, N1+1 ), LDA )\n!\n! Update A22\n!\n CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, &\n A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )\n!\n! Factor A22\n!\n CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), &\n IINFO )\n!\n! Adjust INFO and the pivot indices\n!\n IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO + N1\n DO 20 I = N1+1, MIN( M, N )\n IPIV( I ) = IPIV( I ) + N1\n 20 CONTINUE\n!\n! Apply interchanges to A21\n!\n CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )\n!\n END IF\n RETURN\n!\n! End of DGETRF2\n!\n END SUBROUTINE DGETRF2\n!\n!> \\brief \\b DGETRS\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DGETRS + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER TRANS\n! INTEGER INFO, LDA, LDB, N, NRHS\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * ), B( LDB, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGETRS solves a system of linear equations\n!> A * X = B or A**T * X = B\n!> with a general N-by-N matrix A using the LU factorization computed\n!> by DGETRF.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> Specifies the form of the system of equations:\n!> = 'N': A * X = B (No transpose)\n!> = 'T': A**T* X = B (Transpose)\n!> = 'C': A**T* X = B (Conjugate transpose = Transpose)\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] NRHS\n!> \\verbatim\n!> NRHS is INTEGER\n!> The number of right hand sides, i.e., the number of columns\n!> of the matrix B. NRHS >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The factors L and U from the factorization A = P*L*U\n!> as computed by DGETRF.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> The pivot indices from DGETRF; for 1<=i<=N, row i of the\n!> matrix was interchanged with row IPIV(i).\n!> \\endverbatim\n!>\n!> \\param[in,out] B\n!> \\verbatim\n!> B is DOUBLE PRECISION array, dimension (LDB,NRHS)\n!> On entry, the right hand side matrix B.\n!> On exit, the solution matrix X.\n!> \\endverbatim\n!>\n!> \\param[in] LDB\n!> \\verbatim\n!> LDB is INTEGER\n!> The leading dimension of the array B. LDB >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleGEcomputational\n!\n! =====================================================================\n SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER TRANS\n INTEGER INFO, LDA, LDB, N, NRHS\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * ), B( LDB, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL NOTRAN\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLASWP, DTRSM, XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n NOTRAN = LSAME( TRANS, 'N' )\n IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &\n LSAME( TRANS, 'C' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( NRHS.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -5\n ELSE IF( LDB.LT.MAX( 1, N ) ) THEN\n INFO = -8\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DGETRS', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 .OR. NRHS.EQ.0 ) RETURN\n!\n IF( NOTRAN ) THEN\n!\n! Solve A * X = B.\n!\n! Apply row interchanges to the right hand sides.\n!\n CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )\n!\n! Solve L*X = B, overwriting B with X.\n!\n CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, &\n ONE, A, LDA, B, LDB )\n!\n! Solve U*X = B, overwriting B with X.\n!\n CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, &\n NRHS, ONE, A, LDA, B, LDB )\n ELSE\n!\n! Solve A**T * X = B.\n!\n! Solve U**T *X = B, overwriting B with X.\n!\n CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, &\n ONE, A, LDA, B, LDB )\n!\n! Solve L**T *X = B, overwriting B with X.\n!\n CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, &\n A, LDA, B, LDB )\n!\n! Apply row interchanges to the solution vectors.\n!\n CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )\n END IF\n!\n RETURN\n!\n! End of DGETRS\n!\n END SUBROUTINE DGETRS\n!> \\brief \\b DISNAN tests input for NaN.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DISNAN + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! LOGICAL FUNCTION DISNAN( DIN )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION DIN\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n!> otherwise. To be replaced by the Fortran 2003 intrinsic in the\n!> future.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] DIN\n!> \\verbatim\n!> DIN is DOUBLE PRECISION\n!> Input to test for NaN.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n LOGICAL FUNCTION DISNAN( DIN )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION DIN\n! ..\n!\n!=\n!\n! .. External Functions ..\n! LOGICAL DLAISNAN\n! EXTERNAL DLAISNAN\n! ..\n! .. Executable Statements ..\n DISNAN = DLAISNAN(DIN,DIN)\n RETURN\n END FUNCTION DISNAN\n!\n!> \\brief \\b DLAISNAN tests input for NaN by comparing two arguments for inequality.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAISNAN + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION DIN1, DIN2\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> This routine is not for general use. It exists solely to avoid\n!> over-optimization in DISNAN.\n!>\n!> DLAISNAN checks for NaNs by comparing its two arguments for\n!> inequality. NaN is the only floating-point value where NaN != NaN\n!> returns .TRUE. To check for NaNs, pass the same variable as both\n!> arguments.\n!>\n!> A compiler must assume that the two arguments are\n!> not the same variable, and the test will not be optimized away.\n!> Interprocedural or whole-program optimization may delete this\n!> test. The ISNAN functions will be replaced by the correct\n!> Fortran 03 intrinsic once the intrinsic is widely available.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] DIN1\n!> \\verbatim\n!> DIN1 is DOUBLE PRECISION\n!> \\endverbatim\n!>\n!> \\param[in] DIN2\n!> \\verbatim\n!> DIN2 is DOUBLE PRECISION\n!> Two numbers to compare for inequality.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION DIN1, DIN2\n! ..\n!\n! =====================================================================\n!\n! .. Executable Statements ..\n DLAISNAN = (DIN1.NE.DIN2)\n RETURN\n END FUNCTION DLAISNAN\n!\n!> \\brief \\b DLAMCH\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DLAMCH( CMACH )\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAMCH determines double precision machine parameters.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] CMACH\n!> \\verbatim\n!> Specifies the value to be returned by DLAMCH:\n!> = 'E' or 'e', DLAMCH := eps\n!> = 'S' or 's , DLAMCH := sfmin\n!> = 'B' or 'b', DLAMCH := base\n!> = 'P' or 'p', DLAMCH := eps*base\n!> = 'N' or 'n', DLAMCH := t\n!> = 'R' or 'r', DLAMCH := rnd\n!> = 'M' or 'm', DLAMCH := emin\n!> = 'U' or 'u', DLAMCH := rmin\n!> = 'L' or 'l', DLAMCH := emax\n!> = 'O' or 'o', DLAMCH := rmax\n!> where\n!> eps = relative machine precision\n!> sfmin = safe minimum, such that 1/sfmin does not overflow\n!> base = base of the machine\n!> prec = eps*base\n!> t = number of (base) digits in the mantissa\n!> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise\n!> emin = minimum exponent before (gradual) underflow\n!> rmin = underflow threshold - base**(emin-1)\n!> emax = largest exponent before overflow\n!> rmax = overflow threshold - (base**emax)*(1-eps)\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n DOUBLE PRECISION FUNCTION DLAMCH( CMACH )\n!\n! -- LAPACK auxiliary routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n CHARACTER CMACH\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, &\n MINEXPONENT, RADIX, TINY\n! ..\n! .. Executable Statements ..\n!\n!\n! Assume rounding, not chopping. Always.\n!\n RND = ONE\n!\n IF( ONE.EQ.RND ) THEN\n EPS = EPSILON(ZERO) * 0.5\n ELSE\n EPS = EPSILON(ZERO)\n END IF\n!\n IF( LSAME( CMACH, 'E' ) ) THEN\n RMACH = EPS\n ELSE IF( LSAME( CMACH, 'S' ) ) THEN\n SFMIN = TINY(ZERO)\n SMALL = ONE / HUGE(ZERO)\n IF( SMALL.GE.SFMIN ) THEN\n!\n! Use SMALL plus a bit, to avoid the possibility of rounding\n! causing overflow when computing 1/sfmin.\n!\n SFMIN = SMALL*( ONE+EPS )\n END IF\n RMACH = SFMIN\n ELSE IF( LSAME( CMACH, 'B' ) ) THEN\n RMACH = RADIX(ZERO)\n ELSE IF( LSAME( CMACH, 'P' ) ) THEN\n RMACH = EPS * RADIX(ZERO)\n ELSE IF( LSAME( CMACH, 'N' ) ) THEN\n RMACH = DIGITS(ZERO)\n ELSE IF( LSAME( CMACH, 'R' ) ) THEN\n RMACH = RND\n ELSE IF( LSAME( CMACH, 'M' ) ) THEN\n RMACH = MINEXPONENT(ZERO)\n ELSE IF( LSAME( CMACH, 'U' ) ) THEN\n RMACH = tiny(zero)\n ELSE IF( LSAME( CMACH, 'L' ) ) THEN\n RMACH = MAXEXPONENT(ZERO)\n ELSE IF( LSAME( CMACH, 'O' ) ) THEN\n RMACH = HUGE(ZERO)\n ELSE\n RMACH = ZERO\n END IF\n!\n DLAMCH = RMACH\n RETURN\n!\n! End of DLAMCH\n!\n END FUNCTION DLAMCH\n!\n!***********************************************************************\n!> \\brief \\b DLAMC3\n!> \\details\n!> \\b Purpose:\n!> \\verbatim\n!> DLAMC3 is intended to force A and B to be stored prior to doing\n!> the addition of A and B , for use in situations where optimizers\n!> might hold one of these in a register.\n!> \\endverbatim\n!> \\author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..\n!> \\date November 2015\n!> \\ingroup auxOTHERauxiliary\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is a DOUBLE PRECISION\n!> \\endverbatim\n!>\n!> \\param[in] B\n!> \\verbatim\n!> B is a DOUBLE PRECISION\n!> The values A and B.\n!> \\endverbatim\n!>\n DOUBLE PRECISION FUNCTION DLAMC3( A, B )\n!\n! -- LAPACK auxiliary routine (version 3.6.0) --\n! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..\n! November 2010\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION A, B\n! ..\n! =====================================================================\n!\n! .. Executable Statements ..\n!\n DLAMC3 = A + B\n!\n RETURN\n!\n! End of DLAMC3\n!\n END FUNCTION DLAMC3\n!\n!***********************************************************************\n!> \\brief \\b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAMRG + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n! \n! .. Scalar Arguments ..\n! INTEGER DTRD1, DTRD2, N1, N2\n! ..\n! .. Array Arguments ..\n! INTEGER INDEX( * )\n! DOUBLE PRECISION A( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAMRG will create a permutation list which will merge the elements\n!> of A (which is composed of two independently sorted sets) into a\n!> single set which is sorted in ascending order.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N1\n!> \\verbatim\n!> N1 is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] N2\n!> \\verbatim\n!> N2 is INTEGER\n!> These arguements contain the respective lengths of the two\n!> sorted lists to be merged.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (N1+N2)\n!> The first N1 elements of A contain a list of numbers which\n!> are sorted in either ascending or descending order. Likewise\n!> for the final N2 elements.\n!> \\endverbatim\n!>\n!> \\param[in] DTRD1\n!> \\verbatim\n!> DTRD1 is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] DTRD2\n!> \\verbatim\n!> DTRD2 is INTEGER\n!> These are the strides to be taken through the array A.\n!> Allowable strides are 1 and -1. They indicate whether a\n!> subset of A is sorted in ascending (DTRDx = 1) or descending\n!> (DTRDx = -1) order.\n!> \\endverbatim\n!>\n!> \\param[out] INDEX\n!> \\verbatim\n!> INDEX is INTEGER array, dimension (N1+N2)\n!> On exit this array will contain a permutation such that\n!> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n!> sorted in ascending order.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER DTRD1, DTRD2, N1, N2\n! ..\n! .. Array Arguments ..\n INTEGER INDEX( * )\n DOUBLE PRECISION A( * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n! ..\n! .. Executable Statements ..\n!\n N1SV = N1\n N2SV = N2\n IF( DTRD1.GT.0 ) THEN\n IND1 = 1\n ELSE\n IND1 = N1\n END IF\n IF( DTRD2.GT.0 ) THEN\n IND2 = 1 + N1\n ELSE\n IND2 = N1 + N2\n END IF\n I = 1\n! while ( (N1SV > 0) & (N2SV > 0) )\n 10 CONTINUE\n IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN\n IF( A( IND1 ).LE.A( IND2 ) ) THEN\n INDEX( I ) = IND1\n I = I + 1\n IND1 = IND1 + DTRD1\n N1SV = N1SV - 1\n ELSE\n INDEX( I ) = IND2\n I = I + 1\n IND2 = IND2 + DTRD2\n N2SV = N2SV - 1\n END IF\n GO TO 10\n END IF\n! end while\n IF( N1SV.EQ.0 ) THEN\n DO 20 N1SV = 1, N2SV\n INDEX( I ) = IND2\n I = I + 1\n IND2 = IND2 + DTRD2\n 20 CONTINUE\n ELSE\n! N2SV .EQ. 0\n DO 30 N2SV = 1, N1SV\n INDEX( I ) = IND1\n I = I + 1\n IND1 = IND1 + DTRD1\n 30 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DLAMRG\n!\n END SUBROUTINE DLAMRG\n!\n!> \\brief \\b DLASWP performs a series of row interchanges on a general rectangular matrix.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASWP + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n! \n! .. Scalar Arguments ..\n! INTEGER INCX, K1, K2, LDA, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASWP performs a series of row interchanges on the matrix A.\n!> One row interchange is initiated for each of rows K1 through K2 of A.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the matrix of column dimension N to which the row\n!> interchanges will be applied.\n!> On exit, the permuted matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A.\n!> \\endverbatim\n!>\n!> \\param[in] K1\n!> \\verbatim\n!> K1 is INTEGER\n!> The first element of IPIV for which a row interchange will\n!> be done.\n!> \\endverbatim\n!>\n!> \\param[in] K2\n!> \\verbatim\n!> K2 is INTEGER\n!> The last element of IPIV for which a row interchange will\n!> be done.\n!> \\endverbatim\n!>\n!> \\param[in] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (K2*abs(INCX))\n!> The vector of pivot indices. Only the elements in positions\n!> K1 through K2 of IPIV are accessed.\n!> IPIV(K) = L implies rows K and L are to be interchanged.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> The increment between successive values of IPIV. If IPIV\n!> is negative, the pivots are applied in reverse order.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERauxiliary\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Modified by\n!> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INCX, K1, K2, LDA, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n DOUBLE PRECISION TEMP\n! ..\n! .. Executable Statements ..\n!\n! Interchange row I with row IPIV(I) for each of rows K1 through K2.\n!\n IF( INCX.GT.0 ) THEN\n IX0 = K1\n I1 = K1\n I2 = K2\n INC = 1\n ELSE IF( INCX.LT.0 ) THEN\n IX0 = 1 + ( 1-K2 )*INCX\n I1 = K2\n I2 = K1\n INC = -1\n ELSE\n RETURN\n END IF\n!\n N32 = ( N / 32 )*32\n IF( N32.NE.0 ) THEN\n DO 30 J = 1, N32, 32\n IX = IX0\n DO 20 I = I1, I2, INC\n IP = IPIV( IX )\n IF( IP.NE.I ) THEN\n DO 10 K = J, J + 31\n TEMP = A( I, K )\n A( I, K ) = A( IP, K )\n A( IP, K ) = TEMP\n 10 CONTINUE\n END IF\n IX = IX + INCX\n 20 CONTINUE\n 30 CONTINUE\n END IF\n IF( N32.NE.N ) THEN\n N32 = N32 + 1\n IX = IX0\n DO 50 I = I1, I2, INC\n IP = IPIV( IX )\n IF( IP.NE.I ) THEN\n DO 40 K = N32, N\n TEMP = A( I, K )\n A( I, K ) = A( IP, K )\n A( IP, K ) = TEMP\n 40 CONTINUE\n END IF\n IX = IX + INCX\n 50 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DLASWP\n!\n END SUBROUTINE DLASWP\n!\n!> \\brief \\b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at\n! http://www.netlib.org/lapack/explore-html/\n!\n!> \\htmlonly\n!> Download DLASYF + dependencies\n!> \n!> [TGZ]\n!> \n!> [ZIP]\n!> \n!> [TXT]\n!> \\endhtmlonly\n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n!\n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, KB, LDA, LDW, N, NB\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * ), W( LDW, * )\n! ..\n!\n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASYF computes a partial factorization of a real symmetric matrix A\n!> using the Bunch-Kaufman diagonal pivoting method. The partial\n!> factorization has the form:\n!>\n!> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n!> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )\n!>\n!> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'\n!> ( L21 I ) ( 0 A22 ) ( 0 I )\n!>\n!> where the order of D is at most NB. The actual order is returned in\n!> the argument KB, and is either NB or NB-1, or N if N <= NB.\n!>\n!> DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code\n!> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n!> A22 (if UPLO = 'L').\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies whether the upper or lower triangular part of the\n!> symmetric matrix A is stored:\n!> = 'U': Upper triangular\n!> = 'L': Lower triangular\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] NB\n!> \\verbatim\n!> NB is INTEGER\n!> The maximum number of columns of the matrix A that should be\n!> factored. NB should be at least 2 to allow for 2-by-2 pivot\n!> blocks.\n!> \\endverbatim\n!>\n!> \\param[out] KB\n!> \\verbatim\n!> KB is INTEGER\n!> The number of columns of A that were actually factored.\n!> KB is either NB-1 or NB, or N if N <= NB.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the symmetric matrix A. If UPLO = 'U', the leading\n!> n-by-n upper triangular part of A contains the upper\n!> triangular part of the matrix A, and the strictly lower\n!> triangular part of A is not referenced. If UPLO = 'L', the\n!> leading n-by-n lower triangular part of A contains the lower\n!> triangular part of the matrix A, and the strictly upper\n!> triangular part of A is not referenced.\n!> On exit, A contains details of the partial factorization.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> Details of the interchanges and the block structure of D.\n!>\n!> If UPLO = 'U':\n!> Only the last KB elements of IPIV are set.\n!>\n!> If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n!> interchanged and D(k,k) is a 1-by-1 diagonal block.\n!>\n!> If IPIV(k) = IPIV(k-1) < 0, then rows and columns\n!> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n!> is a 2-by-2 diagonal block.\n!>\n!> If UPLO = 'L':\n!> Only the first KB elements of IPIV are set.\n!>\n!> If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n!> interchanged and D(k,k) is a 1-by-1 diagonal block.\n!>\n!> If IPIV(k) = IPIV(k+1) < 0, then rows and columns\n!> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)\n!> is a 2-by-2 diagonal block.\n!> \\endverbatim\n!>\n!> \\param[out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (LDW,NB)\n!> \\endverbatim\n!>\n!> \\param[in] LDW\n!> \\verbatim\n!> LDW is INTEGER\n!> The leading dimension of the array W. LDW >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n!> has been completed, but the block diagonal matrix D is\n!> exactly singular.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee\n!> \\author Univ. of California Berkeley\n!> \\author Univ. of Colorado Denver\n!> \\author NAG Ltd.\n!\n!> \\date November 2013\n!\n!> \\ingroup doubleSYcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> \\verbatim\n!>\n!> November 2013, Igor Kozachenko,\n!> Computer Science Division,\n!> University of California, Berkeley\n!> \\endverbatim\n!\n! =====================================================================\n SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n!\n! -- LAPACK computational routine (version 3.5.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2013\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, KB, LDA, LDW, N, NB\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * ), W( LDW, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )\n DOUBLE PRECISION EIGHT, SEVTEN\n PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, &\n KSTEP, KW\n DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, &\n ROWMAX, T\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! INTEGER IDAMAX\n! EXTERNAL LSAME, IDAMAX\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n INFO = 0\n!\n! Initialize ALPHA for use in choosing pivot block size.\n!\n ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT\n!\n IF( LSAME( UPLO, 'U' ) ) THEN\n!\n! Factorize the trailing columns of A using the upper triangle\n! of A and working backwards, and compute the matrix W = U12*D\n! for use in updating A11\n!\n! K is the main loop index, decreasing from N in steps of 1 or 2\n!\n! KW is the column of W which corresponds to column K of A\n!\n K = N\n 10 CONTINUE\n KW = NB + K - N\n!\n! Exit from loop\n!\n IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) GO TO 30\n!\n! Copy column K of A to column KW of W and update it\n!\n CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )\n IF( K.LT.N ) &\n CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, &\n W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )\n!\n KSTEP = 1\n!\n! Determine rows and columns to be interchanged and whether\n! a 1-by-1 or 2-by-2 pivot block will be used\n!\n ABSAKK = ABS( W( K, KW ) )\n!\n! IMAX is the row-index of the largest off-diagonal element in\n! column K, and COLMAX is its absolute value.\n! Determine both COLMAX and IMAX.\n!\n IF( K.GT.1 ) THEN\n IMAX = IDAMAX( K-1, W( 1, KW ), 1 )\n COLMAX = ABS( W( IMAX, KW ) )\n ELSE\n COLMAX = ZERO\n END IF\n!\n IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n!\n! Column K is zero or underflow: set INFO and continue\n!\n IF( INFO.EQ.0 ) INFO = K\n KP = K\n ELSE\n IF( ABSAKK.GE.ALPHA*COLMAX ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE\n!\n! Copy column IMAX to column KW-1 of W and update it\n!\n CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )\n CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, &\n W( IMAX+1, KW-1 ), 1 )\n IF( K.LT.N ) &\n CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), &\n LDA, W( IMAX, KW+1 ), LDW, ONE, &\n W( 1, KW-1 ), 1 )\n!\n! JMAX is the column-index of the largest off-diagonal\n! element in row IMAX, and ROWMAX is its absolute value\n!\n JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )\n ROWMAX = ABS( W( JMAX, KW-1 ) )\n IF( IMAX.GT.1 ) THEN\n JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )\n ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )\n END IF\n!\n IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN\n!\n! interchange rows and columns K and IMAX, use 1-by-1\n! pivot block\n!\n KP = IMAX\n!\n! copy column KW-1 of W to column KW of W\n!\n CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )\n ELSE\n!\n! interchange rows and columns K-1 and IMAX, use 2-by-2\n! pivot block\n!\n KP = IMAX\n KSTEP = 2\n END IF\n END IF\n!\n! ============================================================\n!\n! KK is the column of A where pivoting step stopped\n!\n KK = K - KSTEP + 1\n!\n! KKW is the column of W which corresponds to column KK of A\n!\n KKW = NB + KK - N\n!\n! Interchange rows and columns KP and KK.\n! Updated column KP is already stored in column KKW of W.\n!\n IF( KP.NE.KK ) THEN\n!\n! Copy non-updated column KK to column KP of submatrix A\n! at step K. No need to copy element into column K\n! (or K and K-1 for 2-by-2 pivot) of A, since these columns\n! will be later overwritten.\n!\n A( KP, KP ) = A( KK, KK )\n CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), &\n LDA )\n IF( KP.GT.1 ) &\n CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )\n!\n! Interchange rows KK and KP in last K+1 to N columns of A\n! (columns K (or K and K-1 for 2-by-2 pivot) of A will be\n! later overwritten). Interchange rows KK and KP\n! in last KKW to NB columns of W.\n!\n IF( K.LT.N ) &\n CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), &\n LDA )\n CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), &\n LDW )\n END IF\n!\n IF( KSTEP.EQ.1 ) THEN\n!\n! 1-by-1 pivot block D(k): column kw of W now holds\n!\n! W(kw) = U(k)*D(k),\n!\n! where U(k) is the k-th column of U\n!\n! Store subdiag. elements of column U(k)\n! and 1-by-1 block D(k) in column k of A.\n! NOTE: Diagonal element U(k,k) is a UNIT element\n! and not stored.\n! A(k,k) := D(k,k) = W(k,kw)\n! A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)\n!\n CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )\n R1 = ONE / A( K, K )\n CALL DSCAL( K-1, R1, A( 1, K ), 1 )\n!\n ELSE\n!\n! 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold\n!\n! ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)\n!\n! where U(k) and U(k-1) are the k-th and (k-1)-th columns\n! of U\n!\n! Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2\n! block D(k-1:k,k-1:k) in columns k-1 and k of A.\n! NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT\n! block and not stored.\n! A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)\n! A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =\n! = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )\n!\n IF( K.GT.2 ) THEN\n!\n! Compose the columns of the inverse of 2-by-2 pivot\n! block D in the following way to reduce the number\n! of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by\n! this inverse\n!\n! D**(-1) = ( d11 d21 )**(-1) =\n! ( d21 d22 )\n!\n! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =\n! ( (-d21 ) ( d11 ) )\n!\n! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *\n!\n! * ( ( d22/d21 ) ( -1 ) ) =\n! ( ( -1 ) ( d11/d21 ) )\n!\n! = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =\n! ( ( -1 ) ( D22 ) )\n!\n! = 1/d21 * T * ( ( D11 ) ( -1 ) )\n! ( ( -1 ) ( D22 ) )\n!\n! = D21 * ( ( D11 ) ( -1 ) )\n! ( ( -1 ) ( D22 ) )\n!\n D21 = W( K-1, KW )\n D11 = W( K, KW ) / D21\n D22 = W( K-1, KW-1 ) / D21\n T = ONE / ( D11*D22-ONE )\n D21 = T / D21\n!\n! Update elements in columns A(k-1) and A(k) as\n! dot products of rows of ( W(kw-1) W(kw) ) and columns\n! of D**(-1)\n!\n DO 20 J = 1, K - 2\n A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )\n A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )\n 20 CONTINUE\n END IF\n!\n! Copy D(k) to A\n!\n A( K-1, K-1 ) = W( K-1, KW-1 )\n A( K-1, K ) = W( K-1, KW )\n A( K, K ) = W( K, KW )\n!\n END IF\n!\n END IF\n!\n! Store details of the interchanges in IPIV\n!\n IF( KSTEP.EQ.1 ) THEN\n IPIV( K ) = KP\n ELSE\n IPIV( K ) = -KP\n IPIV( K-1 ) = -KP\n END IF\n!\n! Decrease K and return to the start of the main loop\n!\n K = K - KSTEP\n GO TO 10\n!\n 30 CONTINUE\n!\n! Update the upper triangle of A11 (= A(1:k,1:k)) as\n!\n! A11 := A11 - U12*D*U12**T = A11 - U12*W**T\n!\n! computing blocks of NB columns at a time\n!\n DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB\n JB = MIN( NB, K-J+1 )\n!\n! Update the upper triangle of the diagonal block\n!\n DO 40 JJ = J, J + JB - 1\n CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, &\n A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, &\n A( J, JJ ), 1 )\n 40 CONTINUE\n!\n! Update the rectangular superdiagonal block\n!\n CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, &\n A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, &\n A( 1, J ), LDA )\n 50 CONTINUE\n!\n! Put U12 in standard form by partially undoing the interchanges\n! in columns k+1:n looping backwards from k+1 to n\n!\n J = K + 1\n 60 CONTINUE\n!\n! Undo the interchanges (if any) of rows JJ and JP at each\n! step J\n!\n! (Here, J is a diagonal index)\n JJ = J\n JP = IPIV( J )\n IF( JP.LT.0 ) THEN\n JP = -JP\n! (Here, J is a diagonal index)\n J = J + 1\n END IF\n! (NOTE: Here, J is used to determine row length. Length N-J+1\n! of the rows to swap back doesn't include diagonal element)\n J = J + 1\n IF( JP.NE.JJ .AND. J.LE.N ) &\n CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )\n IF( J.LT.N ) GO TO 60\n!\n! Set KB to the number of columns factorized\n!\n KB = N - K\n!\n ELSE\n!\n! Factorize the leading columns of A using the lower triangle\n! of A and working forwards, and compute the matrix W = L21*D\n! for use in updating A22\n!\n! K is the main loop index, increasing from 1 in steps of 1 or 2\n!\n K = 1\n 70 CONTINUE\n!\n! Exit from loop\n!\n IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) GO TO 90\n!\n! Copy column K of A to column K of W and update it\n!\n CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )\n CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, &\n W( K, 1 ), LDW, ONE, W( K, K ), 1 )\n!\n KSTEP = 1\n!\n! Determine rows and columns to be interchanged and whether\n! a 1-by-1 or 2-by-2 pivot block will be used\n!\n ABSAKK = ABS( W( K, K ) )\n!\n! IMAX is the row-index of the largest off-diagonal element in\n! column K, and COLMAX is its absolute value.\n! Determine both COLMAX and IMAX.\n!\n IF( K.LT.N ) THEN\n IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )\n COLMAX = ABS( W( IMAX, K ) )\n ELSE\n COLMAX = ZERO\n END IF\n!\n IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n!\n! Column K is zero or underflow: set INFO and continue\n!\n IF( INFO.EQ.0 ) INFO = K\n KP = K\n ELSE\n IF( ABSAKK.GE.ALPHA*COLMAX ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE\n!\n! Copy column IMAX to column K+1 of W and update it\n!\n CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )\n CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), &\n 1 )\n CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), &\n LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )\n!\n! JMAX is the column-index of the largest off-diagonal\n! element in row IMAX, and ROWMAX is its absolute value\n!\n JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )\n ROWMAX = ABS( W( JMAX, K+1 ) )\n IF( IMAX.LT.N ) THEN\n JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )\n ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )\n END IF\n!\n IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN\n!\n! interchange rows and columns K and IMAX, use 1-by-1\n! pivot block\n!\n KP = IMAX\n!\n! copy column K+1 of W to column K of W\n!\n CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )\n ELSE\n!\n! interchange rows and columns K+1 and IMAX, use 2-by-2\n! pivot block\n!\n KP = IMAX\n KSTEP = 2\n END IF\n END IF\n!\n! ============================================================\n!\n! KK is the column of A where pivoting step stopped\n!\n KK = K + KSTEP - 1\n!\n! Interchange rows and columns KP and KK.\n! Updated column KP is already stored in column KK of W.\n!\n IF( KP.NE.KK ) THEN\n!\n! Copy non-updated column KK to column KP of submatrix A\n! at step K. No need to copy element into column K\n! (or K and K+1 for 2-by-2 pivot) of A, since these columns\n! will be later overwritten.\n!\n A( KP, KP ) = A( KK, KK )\n CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), &\n LDA )\n IF( KP.LT.N ) &\n CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )\n!\n! Interchange rows KK and KP in first K-1 columns of A\n! (columns K (or K and K+1 for 2-by-2 pivot) of A will be\n! later overwritten). Interchange rows KK and KP\n! in first KK columns of W.\n!\n IF( K.GT.1 ) &\n CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )\n CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )\n END IF\n!\n IF( KSTEP.EQ.1 ) THEN\n!\n! 1-by-1 pivot block D(k): column k of W now holds\n!\n! W(k) = L(k)*D(k),\n!\n! where L(k) is the k-th column of L\n!\n! Store subdiag. elements of column L(k)\n! and 1-by-1 block D(k) in column k of A.\n! (NOTE: Diagonal element L(k,k) is a UNIT element\n! and not stored)\n! A(k,k) := D(k,k) = W(k,k)\n! A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)\n!\n CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )\n IF( K.LT.N ) THEN\n R1 = ONE / A( K, K )\n CALL DSCAL( N-K, R1, A( K+1, K ), 1 )\n END IF\n!\n ELSE\n!\n! 2-by-2 pivot block D(k): columns k and k+1 of W now hold\n!\n! ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)\n!\n! where L(k) and L(k+1) are the k-th and (k+1)-th columns\n! of L\n!\n! Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2\n! block D(k:k+1,k:k+1) in columns k and k+1 of A.\n! (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT\n! block and not stored)\n! A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)\n! A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =\n! = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )\n!\n IF( K.LT.N-1 ) THEN\n!\n! Compose the columns of the inverse of 2-by-2 pivot\n! block D in the following way to reduce the number\n! of FLOPS when we myltiply panel ( W(k) W(k+1) ) by\n! this inverse\n!\n! D**(-1) = ( d11 d21 )**(-1) =\n! ( d21 d22 )\n!\n! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =\n! ( (-d21 ) ( d11 ) )\n!\n! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *\n!\n! * ( ( d22/d21 ) ( -1 ) ) =\n! ( ( -1 ) ( d11/d21 ) )\n!\n! = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =\n! ( ( -1 ) ( D22 ) )\n!\n! = 1/d21 * T * ( ( D11 ) ( -1 ) )\n! ( ( -1 ) ( D22 ) )\n!\n! = D21 * ( ( D11 ) ( -1 ) )\n! ( ( -1 ) ( D22 ) )\n!\n D21 = W( K+1, K )\n D11 = W( K+1, K+1 ) / D21\n D22 = W( K, K ) / D21\n T = ONE / ( D11*D22-ONE )\n D21 = T / D21\n!\n! Update elements in columns A(k) and A(k+1) as\n! dot products of rows of ( W(k) W(k+1) ) and columns\n! of D**(-1)\n!\n DO 80 J = K + 2, N\n A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )\n A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )\n 80 CONTINUE\n END IF\n!\n! Copy D(k) to A\n!\n A( K, K ) = W( K, K )\n A( K+1, K ) = W( K+1, K )\n A( K+1, K+1 ) = W( K+1, K+1 )\n!\n END IF\n!\n END IF\n!\n! Store details of the interchanges in IPIV\n!\n IF( KSTEP.EQ.1 ) THEN\n IPIV( K ) = KP\n ELSE\n IPIV( K ) = -KP\n IPIV( K+1 ) = -KP\n END IF\n!\n! Increase K and return to the start of the main loop\n!\n K = K + KSTEP\n GO TO 70\n!\n 90 CONTINUE\n!\n! Update the lower triangle of A22 (= A(k:n,k:n)) as\n!\n! A22 := A22 - L21*D*L21**T = A22 - L21*W**T\n!\n! computing blocks of NB columns at a time\n!\n DO 110 J = K, N, NB\n JB = MIN( NB, N-J+1 )\n!\n! Update the lower triangle of the diagonal block\n!\n DO 100 JJ = J, J + JB - 1\n CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, &\n A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, &\n A( JJ, JJ ), 1 )\n 100 CONTINUE\n!\n! Update the rectangular subdiagonal block\n!\n IF( J+JB.LE.N ) &\n CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, &\n K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, &\n ONE, A( J+JB, J ), LDA )\n 110 CONTINUE\n!\n! Put L21 in standard form by partially undoing the interchanges\n! of rows in columns 1:k-1 looping backwards from k-1 to 1\n!\n J = K - 1\n 120 CONTINUE\n!\n! Undo the interchanges (if any) of rows JJ and JP at each\n! step J\n!\n! (Here, J is a diagonal index)\n JJ = J\n JP = IPIV( J )\n IF( JP.LT.0 ) THEN\n JP = -JP\n! (Here, J is a diagonal index)\n J = J - 1\n END IF\n! (NOTE: Here, J is used to determine row length. Length J\n! of the rows to swap back doesn't include diagonal element)\n J = J - 1\n IF( JP.NE.JJ .AND. J.GE.1 ) &\n CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )\n IF( J.GT.1 ) GO TO 120\n!\n! Set KB to the number of columns factorized\n!\n KB = K - 1\n!\n END IF\n RETURN\n!\n! End of DLASYF\n!\n END SUBROUTINE DLASYF\n!> \\brief \\b DSCAL\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSCAL(N,DA,DX,INCX)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION DA\n! INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSCAL scales a vector by a constant.\n!> uses unrolled loops for increment equal to one.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 3/93 to return if incx .le. 0.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSCAL(N,DA,DX,INCX)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION DA\n INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I,M,MP1,NINCX\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MOD\n! ..\n IF (N.LE.0 .OR. INCX.LE.0) RETURN\n IF (INCX.EQ.1) THEN\n!\n! code for increment equal to 1\n!\n!\n! clean-up loop\n!\n M = MOD(N,5)\n IF (M.NE.0) THEN\n DO I = 1,M\n DX(I) = DA*DX(I)\n END DO\n IF (N.LT.5) RETURN\n END IF\n MP1 = M + 1\n DO I = MP1,N,5\n DX(I) = DA*DX(I)\n DX(I+1) = DA*DX(I+1)\n DX(I+2) = DA*DX(I+2)\n DX(I+3) = DA*DX(I+3)\n DX(I+4) = DA*DX(I+4)\n END DO\n ELSE\n!\n! code for increment not equal to 1\n!\n NINCX = N*INCX\n DO I = 1,NINCX,INCX\n DX(I) = DA*DX(I)\n END DO\n END IF\n RETURN\n END SUBROUTINE DSCAL\n!\n!> \\brief \\b DSWAP\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*),DY(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> interchanges two vectors.\n!> uses unrolled loops for increments equal one.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*),DY(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n DOUBLE PRECISION DTEMP\n INTEGER I,IX,IY,M,MP1\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MOD\n! ..\n IF (N.LE.0) RETURN\n IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN\n!\n! code for both increments equal to 1\n!\n!\n! clean-up loop\n!\n M = MOD(N,3)\n IF (M.NE.0) THEN\n DO I = 1,M\n DTEMP = DX(I)\n DX(I) = DY(I)\n DY(I) = DTEMP\n END DO\n IF (N.LT.3) RETURN\n END IF\n MP1 = M + 1\n DO I = MP1,N,3\n DTEMP = DX(I)\n DX(I) = DY(I)\n DY(I) = DTEMP\n DTEMP = DX(I+1)\n DX(I+1) = DY(I+1)\n DY(I+1) = DTEMP\n DTEMP = DX(I+2)\n DX(I+2) = DY(I+2)\n DY(I+2) = DTEMP\n END DO\n ELSE\n!\n! code for unequal increments or equal increments not equal\n! to 1\n!\n IX = 1\n IY = 1\n IF (INCX.LT.0) IX = (-N+1)*INCX + 1\n IF (INCY.LT.0) IY = (-N+1)*INCY + 1\n DO I = 1,N\n DTEMP = DX(IX)\n DX(IX) = DY(IY)\n DY(IY) = DTEMP\n IX = IX + INCX\n IY = IY + INCY\n END DO\n END IF\n RETURN\n END SUBROUTINE DSWAP\n!\n!> \\brief \\b DSYMV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA,BETA\n! INTEGER INCX,INCY,LDA,N\n! CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSYMV performs the matrix-vector operation\n!>\n!> y := alpha*A*x + beta*y,\n!>\n!> where alpha and beta are scalars, x and y are n element vectors and\n!> A is an n by n symmetric matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the upper or lower\n!> triangular part of the array A is to be referenced as\n!> follows:\n!>\n!> UPLO = 'U' or 'u' Only the upper triangular part of A\n!> is to be referenced.\n!>\n!> UPLO = 'L' or 'l' Only the lower triangular part of A\n!> is to be referenced.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n!> Before entry with UPLO = 'U' or 'u', the leading n by n\n!> upper triangular part of the array A must contain the upper\n!> triangular part of the symmetric matrix and the strictly\n!> lower triangular part of A is not referenced.\n!> Before entry with UPLO = 'L' or 'l', the leading n by n\n!> lower triangular part of the array A must contain the lower\n!> triangular part of the symmetric matrix and the strictly\n!> upper triangular part of A is not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. LDA must be at least\n!> max( 1, n ).\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in] BETA\n!> \\verbatim\n!> BETA is DOUBLE PRECISION.\n!> On entry, BETA specifies the scalar beta. When BETA is\n!> supplied as zero then Y need not be set on input.\n!> \\endverbatim\n!>\n!> \\param[in,out] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCY ) ).\n!> Before entry, the incremented array Y must contain the n\n!> element vector y. On exit, Y is overwritten by the updated\n!> vector y.\n!> \\endverbatim\n!>\n!> \\param[in] INCY\n!> \\verbatim\n!> INCY is INTEGER\n!> On entry, INCY specifies the increment for the elements of\n!> Y. INCY must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!> The vector and matrix arguments are not referenced when N = 0, or M = 0\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA,BETA\n INTEGER INCX,INCY,LDA,N\n CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP1,TEMP2\n INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (LDA.LT.MAX(1,N)) THEN\n INFO = 5\n ELSE IF (INCX.EQ.0) THEN\n INFO = 7\n ELSE IF (INCY.EQ.0) THEN\n INFO = 10\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DSYMV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN\n!\n! Set up the start points in X and Y.\n!\n IF (INCX.GT.0) THEN\n KX = 1\n ELSE\n KX = 1 - (N-1)*INCX\n END IF\n IF (INCY.GT.0) THEN\n KY = 1\n ELSE\n KY = 1 - (N-1)*INCY\n END IF\n!\n! Start the operations. In this version the elements of A are\n! accessed sequentially with one pass through the triangular part\n! of A.\n!\n! First form y := beta*y.\n!\n IF (BETA.NE.ONE) THEN\n IF (INCY.EQ.1) THEN\n IF (BETA.EQ.ZERO) THEN\n DO 10 I = 1,N\n Y(I) = ZERO\n 10 CONTINUE\n ELSE\n DO 20 I = 1,N\n Y(I) = BETA*Y(I)\n 20 CONTINUE\n END IF\n ELSE\n IY = KY\n IF (BETA.EQ.ZERO) THEN\n DO 30 I = 1,N\n Y(IY) = ZERO\n IY = IY + INCY\n 30 CONTINUE\n ELSE\n DO 40 I = 1,N\n Y(IY) = BETA*Y(IY)\n IY = IY + INCY\n 40 CONTINUE\n END IF\n END IF\n END IF\n IF (ALPHA.EQ.ZERO) RETURN\n IF (LSAME(UPLO,'U')) THEN\n!\n! Form y when A is stored in upper triangle.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 60 J = 1,N\n TEMP1 = ALPHA*X(J)\n TEMP2 = ZERO\n DO 50 I = 1,J - 1\n Y(I) = Y(I) + TEMP1*A(I,J)\n TEMP2 = TEMP2 + A(I,J)*X(I)\n 50 CONTINUE\n Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2\n 60 CONTINUE\n ELSE\n JX = KX\n JY = KY\n DO 80 J = 1,N\n TEMP1 = ALPHA*X(JX)\n TEMP2 = ZERO\n IX = KX\n IY = KY\n DO 70 I = 1,J - 1\n Y(IY) = Y(IY) + TEMP1*A(I,J)\n TEMP2 = TEMP2 + A(I,J)*X(IX)\n IX = IX + INCX\n IY = IY + INCY\n 70 CONTINUE\n Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2\n JX = JX + INCX\n JY = JY + INCY\n 80 CONTINUE\n END IF\n ELSE\n!\n! Form y when A is stored in lower triangle.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 100 J = 1,N\n TEMP1 = ALPHA*X(J)\n TEMP2 = ZERO\n Y(J) = Y(J) + TEMP1*A(J,J)\n DO 90 I = J + 1,N\n Y(I) = Y(I) + TEMP1*A(I,J)\n TEMP2 = TEMP2 + A(I,J)*X(I)\n 90 CONTINUE\n Y(J) = Y(J) + ALPHA*TEMP2\n 100 CONTINUE\n ELSE\n JX = KX\n JY = KY\n DO 120 J = 1,N\n TEMP1 = ALPHA*X(JX)\n TEMP2 = ZERO\n Y(JY) = Y(JY) + TEMP1*A(J,J)\n IX = JX\n IY = JY\n DO 110 I = J + 1,N\n IX = IX + INCX\n IY = IY + INCY\n Y(IY) = Y(IY) + TEMP1*A(I,J)\n TEMP2 = TEMP2 + A(I,J)*X(IX)\n 110 CONTINUE\n Y(JY) = Y(JY) + ALPHA*TEMP2\n JX = JX + INCX\n JY = JY + INCY\n 120 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DSYMV .\n!\n END SUBROUTINE DSYMV\n!\n!> \\brief \\b DSYR\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER INCX,LDA,N\n! CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),X(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSYR performs the symmetric rank 1 operation\n!>\n!> A := alpha*x*x**T + A,\n!>\n!> where alpha is a real scalar, x is an n element vector and A is an\n!> n by n symmetric matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the upper or lower\n!> triangular part of the array A is to be referenced as\n!> follows:\n!>\n!> UPLO = 'U' or 'u' Only the upper triangular part of A\n!> is to be referenced.\n!>\n!> UPLO = 'L' or 'l' Only the lower triangular part of A\n!> is to be referenced.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n!> Before entry with UPLO = 'U' or 'u', the leading n by n\n!> upper triangular part of the array A must contain the upper\n!> triangular part of the symmetric matrix and the strictly\n!> lower triangular part of A is not referenced. On exit, the\n!> upper triangular part of the array A is overwritten by the\n!> upper triangular part of the updated matrix.\n!> Before entry with UPLO = 'L' or 'l', the leading n by n\n!> lower triangular part of the array A must contain the lower\n!> triangular part of the symmetric matrix and the strictly\n!> upper triangular part of A is not referenced. On exit, the\n!> lower triangular part of the array A is overwritten by the\n!> lower triangular part of the updated matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. LDA must be at least\n!> max( 1, n ).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER INCX,LDA,N\n CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),X(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JX,KX\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (INCX.EQ.0) THEN\n INFO = 5\n ELSE IF (LDA.LT.MAX(1,N)) THEN\n INFO = 7\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DSYR ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN\n!\n! Set the start point in X if the increment is not unity.\n!\n IF (INCX.LE.0) THEN\n KX = 1 - (N-1)*INCX\n ELSE IF (INCX.NE.1) THEN\n KX = 1\n END IF\n!\n! Start the operations. In this version the elements of A are\n! accessed sequentially with one pass through the triangular part\n! of A.\n!\n IF (LSAME(UPLO,'U')) THEN\n!\n! Form A when A is stored in upper triangle.\n!\n IF (INCX.EQ.1) THEN\n DO 20 J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = ALPHA*X(J)\n DO 10 I = 1,J\n A(I,J) = A(I,J) + X(I)*TEMP\n 10 CONTINUE\n END IF\n 20 CONTINUE\n ELSE\n JX = KX\n DO 40 J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = ALPHA*X(JX)\n IX = KX\n DO 30 I = 1,J\n A(I,J) = A(I,J) + X(IX)*TEMP\n IX = IX + INCX\n 30 CONTINUE\n END IF\n JX = JX + INCX\n 40 CONTINUE\n END IF\n ELSE\n!\n! Form A when A is stored in lower triangle.\n!\n IF (INCX.EQ.1) THEN\n DO 60 J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = ALPHA*X(J)\n DO 50 I = J,N\n A(I,J) = A(I,J) + X(I)*TEMP\n 50 CONTINUE\n END IF\n 60 CONTINUE\n ELSE\n JX = KX\n DO 80 J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = ALPHA*X(JX)\n IX = JX\n DO 70 I = J,N\n A(I,J) = A(I,J) + X(IX)*TEMP\n IX = IX + INCX\n 70 CONTINUE\n END IF\n JX = JX + INCX\n 80 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DSYR .\n!\n END SUBROUTINE DSYR\n!\n!> \\brief \\b DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSYTF2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSYTF2 computes the factorization of a real symmetric matrix A using\n!> the Bunch-Kaufman diagonal pivoting method:\n!>\n!> A = U*D*U**T or A = L*D*L**T\n!>\n!> where U (or L) is a product of permutation and unit upper (lower)\n!> triangular matrices, U**T is the transpose of U, and D is symmetric and\n!> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n!>\n!> This is the unblocked version of the algorithm, calling Level 2 BLAS.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies whether the upper or lower triangular part of the\n!> symmetric matrix A is stored:\n!> = 'U': Upper triangular\n!> = 'L': Lower triangular\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the symmetric matrix A. If UPLO = 'U', the leading\n!> n-by-n upper triangular part of A contains the upper\n!> triangular part of the matrix A, and the strictly lower\n!> triangular part of A is not referenced. If UPLO = 'L', the\n!> leading n-by-n lower triangular part of A contains the lower\n!> triangular part of the matrix A, and the strictly upper\n!> triangular part of A is not referenced.\n!>\n!> On exit, the block diagonal matrix D and the multipliers used\n!> to obtain the factor U or L (see below for further details).\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> Details of the interchanges and the block structure of D.\n!>\n!> If UPLO = 'U':\n!> If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n!> interchanged and D(k,k) is a 1-by-1 diagonal block.\n!>\n!> If IPIV(k) = IPIV(k-1) < 0, then rows and columns\n!> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n!> is a 2-by-2 diagonal block.\n!>\n!> If UPLO = 'L':\n!> If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n!> interchanged and D(k,k) is a 1-by-1 diagonal block.\n!>\n!> If IPIV(k) = IPIV(k+1) < 0, then rows and columns\n!> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)\n!> is a 2-by-2 diagonal block.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -k, the k-th argument had an illegal value\n!> > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n!> has been completed, but the block diagonal matrix D is\n!> exactly singular, and division by zero will occur if it\n!> is used to solve a system of equations.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2013\n!\n!> \\ingroup doubleSYcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> If UPLO = 'U', then A = U*D*U**T, where\n!> U = P(n)*U(n)* ... *P(k)U(k)* ...,\n!> i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n!> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n!> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n!> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n!> that if the diagonal block D(k) is of order s (s = 1 or 2), then\n!>\n!> ( I v 0 ) k-s\n!> U(k) = ( 0 I 0 ) s\n!> ( 0 0 I ) n-k\n!> k-s s n-k\n!>\n!> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n!> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n!> and A(k,k), and v overwrites A(1:k-2,k-1:k).\n!>\n!> If UPLO = 'L', then A = L*D*L**T, where\n!> L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n!> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n!> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n!> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n!> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n!> that if the diagonal block D(k) is of order s (s = 1 or 2), then\n!>\n!> ( I 0 0 ) k-1\n!> L(k) = ( 0 I 0 ) s\n!> ( 0 v I ) n-k-s+1\n!> k-1 s n-k-s+1\n!>\n!> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n!> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n!> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n!> \\endverbatim\n!\n!> \\par Contributors:\n! ==================\n!>\n!> \\verbatim\n!>\n!> 09-29-06 - patch from\n!> Bobby Cheng, MathWorks\n!>\n!> Replace l.204 and l.372\n!> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n!> by\n!> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n!>\n!> 01-01-96 - Based on modifications by\n!> J. Lewis, Boeing Computer Services Company\n!> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n!> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n!> Company\n!> \\endverbatim\n!\n! =====================================================================\n SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n!\n! -- LAPACK computational routine (version 3.5.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2013\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )\n DOUBLE PRECISION EIGHT, SEVTEN\n PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP\n DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, &\n ROWMAX, T, WK, WKM1, WKP1\n! ..\n! .. External Functions ..\n! LOGICAL LSAME, DISNAN\n! INTEGER IDAMAX\n! EXTERNAL LSAME, IDAMAX, DISNAN\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL, DSWAP, DSYR, XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -4\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSYTF2', -INFO )\n RETURN\n END IF\n!\n! Initialize ALPHA for use in choosing pivot block size.\n!\n ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT\n!\n IF( UPPER ) THEN\n!\n! Factorize A as U*D*U**T using the upper triangle of A\n!\n! K is the main loop index, decreasing from N to 1 in steps of\n! 1 or 2\n!\n K = N\n 10 CONTINUE\n!\n! If K < 1, exit from loop\n!\n IF( K.LT.1 ) GO TO 70\n KSTEP = 1\n!\n! Determine rows and columns to be interchanged and whether\n! a 1-by-1 or 2-by-2 pivot block will be used\n!\n ABSAKK = ABS( A( K, K ) )\n!\n! IMAX is the row-index of the largest off-diagonal element in\n! column K, and COLMAX is its absolute value.\n! Determine both COLMAX and IMAX.\n!\n IF( K.GT.1 ) THEN\n IMAX = IDAMAX( K-1, A( 1, K ), 1 )\n COLMAX = ABS( A( IMAX, K ) )\n ELSE\n COLMAX = ZERO\n END IF\n!\n IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n!\n! Column K is zero or underflow, or contains a NaN:\n! set INFO and continue\n!\n IF( INFO.EQ.0 ) INFO = K\n KP = K\n ELSE\n IF( ABSAKK.GE.ALPHA*COLMAX ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE\n!\n! JMAX is the column-index of the largest off-diagonal\n! element in row IMAX, and ROWMAX is its absolute value\n!\n JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )\n ROWMAX = ABS( A( IMAX, JMAX ) )\n IF( IMAX.GT.1 ) THEN\n JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )\n ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )\n END IF\n!\n IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN\n!\n! interchange rows and columns K and IMAX, use 1-by-1\n! pivot block\n!\n KP = IMAX\n ELSE\n!\n! interchange rows and columns K-1 and IMAX, use 2-by-2\n! pivot block\n!\n KP = IMAX\n KSTEP = 2\n END IF\n END IF\n!\n KK = K - KSTEP + 1\n IF( KP.NE.KK ) THEN\n!\n! Interchange rows and columns KK and KP in the leading\n! submatrix A(1:k,1:k)\n!\n CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )\n CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), &\n LDA )\n T = A( KK, KK )\n A( KK, KK ) = A( KP, KP )\n A( KP, KP ) = T\n IF( KSTEP.EQ.2 ) THEN\n T = A( K-1, K )\n A( K-1, K ) = A( KP, K )\n A( KP, K ) = T\n END IF\n END IF\n!\n! Update the leading submatrix\n!\n IF( KSTEP.EQ.1 ) THEN\n!\n! 1-by-1 pivot block D(k): column k now holds\n!\n! W(k) = U(k)*D(k)\n!\n! where U(k) is the k-th column of U\n!\n! Perform a rank-1 update of A(1:k-1,1:k-1) as\n!\n! A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T\n!\n R1 = ONE / A( K, K )\n CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )\n!\n! Store U(k) in column k\n!\n CALL DSCAL( K-1, R1, A( 1, K ), 1 )\n ELSE\n!\n! 2-by-2 pivot block D(k): columns k and k-1 now hold\n!\n! ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)\n!\n! where U(k) and U(k-1) are the k-th and (k-1)-th columns\n! of U\n!\n! Perform a rank-2 update of A(1:k-2,1:k-2) as\n!\n! A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T\n! = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T\n!\n IF( K.GT.2 ) THEN\n!\n D12 = A( K-1, K )\n D22 = A( K-1, K-1 ) / D12\n D11 = A( K, K ) / D12\n T = ONE / ( D11*D22-ONE )\n D12 = T / D12\n!\n DO 30 J = K - 2, 1, -1\n WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )\n WK = D12*( D22*A( J, K )-A( J, K-1 ) )\n DO 20 I = J, 1, -1\n A( I, J ) = A( I, J ) - A( I, K )*WK - &\n A( I, K-1 )*WKM1\n 20 CONTINUE\n A( J, K ) = WK\n A( J, K-1 ) = WKM1\n 30 CONTINUE\n!\n END IF\n!\n END IF\n END IF\n!\n! Store details of the interchanges in IPIV\n!\n IF( KSTEP.EQ.1 ) THEN\n IPIV( K ) = KP\n ELSE\n IPIV( K ) = -KP\n IPIV( K-1 ) = -KP\n END IF\n!\n! Decrease K and return to the start of the main loop\n!\n K = K - KSTEP\n GO TO 10\n!\n ELSE\n!\n! Factorize A as L*D*L**T using the lower triangle of A\n!\n! K is the main loop index, increasing from 1 to N in steps of\n! 1 or 2\n!\n K = 1\n 40 CONTINUE\n!\n! If K > N, exit from loop\n!\n IF( K.GT.N ) GO TO 70\n KSTEP = 1\n!\n! Determine rows and columns to be interchanged and whether\n! a 1-by-1 or 2-by-2 pivot block will be used\n!\n ABSAKK = ABS( A( K, K ) )\n!\n! IMAX is the row-index of the largest off-diagonal element in\n! column K, and COLMAX is its absolute value.\n! Determine both COLMAX and IMAX.\n!\n IF( K.LT.N ) THEN\n IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )\n COLMAX = ABS( A( IMAX, K ) )\n ELSE\n COLMAX = ZERO\n END IF\n!\n IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n!\n! Column K is zero or underflow, or contains a NaN:\n! set INFO and continue\n!\n IF( INFO.EQ.0 ) INFO = K\n KP = K\n ELSE\n IF( ABSAKK.GE.ALPHA*COLMAX ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE\n!\n! JMAX is the column-index of the largest off-diagonal\n! element in row IMAX, and ROWMAX is its absolute value\n!\n JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )\n ROWMAX = ABS( A( IMAX, JMAX ) )\n IF( IMAX.LT.N ) THEN\n JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )\n ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )\n END IF\n!\n IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN\n!\n! no interchange, use 1-by-1 pivot block\n!\n KP = K\n ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN\n!\n! interchange rows and columns K and IMAX, use 1-by-1\n! pivot block\n!\n KP = IMAX\n ELSE\n!\n! interchange rows and columns K+1 and IMAX, use 2-by-2\n! pivot block\n!\n KP = IMAX\n KSTEP = 2\n END IF\n END IF\n!\n KK = K + KSTEP - 1\n IF( KP.NE.KK ) THEN\n!\n! Interchange rows and columns KK and KP in the trailing\n! submatrix A(k:n,k:n)\n!\n IF( KP.LT.N ) &\n CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )\n CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), &\n LDA )\n T = A( KK, KK )\n A( KK, KK ) = A( KP, KP )\n A( KP, KP ) = T\n IF( KSTEP.EQ.2 ) THEN\n T = A( K+1, K )\n A( K+1, K ) = A( KP, K )\n A( KP, K ) = T\n END IF\n END IF\n!\n! Update the trailing submatrix\n!\n IF( KSTEP.EQ.1 ) THEN\n!\n! 1-by-1 pivot block D(k): column k now holds\n!\n! W(k) = L(k)*D(k)\n!\n! where L(k) is the k-th column of L\n!\n IF( K.LT.N ) THEN\n!\n! Perform a rank-1 update of A(k+1:n,k+1:n) as\n!\n! A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T\n!\n D11 = ONE / A( K, K )\n CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, &\n A( K+1, K+1 ), LDA )\n!\n! Store L(k) in column K\n!\n CALL DSCAL( N-K, D11, A( K+1, K ), 1 )\n END IF\n ELSE\n!\n! 2-by-2 pivot block D(k)\n!\n IF( K.LT.N-1 ) THEN\n!\n! Perform a rank-2 update of A(k+2:n,k+2:n) as\n!\n! A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))**T\n!\n! where L(k) and L(k+1) are the k-th and (k+1)-th\n! columns of L\n!\n D21 = A( K+1, K )\n D11 = A( K+1, K+1 ) / D21\n D22 = A( K, K ) / D21\n T = ONE / ( D11*D22-ONE )\n D21 = T / D21\n!\n DO 60 J = K + 2, N\n!\n WK = D21*( D11*A( J, K )-A( J, K+1 ) )\n WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )\n!\n DO 50 I = J, N\n A( I, J ) = A( I, J ) - A( I, K )*WK - &\n A( I, K+1 )*WKP1\n 50 CONTINUE\n!\n A( J, K ) = WK\n A( J, K+1 ) = WKP1\n!\n 60 CONTINUE\n END IF\n END IF\n END IF\n!\n! Store details of the interchanges in IPIV\n!\n IF( KSTEP.EQ.1 ) THEN\n IPIV( K ) = KP\n ELSE\n IPIV( K ) = -KP\n IPIV( K+1 ) = -KP\n END IF\n!\n! Increase K and return to the start of the main loop\n!\n K = K + KSTEP\n GO TO 40\n!\n END IF\n!\n 70 CONTINUE\n!\n RETURN\n!\n! End of DSYTF2\n!\n END SUBROUTINE DSYTF2\n!> \\brief \\b DSYTRF\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSYTRF + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, LDA, LWORK, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSYTRF computes the factorization of a real symmetric matrix A using\n!> the Bunch-Kaufman diagonal pivoting method. The form of the\n!> factorization is\n!>\n!> A = U*D*U**T or A = L*D*L**T\n!>\n!> where U (or L) is a product of permutation and unit upper (lower)\n!> triangular matrices, and D is symmetric and block diagonal with\n!> 1-by-1 and 2-by-2 diagonal blocks.\n!>\n!> This is the blocked version of the algorithm, calling Level 3 BLAS.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangle of A is stored;\n!> = 'L': Lower triangle of A is stored.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the symmetric matrix A. If UPLO = 'U', the leading\n!> N-by-N upper triangular part of A contains the upper\n!> triangular part of the matrix A, and the strictly lower\n!> triangular part of A is not referenced. If UPLO = 'L', the\n!> leading N-by-N lower triangular part of A contains the lower\n!> triangular part of the matrix A, and the strictly upper\n!> triangular part of A is not referenced.\n!>\n!> On exit, the block diagonal matrix D and the multipliers used\n!> to obtain the factor U or L (see below for further details).\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> Details of the interchanges and the block structure of D.\n!> If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n!> interchanged and D(k,k) is a 1-by-1 diagonal block.\n!> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n!> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n!> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n!> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n!> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n!> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LWORK\n!> \\verbatim\n!> LWORK is INTEGER\n!> The length of WORK. LWORK >=1. For best performance\n!> LWORK >= N*NB, where NB is the block size returned by ILAENV.\n!>\n!> If LWORK = -1, then a workspace query is assumed; the routine\n!> only calculates the optimal size of the WORK array, returns\n!> this value as the first entry of the WORK array, and no error\n!> message related to LWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n!> has been completed, but the block diagonal matrix D is\n!> exactly singular, and division by zero will occur if it\n!> is used to solve a system of equations.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleSYcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> If UPLO = 'U', then A = U*D*U**T, where\n!> U = P(n)*U(n)* ... *P(k)U(k)* ...,\n!> i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n!> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n!> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n!> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n!> that if the diagonal block D(k) is of order s (s = 1 or 2), then\n!>\n!> ( I v 0 ) k-s\n!> U(k) = ( 0 I 0 ) s\n!> ( 0 0 I ) n-k\n!> k-s s n-k\n!>\n!> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n!> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n!> and A(k,k), and v overwrites A(1:k-2,k-1:k).\n!>\n!> If UPLO = 'L', then A = L*D*L**T, where\n!> L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n!> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n!> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n!> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n!> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n!> that if the diagonal block D(k) is of order s (s = 1 or 2), then\n!>\n!> ( I 0 0 ) k-1\n!> L(k) = ( 0 I 0 ) s\n!> ( 0 v I ) n-k-s+1\n!> k-1 s n-k-s+1\n!>\n!> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n!> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n!> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, LDA, LWORK, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! INTEGER ILAENV\n! EXTERNAL LSAME, ILAENV\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLASYF, DSYTF2, XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n LQUERY = ( LWORK.EQ.-1 )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -4\n ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN\n INFO = -7\n END IF\n!\n IF( INFO.EQ.0 ) THEN\n!\n! Determine the block size\n!\n NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )\n LWKOPT = N*NB\n WORK( 1 ) = LWKOPT\n END IF\n!\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSYTRF', -INFO )\n RETURN\n ELSE IF( LQUERY ) THEN\n RETURN\n END IF\n!\n NBMIN = 2\n LDWORK = N\n IF( NB.GT.1 .AND. NB.LT.N ) THEN\n IWS = LDWORK*NB\n IF( LWORK.LT.IWS ) THEN\n NB = MAX( LWORK / LDWORK, 1 )\n NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )\n END IF\n ELSE\n IWS = 1\n END IF\n IF( NB.LT.NBMIN ) NB = N\n!\n IF( UPPER ) THEN\n!\n! Factorize A as U*D*U**T using the upper triangle of A\n!\n! K is the main loop index, decreasing from N to 1 in steps of\n! KB, where KB is the number of columns factorized by DLASYF;\n! KB is either NB or NB-1, or K for the last block\n!\n K = N\n 10 CONTINUE\n!\n! If K < 1, exit from loop\n!\n IF( K.LT.1 ) GO TO 40\n!\n IF( K.GT.NB ) THEN\n!\n! Factorize columns k-kb+1:k of A and use blocked code to\n! update columns 1:k-kb\n!\n CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, &\n IINFO )\n ELSE\n!\n! Use unblocked code to factorize columns 1:k of A\n!\n CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )\n KB = K\n END IF\n!\n! Set INFO on the first occurrence of a zero pivot\n!\n IF( INFO.EQ.0 .AND. IINFO.GT.0 ) &\n INFO = IINFO\n!\n! Decrease K and return to the start of the main loop\n!\n K = K - KB\n GO TO 10\n!\n ELSE\n!\n! Factorize A as L*D*L**T using the lower triangle of A\n!\n! K is the main loop index, increasing from 1 to N in steps of\n! KB, where KB is the number of columns factorized by DLASYF;\n! KB is either NB or NB-1, or N-K+1 for the last block\n!\n K = 1\n 20 CONTINUE\n!\n! If K > N, exit from loop\n!\n IF( K.GT.N ) GO TO 40\n!\n IF( K.LE.N-NB ) THEN\n!\n! Factorize columns k:k+kb-1 of A and use blocked code to\n! update columns k+kb:n\n!\n CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), &\n WORK, LDWORK, IINFO )\n ELSE\n!\n! Use unblocked code to factorize columns k:n of A\n!\n CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )\n KB = N - K + 1\n END IF\n!\n! Set INFO on the first occurrence of a zero pivot\n!\n IF( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO + K - 1\n!\n! Adjust IPIV\n!\n DO 30 J = K, K + KB - 1\n IF( IPIV( J ).GT.0 ) THEN\n IPIV( J ) = IPIV( J ) + K - 1\n ELSE\n IPIV( J ) = IPIV( J ) - K + 1\n END IF\n 30 CONTINUE\n!\n! Increase K and return to the start of the main loop\n!\n K = K + KB\n GO TO 20\n!\n END IF\n!\n 40 CONTINUE\n WORK( 1 ) = LWKOPT\n RETURN\n!\n! End of DSYTRF\n!\n END SUBROUTINE DSYTRF\n!> \\brief \\b DSYTRI\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSYTRI + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n! INTEGER IPIV( * )\n! DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSYTRI computes the inverse of a real symmetric indefinite matrix\n!> A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n!> DSYTRF.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies whether the details of the factorization are stored\n!> as an upper or lower triangular matrix.\n!> = 'U': Upper triangular, form is A = U*D*U**T;\n!> = 'L': Lower triangular, form is A = L*D*L**T.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the block diagonal matrix D and the multipliers\n!> used to obtain the factor U or L as computed by DSYTRF.\n!>\n!> On exit, if INFO = 0, the (symmetric) inverse of the original\n!> matrix. If UPLO = 'U', the upper triangular part of the\n!> inverse is formed and the part of A below the diagonal is not\n!> referenced; if UPLO = 'L' the lower triangular part of the\n!> inverse is formed and the part of A above the diagonal is\n!> not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in] IPIV\n!> \\verbatim\n!> IPIV is INTEGER array, dimension (N)\n!> Details of the interchanges and the block structure of D\n!> as determined by DSYTRF.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n!> inverse could not be computed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleSYcomputational\n!\n! =====================================================================\n SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, LDA, N\n! ..\n! .. Array Arguments ..\n INTEGER IPIV( * )\n DOUBLE PRECISION A( LDA, * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER K, KP, KSTEP\n DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DDOT\n! EXTERNAL LSAME, DDOT\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, N ) ) THEN\n INFO = -4\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSYTRI', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! Check that the diagonal matrix D is nonsingular.\n!\n IF( UPPER ) THEN\n!\n! Upper triangular storage: examine D from bottom to top\n!\n DO 10 INFO = N, 1, -1\n IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) RETURN\n 10 CONTINUE\n ELSE\n!\n! Lower triangular storage: examine D from top to bottom.\n!\n DO 20 INFO = 1, N\n IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) RETURN\n 20 CONTINUE\n END IF\n INFO = 0\n!\n IF( UPPER ) THEN\n!\n! Compute inv(A) from the factorization A = U*D*U**T.\n!\n! K is the main loop index, increasing from 1 to N in steps of\n! 1 or 2, depending on the size of the diagonal blocks.\n!\n K = 1\n 30 CONTINUE\n!\n! If K > N, exit from loop.\n!\n IF( K.GT.N ) GO TO 40\n!\n IF( IPIV( K ).GT.0 ) THEN\n!\n! 1 x 1 diagonal block\n!\n! Invert the diagonal block.\n!\n A( K, K ) = ONE / A( K, K )\n!\n! Compute column K of the inverse.\n!\n IF( K.GT.1 ) THEN\n CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )\n CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &\n A( 1, K ), 1 )\n A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), &\n 1 )\n END IF\n KSTEP = 1\n ELSE\n!\n! 2 x 2 diagonal block\n!\n! Invert the diagonal block.\n!\n T = ABS( A( K, K+1 ) )\n AK = A( K, K ) / T\n AKP1 = A( K+1, K+1 ) / T\n AKKP1 = A( K, K+1 ) / T\n D = T*( AK*AKP1-ONE )\n A( K, K ) = AKP1 / D\n A( K+1, K+1 ) = AK / D\n A( K, K+1 ) = -AKKP1 / D\n!\n! Compute columns K and K+1 of the inverse.\n!\n IF( K.GT.1 ) THEN\n CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )\n CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &\n A( 1, K ), 1 )\n A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), &\n 1 )\n A( K, K+1 ) = A( K, K+1 ) -&\n DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )\n CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )\n CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &\n A( 1, K+1 ), 1 )\n A( K+1, K+1 ) = A( K+1, K+1 ) -&\n DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )\n END IF\n KSTEP = 2\n END IF\n!\n KP = ABS( IPIV( K ) )\n IF( KP.NE.K ) THEN\n!\n! Interchange rows and columns K and KP in the leading\n! submatrix A(1:k+1,1:k+1)\n!\n CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )\n CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )\n TEMP = A( K, K )\n A( K, K ) = A( KP, KP )\n A( KP, KP ) = TEMP\n IF( KSTEP.EQ.2 ) THEN\n TEMP = A( K, K+1 )\n A( K, K+1 ) = A( KP, K+1 )\n A( KP, K+1 ) = TEMP\n END IF\n END IF\n!\n K = K + KSTEP\n GO TO 30\n 40 CONTINUE\n!\n ELSE\n!\n! Compute inv(A) from the factorization A = L*D*L**T.\n!\n! K is the main loop index, increasing from 1 to N in steps of\n! 1 or 2, depending on the size of the diagonal blocks.\n!\n K = N\n 50 CONTINUE\n!\n! If K < 1, exit from loop.\n!\n IF( K.LT.1 ) GO TO 60\n!\n IF( IPIV( K ).GT.0 ) THEN\n!\n! 1 x 1 diagonal block\n!\n! Invert the diagonal block.\n!\n A( K, K ) = ONE / A( K, K )\n!\n! Compute column K of the inverse.\n!\n IF( K.LT.N ) THEN\n CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )\n CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &\n ZERO, A( K+1, K ), 1 )\n A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), &\n 1 )\n END IF\n KSTEP = 1\n ELSE\n!\n! 2 x 2 diagonal block\n!\n! Invert the diagonal block.\n!\n T = ABS( A( K, K-1 ) )\n AK = A( K-1, K-1 ) / T\n AKP1 = A( K, K ) / T\n AKKP1 = A( K, K-1 ) / T\n D = T*( AK*AKP1-ONE )\n A( K-1, K-1 ) = AKP1 / D\n A( K, K ) = AK / D\n A( K, K-1 ) = -AKKP1 / D\n!\n! Compute columns K-1 and K of the inverse.\n!\n IF( K.LT.N ) THEN\n CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )\n CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &\n ZERO, A( K+1, K ), 1 )\n A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), &\n 1 )\n A( K, K-1 ) = A( K, K-1 ) -&\n DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), &\n 1 )\n CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )\n CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &\n ZERO, A( K+1, K-1 ), 1 )\n A( K-1, K-1 ) = A( K-1, K-1 ) - &\n DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )\n END IF\n KSTEP = 2\n END IF\n!\n KP = ABS( IPIV( K ) )\n IF( KP.NE.K ) THEN\n!\n! Interchange rows and columns K and KP in the trailing\n! submatrix A(k-1:n,k-1:n)\n!\n IF( KP.LT.N ) &\n CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )\n CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )\n TEMP = A( K, K )\n A( K, K ) = A( KP, KP )\n A( KP, KP ) = TEMP\n IF( KSTEP.EQ.2 ) THEN\n TEMP = A( K, K-1 )\n A( K, K-1 ) = A( KP, K-1 )\n A( KP, K-1 ) = TEMP\n END IF\n END IF\n!\n K = K - KSTEP\n GO TO 50\n 60 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DSYTRI\n!\n END SUBROUTINE DSYTRI\n!> \\brief \\b DTRSM\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER LDA,LDB,M,N\n! CHARACTER DIAG,SIDE,TRANSA,UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),B(LDB,*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTRSM solves one of the matrix equations\n!>\n!> op( A )*X = alpha*B, or X*op( A ) = alpha*B,\n!>\n!> where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n!> non-unit, upper or lower triangular matrix and op( A ) is one of\n!>\n!> op( A ) = A or op( A ) = A**T.\n!>\n!> The matrix X is overwritten on B.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SIDE\n!> \\verbatim\n!> SIDE is CHARACTER*1\n!> On entry, SIDE specifies whether op( A ) appears on the left\n!> or right of X as follows:\n!>\n!> SIDE = 'L' or 'l' op( A )*X = alpha*B.\n!>\n!> SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the matrix A is an upper or\n!> lower triangular matrix as follows:\n!>\n!> UPLO = 'U' or 'u' A is an upper triangular matrix.\n!>\n!> UPLO = 'L' or 'l' A is a lower triangular matrix.\n!> \\endverbatim\n!>\n!> \\param[in] TRANSA\n!> \\verbatim\n!> TRANSA is CHARACTER*1\n!> On entry, TRANSA specifies the form of op( A ) to be used in\n!> the matrix multiplication as follows:\n!>\n!> TRANSA = 'N' or 'n' op( A ) = A.\n!>\n!> TRANSA = 'T' or 't' op( A ) = A**T.\n!>\n!> TRANSA = 'C' or 'c' op( A ) = A**T.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> On entry, DIAG specifies whether or not A is unit triangular\n!> as follows:\n!>\n!> DIAG = 'U' or 'u' A is assumed to be unit triangular.\n!>\n!> DIAG = 'N' or 'n' A is not assumed to be unit\n!> triangular.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> On entry, M specifies the number of rows of B. M must be at\n!> least zero.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the number of columns of B. N must be\n!> at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha. When alpha is\n!> zero then A is not referenced and B need not be set before\n!> entry.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ),\n!> where k is m when SIDE = 'L' or 'l' \n!> and k is n when SIDE = 'R' or 'r'.\n!> Before entry with UPLO = 'U' or 'u', the leading k by k\n!> upper triangular part of the array A must contain the upper\n!> triangular matrix and the strictly lower triangular part of\n!> A is not referenced.\n!> Before entry with UPLO = 'L' or 'l', the leading k by k\n!> lower triangular part of the array A must contain the lower\n!> triangular matrix and the strictly upper triangular part of\n!> A is not referenced.\n!> Note that when DIAG = 'U' or 'u', the diagonal elements of\n!> A are not referenced either, but are assumed to be unity.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. When SIDE = 'L' or 'l' then\n!> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'\n!> then LDA must be at least max( 1, n ).\n!> \\endverbatim\n!>\n!> \\param[in,out] B\n!> \\verbatim\n!> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ).\n!> Before entry, the leading m by n part of the array B must\n!> contain the right-hand side matrix B, and on exit is\n!> overwritten by the solution matrix X.\n!> \\endverbatim\n!>\n!> \\param[in] LDB\n!> \\verbatim\n!> LDB is INTEGER\n!> On entry, LDB specifies the first dimension of B as declared\n!> in the calling (sub) program. LDB must be at least\n!> max( 1, m ).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level3\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 3 Blas routine.\n!>\n!>\n!> -- Written on 8-February-1989.\n!> Jack Dongarra, Argonne National Laboratory.\n!> Iain Duff, AERE Harwell.\n!> Jeremy Du Croz, Numerical Algorithms Group Ltd.\n!> Sven Hammarling, Numerical Algorithms Group Ltd.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)\n!\n! -- Reference BLAS level3 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER LDA,LDB,M,N\n CHARACTER DIAG,SIDE,TRANSA,UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),B(LDB,*)\n! ..\n!\n! =====================================================================\n!\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,J,K,NROWA\n LOGICAL LSIDE,NOUNIT,UPPER\n! ..\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n!\n! Test the input parameters.\n!\n LSIDE = LSAME(SIDE,'L')\n IF (LSIDE) THEN\n NROWA = M\n ELSE\n NROWA = N\n END IF\n NOUNIT = LSAME(DIAG,'N')\n UPPER = LSAME(UPLO,'U')\n!\n INFO = 0\n IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN\n INFO = 1\n ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN\n INFO = 2\n ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. &\n (.NOT.LSAME(TRANSA,'T')) .AND. &\n (.NOT.LSAME(TRANSA,'C'))) THEN\n INFO = 3\n ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN\n INFO = 4\n ELSE IF (M.LT.0) THEN\n INFO = 5\n ELSE IF (N.LT.0) THEN\n INFO = 6\n ELSE IF (LDA.LT.MAX(1,NROWA)) THEN\n INFO = 9\n ELSE IF (LDB.LT.MAX(1,M)) THEN\n INFO = 11\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DTRSM ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF (M.EQ.0 .OR. N.EQ.0) RETURN\n!\n! And when alpha.eq.zero.\n!\n IF (ALPHA.EQ.ZERO) THEN\n DO 20 J = 1,N\n DO 10 I = 1,M\n B(I,J) = ZERO\n 10 CONTINUE\n 20 CONTINUE\n RETURN\n END IF\n!\n! Start the operations.\n!\n IF (LSIDE) THEN\n IF (LSAME(TRANSA,'N')) THEN\n!\n! Form B := alpha*inv( A )*B.\n!\n IF (UPPER) THEN\n DO 60 J = 1,N\n IF (ALPHA.NE.ONE) THEN\n DO 30 I = 1,M\n B(I,J) = ALPHA*B(I,J)\n 30 CONTINUE\n END IF\n DO 50 K = M,1,-1\n IF (B(K,J).NE.ZERO) THEN\n IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)\n DO 40 I = 1,K - 1\n B(I,J) = B(I,J) - B(K,J)*A(I,K)\n 40 CONTINUE\n END IF\n 50 CONTINUE\n 60 CONTINUE\n ELSE\n DO 100 J = 1,N\n IF (ALPHA.NE.ONE) THEN\n DO 70 I = 1,M\n B(I,J) = ALPHA*B(I,J)\n 70 CONTINUE\n END IF\n DO 90 K = 1,M\n IF (B(K,J).NE.ZERO) THEN\n IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)\n DO 80 I = K + 1,M\n B(I,J) = B(I,J) - B(K,J)*A(I,K)\n 80 CONTINUE\n END IF\n 90 CONTINUE\n 100 CONTINUE\n END IF\n ELSE\n!\n! Form B := alpha*inv( A**T )*B.\n!\n IF (UPPER) THEN\n DO 130 J = 1,N\n DO 120 I = 1,M\n TEMP = ALPHA*B(I,J)\n DO 110 K = 1,I - 1\n TEMP = TEMP - A(K,I)*B(K,J)\n 110 CONTINUE\n IF (NOUNIT) TEMP = TEMP/A(I,I)\n B(I,J) = TEMP\n 120 CONTINUE\n 130 CONTINUE\n ELSE\n DO 160 J = 1,N\n DO 150 I = M,1,-1\n TEMP = ALPHA*B(I,J)\n DO 140 K = I + 1,M\n TEMP = TEMP - A(K,I)*B(K,J)\n 140 CONTINUE\n IF (NOUNIT) TEMP = TEMP/A(I,I)\n B(I,J) = TEMP\n 150 CONTINUE\n 160 CONTINUE\n END IF\n END IF\n ELSE\n IF (LSAME(TRANSA,'N')) THEN\n!\n! Form B := alpha*B*inv( A ).\n!\n IF (UPPER) THEN\n DO 210 J = 1,N\n IF (ALPHA.NE.ONE) THEN\n DO 170 I = 1,M\n B(I,J) = ALPHA*B(I,J)\n 170 CONTINUE\n END IF\n DO 190 K = 1,J - 1\n IF (A(K,J).NE.ZERO) THEN\n DO 180 I = 1,M\n B(I,J) = B(I,J) - A(K,J)*B(I,K)\n 180 CONTINUE\n END IF\n 190 CONTINUE\n IF (NOUNIT) THEN\n TEMP = ONE/A(J,J)\n DO 200 I = 1,M\n B(I,J) = TEMP*B(I,J)\n 200 CONTINUE\n END IF\n 210 CONTINUE\n ELSE\n DO 260 J = N,1,-1\n IF (ALPHA.NE.ONE) THEN\n DO 220 I = 1,M\n B(I,J) = ALPHA*B(I,J)\n 220 CONTINUE\n END IF\n DO 240 K = J + 1,N\n IF (A(K,J).NE.ZERO) THEN\n DO 230 I = 1,M\n B(I,J) = B(I,J) - A(K,J)*B(I,K)\n 230 CONTINUE\n END IF\n 240 CONTINUE\n IF (NOUNIT) THEN\n TEMP = ONE/A(J,J)\n DO 250 I = 1,M\n B(I,J) = TEMP*B(I,J)\n 250 CONTINUE\n END IF\n 260 CONTINUE\n END IF\n ELSE\n!\n! Form B := alpha*B*inv( A**T ).\n!\n IF (UPPER) THEN\n DO 310 K = N,1,-1\n IF (NOUNIT) THEN\n TEMP = ONE/A(K,K)\n DO 270 I = 1,M\n B(I,K) = TEMP*B(I,K)\n 270 CONTINUE\n END IF\n DO 290 J = 1,K - 1\n IF (A(J,K).NE.ZERO) THEN\n TEMP = A(J,K)\n DO 280 I = 1,M\n B(I,J) = B(I,J) - TEMP*B(I,K)\n 280 CONTINUE\n END IF\n 290 CONTINUE\n IF (ALPHA.NE.ONE) THEN\n DO 300 I = 1,M\n B(I,K) = ALPHA*B(I,K)\n 300 CONTINUE\n END IF\n 310 CONTINUE\n ELSE\n DO 360 K = 1,N\n IF (NOUNIT) THEN\n TEMP = ONE/A(K,K)\n DO 320 I = 1,M\n B(I,K) = TEMP*B(I,K)\n 320 CONTINUE\n END IF\n DO 340 J = K + 1,N\n IF (A(J,K).NE.ZERO) THEN\n TEMP = A(J,K)\n DO 330 I = 1,M\n B(I,J) = B(I,J) - TEMP*B(I,K)\n 330 CONTINUE\n END IF\n 340 CONTINUE\n IF (ALPHA.NE.ONE) THEN\n DO 350 I = 1,M\n B(I,K) = ALPHA*B(I,K)\n 350 CONTINUE\n END IF\n 360 CONTINUE\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DTRSM .\n!\n END SUBROUTINE DTRSM\n!\n!> \\brief \\b IDAMAX\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION IDAMAX(N,DX,INCX)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> IDAMAX finds the index of the first element having maximum absolute value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup aux_blas\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 3/93 to return if incx .le. 0.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n INTEGER FUNCTION IDAMAX(N,DX,INCX)\n!\n! -- Reference BLAS level1 routine (version 3.6.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n DOUBLE PRECISION DMAX\n INTEGER I,IX\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC DABS\n! ..\n IDAMAX = 0\n IF (N.LT.1 .OR. INCX.LE.0) RETURN\n IDAMAX = 1\n IF (N.EQ.1) RETURN\n IF (INCX.EQ.1) THEN\n!\n! code for increment equal to 1\n!\n DMAX = DABS(DX(1))\n DO I = 2,N\n IF (DABS(DX(I)).GT.DMAX) THEN\n IDAMAX = I\n DMAX = DABS(DX(I))\n END IF\n END DO\n ELSE\n!\n! code for increment not equal to 1\n!\n IX = 1\n DMAX = DABS(DX(1))\n IX = IX + INCX\n DO I = 2,N\n IF (DABS(DX(IX)).GT.DMAX) THEN\n IDAMAX = I\n DMAX = DABS(DX(IX))\n END IF\n IX = IX + INCX\n END DO\n END IF\n RETURN\n END FUNCTION IDAMAX\n\n!> \\brief \\b IEEECK\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download IEEECK + dependencies \n!> [TGZ] \n!> [ZIP] \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )\n! \n! .. Scalar Arguments ..\n! INTEGER ISPEC\n! REAL ONE, ZERO\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> IEEECK is called from the ILAENV to verify that Infinity and\n!> possibly NaN arithmetic is safe (i.e. will not trap).\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ISPEC\n!> \\verbatim\n!> ISPEC is INTEGER\n!> Specifies whether to test just for inifinity arithmetic\n!> or whether to test for infinity and NaN arithmetic.\n!> = 0: Verify infinity arithmetic only.\n!> = 1: Verify infinity and NaN arithmetic.\n!> \\endverbatim\n!>\n!> \\param[in] ZERO\n!> \\verbatim\n!> ZERO is REAL\n!> Must contain the value 0.0\n!> This is passed to prevent the compiler from optimizing\n!> away this code.\n!> \\endverbatim\n!>\n!> \\param[in] ONE\n!> \\verbatim\n!> ONE is REAL\n!> Must contain the value 1.0\n!> This is passed to prevent the compiler from optimizing\n!> away this code.\n!>\n!> RETURN VALUE: INTEGER\n!> = 0: Arithmetic failed to produce the correct answers\n!> = 1: Arithmetic produced the correct answers\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )\n!\n! -- LAPACK auxiliary routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER ISPEC\n REAL ONE, ZERO\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, &\n NEGZRO, NEWZRO, POSINF\n! ..\n! .. Executable Statements ..\n IEEECK = 1\n!\n POSINF = ONE / ZERO\n IF( POSINF.LE.ONE ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n NEGINF = -ONE / ZERO\n IF( NEGINF.GE.ZERO ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n NEGZRO = ONE / ( NEGINF+ONE )\n IF( NEGZRO.NE.ZERO ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n NEGINF = ONE / NEGZRO\n IF( NEGINF.GE.ZERO ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n NEWZRO = NEGZRO + ZERO\n IF( NEWZRO.NE.ZERO ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n POSINF = ONE / NEWZRO\n IF( POSINF.LE.ONE ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n NEGINF = NEGINF*POSINF\n IF( NEGINF.GE.ZERO ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n POSINF = POSINF*POSINF\n IF( POSINF.LE.ONE ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n!\n!\n!\n! Return if we were only asked to check infinity arithmetic\n!\n IF( ISPEC.EQ.0 ) RETURN\n!\n NAN1 = POSINF + NEGINF\n!\n NAN2 = POSINF / NEGINF\n!\n NAN3 = POSINF / POSINF\n!\n NAN4 = POSINF*ZERO\n!\n NAN5 = NEGINF*NEGZRO\n!\n NAN6 = NAN5*ZERO\n!\n IF( NAN1.EQ.NAN1 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n IF( NAN2.EQ.NAN2 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n IF( NAN3.EQ.NAN3 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n IF( NAN4.EQ.NAN4 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n IF( NAN5.EQ.NAN5 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n IF( NAN6.EQ.NAN6 ) THEN\n IEEECK = 0\n RETURN\n END IF\n!\n RETURN\n END FUNCTION IEEECK\n!\n!> \\brief \\b ILAENV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download ILAENV + dependencies \n!> [TGZ] \n!> [ZIP] \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n! \n! .. Scalar Arguments ..\n! CHARACTER*( * ) NAME, OPTS\n! INTEGER ISPEC, N1, N2, N3, N4\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> ILAENV is called from the LAPACK routines to choose problem-dependent\n!> parameters for the local environment. See ISPEC for a description of\n!> the parameters.\n!>\n!> ILAENV returns an INTEGER\n!> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC\n!> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.\n!>\n!> This version provides a set of parameters which should give good,\n!> but not optimal, performance on many of the currently available\n!> computers. Users are encouraged to modify this subroutine to set\n!> the tuning parameters for their particular machine using the option\n!> and problem size information in the arguments.\n!>\n!> This routine will not function correctly if it is converted to all\n!> lower case. Converting it to all upper case is allowed.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ISPEC\n!> \\verbatim\n!> ISPEC is INTEGER\n!> Specifies the parameter to be returned as the value of\n!> ILAENV.\n!> = 1: the optimal blocksize; if this value is 1, an unblocked\n!> algorithm will give the best performance.\n!> = 2: the minimum block size for which the block routine\n!> should be used; if the usable block size is less than\n!> this value, an unblocked routine should be used.\n!> = 3: the crossover point (in a block routine, for N less\n!> than this value, an unblocked routine should be used)\n!> = 4: the number of shifts, used in the nonsymmetric\n!> eigenvalue routines (DEPRECATED)\n!> = 5: the minimum column dimension for blocking to be used;\n!> rectangular blocks must have dimension at least k by m,\n!> where k is given by ILAENV(2,...) and m by ILAENV(5,...)\n!> = 6: the crossover point for the SVD (when reducing an m by n\n!> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds\n!> this value, a QR factorization is used first to reduce\n!> the matrix to a triangular form.)\n!> = 7: the number of processors\n!> = 8: the crossover point for the multishift QR method\n!> for nonsymmetric eigenvalue problems (DEPRECATED)\n!> = 9: maximum size of the subproblems at the bottom of the\n!> computation tree in the divide-and-conquer algorithm\n!> (used by xGELSD and xGESDD)\n!> =10: ieee NaN arithmetic can be trusted not to trap\n!> =11: infinity arithmetic can be trusted not to trap\n!> 12 <= ISPEC <= 16:\n!> xHSEQR or related subroutines,\n!> see IPARMQ for detailed explanation\n!> \\endverbatim\n!>\n!> \\param[in] NAME\n!> \\verbatim\n!> NAME is CHARACTER*(*)\n!> The name of the calling subroutine, in either upper case or\n!> lower case.\n!> \\endverbatim\n!>\n!> \\param[in] OPTS\n!> \\verbatim\n!> OPTS is CHARACTER*(*)\n!> The character options to the subroutine NAME, concatenated\n!> into a single character string. For example, UPLO = 'U',\n!> TRANS = 'T', and DIAG = 'N' for a triangular routine would\n!> be specified as OPTS = 'UTN'.\n!> \\endverbatim\n!>\n!> \\param[in] N1\n!> \\verbatim\n!> N1 is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] N2\n!> \\verbatim\n!> N2 is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] N3\n!> \\verbatim\n!> N3 is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] N4\n!> \\verbatim\n!> N4 is INTEGER\n!> Problem dimensions for the subroutine NAME; these may not all\n!> be required.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERauxiliary\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> The following conventions have been used when calling ILAENV from the\n!> LAPACK routines:\n!> 1) OPTS is a concatenation of all of the character options to\n!> subroutine NAME, in the same order that they appear in the\n!> argument list for NAME, even if they are not used in determining\n!> the value of the parameter specified by ISPEC.\n!> 2) The problem dimensions N1, N2, N3, N4 are specified in the order\n!> that they appear in the argument list for NAME. N1 is used\n!> first, N2 second, and so on, and unused problem dimensions are\n!> passed a value of -1.\n!> 3) The parameter value returned by ILAENV is checked for validity in\n!> the calling subroutine. For example, ILAENV is used to retrieve\n!> the optimal blocksize for STRTRI as follows:\n!>\n!> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )\n!> IF( NB.LE.1 ) NB = MAX( 1, N )\n!> \\endverbatim\n!>\n! =====================================================================\n INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n!\n! -- LAPACK auxiliary routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n CHARACTER*( * ) NAME, OPTS\n INTEGER ISPEC, N1, N2, N3, N4\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, IC, IZ, NB, NBMIN, NX\n LOGICAL CNAME, SNAME\n CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC CHAR, ICHAR, INT, MIN, REAL\n! ..\n! .. External Functions ..\n! INTEGER IEEECK, IPARMQ\n! EXTERNAL IEEECK, IPARMQ\n! ..\n! .. Executable Statements ..\n!\n GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, &\n 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC\n!\n! Invalid value for ISPEC\n!\n ILAENV = -1\n RETURN\n!\n 10 CONTINUE\n!\n! Convert NAME to upper case if the first character is lower case.\n!\n ILAENV = 1\n SUBNAM = NAME\n IC = ICHAR( SUBNAM( 1: 1 ) )\n IZ = ICHAR( 'Z' )\n IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN\n!\n! ASCII character set\n!\n IF( IC.GE.97 .AND. IC.LE.122 ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC-32 )\n DO 20 I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( IC.GE.97 .AND. IC.LE.122 ) &\n SUBNAM( I: I ) = CHAR( IC-32 )\n 20 CONTINUE\n END IF\n!\n ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN\n!\n! EBCDIC character set\n!\n IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &\n ( IC.GE.145 .AND. IC.LE.153 ) .OR. &\n ( IC.GE.162 .AND. IC.LE.169 ) ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC+64 )\n DO 30 I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &\n ( IC.GE.145 .AND. IC.LE.153 ) .OR. &\n ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: &\n I ) = CHAR( IC+64 )\n 30 CONTINUE\n END IF\n!\n ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN\n!\n! Prime machines: ASCII+128\n!\n IF( IC.GE.225 .AND. IC.LE.250 ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC-32 )\n DO 40 I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( IC.GE.225 .AND. IC.LE.250 ) &\n SUBNAM( I: I ) = CHAR( IC-32 )\n 40 CONTINUE\n END IF\n END IF\n!\n C1 = SUBNAM( 1: 1 )\n SNAME = C1.EQ.'S' .OR. C1.EQ.'D'\n CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'\n IF( .NOT.( CNAME .OR. SNAME ) ) RETURN\n C2 = SUBNAM( 2: 3 )\n C3 = SUBNAM( 4: 6 )\n C4 = C3( 2: 3 )\n!\n GO TO ( 50, 60, 70 )ISPEC\n!\n 50 CONTINUE\n!\n! ISPEC = 1: block size\n!\n! In these examples, separate code is provided for setting NB for\n! real and complex. We assume that NB will take the same value in\n! single or double precision.\n!\n NB = 1\n!\n IF( C2.EQ.'GE' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. &\n C3.EQ.'QLF' ) THEN\n IF( SNAME ) THEN\n NB = 32\n ELSE\n NB = 32\n END IF\n ELSE IF( C3.EQ.'HRD' ) THEN\n IF( SNAME ) THEN\n NB = 32\n ELSE\n NB = 32\n END IF\n ELSE IF( C3.EQ.'BRD' ) THEN\n IF( SNAME ) THEN\n NB = 32\n ELSE\n NB = 32\n END IF\n ELSE IF( C3.EQ.'TRI' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n END IF\n ELSE IF( C2.EQ.'PO' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n END IF\n ELSE IF( C2.EQ.'SY' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN\n NB = 32\n ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN\n NB = 64\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n NB = 64\n ELSE IF( C3.EQ.'TRD' ) THEN\n NB = 32\n ELSE IF( C3.EQ.'GST' ) THEN\n NB = 64\n END IF\n ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NB = 32\n END IF\n ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NB = 32\n END IF\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NB = 32\n END IF\n ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NB = 32\n END IF\n END IF\n ELSE IF( C2.EQ.'GB' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n IF( N4.LE.64 ) THEN\n NB = 1\n ELSE\n NB = 32\n END IF\n ELSE\n IF( N4.LE.64 ) THEN\n NB = 1\n ELSE\n NB = 32\n END IF\n END IF\n END IF\n ELSE IF( C2.EQ.'PB' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n IF( N2.LE.64 ) THEN\n NB = 1\n ELSE\n NB = 32\n END IF\n ELSE\n IF( N2.LE.64 ) THEN\n NB = 1\n ELSE\n NB = 32\n END IF\n END IF\n END IF\n ELSE IF( C2.EQ.'TR' ) THEN\n IF( C3.EQ.'TRI' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n END IF\n ELSE IF( C2.EQ.'LA' ) THEN\n IF( C3.EQ.'UUM' ) THEN\n IF( SNAME ) THEN\n NB = 64\n ELSE\n NB = 64\n END IF\n END IF\n ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN\n IF( C3.EQ.'EBZ' ) THEN\n NB = 1\n END IF\n ELSE IF( C2.EQ.'GG' ) THEN\n NB = 32\n IF( C3.EQ.'HD3' ) THEN\n IF( SNAME ) THEN\n NB = 32\n ELSE\n NB = 32\n END IF\n END IF\n END IF\n ILAENV = NB\n RETURN\n!\n 60 CONTINUE\n!\n! ISPEC = 2: minimum block size\n!\n NBMIN = 2\n IF( C2.EQ.'GE' ) THEN\n IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. &\n 'QLF' ) THEN\n IF( SNAME ) THEN\n NBMIN = 2\n ELSE\n NBMIN = 2\n END IF\n ELSE IF( C3.EQ.'HRD' ) THEN\n IF( SNAME ) THEN\n NBMIN = 2\n ELSE\n NBMIN = 2\n END IF\n ELSE IF( C3.EQ.'BRD' ) THEN\n IF( SNAME ) THEN\n NBMIN = 2\n ELSE\n NBMIN = 2\n END IF\n ELSE IF( C3.EQ.'TRI' ) THEN\n IF( SNAME ) THEN\n NBMIN = 2\n ELSE\n NBMIN = 2\n END IF\n END IF\n ELSE IF( C2.EQ.'SY' ) THEN\n IF( C3.EQ.'TRF' ) THEN\n IF( SNAME ) THEN\n NBMIN = 8\n ELSE\n NBMIN = 8\n END IF\n ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN\n NBMIN = 2\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN\n IF( C3.EQ.'TRD' ) THEN\n NBMIN = 2\n END IF\n ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NBMIN = 2\n END IF\n ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NBMIN = 2\n END IF\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NBMIN = 2\n END IF\n ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NBMIN = 2\n END IF\n END IF\n ELSE IF( C2.EQ.'GG' ) THEN\n NBMIN = 2\n IF( C3.EQ.'HD3' ) THEN\n NBMIN = 2\n END IF\n END IF\n ILAENV = NBMIN\n RETURN\n!\n 70 CONTINUE\n!\n! ISPEC = 3: crossover point\n!\n NX = 0\n IF( C2.EQ.'GE' ) THEN\n IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. &\n 'QLF' ) THEN\n IF( SNAME ) THEN\n NX = 128\n ELSE\n NX = 128\n END IF\n ELSE IF( C3.EQ.'HRD' ) THEN\n IF( SNAME ) THEN\n NX = 128\n ELSE\n NX = 128\n END IF\n ELSE IF( C3.EQ.'BRD' ) THEN\n IF( SNAME ) THEN\n NX = 128\n ELSE\n NX = 128\n END IF\n END IF\n ELSE IF( C2.EQ.'SY' ) THEN\n IF( SNAME .AND. C3.EQ.'TRD' ) THEN\n NX = 32\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN\n IF( C3.EQ.'TRD' ) THEN\n NX = 32\n END IF\n ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NX = 128\n END IF\n END IF\n ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN\n IF( C3( 1: 1 ).EQ.'G' ) THEN\n IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. &\n 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) &\n THEN\n NX = 128\n END IF\n END IF\n ELSE IF( C2.EQ.'GG' ) THEN\n NX = 128\n IF( C3.EQ.'HD3' ) THEN\n NX = 128\n END IF\n END IF\n ILAENV = NX\n RETURN\n!\n 80 CONTINUE\n!\n! ISPEC = 4: number of shifts (used by xHSEQR)\n!\n ILAENV = 6\n RETURN\n!\n 90 CONTINUE\n!\n! ISPEC = 5: minimum column dimension (not used)\n!\n ILAENV = 2\n RETURN\n!\n 100 CONTINUE\n!\n! ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)\n!\n ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )\n RETURN\n!\n 110 CONTINUE\n!\n! ISPEC = 7: number of processors (not used)\n!\n ILAENV = 1\n RETURN\n!\n 120 CONTINUE\n!\n! ISPEC = 8: crossover point for multishift (used by xHSEQR)\n!\n ILAENV = 50\n RETURN\n!\n 130 CONTINUE\n!\n! ISPEC = 9: maximum size of the subproblems at the bottom of the\n! computation tree in the divide-and-conquer algorithm\n! (used by xGELSD and xGESDD)\n!\n ILAENV = 25\n RETURN\n!\n 140 CONTINUE\n!\n! ISPEC = 10: ieee NaN arithmetic can be trusted not to trap\n!\n! ILAENV = 0\n ILAENV = 1\n IF( ILAENV.EQ.1 ) THEN\n ILAENV = IEEECK( 1, 0.0, 1.0 )\n END IF\n RETURN\n!\n 150 CONTINUE\n!\n! ISPEC = 11: infinity arithmetic can be trusted not to trap\n!\n! ILAENV = 0\n ILAENV = 1\n IF( ILAENV.EQ.1 ) THEN\n ILAENV = IEEECK( 0, 0.0, 1.0 )\n END IF\n RETURN\n!\n 160 CONTINUE\n!\n! 12 <= ISPEC <= 16: xHSEQR or related subroutines.\n!\n ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n RETURN\n!\n! End of ILAENV\n!\n END FUNCTION ILAENV\n!> \\brief \\b IPARMQ\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download IPARMQ + dependencies \n!> [TGZ] \n!> [ZIP] \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n! \n! .. Scalar Arguments ..\n! INTEGER IHI, ILO, ISPEC, LWORK, N\n! CHARACTER NAME*( * ), OPTS*( * )\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> This program sets problem and machine dependent parameters\n!> useful for xHSEQR and related subroutines for eigenvalue\n!> problems. It is called whenever\n!> IPARMQ is called with 12 <= ISPEC <= 16\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ISPEC\n!> \\verbatim\n!> ISPEC is integer scalar\n!> ISPEC specifies which tunable parameter IPARMQ should\n!> return.\n!>\n!> ISPEC=12: (INMIN) Matrices of order nmin or less\n!> are sent directly to xLAHQR, the implicit\n!> double shift QR algorithm. NMIN must be\n!> at least 11.\n!>\n!> ISPEC=13: (INWIN) Size of the deflation window.\n!> This is best set greater than or equal to\n!> the number of simultaneous shifts NS.\n!> Larger matrices benefit from larger deflation\n!> windows.\n!>\n!> ISPEC=14: (INIBL) Determines when to stop nibbling and\n!> invest in an (expensive) multi-shift QR sweep.\n!> If the aggressive early deflation subroutine\n!> finds LD converged eigenvalues from an order\n!> NW deflation window and LD.GT.(NW*NIBBLE)/100,\n!> then the next QR sweep is skipped and early\n!> deflation is applied immediately to the\n!> remaining active diagonal block. Setting\n!> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a\n!> multi-shift QR sweep whenever early deflation\n!> finds a converged eigenvalue. Setting\n!> IPARMQ(ISPEC=14) greater than or equal to 100\n!> prevents TTQRE from skipping a multi-shift\n!> QR sweep.\n!>\n!> ISPEC=15: (NSHFTS) The number of simultaneous shifts in\n!> a multi-shift QR iteration.\n!>\n!> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the\n!> following meanings.\n!> 0: During the multi-shift QR/QZ sweep,\n!> blocked eigenvalue reordering, blocked\n!> Hessenberg-triangular reduction,\n!> reflections and/or rotations are not\n!> accumulated when updating the\n!> far-from-diagonal matrix entries.\n!> 1: During the multi-shift QR/QZ sweep,\n!> blocked eigenvalue reordering, blocked\n!> Hessenberg-triangular reduction,\n!> reflections and/or rotations are\n!> accumulated, and matrix-matrix\n!> multiplication is used to update the\n!> far-from-diagonal matrix entries.\n!> 2: During the multi-shift QR/QZ sweep,\n!> blocked eigenvalue reordering, blocked\n!> Hessenberg-triangular reduction,\n!> reflections and/or rotations are\n!> accumulated, and 2-by-2 block structure\n!> is exploited during matrix-matrix\n!> multiplies.\n!> (If xTRMM is slower than xGEMM, then\n!> IPARMQ(ISPEC=16)=1 may be more efficient than\n!> IPARMQ(ISPEC=16)=2 despite the greater level of\n!> arithmetic work implied by the latter choice.)\n!> \\endverbatim\n!>\n!> \\param[in] NAME\n!> \\verbatim\n!> NAME is character string\n!> Name of the calling subroutine\n!> \\endverbatim\n!>\n!> \\param[in] OPTS\n!> \\verbatim\n!> OPTS is character string\n!> This is a concatenation of the string arguments to\n!> TTQRE.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is integer scalar\n!> N is the order of the Hessenberg matrix H.\n!> \\endverbatim\n!>\n!> \\param[in] ILO\n!> \\verbatim\n!> ILO is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] IHI\n!> \\verbatim\n!> IHI is INTEGER\n!> It is assumed that H is already upper triangular\n!> in rows and columns 1:ILO-1 and IHI+1:N.\n!> \\endverbatim\n!>\n!> \\param[in] LWORK\n!> \\verbatim\n!> LWORK is integer scalar\n!> The amount of workspace available.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERauxiliary\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Little is known about how best to choose these parameters.\n!> It is possible to use different values of the parameters\n!> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.\n!>\n!> It is probably best to choose different parameters for\n!> different matrices and different parameters at different\n!> times during the iteration, but this has not been\n!> implemented --- yet.\n!>\n!>\n!> The best choices of most of the parameters depend\n!> in an ill-understood way on the relative execution\n!> rate of xLAQR3 and xLAQR5 and on the nature of each\n!> particular eigenvalue problem. Experiment may be the\n!> only practical way to determine which choices are most\n!> effective.\n!>\n!> Following is a list of default values supplied by IPARMQ.\n!> These defaults may be adjusted in order to attain better\n!> performance in any particular computational environment.\n!>\n!> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.\n!> Default: 75. (Must be at least 11.)\n!>\n!> IPARMQ(ISPEC=13) Recommended deflation window size.\n!> This depends on ILO, IHI and NS, the\n!> number of simultaneous shifts returned\n!> by IPARMQ(ISPEC=15). The default for\n!> (IHI-ILO+1).LE.500 is NS. The default\n!> for (IHI-ILO+1).GT.500 is 3*NS/2.\n!>\n!> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.\n!>\n!> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.\n!> a multi-shift QR iteration.\n!>\n!> If IHI-ILO+1 is ...\n!>\n!> greater than ...but less ... the\n!> or equal to ... than default is\n!>\n!> 0 30 NS = 2+\n!> 30 60 NS = 4+\n!> 60 150 NS = 10\n!> 150 590 NS = **\n!> 590 3000 NS = 64\n!> 3000 6000 NS = 128\n!> 6000 infinity NS = 256\n!>\n!> (+) By default matrices of this order are\n!> passed to the implicit double shift routine\n!> xLAHQR. See IPARMQ(ISPEC=12) above. These\n!> values of NS are used only in case of a rare\n!> xLAHQR failure.\n!>\n!> (**) The asterisks (**) indicate an ad-hoc\n!> function increasing from 10 to 64.\n!>\n!> IPARMQ(ISPEC=16) Select structured matrix multiply.\n!> (See ISPEC=16 above for details.)\n!> Default: 3.\n!> \\endverbatim\n!>\n! =====================================================================\n INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n!\n! -- LAPACK auxiliary routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n INTEGER IHI, ILO, ISPEC, LWORK, N\n CHARACTER NAME*( * ), OPTS*( * )\n!\n! ================================================================\n! .. Parameters ..\n INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22\n PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, &\n ISHFTS = 15, IACC22 = 16 )\n INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP\n PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, &\n NIBBLE = 14, KNWSWP = 500 )\n REAL TWO\n PARAMETER ( TWO = 2.0 )\n! ..\n! .. Local Scalars ..\n INTEGER NH, NS\n INTEGER I, IC, IZ\n CHARACTER SUBNAM*6\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC LOG, MAX, MOD, NINT, REAL\n! ..\n! .. Executable Statements ..\n IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. &\n ( ISPEC.EQ.IACC22 ) ) THEN\n!\n! ==== Set the number simultaneous shifts ====\n!\n NH = IHI - ILO + 1\n NS = 2\n IF( NH.GE.30 ) NS = 4\n IF( NH.GE.60 ) NS = 10\n IF( NH.GE.150 ) &\n NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )\n IF( NH.GE.590 ) NS = 64\n IF( NH.GE.3000 ) NS = 128\n IF( NH.GE.6000 ) NS = 256\n NS = MAX( 2, NS-MOD( NS, 2 ) )\n END IF\n!\n IF( ISPEC.EQ.INMIN ) THEN\n!\n!\n! ===== Matrices of order smaller than NMIN get sent\n! . to xLAHQR, the classic double shift algorithm.\n! . This must be at least 11. ====\n!\n IPARMQ = NMIN\n!\n ELSE IF( ISPEC.EQ.INIBL ) THEN\n!\n! ==== INIBL: skip a multi-shift qr iteration and\n! . whenever aggressive early deflation finds\n! . at least (NIBBLE*(window size)/100) deflations. ====\n!\n IPARMQ = NIBBLE\n!\n ELSE IF( ISPEC.EQ.ISHFTS ) THEN\n!\n! ==== NSHFTS: The number of simultaneous shifts =====\n!\n IPARMQ = NS\n!\n ELSE IF( ISPEC.EQ.INWIN ) THEN\n!\n! ==== NW: deflation window size. ====\n!\n IF( NH.LE.KNWSWP ) THEN\n IPARMQ = NS\n ELSE\n IPARMQ = 3*NS / 2\n END IF\n!\n ELSE IF( ISPEC.EQ.IACC22 ) THEN\n!\n! ==== IACC22: Whether to accumulate reflections\n! . before updating the far-from-diagonal elements\n! . and whether to use 2-by-2 block structure while\n! . doing it. A small amount of work could be saved\n! . by making this choice dependent also upon the\n! . NH=IHI-ILO+1.\n!\n!\n! Convert NAME to upper case if the first character is lower case.\n!\n IPARMQ = 0\n SUBNAM = NAME\n IC = ICHAR( SUBNAM( 1: 1 ) )\n IZ = ICHAR( 'Z' )\n IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN\n!\n! ASCII character set\n!\n IF( IC.GE.97 .AND. IC.LE.122 ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC-32 )\n DO I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( IC.GE.97 .AND. IC.LE.122 ) &\n SUBNAM( I: I ) = CHAR( IC-32 )\n END DO\n END IF\n!\n ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN\n!\n! EBCDIC character set\n!\n IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &\n ( IC.GE.145 .AND. IC.LE.153 ) .OR. &\n ( IC.GE.162 .AND. IC.LE.169 ) ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC+64 )\n DO I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &\n ( IC.GE.145 .AND. IC.LE.153 ) .OR. &\n ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: &\n I ) = CHAR( IC+64 )\n END DO\n END IF\n!\n ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN\n!\n! Prime machines: ASCII+128\n!\n IF( IC.GE.225 .AND. IC.LE.250 ) THEN\n SUBNAM( 1: 1 ) = CHAR( IC-32 )\n DO I = 2, 6\n IC = ICHAR( SUBNAM( I: I ) )\n IF( IC.GE.225 .AND. IC.LE.250 ) &\n SUBNAM( I: I ) = CHAR( IC-32 )\n END DO\n END IF\n END IF\n!\n IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. &\n SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN\n IPARMQ = 1\n IF( NH.GE.K22MIN ) IPARMQ = 2\n ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN\n IF( NH.GE.KACMIN ) IPARMQ = 1\n IF( NH.GE.K22MIN ) IPARMQ = 2\n ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. &\n SUBNAM( 2:5 ).EQ.'LAQR' ) THEN\n IF( NS.GE.KACMIN ) IPARMQ = 1\n IF( NS.GE.K22MIN ) IPARMQ = 2\n END IF\n!\n ELSE\n! ===== invalid value of ispec =====\n IPARMQ = -1\n!\n END IF\n!\n! ==== End of IPARMQ ====\n!\n END FUNCTION IPARMQ\n!\n!> \\brief \\b LSAME\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! LOGICAL FUNCTION LSAME(CA,CB)\n! \n! .. Scalar Arguments ..\n! CHARACTER CA,CB\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> LSAME returns .TRUE. if CA is the same letter as CB regardless of\n!> case.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] CA\n!> \\verbatim\n!> CA is CHARACTER*1\n!> \\endverbatim\n!>\n!> \\param[in] CB\n!> \\verbatim\n!> CB is CHARACTER*1\n!> CA and CB specify the single characters to be compared.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup aux_blas\n!\n! =====================================================================\n LOGICAL FUNCTION LSAME(CA,CB)\n!\n! -- Reference BLAS level1 routine (version 3.1) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER CA,CB\n! ..\n!\n! =====================================================================\n!\n! .. Intrinsic Functions ..\n INTRINSIC ICHAR\n! ..\n! .. Local Scalars ..\n INTEGER INTA,INTB,ZCODE\n! ..\n!\n! Test if the characters are equal\n!\n LSAME = CA .EQ. CB\n IF (LSAME) RETURN\n!\n! Now test for equivalence if both characters are alphabetic.\n!\n ZCODE = ICHAR('Z')\n!\n! Use 'Z' rather than 'A' so that ASCII can be detected on Prime\n! machines, on which ICHAR returns a value with bit 8 set.\n! ICHAR('A') on Prime machines returns 193 which is the same as\n! ICHAR('A') on an EBCDIC machine.\n!\n INTA = ICHAR(CA)\n INTB = ICHAR(CB)\n!\n IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN\n!\n! ASCII is assumed - ZCODE is the ASCII code of either lower or\n! upper case 'Z'.\n!\n IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32\n IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32\n!\n ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN\n!\n! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or\n! upper case 'Z'.\n!\n IF (INTA.GE.129 .AND. INTA.LE.137 .OR. &\n INTA.GE.145 .AND. INTA.LE.153 .OR. &\n INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64\n IF (INTB.GE.129 .AND. INTB.LE.137 .OR. &\n INTB.GE.145 .AND. INTB.LE.153 .OR. &\n INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64\n!\n ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN\n!\n! ASCII is assumed, on Prime machines - ZCODE is the ASCII code\n! plus 128 of either lower or upper case 'Z'.\n!\n IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32\n IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32\n END IF\n LSAME = INTA .EQ. INTB\n!\n! RETURN\n!\n! End of LSAME\n!\n END FUNCTION LSAME\n!> \\brief \\b LSAMEN\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download LSAMEN + dependencies \n!> [TGZ] \n!> [ZIP] \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! LOGICAL FUNCTION LSAMEN( N, CA, CB )\n! \n! .. Scalar Arguments ..\n! CHARACTER*( * ) CA, CB\n! INTEGER N\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> LSAMEN tests if the first N letters of CA are the same as the\n!> first N letters of CB, regardless of case.\n!> LSAMEN returns .TRUE. if CA and CB are equivalent except for case\n!> and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )\n!> or LEN( CB ) is less than N.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of characters in CA and CB to be compared.\n!> \\endverbatim\n!>\n!> \\param[in] CA\n!> \\verbatim\n!> CA is CHARACTER*(*)\n!> \\endverbatim\n!>\n!> \\param[in] CB\n!> \\verbatim\n!> CB is CHARACTER*(*)\n!> CA and CB specify two character strings of length at least N.\n!> Only the first N characters of each string will be accessed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n LOGICAL FUNCTION LSAMEN( N, CA, CB )\n!\n! -- LAPACK auxiliary routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER*( * ) CA, CB\n INTEGER N\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC LEN\n! ..\n! .. Executable Statements ..\n!\n LSAMEN = .FALSE.\n IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) GO TO 20\n!\n! Do for each character in the two strings.\n!\n DO 10 I = 1, N\n!\n! Test if the characters are equal using LSAME.\n!\n IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) GO TO 20\n!\n 10 CONTINUE\n LSAMEN = .TRUE.\n!\n 20 CONTINUE\n RETURN\n!\n! End of LSAMEN\n!\n END FUNCTION LSAMEN\n!> \\brief \\b XERBLA\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE XERBLA( SRNAME, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER*(*) SRNAME\n! INTEGER INFO\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> XERBLA is an error handler for the LAPACK routines.\n!> It is called by an LAPACK routine if an input parameter has an\n!> invalid value. A message is printed and execution stops.\n!>\n!> Installers may consider modifying the STOP statement in order to\n!> call system-specific exception-handling facilities.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SRNAME\n!> \\verbatim\n!> SRNAME is CHARACTER*(*)\n!> The name of the routine which called XERBLA.\n!> \\endverbatim\n!>\n!> \\param[in] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> The position of the invalid parameter in the parameter list\n!> of the calling routine.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup aux_blas\n!\n! =====================================================================\n SUBROUTINE XERBLA( SRNAME, INFO )\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER*(*) SRNAME\n INTEGER INFO\n! ..\n!\n! =====================================================================\n!\n! .. Intrinsic Functions ..\n INTRINSIC LEN_TRIM\n! ..\n! .. Executable Statements ..\n!\n WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO\n!\n STOP\n!\n 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', &\n 'an illegal value' )\n!\n! End of XERBLA\n!\n END SUBROUTINE XERBLA\n!\n!> \\brief DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSPEVD + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,\n! IWORK, LIWORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER JOBZ, UPLO\n! INTEGER INFO, LDZ, LIWORK, LWORK, N\n! ..\n! .. Array Arguments ..\n! INTEGER IWORK( * )\n! DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSPEVD computes all the eigenvalues and, optionally, eigenvectors\n!> of a real symmetric matrix A in packed storage. If eigenvectors are\n!> desired, it uses a divide and conquer algorithm.\n!>\n!> The divide and conquer algorithm makes very mild assumptions about\n!> floating point arithmetic. It will work on machines with a guard\n!> digit in add/subtract, or on those binary machines without guard\n!> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n!> Cray-2. It could conceivably fail on hexadecimal or decimal machines\n!> without guard digits, but we know of none.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] JOBZ\n!> \\verbatim\n!> JOBZ is CHARACTER*1\n!> = 'N': Compute eigenvalues only;\n!> = 'V': Compute eigenvalues and eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangle of A is stored;\n!> = 'L': Lower triangle of A is stored.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the upper or lower triangle of the symmetric matrix\n!> A, packed columnwise in a linear array. The j-th column of A\n!> is stored in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n!>\n!> On exit, AP is overwritten by values generated during the\n!> reduction to tridiagonal form. If UPLO = 'U', the diagonal\n!> and first superdiagonal of the tridiagonal matrix T overwrite\n!> the corresponding elements of A, and if UPLO = 'L', the\n!> diagonal and first subdiagonal of T overwrite the\n!> corresponding elements of A.\n!> \\endverbatim\n!>\n!> \\param[out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (N)\n!> If INFO = 0, the eigenvalues in ascending order.\n!> \\endverbatim\n!>\n!> \\param[out] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (LDZ, N)\n!> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n!> eigenvectors of the matrix A, with the i-th column of Z\n!> holding the eigenvector associated with W(i).\n!> If JOBZ = 'N', then Z is not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDZ\n!> \\verbatim\n!> LDZ is INTEGER\n!> The leading dimension of the array Z. LDZ >= 1, and if\n!> JOBZ = 'V', LDZ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array,\n!> dimension (LWORK)\n!> On exit, if INFO = 0, WORK(1) returns the required LWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LWORK\n!> \\verbatim\n!> LWORK is INTEGER\n!> The dimension of the array WORK.\n!> If N <= 1, LWORK must be at least 1.\n!> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n!> If JOBZ = 'V' and N > 1, LWORK must be at least\n!> 1 + 6*N + N**2.\n!>\n!> If LWORK = -1, then a workspace query is assumed; the routine\n!> only calculates the required sizes of the WORK and IWORK\n!> arrays, returns these values as the first entries of the WORK\n!> and IWORK arrays, and no error message related to LWORK or\n!> LIWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] IWORK\n!> \\verbatim\n!> IWORK is INTEGER array, dimension (MAX(1,LIWORK))\n!> On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LIWORK\n!> \\verbatim\n!> LIWORK is INTEGER\n!> The dimension of the array IWORK.\n!> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n!> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n!>\n!> If LIWORK = -1, then a workspace query is assumed; the\n!> routine only calculates the required sizes of the WORK and\n!> IWORK arrays, returns these values as the first entries of\n!> the WORK and IWORK arrays, and no error message related to\n!> LWORK or LIWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = i, the algorithm failed to converge; i\n!> off-diagonal elements of an intermediate tridiagonal\n!> form did not converge to zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHEReigen\n!\n! =====================================================================\n SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, &\n IWORK, LIWORK, INFO )\n!\n! -- LAPACK driver routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER JOBZ, UPLO\n INTEGER INFO, LDZ, LIWORK, LWORK, N\n! ..\n! .. Array Arguments ..\n INTEGER IWORK( * )\n DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL LQUERY, WANTZ\n INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,&\n LLWORK, LWMIN\n DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,&\n SMLNUM\n! ..\n! .. External Functions ..\n!? LOGICAL LSAME\n!? DOUBLE PRECISION DLAMCH, DLANSP\n!? EXTERNAL LSAME, DLAMCH, DLANSP\n! ..\n! .. External Subroutines ..\n!? EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA\n! EXTERNAL DSTERF\n! ..\n! .. Intrinsic Functions ..\n!? INTRINSIC SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n WANTZ = LSAME( JOBZ, 'V' )\n LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )\n!\n INFO = 0\n IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN\n INFO = -1\n ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )&\n THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN\n INFO = -7\n END IF\n!\n IF( INFO.EQ.0 ) THEN\n IF( N.LE.1 ) THEN\n LIWMIN = 1\n LWMIN = 1\n ELSE\n IF( WANTZ ) THEN\n LIWMIN = 3 + 5*N\n LWMIN = 1 + 6*N + N**2\n ELSE\n LIWMIN = 1\n LWMIN = 2*N\n END IF\n END IF\n IWORK( 1 ) = LIWMIN\n WORK( 1 ) = LWMIN\n!\n IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN\n INFO = -9\n ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN\n INFO = -11\n END IF\n END IF\n!\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSPEVD', -INFO )\n RETURN\n ELSE IF( LQUERY ) THEN\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 )&\n RETURN\n!\n IF( N.EQ.1 ) THEN\n W( 1 ) = AP( 1 )\n IF( WANTZ )&\n Z( 1, 1 ) = ONE\n RETURN\n END IF\n!\n! Get machine constants.\n!\n SAFMIN = DLAMCH( 'Safe minimum' )\n EPS = DLAMCH( 'Precision' )\n SMLNUM = SAFMIN / EPS\n BIGNUM = ONE / SMLNUM\n RMIN = SQRT( SMLNUM )\n RMAX = SQRT( BIGNUM )\n!\n! Scale matrix to allowable range, if necessary.\n!\n ANRM = DLANSP( 'M', UPLO, N, AP, WORK )\n ISCALE = 0\n IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN\n ISCALE = 1\n SIGMA = RMIN / ANRM\n ELSE IF( ANRM.GT.RMAX ) THEN\n ISCALE = 1\n SIGMA = RMAX / ANRM\n END IF\n IF( ISCALE.EQ.1 ) THEN\n CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )\n END IF\n!\n! Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.\n!\n INDE = 1\n INDTAU = INDE + N\n CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )\n!\n! For eigenvalues only, call DSTERF. For eigenvectors, first call\n! DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the\n! tridiagonal matrix, then call DOPMTR to multiply it by the\n! Householder transformations represented in AP.\n!\n IF( .NOT.WANTZ ) THEN\n CALL DSTERF( N, W, WORK( INDE ), INFO )\n ELSE\n INDWRK = INDTAU + N\n LLWORK = LWORK - INDWRK + 1\n CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),&\n LLWORK, IWORK, LIWORK, INFO )\n CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,&\n WORK( INDWRK ), IINFO )\n END IF\n!\n! If matrix was scaled, then rescale eigenvalues appropriately.\n!\n IF( ISCALE.EQ.1 ) &\n CALL DSCAL( N, ONE / SIGMA, W, 1 )\n!\n WORK( 1 ) = LWMIN\n IWORK( 1 ) = LIWMIN\n RETURN\n!\n! End of DSPEVD\n!\n END SUBROUTINE DSPEVD\n!\n!\n!> \\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.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLANSP + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n! \n! .. Scalar Arguments ..\n! CHARACTER NORM, UPLO\n! INTEGER N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLANSP returns the value of the one norm, or the Frobenius norm, or\n!> the infinity norm, or the element of largest absolute value of a\n!> real symmetric matrix A, supplied in packed form.\n!> \\endverbatim\n!>\n!> \\return DLANSP\n!> \\verbatim\n!>\n!> DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n!> (\n!> ( norm1(A), NORM = '1', 'O' or 'o'\n!> (\n!> ( normI(A), NORM = 'I' or 'i'\n!> (\n!> ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n!>\n!> where norm1 denotes the one norm of a matrix (maximum column sum),\n!> normI denotes the infinity norm of a matrix (maximum row sum) and\n!> normF denotes the Frobenius norm of a matrix (square root of sum of\n!> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] NORM\n!> \\verbatim\n!> NORM is CHARACTER*1\n!> Specifies the value to be returned in DLANSP as described\n!> above.\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies whether the upper or lower triangular part of the\n!> symmetric matrix A is supplied.\n!> = 'U': Upper triangular part of A is supplied\n!> = 'L': Lower triangular part of A is supplied\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0. When N = 0, DLANSP is\n!> set to zero.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> The upper or lower triangle of the symmetric matrix A, packed\n!> columnwise in a linear array. The j-th column of A is stored\n!> in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n!> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n!> WORK is not referenced.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERauxiliary\n!\n! =====================================================================\n DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER NORM, UPLO\n INTEGER N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, J, K\n DOUBLE PRECISION ABSA, SCALE, SUM, VALUE\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLASSQ\n! ..\n! .. External Functions ..\n! LOGICAL LSAME, DISNAN\n! EXTERNAL LSAME, DISNAN\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SQRT\n! ..\n! .. Executable Statements ..\n!\n IF( N.EQ.0 ) THEN\n VALUE = ZERO\n ELSE IF( LSAME( NORM, 'M' ) ) THEN\n!\n! Find max(abs(A(i,j))).\n!\n VALUE = ZERO\n IF( LSAME( UPLO, 'U' ) ) THEN\n K = 1\n DO 20 J = 1, N\n DO 10 I = K, K + J - 1\n SUM = ABS( AP( I ) )\n IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM\n10 CONTINUE\n K = K + J\n20 CONTINUE\n ELSE\n K = 1\n DO 40 J = 1, N\n DO 30 I = K, K + N - J\n SUM = ABS( AP( I ) )\n IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM\n30 CONTINUE\n K = K + N - J + 1\n40 CONTINUE\n END IF\n ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ).OR.&\n ( NORM.EQ.'1' ) ) THEN\n!\n! Find normI(A) ( = norm1(A), since A is symmetric).\n!\n VALUE = ZERO\n K = 1\n IF( LSAME( UPLO, 'U' ) ) THEN\n DO 60 J = 1, N\n SUM = ZERO\n DO 50 I = 1, J - 1\n ABSA = ABS( AP( K ) )\n SUM = SUM + ABSA\n WORK( I ) = WORK( I ) + ABSA\n K = K + 1\n50 CONTINUE\n WORK( J ) = SUM + ABS( AP( K ) )\n K = K + 1\n60 CONTINUE\n DO 70 I = 1, N\n SUM = WORK( I )\n IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) &\n VALUE = SUM\n70 CONTINUE\n ELSE\n DO 80 I = 1, N\n WORK( I ) = ZERO\n80 CONTINUE\n DO 100 J = 1, N\n SUM = WORK( J ) + ABS( AP( K ) )\n K = K + 1\n DO 90 I = J + 1, N\n ABSA = ABS( AP( K ) )\n SUM = SUM + ABSA\n WORK( I ) = WORK( I ) + ABSA\n K = K + 1\n90 CONTINUE\n IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM\n100 CONTINUE\n END IF\n ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN\n!\n! Find normF(A).\n!\n SCALE = ZERO\n SUM = ONE\n K = 2\n IF( LSAME( UPLO, 'U' ) ) THEN\n DO 110 J = 2, N\n CALL DLASSQ( J-1, AP( K ), 1,&\n SCALE, SUM )\n K = K + J\n110 CONTINUE\n ELSE\n DO 120 J = 1, N - 1\n CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )\n K = K + N - J + 1\n120 CONTINUE\n END IF\n SUM = 2*SUM\n K = 1\n DO 130 I = 1, N\n IF( AP( K ).NE.ZERO ) THEN\n ABSA = ABS( AP( K ) )\n IF( SCALE.LT.ABSA ) THEN\n SUM = ONE + SUM*( SCALE / ABSA )**2\n SCALE = ABSA\n ELSE\n SUM = SUM + ( ABSA / SCALE )**2\n END IF\n END IF\n IF( LSAME( UPLO, 'U' ) ) THEN\n K = K + I + 1\n ELSE\n K = K + N - I + 1\n END IF\n130 CONTINUE\n VALUE = SCALE*SQRT( SUM )\n END IF\n!\n DLANSP = VALUE\n RETURN\n!\n! End of DLANSP\n!\n END FUNCTION DLANSP\n!\n!=\n!\n!> \\brief \\b DLASSQ updates a sum of squares represented in scaled form.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASSQ + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n! \n! .. Scalar Arguments ..\n! INTEGER INCX, N\n! DOUBLE PRECISION SCALE, SUMSQ\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION X( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASSQ returns the values scl and smsq such that\n!>\n!> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n!>\n!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n!> assumed to be non-negative and scl returns the value\n!>\n!> scl = max( scale, abs( x( i ) ) ).\n!>\n!> scale and sumsq must be supplied in SCALE and SUMSQ and\n!> scl and smsq are overwritten on SCALE and SUMSQ respectively.\n!>\n!> The routine makes only one pass through the vector x.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of elements to be used from the vector X.\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array, dimension (N)\n!> The vector for which a scaled sum of squares is computed.\n!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> The increment between successive values of the vector X.\n!> INCX > 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] SCALE\n!> \\verbatim\n!> SCALE is DOUBLE PRECISION\n!> On entry, the value scale in the equation above.\n!> On exit, SCALE is overwritten with scl , the scaling factor\n!> for the sum of squares.\n!> \\endverbatim\n!>\n!> \\param[in,out] SUMSQ\n!> \\verbatim\n!> SUMSQ is DOUBLE PRECISION\n!> On entry, the value sumsq in the equation above.\n!> On exit, SUMSQ is overwritten with smsq , the basic sum of\n!> squares from which scl has been factored out.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INCX, N\n DOUBLE PRECISION SCALE, SUMSQ\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION X( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER IX\n DOUBLE PRECISION ABSXI\n! ..\n! .. External Functions ..\n! LOGICAL DISNAN\n! EXTERNAL DISNAN\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS\n! ..\n! .. Executable Statements ..\n!\n IF( N.GT.0 ) THEN\n DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX\n ABSXI = ABS( X( IX ) )\n IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN\n IF( SCALE.LT.ABSXI ) THEN\n SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2\n SCALE = ABSXI\n ELSE\n SUMSQ = SUMSQ + ( ABSXI / SCALE )**2\n END IF\n END IF\n10 CONTINUE\n END IF\n RETURN\n!\n! End of DLASSQ\n!\n END SUBROUTINE DLASSQ\n!\n!=\n!\n!> \\brief \\b DSPTRD\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSPTRD + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSPTRD reduces a real symmetric matrix A stored in packed form to\n!> symmetric tridiagonal form T by an orthogonal similarity\n!> transformation: Q**T * A * Q = T.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangle of A is stored;\n!> = 'L': Lower triangle of A is stored.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the upper or lower triangle of the symmetric matrix\n!> A, packed columnwise in a linear array. The j-th column of A\n!> is stored in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n!> On exit, if UPLO = 'U', the diagonal and first superdiagonal\n!> of A are overwritten by the corresponding elements of the\n!> tridiagonal matrix T, and the elements above the first\n!> superdiagonal, with the array TAU, represent the orthogonal\n!> matrix Q as a product of elementary reflectors; if UPLO\n!> = 'L', the diagonal and first subdiagonal of A are over-\n!> written by the corresponding elements of the tridiagonal\n!> matrix T, and the elements below the first subdiagonal, with\n!> the array TAU, represent the orthogonal matrix Q as a product\n!> of elementary reflectors. See Further Details.\n!> \\endverbatim\n!>\n!> \\param[out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> The diagonal elements of the tridiagonal matrix T:\n!> D(i) = A(i,i).\n!> \\endverbatim\n!>\n!> \\param[out] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> The off-diagonal elements of the tridiagonal matrix T:\n!> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n!> \\endverbatim\n!>\n!> \\param[out] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (N-1)\n!> The scalar factors of the elementary reflectors (see Further\n!> Details).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> If UPLO = 'U', the matrix Q is represented as a product of elementary\n!> reflectors\n!>\n!> Q = H(n-1) . . . H(2) H(1).\n!>\n!> Each H(i) has the form\n!>\n!> H(i) = I - tau * v * v**T\n!>\n!> where tau is a real scalar, and v is a real vector with\n!> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n!> overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n!>\n!> If UPLO = 'L', the matrix Q is represented as a product of elementary\n!> reflectors\n!>\n!> Q = H(1) H(2) . . . H(n-1).\n!>\n!> Each H(i) has the form\n!>\n!> H(i) = I - tau * v * v**T\n!>\n!> where tau is a real scalar, and v is a real vector with\n!> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n!> overwriting A(i+2:n,i), and tau is stored in TAU(i).\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO, HALF\n PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,&\n HALF = 1.0D0 / 2.0D0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I, I1, I1I1, II\n DOUBLE PRECISION ALPHA, TAUI\n! ..\n! .. External Subroutines ..\n!? EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA\n! EXTERNAL DAXPY, DSPMV, DSPR2\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DDOT\n! EXTERNAL LSAME, DDOT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSPTRD', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.LE.0 )&\n RETURN\n!\n IF( UPPER ) THEN\n!\n! Reduce the upper triangle of A.\n! I1 is the index in AP of A(1,I+1).\n!\n I1 = N*( N-1 ) / 2 + 1\n DO 10 I = N - 1, 1, -1\n!\n! Generate elementary reflector H(i) = I - tau * v * v**T\n! to annihilate A(1:i-1,i+1)\n!\n CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )\n E( I ) = AP( I1+I-1 )\n!\n IF( TAUI.NE.ZERO ) THEN\n!\n! Apply H(i) from both sides to A(1:i,1:i)\n!\n AP( I1+I-1 ) = ONE\n!\n! Compute y := tau * A * v storing y in TAU(1:i)\n!\n CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, 1)\n!\n! Compute w := y - 1/2 * tau * (y**T *v) * v\n!\n ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )\n CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )\n!\n! Apply the transformation as a rank-2 update:\n! A := A - v * w**T - w * v**T\n!\n CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )\n!\n AP( I1+I-1 ) = E( I )\n END IF\n D( I+1 ) = AP( I1+I )\n TAU( I ) = TAUI\n I1 = I1 - I\n10 CONTINUE\n D( 1 ) = AP( 1 )\n ELSE\n!\n! Reduce the lower triangle of A. II is the index in AP of\n! A(i,i) and I1I1 is the index of A(i+1,i+1).\n!\n II = 1\n DO 20 I = 1, N - 1\n I1I1 = II + N - I + 1\n!\n! Generate elementary reflector H(i) = I - tau * v * v**T\n! to annihilate A(i+2:n,i)\n!\n CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )\n E( I ) = AP( II+1 )\n!\n IF( TAUI.NE.ZERO ) THEN\n!\n! Apply H(i) from both sides to A(i+1:n,i+1:n)\n!\n AP( II+1 ) = ONE\n!\n! Compute y := tau * A * v storing y in TAU(i:n-1)\n!\n CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,&\n ZERO, TAU( I ), 1 )\n!\n! Compute w := y - 1/2 * tau * (y**T *v) * v\n!\n ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), 1 )\n CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )\n!\n! Apply the transformation as a rank-2 update:\n! A := A - v * w**T - w * v**T\n!\n CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,&\n AP( I1I1 ) )\n!\n AP( II+1 ) = E( I )\n END IF\n D( I ) = AP( II )\n TAU( I ) = TAUI\n II = I1I1\n20 CONTINUE\n D( N ) = AP( II )\n END IF\n!\n RETURN\n!\n! End of DSPTRD\n!\n END SUBROUTINE DSPTRD\n!\n!=\n!\n!> \\brief \\b DLARFG generates an elementary reflector (Householder matrix).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLARFG + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n! \n! .. Scalar Arguments ..\n! INTEGER INCX, N\n! DOUBLE PRECISION ALPHA, TAU\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION X( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLARFG generates a real elementary reflector H of order n, such\n!> that\n!>\n!> H * ( alpha ) = ( beta ), H**T * H = I.\n!> ( x ) ( 0 )\n!>\n!> where alpha and beta are scalars, and x is an (n-1)-element real\n!> vector. H is represented in the form\n!>\n!> H = I - tau * ( 1 ) * ( 1 v**T ) ,\n!> ( v )\n!>\n!> where tau is a real scalar and v is a real (n-1)-element\n!> vector.\n!>\n!> If the elements of x are all zero, then tau = 0 and H is taken to be\n!> the unit matrix.\n!>\n!> Otherwise 1 <= tau <= 2.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the elementary reflector.\n!> \\endverbatim\n!>\n!> \\param[in,out] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION\n!> On entry, the value alpha.\n!> On exit, it is overwritten with the value beta.\n!> \\endverbatim\n!>\n!> \\param[in,out] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array, dimension\n!> (1+(N-2)*abs(INCX))\n!> On entry, the vector x.\n!> On exit, it is overwritten with the vector v.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> The increment between elements of X. INCX > 0.\n!> \\endverbatim\n!>\n!> \\param[out] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION\n!> The value tau.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INCX, N\n DOUBLE PRECISION ALPHA, TAU\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION X( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER J, KNT\n DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM\n! ..\n! .. External Functions ..\n!? DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2\n! DOUBLE PRECISION DNRM2\n! EXTERNAL DNRM2\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SIGN\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL\n! ..\n! .. Executable Statements ..\n!\n IF( N.LE.1 ) THEN\n TAU = ZERO\n RETURN\n END IF\n!\n XNORM = DNRM2( N-1, X, INCX )\n!\n IF( XNORM.EQ.ZERO ) THEN\n!\n! H = I\n!\n TAU = ZERO\n ELSE\n!\n! general case\n!\n BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )\n SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )\n KNT = 0\n IF( ABS( BETA ).LT.SAFMIN ) THEN\n!\n! XNORM, BETA may be inaccurate; scale X and recompute them\n!\n RSAFMN = ONE / SAFMIN\n10 CONTINUE\n KNT = KNT + 1\n CALL DSCAL( N-1, RSAFMN, X, INCX )\n BETA = BETA*RSAFMN\n ALPHA = ALPHA*RSAFMN\n IF( ABS( BETA ).LT.SAFMIN )&\n GO TO 10\n!\n! New BETA is at most 1, at least SAFMIN\n!\n XNORM = DNRM2( N-1, X, INCX )\n BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )\n END IF\n TAU = ( BETA-ALPHA ) / BETA\n CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )\n!\n! If ALPHA is subnormal, it may lose relative accuracy\n!\n DO 20 J = 1, KNT\n BETA = BETA*SAFMIN\n20 CONTINUE\n ALPHA = BETA\n END IF\n!\n RETURN\n!\n! End of DLARFG\n!\n END SUBROUTINE DLARFG\n!\n!=\n!\n!> \\brief \\b DLAPY2 returns sqrt(x2+y2).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAPY2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION X, Y\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n!> overflow.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION\n!> \\endverbatim\n!>\n!> \\param[in] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION\n!> X and Y specify the values x and y.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION X, Y\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D0 )\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION W, XABS, YABS, Z\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n XABS = ABS( X )\n YABS = ABS( Y )\n W = MAX( XABS, YABS )\n Z = MIN( XABS, YABS )\n IF( Z.EQ.ZERO ) THEN\n DLAPY2 = W\n ELSE\n DLAPY2 = W*SQRT( ONE+( Z / W )**2 )\n END IF\n RETURN\n!\n! End of DLAPY2\n!\n END FUNCTION DLAPY2\n!\n!=\n!\n!> \\brief \\b DSTERF\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSTERF + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSTERF( N, D, E, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * ), E( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n!> using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the n diagonal elements of the tridiagonal matrix.\n!> On exit, if INFO = 0, the eigenvalues in ascending order.\n!> \\endverbatim\n!>\n!> \\param[in,out] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> On entry, the (n-1) subdiagonal elements of the tridiagonal\n!> matrix.\n!> On exit, E has been destroyed.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: the algorithm failed to find all of the eigenvalues in\n!> a total of 30*N iterations; if INFO = i, then i\n!> elements of E have not converged to zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup auxOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DSTERF( N, D, E, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * ), E( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE, TWO, THREE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,&\n THREE = 3.0D0 )\n INTEGER MAXIT\n PARAMETER ( MAXIT = 30 )\n! ..\n! .. Local Scalars ..\n INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,&\n NMAXIT\n DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,&\n OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,&\n SIGMA, SSFMAX, SSFMIN, RMAX\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMCH, DLANST, DLAPY2\n!? EXTERNAL DLAMCH, DLANST, DLAPY2\n! ..\n! .. External Subroutines ..\n!? EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA\n! EXTERNAL DLAE2\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SIGN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n! Quick return if possible\n!\n IF( N.LT.0 ) THEN\n INFO = -1\n CALL XERBLA( 'DSTERF', -INFO )\n RETURN\n END IF\n IF( N.LE.1 ) RETURN\n!\n! Determine the unit roundoff for this environment.\n!\n EPS = DLAMCH( 'E' )\n EPS2 = EPS**2\n SAFMIN = DLAMCH( 'S' )\n SAFMAX = ONE / SAFMIN\n SSFMAX = SQRT( SAFMAX ) / THREE\n SSFMIN = SQRT( SAFMIN ) / EPS2\n RMAX = DLAMCH( 'O' )\n!\n! Compute the eigenvalues of the tridiagonal matrix.\n!\n NMAXIT = N*MAXIT\n SIGMA = ZERO\n JTOT = 0\n!\n! Determine where the matrix splits and choose QL or QR iteration\n! for each block, according to whether top or bottom diagonal\n! element is smaller.\n!\n L1 = 1\n!\n10 CONTINUE\n IF( L1.GT.N ) GO TO 170\n IF( L1.GT.1 ) E( L1-1 ) = ZERO\n DO 20 M = L1, N - 1\n IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+&\n 1 ) ) ) )*EPS ) THEN\n E( M ) = ZERO\n GO TO 30\n END IF\n20 CONTINUE\n M = N\n!\n30 CONTINUE\n L = L1\n LSV = L\n LEND = M\n LENDSV = LEND\n L1 = M + 1\n IF( LEND.EQ.L ) GO TO 10\n!\n! Scale submatrix in rows and columns L to LEND\n!\n ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) )\n ISCALE = 0\n IF( ANORM.EQ.ZERO ) GO TO 10 \n IF( (ANORM.GT.SSFMAX) ) THEN\n ISCALE = 1\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO )\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO)\n ELSE IF( ANORM.LT.SSFMIN ) THEN\n ISCALE = 2\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO)\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO)\n END IF\n!\n DO 40 I = L, LEND - 1\n E( I ) = E( I )**2\n40 CONTINUE\n!\n! Choose between QL and QR iteration\n!\n IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN\n LEND = LSV\n L = LENDSV\n END IF\n!\n IF( LEND.GE.L ) THEN\n!\n! QL Iteration\n!\n! Look for small subdiagonal element.\n!\n50 CONTINUE\n IF( L.NE.LEND ) THEN\n DO 60 M = L, LEND - 1\n IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) GO TO 70\n60 CONTINUE\n END IF\n M = LEND\n!\n70 CONTINUE\n IF( M.LT.LEND ) E( M ) = ZERO\n P = D( L )\n IF( M.EQ.L ) GO TO 90\n!\n! If remaining matrix is 2 by 2, use DLAE2 to compute its\n! eigenvalues.\n!\n IF( M.EQ.L+1 ) THEN\n RTE = SQRT( E( L ) )\n CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )\n D( L ) = RT1\n D( L+1 ) = RT2\n E( L ) = ZERO\n L = L + 2\n IF( L.LE.LEND ) GO TO 50\n GO TO 150\n END IF\n!\n IF( JTOT.EQ.NMAXIT ) GO TO 150\n JTOT = JTOT + 1\n!\n! Form shift.\n!\n RTE = SQRT( E( L ) )\n SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )\n R = DLAPY2( SIGMA, ONE )\n SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )\n!\n C = ONE\n S = ZERO\n GAMMA = D( M ) - SIGMA\n P = GAMMA*GAMMA\n!\n! Inner loop\n!\n DO 80 I = M - 1, L, -1\n BB = E( I )\n R = P + BB\n IF( I.NE.M-1 ) E( I+1 ) = S*R\n OLDC = C\n C = P / R\n S = BB / R\n OLDGAM = GAMMA\n ALPHA = D( I )\n GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM\n D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )\n IF( C.NE.ZERO ) THEN\n P = ( GAMMA*GAMMA ) / C\n ELSE\n P = OLDC*BB\n END IF\n80 CONTINUE\n!\n E( L ) = S*P\n D( L ) = SIGMA + GAMMA\n GO TO 50\n!\n! Eigenvalue found.\n!\n90 CONTINUE\n D( L ) = P\n!\n L = L + 1\n IF( L.LE.LEND ) GO TO 50\n GO TO 150\n!\n ELSE\n!\n! QR Iteration\n!\n! Look for small superdiagonal element.\n!\n100 CONTINUE\n DO 110 M = L, LEND + 1, -1\n IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) GO TO 120\n110 CONTINUE\n M = LEND\n!\n120 CONTINUE\n IF( M.GT.LEND ) E( M-1 ) = ZERO\n P = D( L )\n IF( M.EQ.L ) GO TO 140\n!\n! If remaining matrix is 2 by 2, use DLAE2 to compute its\n! eigenvalues.\n!\n IF( M.EQ.L-1 ) THEN\n RTE = SQRT( E( L-1 ) )\n CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )\n D( L ) = RT1\n D( L-1 ) = RT2\n E( L-1 ) = ZERO\n L = L - 2\n IF( L.GE.LEND ) GO TO 100\n GO TO 150\n END IF\n!\n IF( JTOT.EQ.NMAXIT ) GO TO 150\n JTOT = JTOT + 1\n!\n! Form shift.\n!\n RTE = SQRT( E( L-1 ) )\n SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )\n R = DLAPY2( SIGMA, ONE )\n SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )\n!\n C = ONE\n S = ZERO\n GAMMA = D( M ) - SIGMA\n P = GAMMA*GAMMA\n!\n! Inner loop\n!\n DO 130 I = M, L - 1\n BB = E( I )\n R = P + BB\n IF( I.NE.M ) E( I-1 ) = S*R\n OLDC = C\n C = P / R\n S = BB / R\n OLDGAM = GAMMA\n ALPHA = D( I+1 )\n GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM\n D( I ) = OLDGAM + ( ALPHA-GAMMA )\n IF( C.NE.ZERO ) THEN\n P = ( GAMMA*GAMMA ) / C\n ELSE\n P = OLDC*BB\n END IF\n130 CONTINUE\n!\n E( L-1 ) = S*P\n D( L ) = SIGMA + GAMMA\n GO TO 100\n!\n! Eigenvalue found.\n!\n140 CONTINUE\n D( L ) = P\n!\n L = L - 1\n IF( L.GE.LEND ) GO TO 100\n GO TO 150\n!\n END IF\n!\n! Undo scaling if necessary\n!\n150 CONTINUE\n IF( ISCALE.EQ.1 ) &\n CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,&\n D( LSV ), N, INFO )\n IF( ISCALE.EQ.2 ) &\n CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,&\n D( LSV ), N, INFO )\n!\n! Check for no convergence to an eigenvalue after a total\n! of N*MAXIT iterations.\n!\n IF( JTOT.LT.NMAXIT ) GO TO 10\n DO 160 I = 1, N - 1\n IF( E( I ).NE.ZERO ) INFO = INFO + 1\n160 CONTINUE\n GO TO 180\n!\n! Sort eigenvalues in increasing order.\n!\n170 CONTINUE\n CALL DLASRT( 'I', N, D, INFO )\n!\n180 CONTINUE\n RETURN\n!\n! End of DSTERF\n!\n END SUBROUTINE DSTERF\n!\n!=\n!\n!> \\brief \\b DOPMTR\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DOPMTR + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,\n! INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER SIDE, TRANS, UPLO\n! INTEGER INFO, LDC, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DOPMTR overwrites the general real M-by-N matrix C with\n!>\n!> SIDE = 'L' SIDE = 'R'\n!> TRANS = 'N': Q * C C * Q\n!> TRANS = 'T': Q**T * C C * Q**T\n!>\n!> where Q is a real orthogonal matrix of order nq, with nq = m if\n!> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n!> nq-1 elementary reflectors, as returned by DSPTRD using packed\n!> storage:\n!>\n!> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n!>\n!> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SIDE\n!> \\verbatim\n!> SIDE is CHARACTER*1\n!> = 'L': apply Q or Q**T from the Left;\n!> = 'R': apply Q or Q**T from the Right.\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangular packed storage used in previous\n!> call to DSPTRD;\n!> = 'L': Lower triangular packed storage used in previous\n!> call to DSPTRD.\n!> \\endverbatim\n!>\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> = 'N': No transpose, apply Q;\n!> = 'T': Transpose, apply Q**T.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix C. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix C. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension\n!> (M*(M+1)/2) if SIDE = 'L'\n!> (N*(N+1)/2) if SIDE = 'R'\n!> The vectors which define the elementary reflectors, as\n!> returned by DSPTRD. AP is modified by the routine but\n!> restored on exit.\n!> \\endverbatim\n!>\n!> \\param[in] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'\n!> or (N-1) if SIDE = 'R'\n!> TAU(i) must contain the scalar factor of the elementary\n!> reflector H(i), as returned by DSPTRD.\n!> \\endverbatim\n!>\n!> \\param[in,out] C\n!> \\verbatim\n!> C is DOUBLE PRECISION array, dimension (LDC,N)\n!> On entry, the M-by-N matrix C.\n!> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n!> \\endverbatim\n!>\n!> \\param[in] LDC\n!> \\verbatim\n!> LDC is INTEGER\n!> The leading dimension of the array C. LDC >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension\n!> (N) if SIDE = 'L'\n!> (M) if SIDE = 'R'\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,&\n INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER SIDE, TRANS, UPLO\n INTEGER INFO, LDC, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL FORWRD, LEFT, NOTRAN, UPPER\n INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ\n DOUBLE PRECISION AII\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines .. DLARFG exists ...\n!? EXTERNAL DLARF, XERBLA\n! EXTERNAL DLARF\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n LEFT = LSAME( SIDE, 'L' )\n NOTRAN = LSAME( TRANS, 'N' )\n UPPER = LSAME( UPLO, 'U' )\n!\n! NQ is the order of Q\n!\n IF( LEFT ) THEN\n NQ = M\n ELSE\n NQ = N\n END IF\n IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN\n INFO = -1\n ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -2\n ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN\n INFO = -3\n ELSE IF( M.LT.0 ) THEN\n INFO = -4\n ELSE IF( N.LT.0 ) THEN\n INFO = -5\n ELSE IF( LDC.LT.MAX( 1, M ) ) THEN\n INFO = -9\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DOPMTR', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( M.EQ.0 .OR. N.EQ.0 ) RETURN\n!\n IF( UPPER ) THEN\n!\n! Q was determined by a call to DSPTRD with UPLO = 'U'\n!\n FORWRD = ( LEFT .AND. NOTRAN ) .OR.&\n ( .NOT.LEFT .AND. .NOT.NOTRAN )\n!\n IF( FORWRD ) THEN\n I1 = 1\n I2 = NQ - 1\n I3 = 1\n II = 2\n ELSE\n I1 = NQ - 1\n I2 = 1\n I3 = -1\n II = NQ*( NQ+1 ) / 2 - 1\n END IF\n!\n IF( LEFT ) THEN\n NI = N\n ELSE\n MI = M\n END IF\n!\n DO 10 I = I1, I2, I3\n IF( LEFT ) THEN\n!\n! H(i) is applied to C(1:i,1:n)\n!\n MI = I\n ELSE\n!\n! H(i) is applied to C(1:m,1:i)\n!\n NI = I\n END IF\n!\n! Apply H(i)\n!\n AII = AP( II )\n AP( II ) = ONE\n CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, WORK )\n AP( II ) = AII\n!\n IF( FORWRD ) THEN\n II = II + I + 2\n ELSE\n II = II - I - 1\n END IF\n10 CONTINUE\n ELSE\n!\n! Q was determined by a call to DSPTRD with UPLO = 'L'.\n!\n FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.&\n ( .NOT.LEFT .AND. NOTRAN )\n!\n IF( FORWRD ) THEN\n I1 = 1\n I2 = NQ - 1\n I3 = 1\n II = 2\n ELSE\n I1 = NQ - 1\n I2 = 1\n I3 = -1\n II = NQ*( NQ+1 ) / 2 - 1\n END IF\n!\n IF( LEFT ) THEN\n NI = N\n JC = 1\n ELSE\n MI = M\n IC = 1\n END IF\n!\n DO 20 I = I1, I2, I3\n AII = AP( II )\n AP( II ) = ONE\n IF( LEFT ) THEN\n!\n! H(i) is applied to C(i+1:m,1:n)\n!\n MI = M - I\n IC = I + 1\n ELSE\n!\n! H(i) is applied to C(1:m,i+1:n)\n!\n NI = N - I\n JC = I + 1\n END IF\n!\n! Apply H(i)\n!\n CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),&\n C( IC, JC ), LDC, WORK )\n AP( II ) = AII\n!\n IF( FORWRD ) THEN\n II = II + NQ - I + 1\n ELSE\n II = II - NQ + I - 2\n END IF\n20 CONTINUE\n END IF\n RETURN\n!\n! End of DOPMTR\n!\n END SUBROUTINE DOPMTR\n!\n!=\n!\n!> \\brief \\b DLARF applies an elementary reflector to a general rectangular matrix.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLARF + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n! \n! .. Scalar Arguments ..\n! CHARACTER SIDE\n! INTEGER INCV, LDC, M, N\n! DOUBLE PRECISION TAU\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLARF applies a real elementary reflector H to a real m by n matrix\n!> C, from either the left or the right. H is represented in the form\n!>\n!> H = I - tau * v * v**T\n!>\n!> where tau is a real scalar and v is a real vector.\n!>\n!> If tau = 0, then H is taken to be the unit matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SIDE\n!> \\verbatim\n!> SIDE is CHARACTER*1\n!> = 'L': form H * C\n!> = 'R': form C * H\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix C.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix C.\n!> \\endverbatim\n!>\n!> \\param[in] V\n!> \\verbatim\n!> V is DOUBLE PRECISION array, dimension\n!> (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n!> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n!> The vector v in the representation of H. V is not used if\n!> TAU = 0.\n!> \\endverbatim\n!>\n!> \\param[in] INCV\n!> \\verbatim\n!> INCV is INTEGER\n!> The increment between elements of v. INCV <> 0.\n!> \\endverbatim\n!>\n!> \\param[in] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION\n!> The value tau in the representation of H.\n!> \\endverbatim\n!>\n!> \\param[in,out] C\n!> \\verbatim\n!> C is DOUBLE PRECISION array, dimension (LDC,N)\n!> On entry, the m by n matrix C.\n!> On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n!> or C * H if SIDE = 'R'.\n!> \\endverbatim\n!>\n!> \\param[in] LDC\n!> \\verbatim\n!> LDC is INTEGER\n!> The leading dimension of the array C. LDC >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension\n!> (N) if SIDE = 'L'\n!> or (M) if SIDE = 'R'\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER SIDE\n INTEGER INCV, LDC, M, N\n DOUBLE PRECISION TAU\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL APPLYLEFT\n INTEGER I, LASTV, LASTC\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMV, DGER\n! EXTERNAL DGER\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! INTEGER ILADLR, ILADLC\n! EXTERNAL LSAME, ILADLR, ILADLC\n! EXTERNAL ILADLR, ILADLC\n! ..\n! .. Executable Statements ..\n!\n APPLYLEFT = LSAME( SIDE, 'L' )\n LASTV = 0\n LASTC = 0\n IF( TAU.NE.ZERO ) THEN\n! Set up variables for scanning V. LASTV begins pointing to the end\n! of V.\n IF( APPLYLEFT ) THEN\n LASTV = M\n ELSE\n LASTV = N\n END IF\n IF( INCV.GT.0 ) THEN\n I = 1 + (LASTV-1) * INCV\n ELSE\n I = 1\n END IF\n! Look for the last non-zero row in V.\n DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )\n LASTV = LASTV - 1\n I = I - INCV\n END DO\n IF( APPLYLEFT ) THEN\n! Scan for the last non-zero column in C(1:lastv,:).\n LASTC = ILADLC(LASTV, N, C, LDC)\n ELSE\n! Scan for the last non-zero row in C(:,1:lastv).\n LASTC = ILADLR(M, LASTV, C, LDC)\n END IF\n END IF\n! Note that lastc.eq.0 renders the BLAS operations null; no special\n! case is needed at this level.\n IF( APPLYLEFT ) THEN\n!\n! Form H * C\n!\n IF( LASTV.GT.0 ) THEN\n!\n! w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)\n!\n CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,&\n ZERO, WORK, 1 )\n!\n! C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T\n!\n CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )\n END IF\n ELSE\n!\n! Form C * H\n!\n IF( LASTV.GT.0 ) THEN\n!\n! w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)\n!\n CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,&\n V, INCV, ZERO, WORK, 1 )\n!\n! C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T\n!\n CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )\n END IF\n END IF\n RETURN\n!\n! End of DLARF\n!\n END SUBROUTINE DLARF\n!\n!=\n!\n!> \\brief DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSPEV + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER JOBZ, UPLO\n! INTEGER INFO, LDZ, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n!> real symmetric matrix A in packed storage.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] JOBZ\n!> \\verbatim\n!> JOBZ is CHARACTER*1\n!> = 'N': Compute eigenvalues only;\n!> = 'V': Compute eigenvalues and eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangle of A is stored;\n!> = 'L': Lower triangle of A is stored.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the upper or lower triangle of the symmetric matrix\n!> A, packed columnwise in a linear array. The j-th column of A\n!> is stored in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n!>\n!> On exit, AP is overwritten by values generated during the\n!> reduction to tridiagonal form. If UPLO = 'U', the diagonal\n!> and first superdiagonal of the tridiagonal matrix T overwrite\n!> the corresponding elements of A, and if UPLO = 'L', the\n!> diagonal and first subdiagonal of T overwrite the\n!> corresponding elements of A.\n!> \\endverbatim\n!>\n!> \\param[out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (N)\n!> If INFO = 0, the eigenvalues in ascending order.\n!> \\endverbatim\n!>\n!> \\param[out] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (LDZ, N)\n!> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n!> eigenvectors of the matrix A, with the i-th column of Z\n!> holding the eigenvector associated with W(i).\n!> If JOBZ = 'N', then Z is not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDZ\n!> \\verbatim\n!> LDZ is INTEGER\n!> The leading dimension of the array Z. LDZ >= 1, and if\n!> JOBZ = 'V', LDZ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (3*N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = i, the algorithm failed to converge; i\n!> off-diagonal elements of an intermediate tridiagonal\n!> form did not converge to zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHEReigen\n!\n! =====================================================================\n SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n!\n! -- LAPACK driver routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER JOBZ, UPLO\n INTEGER INFO, LDZ, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )\n! ..\n! .. Local Scalars ..\n LOGICAL WANTZ\n INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE\n DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,&\n SMLNUM\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DLAMCH, DLANSP\n! EXTERNAL LSAME, DLAMCH, DLANSP\n! ..\n! .. External Subroutines ..\n! EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA\n! EXTERNAL DOPGTR, DSTEQR\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n WANTZ = LSAME( JOBZ, 'V' )\n!\n INFO = 0\n IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN\n INFO = -1\n ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN\n INFO = -7\n END IF\n!\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSPEV ', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n IF( N.EQ.1 ) THEN\n W( 1 ) = AP( 1 )\n IF( WANTZ ) Z( 1, 1 ) = ONE\n RETURN\n END IF\n!\n! Get machine constants.\n!\n SAFMIN = DLAMCH( 'Safe minimum' )\n EPS = DLAMCH( 'Precision' )\n SMLNUM = SAFMIN / EPS\n BIGNUM = ONE / SMLNUM\n RMIN = SQRT( SMLNUM )\n RMAX = SQRT( BIGNUM )\n!\n! Scale matrix to allowable range, if necessary.\n!\n ANRM = DLANSP( 'M', UPLO, N, AP, WORK )\n ISCALE = 0\n IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN\n ISCALE = 1\n SIGMA = RMIN / ANRM\n ELSE IF( ANRM.GT.RMAX ) THEN\n ISCALE = 1\n SIGMA = RMAX / ANRM\n END IF\n IF( ISCALE.EQ.1 ) THEN\n CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )\n END IF\n!\n! Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.\n!\n INDE = 1\n INDTAU = INDE + N\n CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )\n!\n! For eigenvalues only, call DSTERF. For eigenvectors, first call\n! DOPGTR to generate the orthogonal matrix, then call DSTEQR.\n!\n IF( .NOT.WANTZ ) THEN\n CALL DSTERF( N, W, WORK( INDE ), INFO )\n ELSE\n INDWRK = INDTAU + N\n CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,&\n WORK( INDWRK ), IINFO )\n CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),&\n INFO )\n END IF\n!\n! If matrix was scaled, then rescale eigenvalues appropriately.\n!\n IF( ISCALE.EQ.1 ) THEN\n IF( INFO.EQ.0 ) THEN\n IMAX = N\n ELSE\n IMAX = INFO - 1\n END IF\n CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )\n END IF\n!\n RETURN\n!\n! End of DSPEV\n!\n END SUBROUTINE DSPEV\n!\n!=\n!\n!> \\brief \\b DSTEDC\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSTEDC + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,\n! LIWORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER COMPZ\n! INTEGER INFO, LDZ, LIWORK, LWORK, N\n! ..\n! .. Array Arguments ..\n! INTEGER IWORK( * )\n! DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n!> symmetric tridiagonal matrix using the divide and conquer method.\n!> The eigenvectors of a full or band real symmetric matrix can also be\n!> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this\n!> matrix to tridiagonal form.\n!>\n!> This code makes very mild assumptions about floating point\n!> arithmetic. It will work on machines with a guard digit in\n!> add/subtract, or on those binary machines without guard digits\n!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n!> It could conceivably fail on hexadecimal or decimal machines\n!> without guard digits, but we know of none. See DLAED3 for details.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] COMPZ\n!> \\verbatim\n!> COMPZ is CHARACTER*1\n!> = 'N': Compute eigenvalues only.\n!> = 'I': Compute eigenvectors of tridiagonal matrix also.\n!> = 'V': Compute eigenvectors of original dense symmetric\n!> matrix also. On entry, Z contains the orthogonal\n!> matrix used to reduce the original matrix to\n!> tridiagonal form.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the diagonal elements of the tridiagonal matrix.\n!> On exit, if INFO = 0, the eigenvalues in ascending order.\n!> \\endverbatim\n!>\n!> \\param[in,out] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> On entry, the subdiagonal elements of the tridiagonal matrix.\n!> On exit, E has been destroyed.\n!> \\endverbatim\n!>\n!> \\param[in,out] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (LDZ,N)\n!> On entry, if COMPZ = 'V', then Z contains the orthogonal\n!> matrix used in the reduction to tridiagonal form.\n!> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n!> orthonormal eigenvectors of the original symmetric matrix,\n!> and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n!> of the symmetric tridiagonal matrix.\n!> If COMPZ = 'N', then Z is not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDZ\n!> \\verbatim\n!> LDZ is INTEGER\n!> The leading dimension of the array Z. LDZ >= 1.\n!> If eigenvectors are desired, then LDZ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array,\n!> dimension (LWORK)\n!> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LWORK\n!> \\verbatim\n!> LWORK is INTEGER\n!> The dimension of the array WORK.\n!> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n!> If COMPZ = 'V' and N > 1 then LWORK must be at least\n!> ( 1 + 3*N + 2*N*lg N + 4*N**2 ),\n!> where lg( N ) = smallest integer k such\n!> that 2**k >= N.\n!> If COMPZ = 'I' and N > 1 then LWORK must be at least\n!> ( 1 + 4*N + N**2 ).\n!> Note that for COMPZ = 'I' or 'V', then if N is less than or\n!> equal to the minimum divide size, usually 25, then LWORK need\n!> only be max(1,2*(N-1)).\n!>\n!> If LWORK = -1, then a workspace query is assumed; the routine\n!> only calculates the optimal size of the WORK array, returns\n!> this value as the first entry of the WORK array, and no error\n!> message related to LWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] IWORK\n!> \\verbatim\n!> IWORK is INTEGER array, dimension (MAX(1,LIWORK))\n!> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n!> \\endverbatim\n!>\n!> \\param[in] LIWORK\n!> \\verbatim\n!> LIWORK is INTEGER\n!> The dimension of the array IWORK.\n!> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n!> If COMPZ = 'V' and N > 1 then LIWORK must be at least\n!> ( 6 + 6*N + 5*N*lg N ).\n!> If COMPZ = 'I' and N > 1 then LIWORK must be at least\n!> ( 3 + 5*N ).\n!> Note that for COMPZ = 'I' or 'V', then if N is less than or\n!> equal to the minimum divide size, usually 25, then LIWORK\n!> need only be 1.\n!>\n!> If LIWORK = -1, then a workspace query is assumed; the\n!> routine only calculates the optimal size of the IWORK array,\n!> returns this value as the first entry of the IWORK array, and\n!> no error message related to LIWORK is issued by XERBLA.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: The algorithm failed to compute an eigenvalue while\n!> working on the submatrix lying in rows and columns\n!> INFO/(N+1) through mod(INFO,N+1).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA \\n\n!> Modified by Francoise Tisseur, University of Tennessee\n!>\n! =====================================================================\n SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,&\n LIWORK, INFO )\n!\n! -- LAPACK computational routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n CHARACTER COMPZ\n INTEGER INFO, LDZ, LIWORK, LWORK, N\n! ..\n! .. Array Arguments ..\n INTEGER IWORK( * )\n DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )\n! ..\n! .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,&\n LWMIN, M, SMLSIZ, START, STOREZ, STRTRW\n DOUBLE PRECISION EPS, ORGNRM, P, TINY\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! INTEGER ILAENV\n! DOUBLE PRECISION DLANST\n! EXTERNAL LSAME, ILAENV, DLAMCH, DLANST\n! EXTERNAL DLANST\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,&\n! DSTEQR, DSTERF, DSWAP, XERBLA\n! EXTERNAL DSTEQR\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )\n!\n IF( LSAME( COMPZ, 'N' ) ) THEN\n ICOMPZ = 0\n ELSE IF( LSAME( COMPZ, 'V' ) ) THEN\n ICOMPZ = 1\n ELSE IF( LSAME( COMPZ, 'I' ) ) THEN\n ICOMPZ = 2\n ELSE\n ICOMPZ = -1\n END IF\n IF( ICOMPZ.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( ( LDZ.LT.1 ) .OR.&\n ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN\n INFO = -6\n END IF\n!\n IF( INFO.EQ.0 ) THEN\n!\n! Compute the workspace requirements\n!\n SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )\n IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN\n LIWMIN = 1\n LWMIN = 1\n ELSE IF( N.LE.SMLSIZ ) THEN\n LIWMIN = 1\n LWMIN = 2*( N - 1 )\n ELSE\n LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) )\n IF( 2**LGN.LT.N ) LGN = LGN + 1\n IF( 2**LGN.LT.N ) LGN = LGN + 1\n IF( ICOMPZ.EQ.1 ) THEN\n LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2\n LIWMIN = 6 + 6*N + 5*N*LGN\n ELSE IF( ICOMPZ.EQ.2 ) THEN\n LWMIN = 1 + 4*N + N**2\n LIWMIN = 3 + 5*N\n END IF\n END IF\n WORK( 1 ) = LWMIN\n IWORK( 1 ) = LIWMIN\n!\n IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN\n INFO = -8\n ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN\n INFO = -10\n END IF\n END IF\n!\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSTEDC', -INFO )\n RETURN\n ELSE IF (LQUERY) THEN\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n IF( N.EQ.1 ) THEN\n IF( ICOMPZ.NE.0 ) Z( 1, 1 ) = ONE\n RETURN\n END IF\n!\n! If the following conditional clause is removed, then the routine\n! will use the Divide and Conquer routine to compute only the\n! eigenvalues, which requires (3N + 3N**2) real workspace and\n! (2 + 5N + 2N lg(N)) integer workspace.\n! Since on many architectures DSTERF is much faster than any other\n! algorithm for finding eigenvalues only, it is used here\n! as the default. If the conditional clause is removed, then\n! information on the size of workspace needs to be changed.\n!\n! If COMPZ = 'N', use DSTERF to compute the eigenvalues.\n!\n IF( ICOMPZ.EQ.0 ) THEN\n CALL DSTERF( N, D, E, INFO )\n GO TO 50\n END IF\n!\n! If N is smaller than the minimum divide size (SMLSIZ+1), then\n! solve the problem with another solver.\n!\n IF( N.LE.SMLSIZ ) THEN\n!\n CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n!\n ELSE\n!\n! If COMPZ = 'V', the Z matrix must be stored elsewhere for later\n! use.\n!\n IF( ICOMPZ.EQ.1 ) THEN\n STOREZ = 1 + N*N\n ELSE\n STOREZ = 1\n END IF\n!\n IF( ICOMPZ.EQ.2 ) THEN\n CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )\n END IF\n!\n! Scale.\n!\n ORGNRM = DLANST( 'M', N, D, E )\n IF( ORGNRM.EQ.ZERO ) GO TO 50\n!\n EPS = DLAMCH( 'Epsilon' )\n!\n START = 1\n!\n! while ( START <= N )\n!\n10 CONTINUE\n IF( START.LE.N ) THEN\n!\n! Let FINISH be the position of the next subdiagonal entry\n! such that E( FINISH ) <= TINY or FINISH = N if no such\n! subdiagonal exists. The matrix identified by the elements\n! between START and FINISH constitutes an independent\n! sub-problem.\n!\n FINISH = START\n20 CONTINUE\n IF( FINISH.LT.N ) THEN\n TINY = EPS*SQRT( ABS( D( FINISH ) ) )*&\n SQRT( ABS( D( FINISH+1 ) ) )\n IF( ABS( E( FINISH ) ).GT.TINY ) THEN\n FINISH = FINISH + 1\n GO TO 20\n END IF\n END IF\n!\n! (Sub) Problem determined. Compute its size and solve it.\n!\n M = FINISH - START + 1\n IF( M.EQ.1 ) THEN\n START = FINISH + 1\n GO TO 10\n END IF\n IF( M.GT.SMLSIZ ) THEN\n!\n! Scale.\n!\n ORGNRM = DLANST( 'M', M, D( START ), E( START ) )\n CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,INFO)\n CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),M-1, INFO )\n!\n IF( ICOMPZ.EQ.1 ) THEN\n STRTRW = 1\n ELSE\n STRTRW = START\n END IF\n CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),&\n Z( STRTRW, START ), LDZ, WORK( 1 ), N,&\n WORK( STOREZ ), IWORK, INFO )\n IF( INFO.NE.0 ) THEN\n INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +&\n MOD( INFO, ( M+1 ) ) + START - 1\n GO TO 50\n END IF\n!\n! Scale back.\n!\n CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,INFO)\n!\n ELSE\n IF( ICOMPZ.EQ.1 ) THEN\n!\n! Since QR won't update a Z matrix which is larger than\n! the length of D, we must solve the sub-problem in a\n! workspace and then multiply back into Z.\n!\n CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,&\n WORK( M*M+1 ), INFO )\n CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,&\n WORK( STOREZ ), N )\n CALL DGEMM( 'N', 'N', N, M, M, ONE,&\n WORK( STOREZ ), N, WORK, M, ZERO,&\n Z( 1, START ), LDZ )\n ELSE IF( ICOMPZ.EQ.2 ) THEN\n CALL DSTEQR( 'I', M, D( START ), E( START ),&\n Z( START, START ), LDZ, WORK, INFO )\n ELSE\n CALL DSTERF( M, D( START ), E( START ), INFO )\n END IF\n IF( INFO.NE.0 ) THEN\n INFO = START*( N+1 ) + FINISH\n GO TO 50\n END IF\n END IF\n!\n START = FINISH + 1\n GO TO 10\n END IF\n!\n! endwhile\n!\n IF( ICOMPZ.EQ.0 ) THEN\n!\n! Use Quick Sort\n!\n CALL DLASRT( 'I', N, D, INFO )\n!\n ELSE\n!\n! Use Selection Sort to minimize swaps of eigenvectors\n!\n DO 40 II = 2, N\n I = II - 1\n K = I\n P = D( I )\n DO 30 J = II, N\n IF( D( J ).LT.P ) THEN\n K = J\n P = D( J )\n END IF\n30 CONTINUE\n IF( K.NE.I ) THEN\n D( K ) = D( I )\n D( I ) = P\n CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )\n END IF\n40 CONTINUE\n END IF\n END IF\n!\n50 CONTINUE\n WORK( 1 ) = LWMIN\n IWORK( 1 ) = LIWMIN\n!\n RETURN\n!\n! End of DSTEDC\n!\n END SUBROUTINE DSTEDC\n!\n!=\n!\n!> \\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.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLANST + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n! \n! .. Scalar Arguments ..\n! CHARACTER NORM\n! INTEGER N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * ), E( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLANST returns the value of the one norm, or the Frobenius norm, or\n!> the infinity norm, or the element of largest absolute value of a\n!> real symmetric tridiagonal matrix A.\n!> \\endverbatim\n!>\n!> \\return DLANST\n!> \\verbatim\n!>\n!> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n!> (\n!> ( norm1(A), NORM = '1', 'O' or 'o'\n!> (\n!> ( normI(A), NORM = 'I' or 'i'\n!> (\n!> ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n!>\n!> where norm1 denotes the one norm of a matrix (maximum column sum),\n!> normI denotes the infinity norm of a matrix (maximum row sum) and\n!> normF denotes the Frobenius norm of a matrix (square root of sum of\n!> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] NORM\n!> \\verbatim\n!> NORM is CHARACTER*1\n!> Specifies the value to be returned in DLANST as described\n!> above.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0. When N = 0, DLANST is\n!> set to zero.\n!> \\endverbatim\n!>\n!> \\param[in] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> The diagonal elements of A.\n!> \\endverbatim\n!>\n!> \\param[in] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> The (n-1) sub-diagonal or super-diagonal elements of A.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER NORM\n INTEGER N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * ), E( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I\n DOUBLE PRECISION ANORM, SCALE, SUM\n! ..\n! .. External Functions ..\n! LOGICAL LSAME, DISNAN\n! EXTERNAL LSAME, DISNAN\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLASSQ\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SQRT\n! ..\n! .. Executable Statements ..\n!\n IF( N.LE.0 ) THEN\n ANORM = ZERO\n ELSE IF( LSAME( NORM, 'M' ) ) THEN\n!\n! Find max(abs(A(i,j))).\n!\n ANORM = ABS( D( N ) )\n DO 10 I = 1, N - 1\n SUM = ABS( D( I ) )\n IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM\n SUM = ABS( E( I ) )\n IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM\n10 CONTINUE\n ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.&\n LSAME( NORM, 'I' ) ) THEN\n!\n! Find norm1(A).\n!\n IF( N.EQ.1 ) THEN\n ANORM = ABS( D( 1 ) )\n ELSE\n ANORM = ABS( D( 1 ) )+ABS( E( 1 ) )\n SUM = ABS( E( N-1 ) )+ABS( D( N ) )\n IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM\n DO 20 I = 2, N - 1\n SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) )\n IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM\n20 CONTINUE\n END IF\n ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN\n!\n! Find normF(A).\n!\n SCALE = ZERO\n SUM = ONE\n IF( N.GT.1 ) THEN\n CALL DLASSQ( N-1, E, 1, SCALE, SUM )\n SUM = 2*SUM\n END IF\n CALL DLASSQ( N, D, 1, SCALE, SUM )\n ANORM = SCALE*SQRT( SUM )\n END IF\n!\n DLANST = ANORM\n RETURN\n!\n! End of DLANST\n!\n END FUNCTION DLANST\n!\n!=\n!\n!> \\brief \\b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASCL + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER TYPE\n! INTEGER INFO, KL, KU, LDA, M, N\n! DOUBLE PRECISION CFROM, CTO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASCL multiplies the M by N real matrix A by the real scalar\n!> CTO/CFROM. This is done without over/underflow as long as the final\n!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n!> A may be full, upper triangular, lower triangular, upper Hessenberg,\n!> or banded.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] TYPE\n!> \\verbatim\n!> TYPE is CHARACTER*1\n!> TYPE indices the storage type of the input matrix.\n!> = 'G': A is a full matrix.\n!> = 'L': A is a lower triangular matrix.\n!> = 'U': A is an upper triangular matrix.\n!> = 'H': A is an upper Hessenberg matrix.\n!> = 'B': A is a symmetric band matrix with lower bandwidth KL\n!> and upper bandwidth KU and with the only the lower\n!> half stored.\n!> = 'Q': A is a symmetric band matrix with lower bandwidth KL\n!> and upper bandwidth KU and with the only the upper\n!> half stored.\n!> = 'Z': A is a band matrix with lower bandwidth KL and upper\n!> bandwidth KU. See DGBTRF for storage details.\n!> \\endverbatim\n!>\n!> \\param[in] KL\n!> \\verbatim\n!> KL is INTEGER\n!> The lower bandwidth of A. Referenced only if TYPE = 'B',\n!> 'Q' or 'Z'.\n!> \\endverbatim\n!>\n!> \\param[in] KU\n!> \\verbatim\n!> KU is INTEGER\n!> The upper bandwidth of A. Referenced only if TYPE = 'B',\n!> 'Q' or 'Z'.\n!> \\endverbatim\n!>\n!> \\param[in] CFROM\n!> \\verbatim\n!> CFROM is DOUBLE PRECISION\n!> \\endverbatim\n!>\n!> \\param[in] CTO\n!> \\verbatim\n!> CTO is DOUBLE PRECISION\n!>\n!> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n!> without over/underflow if the final result CTO*A(I,J)/CFROM\n!> can be represented without over/underflow. CFROM must be\n!> nonzero.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The matrix to be multiplied by CTO/CFROM. See TYPE for the\n!> storage type.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> 0 - successful exit\n!> <0 - if INFO = -i, the i-th argument had an illegal value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER TYPE\n INTEGER INFO, KL, KU, LDA, M, N\n DOUBLE PRECISION CFROM, CTO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )\n! ..\n! .. Local Scalars ..\n LOGICAL DONE\n INTEGER I, ITYPE, J, K1, K2, K3, K4\n DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM\n! ..\n! .. External Functions ..\n! LOGICAL LSAME, DISNAN\n! DOUBLE PRECISION DLAMCH\n! EXTERNAL LSAME, DLAMCH, DISNAN\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, MIN\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n!\n IF( LSAME( TYPE, 'G' ) ) THEN\n ITYPE = 0\n ELSE IF( LSAME( TYPE, 'L' ) ) THEN\n ITYPE = 1\n ELSE IF( LSAME( TYPE, 'U' ) ) THEN\n ITYPE = 2\n ELSE IF( LSAME( TYPE, 'H' ) ) THEN\n ITYPE = 3\n ELSE IF( LSAME( TYPE, 'B' ) ) THEN\n ITYPE = 4\n ELSE IF( LSAME( TYPE, 'Q' ) ) THEN\n ITYPE = 5\n ELSE IF( LSAME( TYPE, 'Z' ) ) THEN\n ITYPE = 6\n ELSE\n ITYPE = -1\n END IF\n!\n IF( ITYPE.EQ.-1 ) THEN\n INFO = -1\n ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN\n INFO = -4\n ELSE IF( DISNAN(CTO) ) THEN\n INFO = -5\n ELSE IF( M.LT.0 ) THEN\n INFO = -6\n ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.&\n ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN\n INFO = -7\n ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN\n INFO = -9\n ELSE IF( ITYPE.GE.4 ) THEN\n IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN\n INFO = -2\n ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.&\n ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )&\n THEN\n INFO = -3\n ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.&\n ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.&\n ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN\n INFO = -9\n END IF\n END IF\n!\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLASCL', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 .OR. M.EQ.0 ) RETURN\n!\n! Get machine parameters\n!\n SMLNUM = DLAMCH( 'S' )\n BIGNUM = ONE / SMLNUM\n!\n CFROMC = CFROM\n CTOC = CTO\n!\n10 CONTINUE\n CFROM1 = CFROMC*SMLNUM\n IF( CFROM1.EQ.CFROMC ) THEN\n! CFROMC is an inf. Multiply by a correctly signed zero for\n! finite CTOC, or a NaN if CTOC is infinite.\n MUL = CTOC / CFROMC\n DONE = .TRUE.\n CTO1 = CTOC\n ELSE\n CTO1 = CTOC / BIGNUM\n IF( CTO1.EQ.CTOC ) THEN\n! CTOC is either 0 or an inf. In both cases, CTOC itself\n! serves as the correct multiplication factor.\n MUL = CTOC\n DONE = .TRUE.\n CFROMC = ONE\n ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN\n MUL = SMLNUM\n DONE = .FALSE.\n CFROMC = CFROM1\n ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN\n MUL = BIGNUM\n DONE = .FALSE.\n CTOC = CTO1\n ELSE\n MUL = CTOC / CFROMC\n DONE = .TRUE.\n END IF\n END IF\n!\n IF( ITYPE.EQ.0 ) THEN\n!\n! Full matrix\n!\n DO 30 J = 1, N\n DO 20 I = 1, M\n A( I, J ) = A( I, J )*MUL\n 20 CONTINUE\n 30 CONTINUE\n!\n ELSE IF( ITYPE.EQ.1 ) THEN\n!\n! Lower triangular matrix\n!\n DO 50 J = 1, N\n DO 40 I = J, M\n A( I, J ) = A( I, J )*MUL\n 40 CONTINUE\n 50 CONTINUE\n!\n ELSE IF( ITYPE.EQ.2 ) THEN\n!\n! Upper triangular matrix\n!\n DO 70 J = 1, N\n DO 60 I = 1, MIN( J, M )\n A( I, J ) = A( I, J )*MUL\n 60 CONTINUE\n 70 CONTINUE\n!\n ELSE IF( ITYPE.EQ.3 ) THEN\n!\n! Upper Hessenberg matrix\n!\n DO 90 J = 1, N\n DO 80 I = 1, MIN( J+1, M )\n A( I, J ) = A( I, J )*MUL\n 80 CONTINUE\n 90 CONTINUE\n!\n ELSE IF( ITYPE.EQ.4 ) THEN\n!\n! Lower half of a symmetric band matrix\n!\n K3 = KL + 1\n K4 = N + 1\n DO 110 J = 1, N\n DO 100 I = 1, MIN( K3, K4-J )\n A( I, J ) = A( I, J )*MUL\n 100 CONTINUE\n 110 CONTINUE\n!\n ELSE IF( ITYPE.EQ.5 ) THEN\n!\n! Upper half of a symmetric band matrix\n!\n K1 = KU + 2\n K3 = KU + 1\n DO 130 J = 1, N\n DO 120 I = MAX( K1-J, 1 ), K3\n A( I, J ) = A( I, J )*MUL\n 120 CONTINUE\n 130 CONTINUE\n!\n ELSE IF( ITYPE.EQ.6 ) THEN\n!\n! Band matrix\n!\n K1 = KL + KU + 2\n K2 = KL + 1\n K3 = 2*KL + KU + 1\n K4 = KL + KU + 1 + M\n DO 150 J = 1, N\n DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )\n A( I, J ) = A( I, J )*MUL\n 140 CONTINUE\n 150 CONTINUE\n!\n END IF\n!\n IF( .NOT.DONE ) GO TO 10\n!\n RETURN\n!\n! End of DLASCL\n!\n END SUBROUTINE DLASCL\n!\n!=\n!\n!> \\brief \\b DSTEQR\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DSTEQR + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER COMPZ\n! INTEGER INFO, LDZ, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n!> symmetric tridiagonal matrix using the implicit QL or QR method.\n!> The eigenvectors of a full or band symmetric matrix can also be found\n!> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to\n!> tridiagonal form.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] COMPZ\n!> \\verbatim\n!> COMPZ is CHARACTER*1\n!> = 'N': Compute eigenvalues only.\n!> = 'V': Compute eigenvalues and eigenvectors of the original\n!> symmetric matrix. On entry, Z must contain the\n!> orthogonal matrix used to reduce the original matrix\n!> to tridiagonal form.\n!> = 'I': Compute eigenvalues and eigenvectors of the\n!> tridiagonal matrix. Z is initialized to the identity\n!> matrix.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the diagonal elements of the tridiagonal matrix.\n!> On exit, if INFO = 0, the eigenvalues in ascending order.\n!> \\endverbatim\n!>\n!> \\param[in,out] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> On entry, the (n-1) subdiagonal elements of the tridiagonal\n!> matrix.\n!> On exit, E has been destroyed.\n!> \\endverbatim\n!>\n!> \\param[in,out] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (LDZ, N)\n!> On entry, if COMPZ = 'V', then Z contains the orthogonal\n!> matrix used in the reduction to tridiagonal form.\n!> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n!> orthonormal eigenvectors of the original symmetric matrix,\n!> and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n!> of the symmetric tridiagonal matrix.\n!> If COMPZ = 'N', then Z is not referenced.\n!> \\endverbatim\n!>\n!> \\param[in] LDZ\n!> \\verbatim\n!> LDZ is INTEGER\n!> The leading dimension of the array Z. LDZ >= 1, and if\n!> eigenvectors are desired, then LDZ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))\n!> If COMPZ = 'N', then WORK is not referenced.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: the algorithm has failed to find all the eigenvalues in\n!> a total of 30*N iterations; if INFO = i, then i\n!> elements of E have not converged to zero; on exit, D\n!> and E contain the elements of a symmetric tridiagonal\n!> matrix which is orthogonally similar to the original\n!> matrix.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup auxOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER COMPZ\n INTEGER INFO, LDZ, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE, TWO, THREE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,&\n THREE = 3.0D0 )\n INTEGER MAXIT\n PARAMETER ( MAXIT = 30 )\n! ..\n! .. Local Scalars ..\n INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,&\n LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,&\n NM1, NMAXIT\n DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,&\n S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DLAPY2\n! EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,\n! $ DLASRT, DSWAP, XERBLA\n! EXTERNAL DLARTG\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, SIGN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( LSAME( COMPZ, 'N' ) ) THEN\n ICOMPZ = 0\n ELSE IF( LSAME( COMPZ, 'V' ) ) THEN\n ICOMPZ = 1\n ELSE IF( LSAME( COMPZ, 'I' ) ) THEN\n ICOMPZ = 2\n ELSE\n ICOMPZ = -1\n END IF\n IF( ICOMPZ.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,&\n N ) ) ) THEN\n INFO = -6\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DSTEQR', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n IF( N.EQ.1 ) THEN\n IF( ICOMPZ.EQ.2 ) Z( 1, 1 ) = ONE\n RETURN\n END IF\n!\n! Determine the unit roundoff and over/underflow thresholds.\n!\n EPS = DLAMCH( 'E' )\n EPS2 = EPS**2\n SAFMIN = DLAMCH( 'S' )\n SAFMAX = ONE / SAFMIN\n SSFMAX = SQRT( SAFMAX ) / THREE\n SSFMIN = SQRT( SAFMIN ) / EPS2\n!\n! Compute the eigenvalues and eigenvectors of the tridiagonal\n! matrix.\n!\n IF( ICOMPZ.EQ.2 )&\n CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )\n!\n NMAXIT = N*MAXIT\n JTOT = 0\n!\n! Determine where the matrix splits and choose QL or QR iteration\n! for each block, according to whether top or bottom diagonal\n! element is smaller.\n!\n L1 = 1\n NM1 = N - 1\n!\n10 CONTINUE\n IF( L1.GT.N ) GO TO 160\n IF( L1.GT.1 ) E( L1-1 ) = ZERO\n IF( L1.LE.NM1 ) THEN\n DO 20 M = L1, NM1\n TST = ABS( E( M ) )\n IF( TST.EQ.ZERO ) GO TO 30\n IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+&\n 1 ) ) ) )*EPS ) THEN\n E( M ) = ZERO\n GO TO 30\n END IF\n20 CONTINUE\n END IF\n M = N\n!\n30 CONTINUE\n L = L1\n LSV = L\n LEND = M\n LENDSV = LEND\n L1 = M + 1\n IF( LEND.EQ.L ) GO TO 10\n!\n! Scale submatrix in rows and columns L to LEND\n!\n ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) )\n ISCALE = 0\n IF( ANORM.EQ.ZERO ) GO TO 10\n IF( ANORM.GT.SSFMAX ) THEN\n ISCALE = 1\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO )\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO )\n ELSE IF( ANORM.LT.SSFMIN ) THEN\n ISCALE = 2\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO )\n CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO )\n END IF\n!\n! Choose between QL and QR iteration\n!\n IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN\n LEND = LSV\n L = LENDSV\n END IF\n!\n IF( LEND.GT.L ) THEN\n!\n! QL Iteration\n!\n! Look for small subdiagonal element.\n!\n40 CONTINUE\n IF( L.NE.LEND ) THEN\n LENDM1 = LEND - 1\n DO 50 M = L, LENDM1\n TST = ABS( E( M ) )**2\n IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+SAFMIN )GO TO 60\n50 CONTINUE\n END IF\n!\n M = LEND\n!\n60 CONTINUE\n IF( M.LT.LEND ) E( M ) = ZERO\n P = D( L )\n IF( M.EQ.L ) GO TO 80\n!\n! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2\n! to compute its eigensystem.\n!\n IF( M.EQ.L+1 ) THEN\n IF( ICOMPZ.GT.0 ) THEN\n CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )\n WORK( L ) = C\n WORK( N-1+L ) = S\n CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),&\n WORK( N-1+L ), Z( 1, L ), LDZ )\n ELSE\n CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )\n END IF\n D( L ) = RT1\n D( L+1 ) = RT2\n E( L ) = ZERO\n L = L + 2\n IF( L.LE.LEND ) GO TO 40\n GO TO 140\n END IF\n!\n IF( JTOT.EQ.NMAXIT ) GO TO 140\n JTOT = JTOT + 1\n!\n! Form shift.\n!\n G = ( D( L+1 )-P ) / ( TWO*E( L ) )\n R = DLAPY2( G, ONE )\n G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )\n!\n S = ONE\n C = ONE\n P = ZERO\n!\n! Inner loop\n!\n MM1 = M - 1\n DO 70 I = MM1, L, -1\n F = S*E( I )\n B = C*E( I )\n CALL DLARTG( G, F, C, S, R )\n IF( I.NE.M-1 ) E( I+1 ) = R\n G = D( I+1 ) - P\n R = ( D( I )-G )*S + TWO*C*B\n P = S*R\n D( I+1 ) = G + P\n G = C*R - B\n!\n! If eigenvectors are desired, then save rotations.\n!\n IF( ICOMPZ.GT.0 ) THEN\n WORK( I ) = C\n WORK( N-1+I ) = -S\n END IF\n!\n70 CONTINUE\n!\n! If eigenvectors are desired, then apply saved rotations.\n!\n IF( ICOMPZ.GT.0 ) THEN\n MM = M - L + 1\n CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),&\n Z( 1, L ), LDZ )\n END IF\n!\n D( L ) = D( L ) - P\n E( L ) = G\n GO TO 40\n!\n! Eigenvalue found.\n!\n80 CONTINUE\n D( L ) = P\n!\n L = L + 1\n IF( L.LE.LEND ) GO TO 40\n GO TO 140\n!\n ELSE\n!\n! QR Iteration\n!\n! Look for small superdiagonal element.\n!\n90 CONTINUE\n IF( L.NE.LEND ) THEN\n LENDP1 = LEND + 1\n DO 100 M = L, LENDP1, -1\n TST = ABS( E( M-1 ) )**2\n IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+&\n SAFMIN )GO TO 110\n100 CONTINUE\n END IF\n!\n M = LEND\n!\n110 CONTINUE\n IF( M.GT.LEND ) E( M-1 ) = ZERO\n P = D( L )\n IF( M.EQ.L ) GO TO 130\n!\n! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2\n! to compute its eigensystem.\n!\n IF( M.EQ.L-1 ) THEN\n IF( ICOMPZ.GT.0 ) THEN\n CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )\n WORK( M ) = C\n WORK( N-1+M ) = S\n CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), &\n WORK( N-1+M ), Z( 1, L-1 ), LDZ )\n ELSE\n CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )\n END IF\n D( L-1 ) = RT1\n D( L ) = RT2\n E( L-1 ) = ZERO\n L = L - 2\n IF( L.GE.LEND ) GO TO 90\n GO TO 140\n END IF\n!\n IF( JTOT.EQ.NMAXIT ) GO TO 140\n JTOT = JTOT + 1\n!\n! Form shift.\n!\n G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )\n R = DLAPY2( G, ONE )\n G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )\n!\n S = ONE\n C = ONE\n P = ZERO\n!\n! Inner loop\n!\n LM1 = L - 1\n DO 120 I = M, LM1\n F = S*E( I )\n B = C*E( I )\n CALL DLARTG( G, F, C, S, R )\n IF( I.NE.M ) E( I-1 ) = R\n G = D( I ) - P\n R = ( D( I+1 )-G )*S + TWO*C*B\n P = S*R\n D( I ) = G + P\n G = C*R - B\n!\n! If eigenvectors are desired, then save rotations.\n!\n IF( ICOMPZ.GT.0 ) THEN\n WORK( I ) = C\n WORK( N-1+I ) = S\n END IF\n!\n120 CONTINUE\n!\n! If eigenvectors are desired, then apply saved rotations.\n!\n IF( ICOMPZ.GT.0 ) THEN\n MM = L - M + 1\n CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),&\n Z( 1, M ), LDZ )\n END IF\n!\n D( L ) = D( L ) - P\n E( LM1 ) = G\n GO TO 90\n!\n! Eigenvalue found.\n!\n130 CONTINUE\n D( L ) = P\n!\n L = L - 1\n IF( L.GE.LEND ) GO TO 90\n GO TO 140\n!\n END IF\n!\n! Undo scaling if necessary\n!\n140 CONTINUE\n IF( ISCALE.EQ.1 ) THEN\n CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,&\n D( LSV ), N, INFO )\n CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),&\n N, INFO )\n ELSE IF( ISCALE.EQ.2 ) THEN\n CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,&\n D( LSV ), N, INFO )\n CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),&\n N, INFO )\n END IF\n!\n! Check for no convergence to an eigenvalue after a total\n! of N*MAXIT iterations.\n!\n IF( JTOT.LT.NMAXIT ) GO TO 10\n DO 150 I = 1, N - 1\n IF( E( I ).NE.ZERO ) INFO = INFO + 1\n150 CONTINUE\n GO TO 190\n!\n! Order eigenvalues and eigenvectors.\n!\n160 CONTINUE\n IF( ICOMPZ.EQ.0 ) THEN\n!\n! Use Quick Sort\n!\n CALL DLASRT( 'I', N, D, INFO )\n!\n ELSE\n!\n! Use Selection Sort to minimize swaps of eigenvectors\n!\n DO 180 II = 2, N\n I = II - 1\n K = I\n P = D( I )\n DO 170 J = II, N\n IF( D( J ).LT.P ) THEN\n K = J\n P = D( J )\n END IF\n170 CONTINUE\n IF( K.NE.I ) THEN\n D( K ) = D( I )\n D( I ) = P\n CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )\n END IF\n180 CONTINUE\n END IF\n!\n190 CONTINUE\n RETURN\n!\n! End of DSTEQR\n!\n END SUBROUTINE DSTEQR\n!\n!=\n!\n!> \\brief \\b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASET + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER LDA, M, N\n! DOUBLE PRECISION ALPHA, BETA\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASET initializes an m-by-n matrix A to BETA on the diagonal and\n!> ALPHA on the offdiagonals.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies the part of the matrix A to be set.\n!> = 'U': Upper triangular part is set; the strictly lower\n!> triangular part of A is not changed.\n!> = 'L': Lower triangular part is set; the strictly upper\n!> triangular part of A is not changed.\n!> Otherwise: All of the matrix A is set.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION\n!> The constant to which the offdiagonal elements are to be set.\n!> \\endverbatim\n!>\n!> \\param[in] BETA\n!> \\verbatim\n!> BETA is DOUBLE PRECISION\n!> The constant to which the diagonal elements are to be set.\n!> \\endverbatim\n!>\n!> \\param[out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On exit, the leading m-by-n submatrix of A is set as follows:\n!>\n!> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n!> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n!> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n!>\n!> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n!\n! -- LAPACK auxiliary routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER LDA, M, N\n DOUBLE PRECISION ALPHA, BETA\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, J\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MIN\n! ..\n! .. Executable Statements ..\n!\n IF( LSAME( UPLO, 'U' ) ) THEN\n!\n! Set the strictly upper triangular or trapezoidal part of the\n! array to ALPHA.\n!\n DO 20 J = 2, N\n DO 10 I = 1, MIN( J-1, M )\n A( I, J ) = ALPHA\n10 CONTINUE\n20 CONTINUE\n!\n ELSE IF( LSAME( UPLO, 'L' ) ) THEN\n!\n! Set the strictly lower triangular or trapezoidal part of the\n! array to ALPHA.\n!\n DO 40 J = 1, MIN( M, N )\n DO 30 I = J + 1, M\n A( I, J ) = ALPHA\n 30 CONTINUE\n 40 CONTINUE\n!\n ELSE\n!\n! Set the leading m-by-n submatrix to ALPHA.\n!\n DO 60 J = 1, N\n DO 50 I = 1, M\n A( I, J ) = ALPHA\n 50 CONTINUE\n 60 CONTINUE\n END IF\n!\n! Set the first min(M,N) diagonal elements to BETA.\n!\n DO 70 I = 1, MIN( M, N )\n A( I, I ) = BETA\n 70 CONTINUE\n!\n RETURN\n!\n! End of DLASET\n!\n END SUBROUTINE DLASET\n!\n!=\n!\n!> \\brief \\b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAEV2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n!> [ A B ]\n!> [ B C ].\n!> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n!> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n!> eigenvector for RT1, giving the decomposition\n!>\n!> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n!> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION\n!> The (1,1) element of the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[in] B\n!> \\verbatim\n!> B is DOUBLE PRECISION\n!> The (1,2) element and the conjugate of the (2,1) element of\n!> the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[in] C\n!> \\verbatim\n!> C is DOUBLE PRECISION\n!> The (2,2) element of the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[out] RT1\n!> \\verbatim\n!> RT1 is DOUBLE PRECISION\n!> The eigenvalue of larger absolute value.\n!> \\endverbatim\n!>\n!> \\param[out] RT2\n!> \\verbatim\n!> RT2 is DOUBLE PRECISION\n!> The eigenvalue of smaller absolute value.\n!> \\endverbatim\n!>\n!> \\param[out] CS1\n!> \\verbatim\n!> CS1 is DOUBLE PRECISION\n!> \\endverbatim\n!>\n!> \\param[out] SN1\n!> \\verbatim\n!> SN1 is DOUBLE PRECISION\n!> The vector (CS1, SN1) is a unit right eigenvector for RT1.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> RT1 is accurate to a few ulps barring over/underflow.\n!>\n!> RT2 may be inaccurate if there is massive cancellation in the\n!> determinant A*C-B*B; higher precision or correctly rounded or\n!> correctly truncated arithmetic would be needed to compute RT2\n!> accurately in all cases.\n!>\n!> CS1 and SN1 are accurate to a few ulps barring over/underflow.\n!>\n!> Overflow is possible only if RT1 is within a factor of 5 of overflow.\n!> Underflow is harmless if the input data is 0 or exceeds\n!> underflow_threshold / macheps.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D0 )\n DOUBLE PRECISION TWO\n PARAMETER ( TWO = 2.0D0 )\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n DOUBLE PRECISION HALF\n PARAMETER ( HALF = 0.5D0 )\n! ..\n! .. Local Scalars ..\n INTEGER SGN1, SGN2\n DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,&\n TB, TN\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Compute the eigenvalues\n!\n SM = A + C\n DF = A - C\n ADF = ABS( DF )\n TB = B + B\n AB = ABS( TB )\n IF( ABS( A ).GT.ABS( C ) ) THEN\n ACMX = A\n ACMN = C\n ELSE\n ACMX = C\n ACMN = A\n END IF\n IF( ADF.GT.AB ) THEN\n RT = ADF*SQRT( ONE+( AB / ADF )**2 )\n ELSE IF( ADF.LT.AB ) THEN\n RT = AB*SQRT( ONE+( ADF / AB )**2 )\n ELSE\n!\n! Includes case AB=ADF=0\n!\n RT = AB*SQRT( TWO )\n END IF\n IF( SM.LT.ZERO ) THEN\n RT1 = HALF*( SM-RT )\n SGN1 = -1\n!\n! Order of execution important.\n! To get fully accurate smaller eigenvalue,\n! next line needs to be executed in higher precision.\n!\n RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B\n ELSE IF( SM.GT.ZERO ) THEN\n RT1 = HALF*( SM+RT )\n SGN1 = 1\n!\n! Order of execution important.\n! To get fully accurate smaller eigenvalue,\n! next line needs to be executed in higher precision.\n!\n RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B\n ELSE\n!\n! Includes case RT1 = RT2 = 0\n!\n RT1 = HALF*RT\n RT2 = -HALF*RT\n SGN1 = 1\n END IF\n!\n! Compute the eigenvector\n!\n IF( DF.GE.ZERO ) THEN\n CS = DF + RT\n SGN2 = 1\n ELSE\n CS = DF - RT\n SGN2 = -1\n END IF\n ACS = ABS( CS )\n IF( ACS.GT.AB ) THEN\n CT = -TB / CS\n SN1 = ONE / SQRT( ONE+CT*CT )\n CS1 = CT*SN1\n ELSE\n IF( AB.EQ.ZERO ) THEN\n CS1 = ONE\n SN1 = ZERO\n ELSE\n TN = -CS / TB\n CS1 = ONE / SQRT( ONE+TN*TN )\n SN1 = TN*CS1\n END IF\n END IF\n IF( SGN1.EQ.SGN2 ) THEN\n TN = CS1\n CS1 = -SN1\n SN1 = TN\n END IF\n RETURN\n!\n! End of DLAEV2\n!\n END SUBROUTINE DLAEV2\n!\n!> \\brief \\b DLASR applies a sequence of plane rotations to a general rectangular matrix.\n!\n!=\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASR + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n! \n! .. Scalar Arguments ..\n! CHARACTER DIRECT, PIVOT, SIDE\n! INTEGER LDA, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * ), C( * ), S( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLASR applies a sequence of plane rotations to a real matrix A,\n!> from either the left or the right.\n!> \n!> When SIDE = 'L', the transformation takes the form\n!> \n!> A := P*A\n!> \n!> and when SIDE = 'R', the transformation takes the form\n!> \n!> A := A*P**T\n!> \n!> where P is an orthogonal matrix consisting of a sequence of z plane\n!> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n!> and P**T is the transpose of P.\n!> \n!> When DIRECT = 'F' (Forward sequence), then\n!> \n!> P = P(z-1) * ... * P(2) * P(1)\n!> \n!> and when DIRECT = 'B' (Backward sequence), then\n!> \n!> P = P(1) * P(2) * ... * P(z-1)\n!> \n!> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n!> \n!> R(k) = ( c(k) s(k) )\n!> = ( -s(k) c(k) ).\n!> \n!> When PIVOT = 'V' (Variable pivot), the rotation is performed\n!> for the plane (k,k+1), i.e., P(k) has the form\n!> \n!> P(k) = ( 1 )\n!> ( ... )\n!> ( 1 )\n!> ( c(k) s(k) )\n!> ( -s(k) c(k) )\n!> ( 1 )\n!> ( ... )\n!> ( 1 )\n!> \n!> where R(k) appears as a rank-2 modification to the identity matrix in\n!> rows and columns k and k+1.\n!> \n!> When PIVOT = 'T' (Top pivot), the rotation is performed for the\n!> plane (1,k+1), so P(k) has the form\n!> \n!> P(k) = ( c(k) s(k) )\n!> ( 1 )\n!> ( ... )\n!> ( 1 )\n!> ( -s(k) c(k) )\n!> ( 1 )\n!> ( ... )\n!> ( 1 )\n!> \n!> where R(k) appears in rows and columns 1 and k+1.\n!> \n!> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n!> performed for the plane (k,z), giving P(k) the form\n!> \n!> P(k) = ( 1 )\n!> ( ... )\n!> ( 1 )\n!> ( c(k) s(k) )\n!> ( 1 )\n!> ( ... )\n!> ( 1 )\n!> ( -s(k) c(k) )\n!> \n!> where R(k) appears in rows and columns k and z. The rotations are\n!> performed without ever forming P(k) explicitly.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SIDE\n!> \\verbatim\n!> SIDE is CHARACTER*1\n!> Specifies whether the plane rotation matrix P is applied to\n!> A on the left or the right.\n!> = 'L': Left, compute A := P*A\n!> = 'R': Right, compute A:= A*P**T\n!> \\endverbatim\n!>\n!> \\param[in] PIVOT\n!> \\verbatim\n!> PIVOT is CHARACTER*1\n!> Specifies the plane for which P(k) is a plane rotation\n!> matrix.\n!> = 'V': Variable pivot, the plane (k,k+1)\n!> = 'T': Top pivot, the plane (1,k+1)\n!> = 'B': Bottom pivot, the plane (k,z)\n!> \\endverbatim\n!>\n!> \\param[in] DIRECT\n!> \\verbatim\n!> DIRECT is CHARACTER*1\n!> Specifies whether P is a forward or backward sequence of\n!> plane rotations.\n!> = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n!> = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. If m <= 1, an immediate\n!> return is effected.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. If n <= 1, an\n!> immediate return is effected.\n!> \\endverbatim\n!>\n!> \\param[in] C\n!> \\verbatim\n!> C is DOUBLE PRECISION array, dimension\n!> (M-1) if SIDE = 'L'\n!> (N-1) if SIDE = 'R'\n!> The cosines c(k) of the plane rotations.\n!> \\endverbatim\n!>\n!> \\param[in] S\n!> \\verbatim\n!> S is DOUBLE PRECISION array, dimension\n!> (M-1) if SIDE = 'L'\n!> (N-1) if SIDE = 'R'\n!> The sines s(k) of the plane rotations. The 2-by-2 plane\n!> rotation part of the matrix P(k), R(k), has the form\n!> R(k) = ( c(k) s(k) )\n!> ( -s(k) c(k) ).\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The M-by-N matrix A. On exit, A is overwritten by P*A if\n!> SIDE = 'R' or by A*P**T if SIDE = 'L'.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER DIRECT, PIVOT, SIDE\n INTEGER LDA, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * ), C( * ), S( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, INFO, J\n DOUBLE PRECISION CTEMP, STEMP, TEMP\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters\n!\n INFO = 0\n IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN\n INFO = 1\n ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,&\n 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN\n INFO = 2\n ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )&\n THEN\n INFO = 3\n ELSE IF( M.LT.0 ) THEN\n INFO = 4\n ELSE IF( N.LT.0 ) THEN\n INFO = 5\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = 9\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLASR ', INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) RETURN\n IF( LSAME( SIDE, 'L' ) ) THEN\n!\n! Form P * A\n!\n IF( LSAME( PIVOT, 'V' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 20 J = 1, M - 1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 10 I = 1, N\n TEMP = A( J+1, I )\n A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )\n A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )\n10 CONTINUE\n END IF\n20 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 40 J = M - 1, 1, -1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 30 I = 1, N\n TEMP = A( J+1, I )\n A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )\n A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )\n 30 CONTINUE\n END IF\n 40 CONTINUE\n END IF\n ELSE IF( LSAME( PIVOT, 'T' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 60 J = 2, M\n CTEMP = C( J-1 )\n STEMP = S( J-1 )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 50 I = 1, N\n TEMP = A( J, I )\n A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )\n A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )\n 50 CONTINUE\n END IF\n 60 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 80 J = M, 2, -1\n CTEMP = C( J-1 )\n STEMP = S( J-1 )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 70 I = 1, N\n TEMP = A( J, I )\n A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )\n A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )\n 70 CONTINUE\n END IF\n 80 CONTINUE\n END IF\n ELSE IF( LSAME( PIVOT, 'B' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 100 J = 1, M - 1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 90 I = 1, N\n TEMP = A( J, I )\n A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP\n A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP\n 90 CONTINUE\n END IF\n 100 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 120 J = M - 1, 1, -1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 110 I = 1, N\n TEMP = A( J, I )\n A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP\n A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP\n 110 CONTINUE\n END IF\n 120 CONTINUE\n END IF\n END IF\n ELSE IF( LSAME( SIDE, 'R' ) ) THEN\n!\n! Form A * P**T\n!\n IF( LSAME( PIVOT, 'V' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 140 J = 1, N - 1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 130 I = 1, M\n TEMP = A( I, J+1 )\n A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )\n A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )\n 130 CONTINUE\n END IF\n 140 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 160 J = N - 1, 1, -1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 150 I = 1, M\n TEMP = A( I, J+1 )\n A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )\n A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )\n 150 CONTINUE\n END IF\n 160 CONTINUE\n END IF\n ELSE IF( LSAME( PIVOT, 'T' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 180 J = 2, N\n CTEMP = C( J-1 )\n STEMP = S( J-1 )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 170 I = 1, M\n TEMP = A( I, J )\n A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )\n A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )\n 170 CONTINUE\n END IF\n 180 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 200 J = N, 2, -1\n CTEMP = C( J-1 )\n STEMP = S( J-1 )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 190 I = 1, M\n TEMP = A( I, J )\n A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )\n A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )\n 190 CONTINUE\n END IF\n 200 CONTINUE\n END IF\n ELSE IF( LSAME( PIVOT, 'B' ) ) THEN\n IF( LSAME( DIRECT, 'F' ) ) THEN\n DO 220 J = 1, N - 1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 210 I = 1, M\n TEMP = A( I, J )\n A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP\n A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP\n 210 CONTINUE\n END IF\n 220 CONTINUE\n ELSE IF( LSAME( DIRECT, 'B' ) ) THEN\n DO 240 J = N - 1, 1, -1\n CTEMP = C( J )\n STEMP = S( J )\n IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN\n DO 230 I = 1, M\n TEMP = A( I, J )\n A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP\n A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP\n 230 CONTINUE\n END IF\n 240 CONTINUE\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DLASR\n!\n END SUBROUTINE DLASR\n!\n!=\n!\n!> \\brief \\b DLASRT sorts numbers in increasing or decreasing order.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLASRT + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLASRT( ID, N, D, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER ID\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> Sort the numbers in D in increasing order (if ID = 'I') or\n!> in decreasing order (if ID = 'D' ).\n!>\n!> Use Quick Sort, reverting to Insertion sort on arrays of\n!> size <= 20. Dimension of STACK limits N to about 2**32.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ID\n!> \\verbatim\n!> ID is CHARACTER*1\n!> = 'I': sort D in increasing order;\n!> = 'D': sort D in decreasing order.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The length of the array D.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the array to be sorted.\n!> On exit, D has been sorted into increasing order\n!> (D(1) <= ... <= D(N) ) or into decreasing order\n!> (D(1) >= ... >= D(N) ), depending on ID.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DLASRT( ID, N, D, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER ID\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n INTEGER SELECT\n PARAMETER ( SELECT = 20 )\n! ..\n! .. Local Scalars ..\n INTEGER DIR, ENDD, I, J, START, STKPNT\n DOUBLE PRECISION D1, D2, D3, DMNMX, TMP\n! ..\n! .. Local Arrays ..\n INTEGER STACK( 2, 32 )\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Executable Statements ..\n!\n! Test the input paramters.\n!\n INFO = 0\n DIR = -1\n IF( LSAME( ID, 'D' ) ) THEN\n DIR = 0\n ELSE IF( LSAME( ID, 'I' ) ) THEN\n DIR = 1\n END IF\n IF( DIR.EQ.-1 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLASRT', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.LE.1 ) RETURN\n!\n STKPNT = 1\n STACK( 1, 1 ) = 1\n STACK( 2, 1 ) = N\n10 CONTINUE\n START = STACK( 1, STKPNT )\n ENDD = STACK( 2, STKPNT )\n STKPNT = STKPNT - 1\n IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN\n!\n! Do Insertion sort on D( START:ENDD )\n!\n IF( DIR.EQ.0 ) THEN\n!\n! Sort into decreasing order\n!\n DO 30 I = START + 1, ENDD\n DO 20 J = I, START + 1, -1\n IF( D( J ).GT.D( J-1 ) ) THEN\n DMNMX = D( J )\n D( J ) = D( J-1 )\n D( J-1 ) = DMNMX\n ELSE\n GO TO 30\n END IF\n20 CONTINUE\n30 CONTINUE\n!\n ELSE\n!\n! Sort into increasing order\n!\n DO 50 I = START + 1, ENDD\n DO 40 J = I, START + 1, -1\n IF( D( J ).LT.D( J-1 ) ) THEN\n DMNMX = D( J )\n D( J ) = D( J-1 )\n D( J-1 ) = DMNMX\n ELSE\n GO TO 50\n END IF\n40 CONTINUE\n50 CONTINUE\n!\n END IF\n!\n ELSE IF( ENDD-START.GT.SELECT ) THEN\n!\n! Partition D( START:ENDD ) and stack parts, largest one first\n!\n! Choose partition entry as median of 3\n!\n D1 = D( START )\n D2 = D( ENDD )\n I = ( START+ENDD ) / 2\n D3 = D( I )\n IF( D1.LT.D2 ) THEN\n IF( D3.LT.D1 ) THEN\n DMNMX = D1\n ELSE IF( D3.LT.D2 ) THEN\n DMNMX = D3\n ELSE\n DMNMX = D2\n END IF\n ELSE\n IF( D3.LT.D2 ) THEN\n DMNMX = D2\n ELSE IF( D3.LT.D1 ) THEN\n DMNMX = D3\n ELSE\n DMNMX = D1\n END IF\n END IF\n!\n IF( DIR.EQ.0 ) THEN\n!\n! Sort into decreasing order\n!\n I = START - 1\n J = ENDD + 1\n60 CONTINUE\n70 CONTINUE\n J = J - 1\n IF( D( J ).LT.DMNMX ) GO TO 70\n80 CONTINUE\n I = I + 1\n IF( D( I ).GT.DMNMX ) GO TO 80\n IF( I.LT.J ) THEN\n TMP = D( I )\n D( I ) = D( J )\n D( J ) = TMP\n GO TO 60\n END IF\n IF( J-START.GT.ENDD-J-1 ) THEN\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = START\n STACK( 2, STKPNT ) = J\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = J + 1\n STACK( 2, STKPNT ) = ENDD\n ELSE\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = J + 1\n STACK( 2, STKPNT ) = ENDD\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = START\n STACK( 2, STKPNT ) = J\n END IF\n ELSE\n!\n! Sort into increasing order\n!\n I = START - 1\n J = ENDD + 1\n90 CONTINUE\n100 CONTINUE\n J = J - 1\n IF( D( J ).GT.DMNMX ) GO TO 100\n110 CONTINUE\n I = I + 1\n IF( D( I ).LT.DMNMX ) GO TO 110\n IF( I.LT.J ) THEN\n TMP = D( I )\n D( I ) = D( J )\n D( J ) = TMP\n GO TO 90\n END IF\n IF( J-START.GT.ENDD-J-1 ) THEN\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = START\n STACK( 2, STKPNT ) = J\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = J + 1\n STACK( 2, STKPNT ) = ENDD\n ELSE\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = J + 1\n STACK( 2, STKPNT ) = ENDD\n STKPNT = STKPNT + 1\n STACK( 1, STKPNT ) = START\n STACK( 2, STKPNT ) = J\n END IF\n END IF\n END IF\n IF( STKPNT.GT.0 ) GO TO 10\n RETURN\n!\n! End of DLASRT\n!\n END SUBROUTINE DLASRT\n!\n!=\n!\n!> \\brief \\b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAE2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION A, B, C, RT1, RT2\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n!> [ A B ]\n!> [ B C ].\n!> On return, RT1 is the eigenvalue of larger absolute value, and RT2\n!> is the eigenvalue of smaller absolute value.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION\n!> The (1,1) element of the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[in] B\n!> \\verbatim\n!> B is DOUBLE PRECISION\n!> The (1,2) and (2,1) elements of the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[in] C\n!> \\verbatim\n!> C is DOUBLE PRECISION\n!> The (2,2) element of the 2-by-2 matrix.\n!> \\endverbatim\n!>\n!> \\param[out] RT1\n!> \\verbatim\n!> RT1 is DOUBLE PRECISION\n!> The eigenvalue of larger absolute value.\n!> \\endverbatim\n!>\n!> \\param[out] RT2\n!> \\verbatim\n!> RT2 is DOUBLE PRECISION\n!> The eigenvalue of smaller absolute value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> RT1 is accurate to a few ulps barring over/underflow.\n!>\n!> RT2 may be inaccurate if there is massive cancellation in the\n!> determinant A*C-B*B; higher precision or correctly rounded or\n!> correctly truncated arithmetic would be needed to compute RT2\n!> accurately in all cases.\n!>\n!> Overflow is possible only if RT1 is within a factor of 5 of overflow.\n!> Underflow is harmless if the input data is 0 or exceeds\n!> underflow_threshold / macheps.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION A, B, C, RT1, RT2\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D0 )\n DOUBLE PRECISION TWO\n PARAMETER ( TWO = 2.0D0 )\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n DOUBLE PRECISION HALF\n PARAMETER ( HALF = 0.5D0 )\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Compute the eigenvalues\n!\n SM = A + C\n DF = A - C\n ADF = ABS( DF )\n TB = B + B\n AB = ABS( TB )\n IF( ABS( A ).GT.ABS( C ) ) THEN\n ACMX = A\n ACMN = C\n ELSE\n ACMX = C\n ACMN = A\n END IF\n IF( ADF.GT.AB ) THEN\n RT = ADF*SQRT( ONE+( AB / ADF )**2 )\n ELSE IF( ADF.LT.AB ) THEN\n RT = AB*SQRT( ONE+( ADF / AB )**2 )\n ELSE\n!\n! Includes case AB=ADF=0\n!\n RT = AB*SQRT( TWO )\n END IF\n IF( SM.LT.ZERO ) THEN\n RT1 = HALF*( SM-RT )\n!\n! Order of execution important.\n! To get fully accurate smaller eigenvalue,\n! next line needs to be executed in higher precision.\n!\n RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B\n ELSE IF( SM.GT.ZERO ) THEN\n RT1 = HALF*( SM+RT )\n!\n! Order of execution important.\n! To get fully accurate smaller eigenvalue,\n! next line needs to be executed in higher precision.\n!\n RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B\n ELSE\n!\n! Includes case RT1 = RT2 = 0\n!\n RT1 = HALF*RT\n RT2 = -HALF*RT\n END IF\n RETURN\n!\n! End of DLAE2\n!\n END SUBROUTINE DLAE2\n!\n!=\n!\n!> \\brief \\b DLARTG generates a plane rotation with real cosine and real sine.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLARTG + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLARTG( F, G, CS, SN, R )\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION CS, F, G, R, SN\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLARTG generate a plane rotation so that\n!>\n!> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n!> [ -SN CS ] [ G ] [ 0 ]\n!>\n!> This is a slower, more accurate version of the BLAS1 routine DROTG,\n!> with the following other differences:\n!> F and G are unchanged on return.\n!> If G=0, then CS=1 and SN=0.\n!> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n!> floating point operations (saves work in DBDSQR when\n!> there are zeros on the diagonal).\n!>\n!> If F exceeds G in magnitude, CS will be positive.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] F\n!> \\verbatim\n!> F is DOUBLE PRECISION\n!> The first component of vector to be rotated.\n!> \\endverbatim\n!>\n!> \\param[in] G\n!> \\verbatim\n!> G is DOUBLE PRECISION\n!> The second component of vector to be rotated.\n!> \\endverbatim\n!>\n!> \\param[out] CS\n!> \\verbatim\n!> CS is DOUBLE PRECISION\n!> The cosine of the rotation.\n!> \\endverbatim\n!>\n!> \\param[out] SN\n!> \\verbatim\n!> SN is DOUBLE PRECISION\n!> The sine of the rotation.\n!> \\endverbatim\n!>\n!> \\param[out] R\n!> \\verbatim\n!> R is DOUBLE PRECISION\n!> The nonzero component of the rotated vector.\n!>\n!> This version has a few statements commented out for thread safety\n!> (machine parameters are computed on each entry). 10 feb 03, SJH.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLARTG( F, G, CS, SN, R )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION CS, F, G, R, SN\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D0 )\n DOUBLE PRECISION TWO\n PARAMETER ( TWO = 2.0D0 )\n! ..\n! .. Local Scalars ..\n! LOGICAL FIRST\n INTEGER COUNT, I\n DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMCH\n! EXTERNAL DLAMCH\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, INT, LOG, MAX, SQRT\n! ..\n! .. Save statement ..\n! SAVE FIRST, SAFMX2, SAFMIN, SAFMN2\n! ..\n! .. Data statements ..\n! DATA FIRST / .TRUE. /\n! ..\n! .. Executable Statements ..\n!\n! IF( FIRST ) THEN\n SAFMIN = DLAMCH( 'S' )\n EPS = DLAMCH( 'E' )\n SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /&\n LOG( DLAMCH( 'B' ) ) / TWO )\n SAFMX2 = ONE / SAFMN2\n! FIRST = .FALSE.\n! END IF\n IF( G.EQ.ZERO ) THEN\n CS = ONE\n SN = ZERO\n R = F\n ELSE IF( F.EQ.ZERO ) THEN\n CS = ZERO\n SN = ONE\n R = G\n ELSE\n F1 = F\n G1 = G\n SCALE = MAX( ABS( F1 ), ABS( G1 ) )\n IF( SCALE.GE.SAFMX2 ) THEN\n COUNT = 0\n 10 CONTINUE\n COUNT = COUNT + 1\n F1 = F1*SAFMN2\n G1 = G1*SAFMN2\n SCALE = MAX( ABS( F1 ), ABS( G1 ) )\n IF( SCALE.GE.SAFMX2 ) GO TO 10\n R = SQRT( F1**2+G1**2 )\n CS = F1 / R\n SN = G1 / R\n DO 20 I = 1, COUNT\n R = R*SAFMX2\n 20 CONTINUE\n ELSE IF( SCALE.LE.SAFMN2 ) THEN\n COUNT = 0\n 30 CONTINUE\n COUNT = COUNT + 1\n F1 = F1*SAFMX2\n G1 = G1*SAFMX2\n SCALE = MAX( ABS( F1 ), ABS( G1 ) )\n IF( SCALE.LE.SAFMN2 ) GO TO 30\n R = SQRT( F1**2+G1**2 )\n CS = F1 / R\n SN = G1 / R\n DO 40 I = 1, COUNT\n R = R*SAFMN2\n 40 CONTINUE\n ELSE\n R = SQRT( F1**2+G1**2 )\n CS = F1 / R\n SN = G1 / R\n END IF\n IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN\n CS = -CS\n SN = -SN\n R = -R\n END IF\n END IF\n RETURN\n!\n! End of DLARTG\n!\n END SUBROUTINE DLARTG\n!\n!=\n!\n!> \\brief \\b DLACPY copies all or part of one two-dimensional array to another.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLACPY + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER LDA, LDB, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * ), B( LDB, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLACPY copies all or part of a two-dimensional matrix A to another\n!> matrix B.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> Specifies the part of the matrix A to be copied to B.\n!> = 'U': Upper triangular part\n!> = 'L': Lower triangular part\n!> Otherwise: All of the matrix A\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The m by n matrix A. If UPLO = 'U', only the upper triangle\n!> or trapezoid is accessed; if UPLO = 'L', only the lower\n!> triangle or trapezoid is accessed.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] B\n!> \\verbatim\n!> B is DOUBLE PRECISION array, dimension (LDB,N)\n!> On exit, B = A in the locations specified by UPLO.\n!> \\endverbatim\n!>\n!> \\param[in] LDB\n!> \\verbatim\n!> LDB is INTEGER\n!> The leading dimension of the array B. LDB >= max(1,M).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER LDA, LDB, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * ), B( LDB, * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, J\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MIN\n! ..\n! .. Executable Statements ..\n!\n IF( LSAME( UPLO, 'U' ) ) THEN\n DO 20 J = 1, N\n DO 10 I = 1, MIN( J, M )\n B( I, J ) = A( I, J )\n10 CONTINUE\n20 CONTINUE\n ELSE IF( LSAME( UPLO, 'L' ) ) THEN\n DO 40 J = 1, N\n DO 30 I = J, M\n B( I, J ) = A( I, J )\n 30 CONTINUE\n 40 CONTINUE\n ELSE\n DO 60 J = 1, N\n DO 50 I = 1, M\n B( I, J ) = A( I, J )\n 50 CONTINUE\n 60 CONTINUE\n END IF\n RETURN\n!\n! End of DLACPY\n!\n END SUBROUTINE DLACPY\n!\n!=\n!\n!> \\brief \\b DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED0 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,\n! WORK, IWORK, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ\n! ..\n! .. Array Arguments ..\n! INTEGER IWORK( * )\n! DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),\n! $ WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED0 computes all eigenvalues and corresponding eigenvectors of a\n!> symmetric tridiagonal matrix using the divide and conquer method.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ICOMPQ\n!> \\verbatim\n!> ICOMPQ is INTEGER\n!> = 0: Compute eigenvalues only.\n!> = 1: Compute eigenvectors of original dense symmetric matrix\n!> also. On entry, Q contains the orthogonal matrix used\n!> to reduce the original matrix to tridiagonal form.\n!> = 2: Compute eigenvalues and eigenvectors of tridiagonal\n!> matrix.\n!> \\endverbatim\n!>\n!> \\param[in] QSIZ\n!> \\verbatim\n!> QSIZ is INTEGER\n!> The dimension of the orthogonal matrix used to reduce\n!> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the main diagonal of the tridiagonal matrix.\n!> On exit, its eigenvalues.\n!> \\endverbatim\n!>\n!> \\param[in] E\n!> \\verbatim\n!> E is DOUBLE PRECISION array, dimension (N-1)\n!> The off-diagonal elements of the tridiagonal matrix.\n!> On exit, E has been destroyed.\n!> \\endverbatim\n!>\n!> \\param[in,out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ, N)\n!> On entry, Q must contain an N-by-N orthogonal matrix.\n!> If ICOMPQ = 0 Q is not referenced.\n!> If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n!> orthogonal matrix used to reduce the full\n!> matrix to tridiagonal form corresponding to\n!> the subset of the full matrix which is being\n!> decomposed at this time.\n!> If ICOMPQ = 2 On entry, Q will be the identity matrix.\n!> On exit, Q contains the eigenvectors of the\n!> tridiagonal matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. If eigenvectors are\n!> desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n!> \\endverbatim\n!>\n!> \\param[out] QSTORE\n!> \\verbatim\n!> QSTORE is DOUBLE PRECISION array, dimension (LDQS, N)\n!> Referenced only when ICOMPQ = 1. Used to store parts of\n!> the eigenvector matrix when the updating matrix multiplies\n!> take place.\n!> \\endverbatim\n!>\n!> \\param[in] LDQS\n!> \\verbatim\n!> LDQS is INTEGER\n!> The leading dimension of the array QSTORE. If ICOMPQ = 1,\n!> then LDQS >= max(1,N). In any case, LDQS >= 1.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array,\n!> If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n!> 1 + 3*N + 2*N*lg N + 3*N**2\n!> ( lg( N ) = smallest integer k\n!> such that 2^k >= N )\n!> If ICOMPQ = 2, the dimension of WORK must be at least\n!> 4*N + N**2.\n!> \\endverbatim\n!>\n!> \\param[out] IWORK\n!> \\verbatim\n!> IWORK is INTEGER array,\n!> If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n!> 6 + 6*N + 5*N*lg N.\n!> ( lg( N ) = smallest integer k\n!> such that 2^k >= N )\n!> If ICOMPQ = 2, the dimension of IWORK must be at least\n!> 3 + 5*N.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: The algorithm failed to compute an eigenvalue while\n!> working on the submatrix lying in rows and columns\n!> INFO/(N+1) through mod(INFO,N+1).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA\n!\n! =====================================================================\n SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,&\n WORK, IWORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ\n! ..\n! .. Array Arguments ..\n INTEGER IWORK( * )\n DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),&\n WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE, TWO\n PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )\n! ..\n! .. Local Scalars ..\n INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,&\n IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,&\n J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,&\n SPM2, SUBMAT, SUBPBS, TLVLS\n DOUBLE PRECISION TEMP\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,\n! $ XERBLA\n! ..\n! .. External Functions ..\n! INTEGER ILAENV\n! EXTERNAL ILAENV\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, DBLE, INT, LOG, MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN\n INFO = -1\n ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -7\n ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN\n INFO = -9\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED0', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )\n!\n! Determine the size and placement of the submatrices, and save in\n! the leading elements of IWORK.\n!\n IWORK( 1 ) = N\n SUBPBS = 1\n TLVLS = 0\n 10 CONTINUE\n IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN\n DO 20 J = SUBPBS, 1, -1\n IWORK( 2*J ) = ( IWORK( J )+1 ) / 2\n IWORK( 2*J-1 ) = IWORK( J ) / 2\n 20 CONTINUE\n TLVLS = TLVLS + 1\n SUBPBS = 2*SUBPBS\n GO TO 10\n END IF\n DO 30 J = 2, SUBPBS\n IWORK( J ) = IWORK( J ) + IWORK( J-1 )\n 30 CONTINUE\n!\n! Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1\n! using rank-1 modifications (cuts).\n!\n SPM1 = SUBPBS - 1\n DO 40 I = 1, SPM1\n SUBMAT = IWORK( I ) + 1\n SMM1 = SUBMAT - 1\n D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )\n D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )\n 40 CONTINUE\n!\n INDXQ = 4*N + 3\n IF( ICOMPQ.NE.2 ) THEN\n!\n! Set up workspaces for eigenvalues only/accumulate new vectors\n! routine\n!\n TEMP = LOG( DBLE( N ) ) / LOG( TWO )\n LGN = INT( TEMP )\n IF( 2**LGN.LT.N ) LGN = LGN + 1\n IF( 2**LGN.LT.N ) LGN = LGN + 1\n IPRMPT = INDXQ + N + 1\n IPERM = IPRMPT + N*LGN\n IQPTR = IPERM + N*LGN\n IGIVPT = IQPTR + N + 2\n IGIVCL = IGIVPT + N*LGN\n!\n IGIVNM = 1\n IQ = IGIVNM + 2*N*LGN\n IWREM = IQ + N**2 + 1\n!\n! Initialize pointers\n!\n DO 50 I = 0, SUBPBS\n IWORK( IPRMPT+I ) = 1\n IWORK( IGIVPT+I ) = 1\n 50 CONTINUE\n IWORK( IQPTR ) = 1\n END IF\n!\n! Solve each submatrix eigenproblem at the bottom of the divide and\n! conquer tree.\n!\n CURR = 0\n DO 70 I = 0, SPM1\n IF( I.EQ.0 ) THEN\n SUBMAT = 1\n MATSIZ = IWORK( 1 )\n ELSE\n SUBMAT = IWORK( I ) + 1\n MATSIZ = IWORK( I+1 ) - IWORK( I )\n END IF\n IF( ICOMPQ.EQ.2 ) THEN\n CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),&\n Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )\n IF( INFO.NE.0 ) GO TO 130\n ELSE\n CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),&\n WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, INFO )\n IF( INFO.NE.0 ) GO TO 130\n IF( ICOMPQ.EQ.1 ) THEN\n CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,&\n Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+&\n CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),&\n LDQS )\n END IF\n IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2\n CURR = CURR + 1\n END IF\n K = 1\n DO 60 J = SUBMAT, IWORK( I+1 )\n IWORK( INDXQ+J ) = K\n K = K + 1\n 60 CONTINUE\n 70 CONTINUE\n!\n! Successively merge eigensystems of adjacent submatrices\n! into eigensystem for the corresponding larger matrix.\n!\n! while ( SUBPBS > 1 )\n!\n CURLVL = 1\n 80 CONTINUE\n IF( SUBPBS.GT.1 ) THEN\n SPM2 = SUBPBS - 2\n DO 90 I = 0, SPM2, 2\n IF( I.EQ.0 ) THEN\n SUBMAT = 1\n MATSIZ = IWORK( 2 )\n MSD2 = IWORK( 1 )\n CURPRB = 0\n ELSE\n SUBMAT = IWORK( I ) + 1\n MATSIZ = IWORK( I+2 ) - IWORK( I )\n MSD2 = MATSIZ / 2\n CURPRB = CURPRB + 1\n END IF\n!\n! Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)\n! into an eigensystem of size MATSIZ.\n! DLAED1 is used only for the full eigensystem of a tridiagonal\n! matrix.\n! DLAED7 handles the cases in which eigenvalues only or eigenvalues\n! and eigenvectors of a full symmetric matrix (which was reduced to\n! tridiagonal form) are desired.\n!\n IF( ICOMPQ.EQ.2 ) THEN\n CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),&\n LDQ, IWORK( INDXQ+SUBMAT ),&\n E( SUBMAT+MSD2-1 ), MSD2, WORK,&\n IWORK( SUBPBS+1 ), INFO )\n ELSE\n CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,&\n D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,&\n IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),&\n MSD2, WORK( IQ ), IWORK( IQPTR ),&\n IWORK( IPRMPT ), IWORK( IPERM ),&\n IWORK( IGIVPT ), IWORK( IGIVCL ),&\n WORK( IGIVNM ), WORK( IWREM ),&\n IWORK( SUBPBS+1 ), INFO )\n END IF\n IF( INFO.NE.0 ) GO TO 130\n IWORK( I / 2+1 ) = IWORK( I+2 )\n 90 CONTINUE\n SUBPBS = SUBPBS / 2\n CURLVL = CURLVL + 1\n GO TO 80\n END IF\n!\n! end while\n!\n! Re-merge the eigenvalues/vectors which were deflated at the final\n! merge step.\n!\n IF( ICOMPQ.EQ.1 ) THEN\n DO 100 I = 1, N\n J = IWORK( INDXQ+I )\n WORK( I ) = D( J )\n CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )\n 100 CONTINUE\n CALL DCOPY( N, WORK, 1, D, 1 )\n ELSE IF( ICOMPQ.EQ.2 ) THEN\n DO 110 I = 1, N\n J = IWORK( INDXQ+I )\n WORK( I ) = D( J )\n CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )\n 110 CONTINUE\n CALL DCOPY( N, WORK, 1, D, 1 )\n CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )\n ELSE\n DO 120 I = 1, N\n J = IWORK( INDXQ+I )\n WORK( I ) = D( J )\n 120 CONTINUE\n CALL DCOPY( N, WORK, 1, D, 1 )\n END IF\n GO TO 140\n!\n 130 CONTINUE\n INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1\n!\n 140 CONTINUE\n RETURN\n!\n! End of DLAED0\n!\n END SUBROUTINE DLAED0\n!\n!=\n!\n!> \\brief \\b ILADLC scans a matrix for its last non-zero column.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download ILADLC + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION ILADLC( M, N, A, LDA )\n! \n! .. Scalar Arguments ..\n! INTEGER M, N, LDA\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> ILADLC scans A for its last non-zero column.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The m by n matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n INTEGER FUNCTION ILADLC( M, N, A, LDA )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER M, N, LDA\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I\n! ..\n! .. Executable Statements ..\n!\n! Quick test for the common case where one corner is non-zero.\n IF( N.EQ.0 ) THEN\n ILADLC = N\n ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN\n ILADLC = N\n ELSE\n! Now scan each column from the end, returning with the first non-zero.\n DO ILADLC = N, 1, -1\n DO I = 1, M\n IF( A(I, ILADLC).NE.ZERO ) RETURN\n END DO\n END DO\n END IF\n RETURN\n END FUNCTION ILADLC\n!\n!=\n!\n!> \\brief \\b ILADLR scans a matrix for its last non-zero row.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download ILADLR + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! INTEGER FUNCTION ILADLR( M, N, A, LDA )\n! \n! .. Scalar Arguments ..\n! INTEGER M, N, LDA\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> ILADLR scans A for its last non-zero row.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> The m by n matrix A.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERauxiliary\n!\n! =====================================================================\n INTEGER FUNCTION ILADLR( M, N, A, LDA )\n!\n! -- LAPACK auxiliary routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER M, N, LDA\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, J\n! ..\n! .. Executable Statements ..\n!\n! Quick test for the common case where one corner is non-zero.\n IF( M.EQ.0 ) THEN\n ILADLR = M\n ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN\n ILADLR = M\n ELSE\n! Scan up each column tracking the last zero row seen.\n ILADLR = 0\n DO J = 1, N\n I=M\n DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))\n I=I-1\n ENDDO\n ILADLR = MAX( ILADLR, I )\n END DO\n END IF\n RETURN\n END FUNCTION ILADLR\n!\n!=\n!\n!> \\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.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED1 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,\n! INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER CUTPNT, INFO, LDQ, N\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! INTEGER INDXQ( * ), IWORK( * )\n! DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED1 computes the updated eigensystem of a diagonal\n!> matrix after modification by a rank-one symmetric matrix. This\n!> routine is used only for the eigenproblem which requires all\n!> eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles\n!> the case in which eigenvalues only or eigenvalues and eigenvectors\n!> of a full symmetric matrix (which was reduced to tridiagonal form)\n!> are desired.\n!>\n!> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)\n!>\n!> where Z = Q**T*u, u is a vector of length N with ones in the\n!> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n!>\n!> The eigenvectors of the original matrix are stored in Q, and the\n!> eigenvalues are in D. The algorithm consists of three stages:\n!>\n!> The first stage consists of deflating the size of the problem\n!> when there are multiple eigenvalues or if there is a zero in\n!> the Z vector. For each such occurence the dimension of the\n!> secular equation problem is reduced by one. This stage is\n!> performed by the routine DLAED2.\n!>\n!> The second stage consists of calculating the updated\n!> eigenvalues. This is done by finding the roots of the secular\n!> equation via the routine DLAED4 (as called by DLAED3).\n!> This routine also calculates the eigenvectors of the current\n!> problem.\n!>\n!> The final stage consists of computing the updated eigenvectors\n!> directly using the updated eigenvalues. The eigenvectors for\n!> the current problem are multiplied with the eigenvectors from\n!> the overall problem.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the eigenvalues of the rank-1-perturbed matrix.\n!> On exit, the eigenvalues of the repaired matrix.\n!> \\endverbatim\n!>\n!> \\param[in,out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ,N)\n!> On entry, the eigenvectors of the rank-1-perturbed matrix.\n!> On exit, the eigenvectors of the repaired tridiagonal matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in,out] INDXQ\n!> \\verbatim\n!> INDXQ is INTEGER array, dimension (N)\n!> On entry, the permutation which separately sorts the two\n!> subproblems in D into ascending order.\n!> On exit, the permutation which will reintegrate the\n!> subproblems back into sorted order,\n!> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The subdiagonal entry used to create the rank-1 modification.\n!> \\endverbatim\n!>\n!> \\param[in] CUTPNT\n!> \\verbatim\n!> CUTPNT is INTEGER\n!> The location of the last eigenvalue in the leading sub-matrix.\n!> min(1,N) <= CUTPNT <= N/2.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (4*N + N**2)\n!> \\endverbatim\n!>\n!> \\param[out] IWORK\n!> \\verbatim\n!> IWORK is INTEGER array, dimension (4*N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = 1, an eigenvalue did not converge\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA \\n\n!> Modified by Francoise Tisseur, University of Tennessee\n!>\n! =====================================================================\n SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER CUTPNT, INFO, LDQ, N\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n INTEGER INDXQ( * ), IWORK( * )\n DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,&\n IW, IZ, K, N1, N2, ZPP1\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( N.LT.0 ) THEN\n INFO = -1\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -4\n ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN\n INFO = -7\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED1', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! The following values are integer pointers which indicate\n! the portion of the workspace\n! used by a particular array in DLAED2 and DLAED3.\n!\n IZ = 1\n IDLMDA = IZ + N\n IW = IDLMDA + N\n IQ2 = IW + N\n!\n INDX = 1\n INDXC = INDX + N\n COLTYP = INDXC + N\n INDXP = COLTYP + N\n!\n!\n! Form the z-vector which consists of the last row of Q_1 and the\n! first row of Q_2.\n!\n CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )\n ZPP1 = CUTPNT + 1\n CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )\n!\n! Deflate eigenvalues.\n!\n CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),&\n WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),&\n IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),&\n IWORK( COLTYP ), INFO )\n!\n IF( INFO.NE.0 ) GO TO 20\n!\n! Solve Secular Equation.\n!\n IF( K.NE.0 ) THEN\n IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +&\n ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2\n CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),&\n WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),&\n WORK( IW ), WORK( IS ), INFO )\n IF( INFO.NE.0 ) GO TO 20\n!\n! Prepare the INDXQ sorting permutation.\n!\n N1 = K\n N2 = N - K\n CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )\n ELSE\n DO 10 I = 1, N\n INDXQ( I ) = I\n 10 CONTINUE\n END IF\n!\n 20 CONTINUE\n RETURN\n!\n! End of DLAED1\n!\n END SUBROUTINE DLAED1\n!\n!=\n!\n!> \\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.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED7 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,\n! LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,\n! PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,\n! INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,\n! $ QSIZ, TLVLS\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),\n! $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )\n! DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),\n! $ QSTORE( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED7 computes the updated eigensystem of a diagonal\n!> matrix after modification by a rank-one symmetric matrix. This\n!> routine is used only for the eigenproblem which requires all\n!> eigenvalues and optionally eigenvectors of a dense symmetric matrix\n!> that has been reduced to tridiagonal form. DLAED1 handles\n!> the case in which all eigenvalues and eigenvectors of a symmetric\n!> tridiagonal matrix are desired.\n!>\n!> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)\n!>\n!> where Z = Q**Tu, u is a vector of length N with ones in the\n!> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n!>\n!> The eigenvectors of the original matrix are stored in Q, and the\n!> eigenvalues are in D. The algorithm consists of three stages:\n!>\n!> The first stage consists of deflating the size of the problem\n!> when there are multiple eigenvalues or if there is a zero in\n!> the Z vector. For each such occurence the dimension of the\n!> secular equation problem is reduced by one. This stage is\n!> performed by the routine DLAED8.\n!>\n!> The second stage consists of calculating the updated\n!> eigenvalues. This is done by finding the roots of the secular\n!> equation via the routine DLAED4 (as called by DLAED9).\n!> This routine also calculates the eigenvectors of the current\n!> problem.\n!>\n!> The final stage consists of computing the updated eigenvectors\n!> directly using the updated eigenvalues. The eigenvectors for\n!> the current problem are multiplied with the eigenvectors from\n!> the overall problem.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ICOMPQ\n!> \\verbatim\n!> ICOMPQ is INTEGER\n!> = 0: Compute eigenvalues only.\n!> = 1: Compute eigenvectors of original dense symmetric matrix\n!> also. On entry, Q contains the orthogonal matrix used\n!> to reduce the original matrix to tridiagonal form.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] QSIZ\n!> \\verbatim\n!> QSIZ is INTEGER\n!> The dimension of the orthogonal matrix used to reduce\n!> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n!> \\endverbatim\n!>\n!> \\param[in] TLVLS\n!> \\verbatim\n!> TLVLS is INTEGER\n!> The total number of merging levels in the overall divide and\n!> conquer tree.\n!> \\endverbatim\n!>\n!> \\param[in] CURLVL\n!> \\verbatim\n!> CURLVL is INTEGER\n!> The current level in the overall merge routine,\n!> 0 <= CURLVL <= TLVLS.\n!> \\endverbatim\n!>\n!> \\param[in] CURPBM\n!> \\verbatim\n!> CURPBM is INTEGER\n!> The current problem in the current level in the overall\n!> merge routine (counting from upper left to lower right).\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the eigenvalues of the rank-1-perturbed matrix.\n!> On exit, the eigenvalues of the repaired matrix.\n!> \\endverbatim\n!>\n!> \\param[in,out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ, N)\n!> On entry, the eigenvectors of the rank-1-perturbed matrix.\n!> On exit, the eigenvectors of the repaired tridiagonal matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] INDXQ\n!> \\verbatim\n!> INDXQ is INTEGER array, dimension (N)\n!> The permutation which will reintegrate the subproblem just\n!> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n!> will be in ascending order.\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The subdiagonal element used to create the rank-1\n!> modification.\n!> \\endverbatim\n!>\n!> \\param[in] CUTPNT\n!> \\verbatim\n!> CUTPNT is INTEGER\n!> Contains the location of the last eigenvalue in the leading\n!> sub-matrix. min(1,N) <= CUTPNT <= N.\n!> \\endverbatim\n!>\n!> \\param[in,out] QSTORE\n!> \\verbatim\n!> QSTORE is DOUBLE PRECISION array, dimension (N**2+1)\n!> Stores eigenvectors of submatrices encountered during\n!> divide and conquer, packed together. QPTR points to\n!> beginning of the submatrices.\n!> \\endverbatim\n!>\n!> \\param[in,out] QPTR\n!> \\verbatim\n!> QPTR is INTEGER array, dimension (N+2)\n!> List of indices pointing to beginning of submatrices stored\n!> in QSTORE. The submatrices are numbered starting at the\n!> bottom left of the divide and conquer tree, from left to\n!> right and bottom to top.\n!> \\endverbatim\n!>\n!> \\param[in] PRMPTR\n!> \\verbatim\n!> PRMPTR is INTEGER array, dimension (N lg N)\n!> Contains a list of pointers which indicate where in PERM a\n!> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n!> indicates the size of the permutation and also the size of\n!> the full, non-deflated problem.\n!> \\endverbatim\n!>\n!> \\param[in] PERM\n!> \\verbatim\n!> PERM is INTEGER array, dimension (N lg N)\n!> Contains the permutations (from deflation and sorting) to be\n!> applied to each eigenblock.\n!> \\endverbatim\n!>\n!> \\param[in] GIVPTR\n!> \\verbatim\n!> GIVPTR is INTEGER array, dimension (N lg N)\n!> Contains a list of pointers which indicate where in GIVCOL a\n!> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n!> indicates the number of Givens rotations.\n!> \\endverbatim\n!>\n!> \\param[in] GIVCOL\n!> \\verbatim\n!> GIVCOL is INTEGER array, dimension (2, N lg N)\n!> Each pair of numbers indicates a pair of columns to take place\n!> in a Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[in] GIVNUM\n!> \\verbatim\n!> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)\n!> Each number indicates the S value to be used in the\n!> corresponding Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N)\n!> \\endverbatim\n!>\n!> \\param[out] IWORK\n!> \\verbatim\n!> IWORK is INTEGER array, dimension (4*N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = 1, an eigenvalue did not converge\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA\n!\n! =====================================================================\n SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,&\n LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,&\n PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,&\n INFO )\n!\n! -- LAPACK computational routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,&\n QSIZ, TLVLS\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),&\n IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )\n DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),&\n QSTORE( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )\n! ..\n! .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,&\n IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR\n! ..\n! .. External Subroutines ..\n! EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN\n INFO = -3\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -9\n ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN\n INFO = -12\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED7', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! The following values are for bookkeeping purposes only. They are\n! integer pointers which indicate the portion of the workspace\n! used by a particular array in DLAED8 and DLAED9.\n!\n IF( ICOMPQ.EQ.1 ) THEN\n LDQ2 = QSIZ\n ELSE\n LDQ2 = N\n END IF\n!\n IZ = 1\n IDLMDA = IZ + N\n IW = IDLMDA + N\n IQ2 = IW + N\n IS = IQ2 + N*LDQ2\n!\n INDX = 1\n INDXC = INDX + N\n COLTYP = INDXC + N\n INDXP = COLTYP + N\n!\n! Form the z-vector which consists of the last row of Q_1 and the\n! first row of Q_2.\n!\n PTR = 1 + 2**TLVLS\n DO 10 I = 1, CURLVL - 1\n PTR = PTR + 2**( TLVLS-I )\n10 CONTINUE\n CURR = PTR + CURPBM\n CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,&\n GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),&\n WORK( IZ+N ), INFO )\n!\n! When solving the final problem, we no longer need the stored data,\n! so we will overwrite the data from this level onto the previously\n! used storage space.\n!\n IF( CURLVL.EQ.TLVLS ) THEN\n QPTR( CURR ) = 1\n PRMPTR( CURR ) = 1\n GIVPTR( CURR ) = 1\n END IF\n!\n! Sort and Deflate eigenvalues.\n!\n CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,&\n WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,&\n WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),&\n GIVCOL( 1, GIVPTR( CURR ) ),&\n GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),&\n IWORK( INDX ), INFO )\n PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N\n GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )\n!\n! Solve Secular Equation.\n!\n IF( K.NE.0 ) THEN\n CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),&\n WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )\n IF( INFO.NE.0 ) GO TO 30\n IF( ICOMPQ.EQ.1 ) THEN\n CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,&\n QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )\n END IF\n QPTR( CURR+1 ) = QPTR( CURR ) + K**2\n!\n! Prepare the INDXQ sorting permutation.\n!\n N1 = K\n N2 = N - K\n CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )\n ELSE\n QPTR( CURR+1 ) = QPTR( CURR )\n DO 20 I = 1, N\n INDXQ( I ) = I\n20 CONTINUE\n END IF\n!\n30 CONTINUE\n RETURN\n!\n! End of DLAED7\n!\n END SUBROUTINE DLAED7\n!\n!=\n!\n!> \\brief \\b DLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED8 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,\n! CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,\n! GIVCOL, GIVNUM, INDXP, INDX, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,\n! $ QSIZ\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),\n! $ INDXQ( * ), PERM( * )\n! DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),\n! $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED8 merges the two sets of eigenvalues together into a single\n!> sorted set. Then it tries to deflate the size of the problem.\n!> There are two ways in which deflation can occur: when two or more\n!> eigenvalues are close together or if there is a tiny element in the\n!> Z vector. For each such occurrence the order of the related secular\n!> equation problem is reduced by one.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] ICOMPQ\n!> \\verbatim\n!> ICOMPQ is INTEGER\n!> = 0: Compute eigenvalues only.\n!> = 1: Compute eigenvectors of original dense symmetric matrix\n!> also. On entry, Q contains the orthogonal matrix used\n!> to reduce the original matrix to tridiagonal form.\n!> \\endverbatim\n!>\n!> \\param[out] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of non-deflated eigenvalues, and the order of the\n!> related secular equation.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] QSIZ\n!> \\verbatim\n!> QSIZ is INTEGER\n!> The dimension of the orthogonal matrix used to reduce\n!> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, the eigenvalues of the two submatrices to be\n!> combined. On exit, the trailing (N-K) updated eigenvalues\n!> (those which were deflated) sorted into increasing order.\n!> \\endverbatim\n!>\n!> \\param[in,out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ,N)\n!> If ICOMPQ = 0, Q is not referenced. Otherwise,\n!> on entry, Q contains the eigenvectors of the partially solved\n!> system which has been previously updated in matrix\n!> multiplies with other partially solved eigensystems.\n!> On exit, Q contains the trailing (N-K) updated eigenvectors\n!> (those which were deflated) in its last N-K columns.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in] INDXQ\n!> \\verbatim\n!> INDXQ is INTEGER array, dimension (N)\n!> The permutation which separately sorts the two sub-problems\n!> in D into ascending order. Note that elements in the second\n!> half of this permutation must first have CUTPNT added to\n!> their values in order to be accurate.\n!> \\endverbatim\n!>\n!> \\param[in,out] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> On entry, the off-diagonal element associated with the rank-1\n!> cut which originally split the two submatrices which are now\n!> being recombined.\n!> On exit, RHO has been modified to the value required by\n!> DLAED3.\n!> \\endverbatim\n!>\n!> \\param[in] CUTPNT\n!> \\verbatim\n!> CUTPNT is INTEGER\n!> The location of the last eigenvalue in the leading\n!> sub-matrix. min(1,N) <= CUTPNT <= N.\n!> \\endverbatim\n!>\n!> \\param[in] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (N)\n!> On entry, Z contains the updating vector (the last row of\n!> the first sub-eigenvector matrix and the first row of the\n!> second sub-eigenvector matrix).\n!> On exit, the contents of Z are destroyed by the updating\n!> process.\n!> \\endverbatim\n!>\n!> \\param[out] DLAMDA\n!> \\verbatim\n!> DLAMDA is DOUBLE PRECISION array, dimension (N)\n!> A copy of the first K eigenvalues which will be used by\n!> DLAED3 to form the secular equation.\n!> \\endverbatim\n!>\n!> \\param[out] Q2\n!> \\verbatim\n!> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N)\n!> If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n!> a copy of the first K eigenvectors which will be used by\n!> DLAED7 in a matrix multiply (DGEMM) to update the new\n!> eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ2\n!> \\verbatim\n!> LDQ2 is INTEGER\n!> The leading dimension of the array Q2. LDQ2 >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (N)\n!> The first k values of the final deflation-altered z-vector and\n!> will be passed to DLAED3.\n!> \\endverbatim\n!>\n!> \\param[out] PERM\n!> \\verbatim\n!> PERM is INTEGER array, dimension (N)\n!> The permutations (from deflation and sorting) to be applied\n!> to each eigenblock.\n!> \\endverbatim\n!>\n!> \\param[out] GIVPTR\n!> \\verbatim\n!> GIVPTR is INTEGER\n!> The number of Givens rotations which took place in this\n!> subproblem.\n!> \\endverbatim\n!>\n!> \\param[out] GIVCOL\n!> \\verbatim\n!> GIVCOL is INTEGER array, dimension (2, N)\n!> Each pair of numbers indicates a pair of columns to take place\n!> in a Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[out] GIVNUM\n!> \\verbatim\n!> GIVNUM is DOUBLE PRECISION array, dimension (2, N)\n!> Each number indicates the S value to be used in the\n!> corresponding Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[out] INDXP\n!> \\verbatim\n!> INDXP is INTEGER array, dimension (N)\n!> The permutation used to place deflated values of D at the end\n!> of the array. INDXP(1:K) points to the nondeflated D-values\n!> and INDXP(K+1:N) points to the deflated eigenvalues.\n!> \\endverbatim\n!>\n!> \\param[out] INDX\n!> \\verbatim\n!> INDX is INTEGER array, dimension (N)\n!> The permutation used to sort the contents of D into ascending\n!> order.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA\n!\n! =====================================================================\n SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,&\n CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,&\n GIVCOL, GIVNUM, INDXP, INDX, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,&\n QSIZ\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),&\n INDXQ( * ), PERM( * )\n DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),&\n Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT\n PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,&\n TWO = 2.0D0, EIGHT = 8.0D0 )\n! ..\n! .. Local Scalars ..\n!\n INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2\n DOUBLE PRECISION C, EPS, S, T, TAU, TOL\n! ..\n! .. External Functions ..\n! INTEGER IDAMAX\n! DOUBLE PRECISION DLAMCH, DLAPY2\n! EXTERNAL IDAMAX, DLAMCH, DLAPY2\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN\n INFO = -4\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -7\n ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN\n INFO = -10\n ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN\n INFO = -14\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED8', -INFO )\n RETURN\n END IF\n!\n! Need to initialize GIVPTR to O here in case of quick exit\n! to prevent an unspecified code behavior (usually sigfault) \n! when IWORK array on entry to *stedc is not zeroed \n! (or at least some IWORK entries which used in *laed7 for GIVPTR).\n!\n GIVPTR = 0\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n N1 = CUTPNT\n N2 = N - N1\n N1P1 = N1 + 1\n!\n IF( RHO.LT.ZERO ) THEN\n CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )\n END IF\n!\n! Normalize z so that norm(z) = 1\n!\n T = ONE / SQRT( TWO )\n DO 10 J = 1, N\n INDX( J ) = J\n10 CONTINUE\n CALL DSCAL( N, T, Z, 1 )\n RHO = ABS( TWO*RHO )\n!\n! Sort the eigenvalues into increasing order\n!\n DO 20 I = CUTPNT + 1, N\n INDXQ( I ) = INDXQ( I ) + CUTPNT\n20 CONTINUE\n DO 30 I = 1, N\n DLAMDA( I ) = D( INDXQ( I ) )\n W( I ) = Z( INDXQ( I ) )\n30 CONTINUE\n I = 1\n J = CUTPNT + 1\n CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )\n DO 40 I = 1, N\n D( I ) = DLAMDA( INDX( I ) )\n Z( I ) = W( INDX( I ) )\n40 CONTINUE\n!\n! Calculate the allowable deflation tolerence\n!\n IMAX = IDAMAX( N, Z, 1 )\n JMAX = IDAMAX( N, D, 1 )\n EPS = DLAMCH( 'Epsilon' )\n TOL = EIGHT*EPS*ABS( D( JMAX ) )\n!\n! If the rank-1 modifier is small enough, no more needs to be done\n! except to reorganize Q so that its columns correspond with the\n! elements in D.\n!\n IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN\n K = 0\n IF( ICOMPQ.EQ.0 ) THEN\n DO 50 J = 1, N\n PERM( J ) = INDXQ( INDX( J ) )\n 50 CONTINUE\n ELSE\n DO 60 J = 1, N\n PERM( J ) = INDXQ( INDX( J ) )\n CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )\n 60 CONTINUE\n CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )\n END IF\n RETURN\n END IF\n!\n! If there are multiple eigenvalues then the problem deflates. Here\n! the number of equal eigenvalues are found. As each equal\n! eigenvalue is found, an elementary reflector is computed to rotate\n! the corresponding eigensubspace so that the corresponding\n! components of Z are zero in this new basis.\n!\n K = 0\n K2 = N + 1\n DO 70 J = 1, N\n IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN\n!\n! Deflate due to small z component.\n!\n K2 = K2 - 1\n INDXP( K2 ) = J\n IF( J.EQ.N ) GO TO 110\n ELSE\n JLAM = J\n GO TO 80\n END IF\n70 CONTINUE\n80 CONTINUE\n J = J + 1\n IF( J.GT.N ) GO TO 100\n IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN\n!\n! Deflate due to small z component.\n!\n K2 = K2 - 1\n INDXP( K2 ) = J\n ELSE\n!\n! Check if eigenvalues are close enough to allow deflation.\n!\n S = Z( JLAM )\n C = Z( J )\n!\n! Find sqrt(a**2+b**2) without overflow or\n! destructive underflow.\n!\n TAU = DLAPY2( C, S )\n T = D( J ) - D( JLAM )\n C = C / TAU\n S = -S / TAU\n IF( ABS( T*C*S ).LE.TOL ) THEN\n!\n! Deflation is possible.\n!\n Z( J ) = TAU\n Z( JLAM ) = ZERO\n!\n! Record the appropriate Givens rotation\n!\n GIVPTR = GIVPTR + 1\n GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )\n GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )\n GIVNUM( 1, GIVPTR ) = C\n GIVNUM( 2, GIVPTR ) = S\n IF( ICOMPQ.EQ.1 ) THEN\n CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,&\n Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )\n END IF\n T = D( JLAM )*C*C + D( J )*S*S\n D( J ) = D( JLAM )*S*S + D( J )*C*C\n D( JLAM ) = T\n K2 = K2 - 1\n I = 1\n90 CONTINUE\n IF( K2+I.LE.N ) THEN\n IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN\n INDXP( K2+I-1 ) = INDXP( K2+I )\n INDXP( K2+I ) = JLAM\n I = I + 1\n GO TO 90\n ELSE\n INDXP( K2+I-1 ) = JLAM\n END IF\n ELSE\n INDXP( K2+I-1 ) = JLAM\n END IF\n JLAM = J\n ELSE\n K = K + 1\n W( K ) = Z( JLAM )\n DLAMDA( K ) = D( JLAM )\n INDXP( K ) = JLAM\n JLAM = J\n END IF\n END IF\n GO TO 80\n100 CONTINUE\n!\n! Record the last eigenvalue.\n!\n K = K + 1\n W( K ) = Z( JLAM )\n DLAMDA( K ) = D( JLAM )\n INDXP( K ) = JLAM\n!\n110 CONTINUE\n!\n! Sort the eigenvalues and corresponding eigenvectors into DLAMDA\n! and Q2 respectively. The eigenvalues/vectors which were not\n! deflated go into the first K slots of DLAMDA and Q2 respectively,\n! while those which were deflated go into the last N - K slots.\n!\n IF( ICOMPQ.EQ.0 ) THEN\n DO 120 J = 1, N\n JP = INDXP( J )\n DLAMDA( J ) = D( JP )\n PERM( J ) = INDXQ( INDX( JP ) )\n120 CONTINUE\n ELSE\n DO 130 J = 1, N\n JP = INDXP( J )\n DLAMDA( J ) = D( JP )\n PERM( J ) = INDXQ( INDX( JP ) )\n CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )\n130 CONTINUE\n END IF\n!\n! The deflated eigenvalues and their corresponding vectors go back\n! into the last N - K slots of D and Q respectively.\n!\n IF( K.LT.N ) THEN\n IF( ICOMPQ.EQ.0 ) THEN\n CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )\n ELSE\n CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )\n CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,&\n Q( 1, K+1 ), LDQ )\n END IF\n END IF\n!\n RETURN\n!\n! End of DLAED8\n!\n END SUBROUTINE DLAED8\n!\n!=\n!\n!> \\brief \\b DLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED9 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,\n! S, LDS, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),\n! $ W( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED9 finds the roots of the secular equation, as defined by the\n!> values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n!> appropriate calls to DLAED4 and then stores the new matrix of\n!> eigenvectors for use in calculating the next level of Z vectors.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of terms in the rational function to be solved by\n!> DLAED4. K >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] KSTART\n!> \\verbatim\n!> KSTART is INTEGER\n!> \\endverbatim\n!>\n!> \\param[in] KSTOP\n!> \\verbatim\n!> KSTOP is INTEGER\n!> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n!> are to be computed. 1 <= KSTART <= KSTOP <= K.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of rows and columns in the Q matrix.\n!> N >= K (delation may result in N > K).\n!> \\endverbatim\n!>\n!> \\param[out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> D(I) contains the updated eigenvalues\n!> for KSTART <= I <= KSTOP.\n!> \\endverbatim\n!>\n!> \\param[out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ,N)\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max( 1, N ).\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The value of the parameter in the rank one update equation.\n!> RHO >= 0 required.\n!> \\endverbatim\n!>\n!> \\param[in] DLAMDA\n!> \\verbatim\n!> DLAMDA is DOUBLE PRECISION array, dimension (K)\n!> The first K elements of this array contain the old roots\n!> of the deflated updating problem. These are the poles\n!> of the secular equation.\n!> \\endverbatim\n!>\n!> \\param[in] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (K)\n!> The first K elements of this array contain the components\n!> of the deflation-adjusted updating vector.\n!> \\endverbatim\n!>\n!> \\param[out] S\n!> \\verbatim\n!> S is DOUBLE PRECISION array, dimension (LDS, K)\n!> Will contain the eigenvectors of the repaired matrix which\n!> will be stored for subsequent Z vector calculation and\n!> multiplied by the previously accumulated eigenvectors\n!> to update the system.\n!> \\endverbatim\n!>\n!> \\param[in] LDS\n!> \\verbatim\n!> LDS is INTEGER\n!> The leading dimension of S. LDS >= max( 1, K ).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = 1, an eigenvalue did not converge\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA\n!\n! =====================================================================\n SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,&\n S, LDS, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),&\n W( * )\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION TEMP\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMC3, DNRM2\n! EXTERNAL DLAMC3, DNRM2\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DLAED4, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, SIGN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( K.LT.0 ) THEN\n INFO = -1\n ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN\n INFO = -2\n ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) THEN\n INFO = -3\n ELSE IF( N.LT.K ) THEN\n INFO = -4\n ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN\n INFO = -7\n ELSE IF( LDS.LT.MAX( 1, K ) ) THEN\n INFO = -12\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED9', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( K.EQ.0 ) RETURN\n!\n! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can\n! be computed with high relative accuracy (barring over/underflow).\n! This is a problem on machines without a guard digit in\n! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).\n! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),\n! which on any of these machines zeros out the bottommost\n! bit of DLAMDA(I) if it is 1; this makes the subsequent\n! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation\n! occurs. On binary machines with a guard digit (almost all\n! machines) it does not change DLAMDA(I) at all. On hexadecimal\n! and decimal machines with a guard digit, it slightly\n! changes the bottommost bits of DLAMDA(I). It does not account\n! for hexadecimal or decimal machines without guard digits\n! (we know of none). We use a subroutine call to compute\n! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating\n! this code.\n!\n DO 10 I = 1, N\n DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )\n10 CONTINUE\n!\n DO 20 J = KSTART, KSTOP\n CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )\n!\n! If the zero finder fails, the computation is terminated.\n!\n IF( INFO.NE.0 ) GO TO 120\n20 CONTINUE\n!\n IF( K.EQ.1 .OR. K.EQ.2 ) THEN\n DO 40 I = 1, K\n DO 30 J = 1, K\n S( J, I ) = Q( J, I )\n30 CONTINUE\n40 CONTINUE\n GO TO 120\n END IF\n!\n! Compute updated W.\n!\n CALL DCOPY( K, W, 1, S, 1 )\n!\n! Initialize W(I) = Q(I,I)\n!\n CALL DCOPY( K, Q, LDQ+1, W, 1 )\n DO 70 J = 1, K\n DO 50 I = 1, J - 1\n W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )\n50 CONTINUE\n DO 60 I = J + 1, K\n W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )\n60 CONTINUE\n70 CONTINUE\n DO 80 I = 1, K\n W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )\n80 CONTINUE\n!\n! Compute eigenvectors of the modified rank-1 modification.\n!\n DO 110 J = 1, K\n DO 90 I = 1, K\n Q( I, J ) = W( I ) / Q( I, J )\n90 CONTINUE\n TEMP = DNRM2( K, Q( 1, J ), 1 )\n DO 100 I = 1, K\n S( I, J ) = Q( I, J ) / TEMP\n100 CONTINUE\n110 CONTINUE\n!\n120 CONTINUE\n RETURN\n!\n! End of DLAED9\n!\n END SUBROUTINE DLAED9\n!\n!=\n!\n!> \\brief \\b DLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,\n! Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, K, LDQ, N, N1\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),\n! $ INDXQ( * )\n! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),\n! $ W( * ), Z( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED2 merges the two sets of eigenvalues together into a single\n!> sorted set. Then it tries to deflate the size of the problem.\n!> There are two ways in which deflation can occur: when two or more\n!> eigenvalues are close together or if there is a tiny entry in the\n!> Z vector. For each such occurrence the order of the related secular\n!> equation problem is reduced by one.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[out] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of non-deflated eigenvalues, and the order of the\n!> related secular equation. 0 <= K <=N.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N1\n!> \\verbatim\n!> N1 is INTEGER\n!> The location of the last eigenvalue in the leading sub-matrix.\n!> min(1,N) <= N1 <= N/2.\n!> \\endverbatim\n!>\n!> \\param[in,out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> On entry, D contains the eigenvalues of the two submatrices to\n!> be combined.\n!> On exit, D contains the trailing (N-K) updated eigenvalues\n!> (those which were deflated) sorted into increasing order.\n!> \\endverbatim\n!>\n!> \\param[in,out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ, N)\n!> On entry, Q contains the eigenvectors of two submatrices in\n!> the two square blocks with corners at (1,1), (N1,N1)\n!> and (N1+1, N1+1), (N,N).\n!> On exit, Q contains the trailing (N-K) updated eigenvectors\n!> (those which were deflated) in its last N-K columns.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in,out] INDXQ\n!> \\verbatim\n!> INDXQ is INTEGER array, dimension (N)\n!> The permutation which separately sorts the two sub-problems\n!> in D into ascending order. Note that elements in the second\n!> half of this permutation must first have N1 added to their\n!> values. Destroyed on exit.\n!> \\endverbatim\n!>\n!> \\param[in,out] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> On entry, the off-diagonal element associated with the rank-1\n!> cut which originally split the two submatrices which are now\n!> being recombined.\n!> On exit, RHO has been modified to the value required by\n!> DLAED3.\n!> \\endverbatim\n!>\n!> \\param[in] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (N)\n!> On entry, Z contains the updating vector (the last\n!> row of the first sub-eigenvector matrix and the first row of\n!> the second sub-eigenvector matrix).\n!> On exit, the contents of Z have been destroyed by the updating\n!> process.\n!> \\endverbatim\n!>\n!> \\param[out] DLAMDA\n!> \\verbatim\n!> DLAMDA is DOUBLE PRECISION array, dimension (N)\n!> A copy of the first K eigenvalues which will be used by\n!> DLAED3 to form the secular equation.\n!> \\endverbatim\n!>\n!> \\param[out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (N)\n!> The first k values of the final deflation-altered z-vector\n!> which will be passed to DLAED3.\n!> \\endverbatim\n!>\n!> \\param[out] Q2\n!> \\verbatim\n!> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)\n!> A copy of the first K eigenvectors which will be used by\n!> DLAED3 in a matrix multiply (DGEMM) to solve for the new\n!> eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[out] INDX\n!> \\verbatim\n!> INDX is INTEGER array, dimension (N)\n!> The permutation used to sort the contents of DLAMDA into\n!> ascending order.\n!> \\endverbatim\n!>\n!> \\param[out] INDXC\n!> \\verbatim\n!> INDXC is INTEGER array, dimension (N)\n!> The permutation used to arrange the columns of the deflated\n!> Q matrix into three groups: the first group contains non-zero\n!> elements only at and above N1, the second contains\n!> non-zero elements only below N1, and the third is dense.\n!> \\endverbatim\n!>\n!> \\param[out] INDXP\n!> \\verbatim\n!> INDXP is INTEGER array, dimension (N)\n!> The permutation used to place deflated values of D at the end\n!> of the array. INDXP(1:K) points to the nondeflated D-values\n!> and INDXP(K+1:N) points to the deflated eigenvalues.\n!> \\endverbatim\n!>\n!> \\param[out] COLTYP\n!> \\verbatim\n!> COLTYP is INTEGER array, dimension (N)\n!> During execution, a label which will indicate which of the\n!> following types a column in the Q2 matrix is:\n!> 1 : non-zero in the upper half only;\n!> 2 : dense;\n!> 3 : non-zero in the lower half only;\n!> 4 : deflated.\n!> On exit, COLTYP(i) is the number of columns of type i,\n!> for i=1 to 4 only.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA \\n\n!> Modified by Francoise Tisseur, University of Tennessee\n!>\n! =====================================================================\n SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,&\n Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, K, LDQ, N, N1\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),&\n INDXQ( * )\n DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),&\n W( * ), Z( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT\n PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,&\n TWO = 2.0D0, EIGHT = 8.0D0 )\n! ..\n! .. Local Arrays ..\n INTEGER CTOT( 4 ), PSM( 4 )\n! ..\n! .. Local Scalars ..\n INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,&\n N2, NJ, PJ\n DOUBLE PRECISION C, EPS, S, T, TAU, TOL\n! ..\n! .. External Functions ..\n! INTEGER IDAMAX\n! DOUBLE PRECISION DLAMCH, DLAPY2\n! EXTERNAL IDAMAX, DLAMCH, DLAPY2\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -6\n ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN\n INFO = -3\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED2', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n N2 = N - N1\n N1P1 = N1 + 1\n!\n IF( RHO.LT.ZERO ) THEN\n CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )\n END IF\n!\n! Normalize z so that norm(z) = 1. Since z is the concatenation of\n! two normalized vectors, norm2(z) = sqrt(2).\n!\n T = ONE / SQRT( TWO )\n CALL DSCAL( N, T, Z, 1 )\n!\n! RHO = ABS( norm(z)**2 * RHO )\n!\n RHO = ABS( TWO*RHO )\n!\n! Sort the eigenvalues into increasing order\n!\n DO 10 I = N1P1, N\n INDXQ( I ) = INDXQ( I ) + N1\n10 CONTINUE\n!\n! re-integrate the deflated parts from the last pass\n!\n DO 20 I = 1, N\n DLAMDA( I ) = D( INDXQ( I ) )\n20 CONTINUE\n CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )\n DO 30 I = 1, N\n INDX( I ) = INDXQ( INDXC( I ) )\n30 CONTINUE\n!\n! Calculate the allowable deflation tolerance\n!\n IMAX = IDAMAX( N, Z, 1 )\n JMAX = IDAMAX( N, D, 1 )\n EPS = DLAMCH( 'Epsilon' )\n TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )\n!\n! If the rank-1 modifier is small enough, no more needs to be done\n! except to reorganize Q so that its columns correspond with the\n! elements in D.\n!\n IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN\n K = 0\n IQ2 = 1\n DO 40 J = 1, N\n I = INDX( J )\n CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )\n DLAMDA( J ) = D( I )\n IQ2 = IQ2 + N\n40 CONTINUE\n CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )\n CALL DCOPY( N, DLAMDA, 1, D, 1 )\n GO TO 190\n END IF\n!\n! If there are multiple eigenvalues then the problem deflates. Here\n! the number of equal eigenvalues are found. As each equal\n! eigenvalue is found, an elementary reflector is computed to rotate\n! the corresponding eigensubspace so that the corresponding\n! components of Z are zero in this new basis.\n!\n DO 50 I = 1, N1\n COLTYP( I ) = 1\n50 CONTINUE\n DO 60 I = N1P1, N\n COLTYP( I ) = 3\n60 CONTINUE\n!\n!\n K = 0\n K2 = N + 1\n DO 70 J = 1, N\n NJ = INDX( J )\n IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN\n!\n! Deflate due to small z component.\n!\n K2 = K2 - 1\n COLTYP( NJ ) = 4\n INDXP( K2 ) = NJ\n IF( J.EQ.N ) GO TO 100\n ELSE\n PJ = NJ\n GO TO 80\n END IF\n70 CONTINUE\n80 CONTINUE\n J = J + 1\n NJ = INDX( J )\n IF( J.GT.N ) GO TO 100\n IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN\n!\n! Deflate due to small z component.\n!\n K2 = K2 - 1\n COLTYP( NJ ) = 4\n INDXP( K2 ) = NJ\n ELSE\n!\n! Check if eigenvalues are close enough to allow deflation.\n!\n S = Z( PJ )\n C = Z( NJ )\n!\n! Find sqrt(a**2+b**2) without overflow or\n! destructive underflow.\n!\n TAU = DLAPY2( C, S )\n T = D( NJ ) - D( PJ )\n C = C / TAU\n S = -S / TAU\n IF( ABS( T*C*S ).LE.TOL ) THEN\n!\n! Deflation is possible.\n!\n Z( NJ ) = TAU\n Z( PJ ) = ZERO\n IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) COLTYP( NJ ) = 2\n COLTYP( PJ ) = 4\n CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )\n T = D( PJ )*C**2 + D( NJ )*S**2\n D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2\n D( PJ ) = T\n K2 = K2 - 1\n I = 1\n90 CONTINUE\n IF( K2+I.LE.N ) THEN\n IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN\n INDXP( K2+I-1 ) = INDXP( K2+I )\n INDXP( K2+I ) = PJ\n I = I + 1\n GO TO 90\n ELSE\n INDXP( K2+I-1 ) = PJ\n END IF\n ELSE\n INDXP( K2+I-1 ) = PJ\n END IF\n PJ = NJ\n ELSE\n K = K + 1\n DLAMDA( K ) = D( PJ )\n W( K ) = Z( PJ )\n INDXP( K ) = PJ\n PJ = NJ\n END IF\n END IF\n GO TO 80\n100 CONTINUE\n!\n! Record the last eigenvalue.\n!\n K = K + 1\n DLAMDA( K ) = D( PJ )\n W( K ) = Z( PJ )\n INDXP( K ) = PJ\n!\n! Count up the total number of the various types of columns, then\n! form a permutation which positions the four column types into\n! four uniform groups (although one or more of these groups may be\n! empty).\n!\n DO 110 J = 1, 4\n CTOT( J ) = 0\n110 CONTINUE\n DO 120 J = 1, N\n CT = COLTYP( J )\n CTOT( CT ) = CTOT( CT ) + 1\n120 CONTINUE\n!\n! PSM(*) = Position in SubMatrix (of types 1 through 4)\n!\n PSM( 1 ) = 1\n PSM( 2 ) = 1 + CTOT( 1 )\n PSM( 3 ) = PSM( 2 ) + CTOT( 2 )\n PSM( 4 ) = PSM( 3 ) + CTOT( 3 )\n K = N - CTOT( 4 )\n!\n! Fill out the INDXC array so that the permutation which it induces\n! will place all type-1 columns first, all type-2 columns next,\n! then all type-3's, and finally all type-4's.\n!\n DO 130 J = 1, N\n JS = INDXP( J )\n CT = COLTYP( JS )\n INDX( PSM( CT ) ) = JS\n INDXC( PSM( CT ) ) = J\n PSM( CT ) = PSM( CT ) + 1\n130 CONTINUE\n!\n! Sort the eigenvalues and corresponding eigenvectors into DLAMDA\n! and Q2 respectively. The eigenvalues/vectors which were not\n! deflated go into the first K slots of DLAMDA and Q2 respectively,\n! while those which were deflated go into the last N - K slots.\n!\n I = 1\n IQ1 = 1\n IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1\n DO 140 J = 1, CTOT( 1 )\n JS = INDX( I )\n CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )\n Z( I ) = D( JS )\n I = I + 1\n IQ1 = IQ1 + N1\n140 CONTINUE\n!\n DO 150 J = 1, CTOT( 2 )\n JS = INDX( I )\n CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )\n CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )\n Z( I ) = D( JS )\n I = I + 1\n IQ1 = IQ1 + N1\n IQ2 = IQ2 + N2\n150 CONTINUE\n!\n DO 160 J = 1, CTOT( 3 )\n JS = INDX( I )\n CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )\n Z( I ) = D( JS )\n I = I + 1\n IQ2 = IQ2 + N2\n160 CONTINUE\n!\n IQ1 = IQ2\n DO 170 J = 1, CTOT( 4 )\n JS = INDX( I )\n CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )\n IQ2 = IQ2 + N\n Z( I ) = D( JS )\n I = I + 1\n170 CONTINUE\n!\n! The deflated eigenvalues and their corresponding vectors go back\n! into the last N - K slots of D and Q respectively.\n!\n IF( K.LT.N ) THEN\n CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, &\n Q( 1, K+1 ), LDQ )\n CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )\n END IF\n!\n! Copy CTOT into COLTYP for referencing in DLAED3.\n!\n DO 180 J = 1, 4\n COLTYP( J ) = CTOT( J )\n180 CONTINUE\n!\n190 CONTINUE\n RETURN\n!\n! End of DLAED2\n!\n END SUBROUTINE DLAED2\n!\n!=\n!\n!> \\brief \\b DLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED3 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,\n! CTOT, W, S, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, K, LDQ, N, N1\n! DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n! INTEGER CTOT( * ), INDX( * )\n! DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),\n! $ S( * ), W( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED3 finds the roots of the secular equation, as defined by the\n!> values in D, W, and RHO, between 1 and K. It makes the\n!> appropriate calls to DLAED4 and then updates the eigenvectors by\n!> multiplying the matrix of eigenvectors of the pair of eigensystems\n!> being combined by the matrix of eigenvectors of the K-by-K system\n!> which is solved here.\n!>\n!> This code makes very mild assumptions about floating point\n!> arithmetic. It will work on machines with a guard digit in\n!> add/subtract, or on those binary machines without guard digits\n!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n!> It could conceivably fail on hexadecimal or decimal machines\n!> without guard digits, but we know of none.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of terms in the rational function to be solved by\n!> DLAED4. K >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of rows and columns in the Q matrix.\n!> N >= K (deflation may result in N>K).\n!> \\endverbatim\n!>\n!> \\param[in] N1\n!> \\verbatim\n!> N1 is INTEGER\n!> The location of the last eigenvalue in the leading submatrix.\n!> min(1,N) <= N1 <= N/2.\n!> \\endverbatim\n!>\n!> \\param[out] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> D(I) contains the updated eigenvalues for\n!> 1 <= I <= K.\n!> \\endverbatim\n!>\n!> \\param[out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ,N)\n!> Initially the first K columns are used as workspace.\n!> On output the columns 1 to K contain\n!> the updated eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The value of the parameter in the rank one update equation.\n!> RHO >= 0 required.\n!> \\endverbatim\n!>\n!> \\param[in,out] DLAMDA\n!> \\verbatim\n!> DLAMDA is DOUBLE PRECISION array, dimension (K)\n!> The first K elements of this array contain the old roots\n!> of the deflated updating problem. These are the poles\n!> of the secular equation. May be changed on output by\n!> having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n!> Cray-2, or Cray C-90, as described above.\n!> \\endverbatim\n!>\n!> \\param[in] Q2\n!> \\verbatim\n!> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)\n!> The first K columns of this matrix contain the non-deflated\n!> eigenvectors for the split problem.\n!> \\endverbatim\n!>\n!> \\param[in] INDX\n!> \\verbatim\n!> INDX is INTEGER array, dimension (N)\n!> The permutation used to arrange the columns of the deflated\n!> Q matrix into three groups (see DLAED2).\n!> The rows of the eigenvectors found by DLAED4 must be likewise\n!> permuted before the matrix multiply can take place.\n!> \\endverbatim\n!>\n!> \\param[in] CTOT\n!> \\verbatim\n!> CTOT is INTEGER array, dimension (4)\n!> A count of the total number of the various types of columns\n!> in Q, as described in INDX. The fourth column type is any\n!> column which has been deflated.\n!> \\endverbatim\n!>\n!> \\param[in,out] W\n!> \\verbatim\n!> W is DOUBLE PRECISION array, dimension (K)\n!> The first K elements of this array contain the components\n!> of the deflation-adjusted updating vector. Destroyed on\n!> output.\n!> \\endverbatim\n!>\n!> \\param[out] S\n!> \\verbatim\n!> S is DOUBLE PRECISION array, dimension (N1 + 1)*K\n!> Will contain the eigenvectors of the repaired matrix which\n!> will be multiplied by the previously accumulated eigenvectors\n!> to update the system.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> > 0: if INFO = 1, an eigenvalue did not converge\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA \\n\n!> Modified by Francoise Tisseur, University of Tennessee\n!>\n! =====================================================================\n SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,&\n CTOT, W, S, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, K, LDQ, N, N1\n DOUBLE PRECISION RHO\n! ..\n! .. Array Arguments ..\n INTEGER CTOT( * ), INDX( * )\n DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),&\n S( * ), W( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, II, IQ2, J, N12, N2, N23\n DOUBLE PRECISION TEMP\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMC3, DNRM2\n! EXTERNAL DLAMC3, DNRM2\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, SIGN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( K.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.K ) THEN\n INFO = -2\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -6\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAED3', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( K.EQ.0 ) RETURN\n!\n! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can\n! be computed with high relative accuracy (barring over/underflow).\n! This is a problem on machines without a guard digit in\n! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).\n! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),\n! which on any of these machines zeros out the bottommost\n! bit of DLAMDA(I) if it is 1; this makes the subsequent\n! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation\n! occurs. On binary machines with a guard digit (almost all\n! machines) it does not change DLAMDA(I) at all. On hexadecimal\n! and decimal machines with a guard digit, it slightly\n! changes the bottommost bits of DLAMDA(I). It does not account\n! for hexadecimal or decimal machines without guard digits\n! (we know of none). We use a subroutine call to compute\n! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating\n! this code.\n!\n DO 10 I = 1, K\n DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )\n10 CONTINUE\n!\n DO 20 J = 1, K\n CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )\n!\n! If the zero finder fails, the computation is terminated.\n!\n IF( INFO.NE.0 ) GO TO 120\n20 CONTINUE\n!\n IF( K.EQ.1 ) GO TO 110\n IF( K.EQ.2 ) THEN\n DO 30 J = 1, K\n W( 1 ) = Q( 1, J )\n W( 2 ) = Q( 2, J )\n II = INDX( 1 )\n Q( 1, J ) = W( II )\n II = INDX( 2 )\n Q( 2, J ) = W( II )\n30 CONTINUE\n GO TO 110\n END IF\n!\n! Compute updated W.\n!\n CALL DCOPY( K, W, 1, S, 1 )\n!\n! Initialize W(I) = Q(I,I)\n!\n CALL DCOPY( K, Q, LDQ+1, W, 1 )\n DO 60 J = 1, K\n DO 40 I = 1, J - 1\n W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )\n40 CONTINUE\n DO 50 I = J + 1, K\n W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )\n50 CONTINUE\n60 CONTINUE\n DO 70 I = 1, K\n W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )\n70 CONTINUE\n!\n! Compute eigenvectors of the modified rank-1 modification.\n!\n DO 100 J = 1, K\n DO 80 I = 1, K\n S( I ) = W( I ) / Q( I, J )\n80 CONTINUE\n TEMP = DNRM2( K, S, 1 )\n DO 90 I = 1, K\n II = INDX( I )\n Q( I, J ) = S( II ) / TEMP\n90 CONTINUE\n100 CONTINUE\n!\n! Compute the updated eigenvectors.\n!\n110 CONTINUE\n!\n N2 = N - N1\n N12 = CTOT( 1 ) + CTOT( 2 )\n N23 = CTOT( 2 ) + CTOT( 3 )\n!\n CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )\n IQ2 = N1*N12 + 1\n IF( N23.NE.0 ) THEN\n CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,&\n ZERO, Q( N1+1, 1 ), LDQ )\n ELSE\n CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )\n END IF\n!\n CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )\n IF( N12.NE.0 ) THEN\n CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,&\n LDQ )\n ELSE\n CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )\n END IF\n!\n!\n120 CONTINUE\n RETURN\n!\n! End of DLAED3\n!\n END SUBROUTINE DLAED3\n!\n!=\n!\n!> \\brief \\b DLAED4 used by sstedc. Finds a single root of the secular equation.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED4 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER I, INFO, N\n! DOUBLE PRECISION DLAM, RHO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( * ), DELTA( * ), Z( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> This subroutine computes the I-th updated eigenvalue of a symmetric\n!> rank-one modification to a diagonal matrix whose elements are\n!> given in the array d, and that\n!>\n!> D(i) < D(j) for i < j\n!>\n!> and that RHO > 0. This is arranged by the calling routine, and is\n!> no loss in generality. The rank-one modified system is thus\n!>\n!> diag( D ) + RHO * Z * Z_transpose.\n!>\n!> where we assume the Euclidean norm of Z is 1.\n!>\n!> The method consists of approximating the rational functions in the\n!> secular equation by simpler interpolating rational functions.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The length of all arrays.\n!> \\endverbatim\n!>\n!> \\param[in] I\n!> \\verbatim\n!> I is INTEGER\n!> The index of the eigenvalue to be computed. 1 <= I <= N.\n!> \\endverbatim\n!>\n!> \\param[in] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (N)\n!> The original eigenvalues. It is assumed that they are in\n!> order, D(I) < D(J) for I < J.\n!> \\endverbatim\n!>\n!> \\param[in] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (N)\n!> The components of the updating vector.\n!> \\endverbatim\n!>\n!> \\param[out] DELTA\n!> \\verbatim\n!> DELTA is DOUBLE PRECISION array, dimension (N)\n!> If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n!> component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5\n!> for detail. The vector DELTA contains the information necessary\n!> to construct the eigenvectors by DLAED3 and DLAED9.\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The scalar in the symmetric updating formula.\n!> \\endverbatim\n!>\n!> \\param[out] DLAM\n!> \\verbatim\n!> DLAM is DOUBLE PRECISION\n!> The computed lambda_I, the I-th updated eigenvalue.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> > 0: if INFO = 1, the updating process failed.\n!> \\endverbatim\n!\n!> \\par Internal Parameters:\n! =========================\n!>\n!> \\verbatim\n!> Logical variable ORGATI (origin-at-i?) is used for distinguishing\n!> whether D(i) or D(i+1) is treated as the origin.\n!>\n!> ORGATI = .true. origin at i\n!> ORGATI = .false. origin at i+1\n!>\n!> Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n!> if we are working with THREE poles!\n!>\n!> MAXIT is the maximum number of iterations allowed for each\n!> eigenvalue.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Ren-Cang Li, Computer Science Division, University of California\n!> at Berkeley, USA\n!>\n! =====================================================================\n SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER I, INFO, N\n DOUBLE PRECISION DLAM, RHO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( * ), DELTA( * ), Z( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n INTEGER MAXIT\n PARAMETER ( MAXIT = 30 )\n DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,&\n THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,&\n TEN = 10.0D0 )\n! ..\n! .. Local Scalars ..\n LOGICAL ORGATI, SWTCH, SWTCH3\n INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER\n DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,&\n EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,&\n RHOINV, TAU, TEMP, TEMP1, W\n! ..\n! .. Local Arrays ..\n DOUBLE PRECISION ZZ( 3 )\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMCH\n! EXTERNAL DLAMCH\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLAED5, DLAED6\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Since this routine is called in an inner loop, we do no argument\n! checking.\n!\n! Quick return for N=1 and 2.\n!\n INFO = 0\n IF( N.EQ.1 ) THEN\n!\n! Presumably, I=1 upon entry\n!\n DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )\n DELTA( 1 ) = ONE\n RETURN\n END IF\n IF( N.EQ.2 ) THEN\n CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )\n RETURN\n END IF\n!\n! Compute machine epsilon\n!\n EPS = DLAMCH( 'Epsilon' )\n RHOINV = ONE / RHO\n!\n! The case I = N\n!\n IF( I.EQ.N ) THEN\n!\n! Initialize some basic variables\n!\n II = N - 1\n NITER = 1\n!\n! Calculate initial guess\n!\n MIDPT = RHO / TWO\n!\n! If ||Z||_2 is not one, then TEMP should be set to\n! RHO * ||Z||_2^2 / TWO\n!\n DO 10 J = 1, N\n DELTA( J ) = ( D( J )-D( I ) ) - MIDPT\n10 CONTINUE\n!\n PSI = ZERO\n DO 20 J = 1, N - 2\n PSI = PSI + Z( J )*Z( J ) / DELTA( J )\n20 CONTINUE\n!\n C = RHOINV + PSI\n W = C + Z( II )*Z( II ) / DELTA( II ) +&\n Z( N )*Z( N ) / DELTA( N )\n!\n IF( W.LE.ZERO ) THEN\n TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +&\n Z( N )*Z( N ) / RHO\n IF( C.LE.TEMP ) THEN\n TAU = RHO\n ELSE\n DEL = D( N ) - D( N-1 )\n A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )\n B = Z( N )*Z( N )*DEL\n IF( A.LT.ZERO ) THEN\n TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )\n ELSE\n TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )\n END IF\n END IF\n!\n! It can be proved that\n! D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO\n!\n DLTLB = MIDPT\n DLTUB = RHO\n ELSE\n DEL = D( N ) - D( N-1 )\n A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )\n B = Z( N )*Z( N )*DEL\n IF( A.LT.ZERO ) THEN\n TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )\n ELSE\n TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )\n END IF\n!\n! It can be proved that\n! D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2\n!\n DLTLB = ZERO\n DLTUB = MIDPT\n END IF\n!\n DO 30 J = 1, N\n DELTA( J ) = ( D( J )-D( I ) ) - TAU\n30 CONTINUE\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 40 J = 1, II\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n40 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n TEMP = Z( N ) / DELTA( N )\n PHI = Z( N )*TEMP\n DPHI = TEMP*TEMP\n ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +&\n ABS( TAU )*( DPSI+DPHI )\n!\n W = RHOINV + PHI + PSI\n!\n! Test for convergence\n!\n IF( ABS( W ).LE.EPS*ERRETM ) THEN\n DLAM = D( I ) + TAU\n GO TO 250\n END IF\n!\n IF( W.LE.ZERO ) THEN\n DLTLB = MAX( DLTLB, TAU )\n ELSE\n DLTUB = MIN( DLTUB, TAU )\n END IF\n!\n! Calculate the new step\n!\n NITER = NITER + 1\n C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI\n A = ( DELTA( N-1 )+DELTA( N ) )*W -&\n DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )\n B = DELTA( N-1 )*DELTA( N )*W\n IF( C.LT.ZERO ) C = ABS( C )\n IF( C.EQ.ZERO ) THEN\n! ETA = B/A\n! ETA = RHO - TAU\n ETA = DLTUB - TAU\n ELSE IF( A.GE.ZERO ) THEN\n ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n!\n! Note, eta should be positive if w is negative, and\n! eta should be negative otherwise. However,\n! if for some reason caused by roundoff, eta*w > 0,\n! we simply use one Newton step instead. This way\n! will guarantee eta*w < 0.\n!\n IF( W*ETA.GT.ZERO ) ETA = -W / ( DPSI+DPHI )\n TEMP = TAU + ETA\n IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN\n IF( W.LT.ZERO ) THEN\n ETA = ( DLTUB-TAU ) / TWO\n ELSE\n ETA = ( DLTLB-TAU ) / TWO\n END IF\n END IF\n DO 50 J = 1, N\n DELTA( J ) = DELTA( J ) - ETA\n50 CONTINUE\n!\n TAU = TAU + ETA\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 60 J = 1, II\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n60 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n TEMP = Z( N ) / DELTA( N )\n PHI = Z( N )*TEMP\n DPHI = TEMP*TEMP\n ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +&\n ABS( TAU )*( DPSI+DPHI )\n!\n W = RHOINV + PHI + PSI\n!\n! Main loop to update the values of the array DELTA\n!\n ITER = NITER + 1\n!\n DO 90 NITER = ITER, MAXIT\n!\n! Test for convergence\n!\n IF( ABS( W ).LE.EPS*ERRETM ) THEN\n DLAM = D( I ) + TAU\n GO TO 250\n END IF\n!\n IF( W.LE.ZERO ) THEN\n DLTLB = MAX( DLTLB, TAU )\n ELSE\n DLTUB = MIN( DLTUB, TAU )\n END IF\n!\n! Calculate the new step\n!\n C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI\n A = ( DELTA( N-1 )+DELTA( N ) )*W -&\n DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )\n B = DELTA( N-1 )*DELTA( N )*W\n IF( A.GE.ZERO ) THEN\n ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n!\n! Note, eta should be positive if w is negative, and\n! eta should be negative otherwise. However,\n! if for some reason caused by roundoff, eta*w > 0,\n! we simply use one Newton step instead. This way\n! will guarantee eta*w < 0.\n!\n IF( W*ETA.GT.ZERO )&\n ETA = -W / ( DPSI+DPHI )\n TEMP = TAU + ETA\n IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN\n IF( W.LT.ZERO ) THEN\n ETA = ( DLTUB-TAU ) / TWO\n ELSE\n ETA = ( DLTLB-TAU ) / TWO\n END IF\n END IF\n DO 70 J = 1, N\n DELTA( J ) = DELTA( J ) - ETA\n70 CONTINUE\n!\n TAU = TAU + ETA\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 80 J = 1, II\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n80 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n TEMP = Z( N ) / DELTA( N )\n PHI = Z( N )*TEMP\n DPHI = TEMP*TEMP\n ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +&\n ABS( TAU )*( DPSI+DPHI )\n!\n W = RHOINV + PHI + PSI\n90 CONTINUE\n!\n! Return with INFO = 1, NITER = MAXIT and not converged\n!\n INFO = 1\n DLAM = D( I ) + TAU\n GO TO 250\n!\n! End for the case I = N\n!\n ELSE\n!\n! The case for I < N\n!\n NITER = 1\n IP1 = I + 1\n!\n! Calculate initial guess\n!\n DEL = D( IP1 ) - D( I )\n MIDPT = DEL / TWO\n DO 100 J = 1, N\n DELTA( J ) = ( D( J )-D( I ) ) - MIDPT\n100 CONTINUE\n!\n PSI = ZERO\n DO 110 J = 1, I - 1\n PSI = PSI + Z( J )*Z( J ) / DELTA( J )\n110 CONTINUE\n!\n PHI = ZERO\n DO 120 J = N, I + 2, -1\n PHI = PHI + Z( J )*Z( J ) / DELTA( J )\n120 CONTINUE\n C = RHOINV + PSI + PHI\n W = C + Z( I )*Z( I ) / DELTA( I ) +&\n Z( IP1 )*Z( IP1 ) / DELTA( IP1 )\n!\n IF( W.GT.ZERO ) THEN\n!\n! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2\n!\n! We choose d(i) as origin.\n!\n ORGATI = .TRUE.\n A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )\n B = Z( I )*Z( I )*DEL\n IF( A.GT.ZERO ) THEN\n TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )\n ELSE\n TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n END IF\n DLTLB = ZERO\n DLTUB = MIDPT\n ELSE\n!\n! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)\n!\n! We choose d(i+1) as origin.\n!\n ORGATI = .FALSE.\n A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )\n B = Z( IP1 )*Z( IP1 )*DEL\n IF( A.LT.ZERO ) THEN\n TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )\n ELSE\n TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )\n END IF\n DLTLB = -MIDPT\n DLTUB = ZERO\n END IF\n!\n IF( ORGATI ) THEN\n DO 130 J = 1, N\n DELTA( J ) = ( D( J )-D( I ) ) - TAU\n130 CONTINUE\n ELSE\n DO 140 J = 1, N\n DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU\n140 CONTINUE\n END IF\n IF( ORGATI ) THEN\n II = I\n ELSE\n II = I + 1\n END IF\n IIM1 = II - 1\n IIP1 = II + 1\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 150 J = 1, IIM1\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n150 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n DPHI = ZERO\n PHI = ZERO\n DO 160 J = N, IIP1, -1\n TEMP = Z( J ) / DELTA( J )\n PHI = PHI + Z( J )*TEMP\n DPHI = DPHI + TEMP*TEMP\n ERRETM = ERRETM + PHI\n160 CONTINUE\n!\n W = RHOINV + PHI + PSI\n!\n! W is the value of the secular function with\n! its ii-th element removed.\n!\n SWTCH3 = .FALSE.\n IF( ORGATI ) THEN\n IF( W.LT.ZERO ) SWTCH3 = .TRUE.\n ELSE\n IF( W.GT.ZERO ) SWTCH3 = .TRUE.\n END IF\n IF( II.EQ.1 .OR. II.EQ.N ) SWTCH3 = .FALSE.\n!\n TEMP = Z( II ) / DELTA( II )\n DW = DPSI + DPHI + TEMP*TEMP\n TEMP = Z( II )*TEMP\n W = W + TEMP\n ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +&\n THREE*ABS( TEMP ) + ABS( TAU )*DW\n!\n! Test for convergence\n!\n IF( ABS( W ).LE.EPS*ERRETM ) THEN\n IF( ORGATI ) THEN\n DLAM = D( I ) + TAU\n ELSE\n DLAM = D( IP1 ) + TAU\n END IF\n GO TO 250\n END IF\n!\n IF( W.LE.ZERO ) THEN\n DLTLB = MAX( DLTLB, TAU )\n ELSE\n DLTUB = MIN( DLTUB, TAU )\n END IF\n!\n! Calculate the new step\n!\n NITER = NITER + 1\n IF( .NOT.SWTCH3 ) THEN\n IF( ORGATI ) THEN\n C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*&\n ( Z( I ) / DELTA( I ) )**2\n ELSE\n C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*&\n ( Z( IP1 ) / DELTA( IP1 ) )**2\n END IF\n A = ( DELTA( I )+DELTA( IP1 ) )*W -&\n DELTA( I )*DELTA( IP1 )*DW\n B = DELTA( I )*DELTA( IP1 )*W\n IF( C.EQ.ZERO ) THEN\n IF( A.EQ.ZERO ) THEN\n IF( ORGATI ) THEN\n A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*&\n ( DPSI+DPHI )\n ELSE\n A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*&\n ( DPSI+DPHI )\n END IF\n END IF\n ETA = B / A\n ELSE IF( A.LE.ZERO ) THEN\n ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n ELSE\n!\n! Interpolation using THREE most relevant poles\n!\n TEMP = RHOINV + PSI + PHI\n IF( ORGATI ) THEN\n TEMP1 = Z( IIM1 ) / DELTA( IIM1 )\n TEMP1 = TEMP1*TEMP1\n C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -&\n ( D( IIM1 )-D( IIP1 ) )*TEMP1\n ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )\n ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*&\n ( ( DPSI-TEMP1 )+DPHI )\n ELSE\n TEMP1 = Z( IIP1 ) / DELTA( IIP1 )\n TEMP1 = TEMP1*TEMP1\n C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -&\n ( D( IIP1 )-D( IIM1 ) )*TEMP1\n ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*&\n ( DPSI+( DPHI-TEMP1 ) )\n ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )\n END IF\n ZZ( 2 ) = Z( II )*Z( II )\n CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,&\n INFO )\n IF( INFO.NE.0 ) GO TO 250\n END IF\n!\n! Note, eta should be positive if w is negative, and\n! eta should be negative otherwise. However,\n! if for some reason caused by roundoff, eta*w > 0,\n! we simply use one Newton step instead. This way\n! will guarantee eta*w < 0.\n!\n IF( W*ETA.GE.ZERO ) ETA = -W / DW\n TEMP = TAU + ETA\n IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN\n IF( W.LT.ZERO ) THEN\n ETA = ( DLTUB-TAU ) / TWO\n ELSE\n ETA = ( DLTLB-TAU ) / TWO\n END IF\n END IF\n!\n PREW = W\n!\n DO 180 J = 1, N\n DELTA( J ) = DELTA( J ) - ETA\n180 CONTINUE\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 190 J = 1, IIM1\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n190 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n DPHI = ZERO\n PHI = ZERO\n DO 200 J = N, IIP1, -1\n TEMP = Z( J ) / DELTA( J )\n PHI = PHI + Z( J )*TEMP\n DPHI = DPHI + TEMP*TEMP\n ERRETM = ERRETM + PHI\n200 CONTINUE\n!\n TEMP = Z( II ) / DELTA( II )\n DW = DPSI + DPHI + TEMP*TEMP\n TEMP = Z( II )*TEMP\n W = RHOINV + PHI + PSI + TEMP\n ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +&\n THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW\n!\n SWTCH = .FALSE.\n IF( ORGATI ) THEN\n IF( -W.GT.ABS( PREW ) / TEN ) SWTCH = .TRUE.\n ELSE\n IF( W.GT.ABS( PREW ) / TEN ) SWTCH = .TRUE.\n END IF\n!\n TAU = TAU + ETA\n!\n! Main loop to update the values of the array DELTA\n!\n ITER = NITER + 1\n!\n DO 240 NITER = ITER, MAXIT\n!\n! Test for convergence\n!\n IF( ABS( W ).LE.EPS*ERRETM ) THEN\n IF( ORGATI ) THEN\n DLAM = D( I ) + TAU\n ELSE\n DLAM = D( IP1 ) + TAU\n END IF\n GO TO 250\n END IF\n!\n IF( W.LE.ZERO ) THEN\n DLTLB = MAX( DLTLB, TAU )\n ELSE\n DLTUB = MIN( DLTUB, TAU )\n END IF\n!\n! Calculate the new step\n!\n IF( .NOT.SWTCH3 ) THEN\n IF( .NOT.SWTCH ) THEN\n IF( ORGATI ) THEN\n C = W - DELTA( IP1 )*DW -&\n ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2\n ELSE\n C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*&\n ( Z( IP1 ) / DELTA( IP1 ) )**2\n END IF\n ELSE\n TEMP = Z( II ) / DELTA( II )\n IF( ORGATI ) THEN\n DPSI = DPSI + TEMP*TEMP\n ELSE\n DPHI = DPHI + TEMP*TEMP\n END IF\n C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI\n END IF\n A = ( DELTA( I )+DELTA( IP1 ) )*W -&\n DELTA( I )*DELTA( IP1 )*DW\n B = DELTA( I )*DELTA( IP1 )*W\n IF( C.EQ.ZERO ) THEN\n IF( A.EQ.ZERO ) THEN\n IF( .NOT.SWTCH ) THEN\n IF( ORGATI ) THEN\n A = Z( I )*Z( I ) + DELTA( IP1 )*&\n DELTA( IP1 )*( DPSI+DPHI )\n ELSE\n A = Z( IP1 )*Z( IP1 ) +&\n DELTA( I )*DELTA( I )*( DPSI+DPHI )\n END IF\n ELSE\n A = DELTA( I )*DELTA( I )*DPSI +&\n DELTA( IP1 )*DELTA( IP1 )*DPHI\n END IF\n END IF\n ETA = B / A\n ELSE IF( A.LE.ZERO ) THEN\n ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n ELSE\n!\n! Interpolation using THREE most relevant poles\n!\n TEMP = RHOINV + PSI + PHI\n IF( SWTCH ) THEN\n C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI\n ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI\n ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI\n ELSE\n IF( ORGATI ) THEN\n TEMP1 = Z( IIM1 ) / DELTA( IIM1 )\n TEMP1 = TEMP1*TEMP1\n C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -&\n ( D( IIM1 )-D( IIP1 ) )*TEMP1\n ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )\n ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*&\n ( ( DPSI-TEMP1 )+DPHI )\n ELSE\n TEMP1 = Z( IIP1 ) / DELTA( IIP1 )\n TEMP1 = TEMP1*TEMP1\n C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -&\n ( D( IIP1 )-D( IIM1 ) )*TEMP1\n ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*&\n ( DPSI+( DPHI-TEMP1 ) )\n ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )\n END IF\n END IF\n CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,&\n INFO )\n IF( INFO.NE.0 ) GO TO 250\n END IF\n!\n! Note, eta should be positive if w is negative, and\n! eta should be negative otherwise. However,\n! if for some reason caused by roundoff, eta*w > 0,\n! we simply use one Newton step instead. This way\n! will guarantee eta*w < 0.\n!\n IF( W*ETA.GE.ZERO ) ETA = -W / DW\n TEMP = TAU + ETA\n IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN\n IF( W.LT.ZERO ) THEN\n ETA = ( DLTUB-TAU ) / TWO\n ELSE\n ETA = ( DLTLB-TAU ) / TWO\n END IF\n END IF\n!\n DO 210 J = 1, N\n DELTA( J ) = DELTA( J ) - ETA\n210 CONTINUE\n!\n TAU = TAU + ETA\n PREW = W\n!\n! Evaluate PSI and the derivative DPSI\n!\n DPSI = ZERO\n PSI = ZERO\n ERRETM = ZERO\n DO 220 J = 1, IIM1\n TEMP = Z( J ) / DELTA( J )\n PSI = PSI + Z( J )*TEMP\n DPSI = DPSI + TEMP*TEMP\n ERRETM = ERRETM + PSI\n220 CONTINUE\n ERRETM = ABS( ERRETM )\n!\n! Evaluate PHI and the derivative DPHI\n!\n DPHI = ZERO\n PHI = ZERO\n DO 230 J = N, IIP1, -1\n TEMP = Z( J ) / DELTA( J )\n PHI = PHI + Z( J )*TEMP\n DPHI = DPHI + TEMP*TEMP\n ERRETM = ERRETM + PHI\n230 CONTINUE\n!\n TEMP = Z( II ) / DELTA( II )\n DW = DPSI + DPHI + TEMP*TEMP\n TEMP = Z( II )*TEMP\n W = RHOINV + PHI + PSI + TEMP\n ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +&\n THREE*ABS( TEMP ) + ABS( TAU )*DW\n IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) &\n SWTCH = .NOT.SWTCH\n!\n240 CONTINUE\n!\n! Return with INFO = 1, NITER = MAXIT and not converged\n!\n INFO = 1\n IF( ORGATI ) THEN\n DLAM = D( I ) + TAU\n ELSE\n DLAM = D( IP1 ) + TAU\n END IF\n!\n END IF\n!\n250 CONTINUE\n!\n RETURN\n!\n! End of DLAED4\n!\n END SUBROUTINE DLAED4\n!\n!=\n!\n!> \\brief \\b DLAED5 used by sstedc. Solves the 2-by-2 secular equation.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED5 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n! \n! .. Scalar Arguments ..\n! INTEGER I\n! DOUBLE PRECISION DLAM, RHO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> This subroutine computes the I-th eigenvalue of a symmetric rank-one\n!> modification of a 2-by-2 diagonal matrix\n!>\n!> diag( D ) + RHO * Z * transpose(Z) .\n!>\n!> The diagonal elements in the array D are assumed to satisfy\n!>\n!> D(i) < D(j) for i < j .\n!>\n!> We also assume RHO > 0 and that the Euclidean norm of the vector\n!> Z is one.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] I\n!> \\verbatim\n!> I is INTEGER\n!> The index of the eigenvalue to be computed. I = 1 or I = 2.\n!> \\endverbatim\n!>\n!> \\param[in] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (2)\n!> The original eigenvalues. We assume D(1) < D(2).\n!> \\endverbatim\n!>\n!> \\param[in] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (2)\n!> The components of the updating vector.\n!> \\endverbatim\n!>\n!> \\param[out] DELTA\n!> \\verbatim\n!> DELTA is DOUBLE PRECISION array, dimension (2)\n!> The vector DELTA contains the information necessary\n!> to construct the eigenvectors.\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> The scalar in the symmetric updating formula.\n!> \\endverbatim\n!>\n!> \\param[out] DLAM\n!> \\verbatim\n!> DLAM is DOUBLE PRECISION\n!> The computed lambda_I, the I-th updated eigenvalue.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Ren-Cang Li, Computer Science Division, University of California\n!> at Berkeley, USA\n!>\n! =====================================================================\n SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER I\n DOUBLE PRECISION DLAM, RHO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE, TWO, FOUR\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,&\n FOUR = 4.0D0 )\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION B, C, DEL, TAU, TEMP, W\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, SQRT\n! ..\n! .. Executable Statements ..\n!\n DEL = D( 2 ) - D( 1 )\n IF( I.EQ.1 ) THEN\n W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL\n IF( W.GT.ZERO ) THEN\n B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )\n C = RHO*Z( 1 )*Z( 1 )*DEL\n!\n! B > ZERO, always\n!\n TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )\n DLAM = D( 1 ) + TAU\n DELTA( 1 ) = -Z( 1 ) / TAU\n DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )\n ELSE\n B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )\n C = RHO*Z( 2 )*Z( 2 )*DEL\n IF( B.GT.ZERO ) THEN\n TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )\n ELSE\n TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO\n END IF\n DLAM = D( 2 ) + TAU\n DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )\n DELTA( 2 ) = -Z( 2 ) / TAU\n END IF\n TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )\n DELTA( 1 ) = DELTA( 1 ) / TEMP\n DELTA( 2 ) = DELTA( 2 ) / TEMP\n ELSE\n!\n! Now I=2\n!\n B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )\n C = RHO*Z( 2 )*Z( 2 )*DEL\n IF( B.GT.ZERO ) THEN\n TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO\n ELSE\n TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )\n END IF\n DLAM = D( 2 ) + TAU\n DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )\n DELTA( 2 ) = -Z( 2 ) / TAU\n TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )\n DELTA( 1 ) = DELTA( 1 ) / TEMP\n DELTA( 2 ) = DELTA( 2 ) / TEMP\n END IF\n RETURN\n!\n! End OF DLAED5\n!\n END SUBROUTINE DLAED5\n!=\n!> \\brief \\b DLAED6 used by sstedc. Computes one Newton step in solution of the secular equation.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAED6 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n! \n! .. Scalar Arguments ..\n! LOGICAL ORGATI\n! INTEGER INFO, KNITER\n! DOUBLE PRECISION FINIT, RHO, TAU\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION D( 3 ), Z( 3 )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAED6 computes the positive or negative root (closest to the origin)\n!> of\n!> z(1) z(2) z(3)\n!> f(x) = rho + --------- + ---------- + ---------\n!> d(1)-x d(2)-x d(3)-x\n!>\n!> It is assumed that\n!>\n!> if ORGATI = .true. the root is between d(2) and d(3);\n!> otherwise it is between d(1) and d(2)\n!>\n!> This routine will be called by DLAED4 when necessary. In most cases,\n!> the root sought is the smallest in magnitude, though it might not be\n!> in some extremely rare situations.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] KNITER\n!> \\verbatim\n!> KNITER is INTEGER\n!> Refer to DLAED4 for its significance.\n!> \\endverbatim\n!>\n!> \\param[in] ORGATI\n!> \\verbatim\n!> ORGATI is LOGICAL\n!> If ORGATI is true, the needed root is between d(2) and\n!> d(3); otherwise it is between d(1) and d(2). See\n!> DLAED4 for further details.\n!> \\endverbatim\n!>\n!> \\param[in] RHO\n!> \\verbatim\n!> RHO is DOUBLE PRECISION\n!> Refer to the equation f(x) above.\n!> \\endverbatim\n!>\n!> \\param[in] D\n!> \\verbatim\n!> D is DOUBLE PRECISION array, dimension (3)\n!> D satisfies d(1) < d(2) < d(3).\n!> \\endverbatim\n!>\n!> \\param[in] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (3)\n!> Each of the elements in z must be positive.\n!> \\endverbatim\n!>\n!> \\param[in] FINIT\n!> \\verbatim\n!> FINIT is DOUBLE PRECISION\n!> The value of f at 0. It is more accurate than the one\n!> evaluated inside this routine (if someone wants to do\n!> so).\n!> \\endverbatim\n!>\n!> \\param[out] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION\n!> The root of the equation f(x).\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> > 0: if INFO = 1, failure to converge\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2015\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> 10/02/03: This version has a few statements commented out for thread\n!> safety (machine parameters are computed on each entry). SJH.\n!>\n!> 05/10/06: Modified from a new version of Ren-Cang Li, use\n!> Gragg-Thornton-Warner cubic convergent scheme for better stability.\n!> \\endverbatim\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Ren-Cang Li, Computer Science Division, University of California\n!> at Berkeley, USA\n!>\n! =====================================================================\n SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n!\n! -- LAPACK computational routine (version 3.6.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2015\n!\n! .. Scalar Arguments ..\n LOGICAL ORGATI\n INTEGER INFO, KNITER\n DOUBLE PRECISION FINIT, RHO, TAU\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION D( 3 ), Z( 3 )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n INTEGER MAXIT\n PARAMETER ( MAXIT = 40 )\n DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,&\n THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )\n! ..\n! .. External Functions ..\n! DOUBLE PRECISION DLAMCH\n! EXTERNAL DLAMCH\n! ..\n! .. Local Arrays ..\n DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )\n! ..\n! .. Local Scalars ..\n LOGICAL SCALE\n INTEGER I, ITER, NITER\n DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,&\n FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,&\n SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, &\n LBD, UBD\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT\n! ..\n! .. Executable Statements ..\n!\n INFO = 0\n!\n IF( ORGATI ) THEN\n LBD = D(2)\n UBD = D(3)\n ELSE\n LBD = D(1)\n UBD = D(2)\n END IF\n IF( FINIT .LT. ZERO )THEN\n LBD = ZERO\n ELSE\n UBD = ZERO \n END IF\n!\n NITER = 1\n TAU = ZERO\n IF( KNITER.EQ.2 ) THEN\n IF( ORGATI ) THEN\n TEMP = ( D( 3 )-D( 2 ) ) / TWO\n C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )\n A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )\n B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )\n ELSE\n TEMP = ( D( 1 )-D( 2 ) ) / TWO\n C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )\n A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )\n B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )\n END IF\n TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )\n A = A / TEMP\n B = B / TEMP\n C = C / TEMP\n IF( C.EQ.ZERO ) THEN\n TAU = B / A\n ELSE IF( A.LE.ZERO ) THEN\n TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n IF( TAU .LT. LBD .OR. TAU .GT. UBD ) TAU = ( LBD+UBD )/TWO\n IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN\n TAU = ZERO\n ELSE\n TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +&\n TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +&\n TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )\n IF( TEMP .LE. ZERO )THEN\n LBD = TAU\n ELSE\n UBD = TAU\n END IF\n IF( ABS( FINIT ).LE.ABS( TEMP ) ) TAU = ZERO\n END IF\n END IF\n!\n! get machine parameters for possible scaling to avoid overflow\n!\n! modified by Sven: parameters SMALL1, SMINV1, SMALL2,\n! SMINV2, EPS are not SAVEd anymore between one call to the\n! others but recomputed at each call\n!\n EPS = DLAMCH( 'Epsilon' )\n BASE = DLAMCH( 'Base' )\n SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /&\n THREE ) )\n SMINV1 = ONE / SMALL1\n SMALL2 = SMALL1*SMALL1\n SMINV2 = SMINV1*SMINV1\n!\n! Determine if scaling of inputs necessary to avoid overflow\n! when computing 1/TEMP**3\n!\n IF( ORGATI ) THEN\n TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )\n ELSE\n TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )\n END IF\n SCALE = .FALSE.\n IF( TEMP.LE.SMALL1 ) THEN\n SCALE = .TRUE.\n IF( TEMP.LE.SMALL2 ) THEN\n!\n! Scale up by power of radix nearest 1/SAFMIN**(2/3)\n!\n SCLFAC = SMINV2\n SCLINV = SMALL2\n ELSE\n!\n! Scale up by power of radix nearest 1/SAFMIN**(1/3)\n!\n SCLFAC = SMINV1\n SCLINV = SMALL1\n END IF\n!\n! Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)\n!\n DO 10 I = 1, 3\n DSCALE( I ) = D( I )*SCLFAC\n ZSCALE( I ) = Z( I )*SCLFAC\n10 CONTINUE\n TAU = TAU*SCLFAC\n LBD = LBD*SCLFAC\n UBD = UBD*SCLFAC\n ELSE\n!\n! Copy D and Z to DSCALE and ZSCALE\n!\n DO 20 I = 1, 3\n DSCALE( I ) = D( I )\n ZSCALE( I ) = Z( I )\n20 CONTINUE\n END IF\n!\n FC = ZERO\n DF = ZERO\n DDF = ZERO\n DO 30 I = 1, 3\n TEMP = ONE / ( DSCALE( I )-TAU )\n TEMP1 = ZSCALE( I )*TEMP\n TEMP2 = TEMP1*TEMP\n TEMP3 = TEMP2*TEMP\n FC = FC + TEMP1 / DSCALE( I )\n DF = DF + TEMP2\n DDF = DDF + TEMP3\n30 CONTINUE\n F = FINIT + TAU*FC\n!\n IF( ABS( F ).LE.ZERO ) GO TO 60\n IF( F .LE. ZERO )THEN\n LBD = TAU\n ELSE\n UBD = TAU\n END IF\n!\n! Iteration begins -- Use Gragg-Thornton-Warner cubic convergent\n! scheme\n!\n! It is not hard to see that\n!\n! 1) Iterations will go up monotonically\n! if FINIT < 0;\n!\n! 2) Iterations will go down monotonically\n! if FINIT > 0.\n!\n ITER = NITER + 1\n!\n DO 50 NITER = ITER, MAXIT\n!\n IF( ORGATI ) THEN\n TEMP1 = DSCALE( 2 ) - TAU\n TEMP2 = DSCALE( 3 ) - TAU\n ELSE\n TEMP1 = DSCALE( 1 ) - TAU\n TEMP2 = DSCALE( 2 ) - TAU\n END IF\n A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF\n B = TEMP1*TEMP2*F\n C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF\n TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )\n A = A / TEMP\n B = B / TEMP\n C = C / TEMP\n IF( C.EQ.ZERO ) THEN\n ETA = B / A\n ELSE IF( A.LE.ZERO ) THEN\n ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )\n ELSE\n ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )\n END IF\n IF( F*ETA.GE.ZERO ) THEN\n ETA = -F / DF\n END IF\n!\n TAU = TAU + ETA\n IF( TAU .LT. LBD .OR. TAU .GT. UBD ) TAU = ( LBD + UBD )/TWO \n!\n FC = ZERO\n ERRETM = ZERO\n DF = ZERO\n DDF = ZERO\n DO 40 I = 1, 3\n IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN\n TEMP = ONE / ( DSCALE( I )-TAU )\n TEMP1 = ZSCALE( I )*TEMP\n TEMP2 = TEMP1*TEMP\n TEMP3 = TEMP2*TEMP\n TEMP4 = TEMP1 / DSCALE( I )\n FC = FC + TEMP4\n ERRETM = ERRETM + ABS( TEMP4 )\n DF = DF + TEMP2\n DDF = DDF + TEMP3\n ELSE\n GO TO 60\n END IF\n40 CONTINUE\n F = FINIT + TAU*FC\n ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + ABS( TAU )*DF\n IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. &\n ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) )&\n GO TO 60\n IF( F .LE. ZERO )THEN\n LBD = TAU\n ELSE\n UBD = TAU\n END IF\n50 CONTINUE\n INFO = 1\n60 CONTINUE\n!\n! Undo scaling\n!\n IF( SCALE ) TAU = TAU*SCLINV\n RETURN\n!\n! End of DLAED6\n!\n END SUBROUTINE DLAED6\n!\n!=\n!\n!> \\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.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DLAEDA + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,\n! GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER CURLVL, CURPBM, INFO, N, TLVLS\n! ..\n! .. Array Arguments ..\n! INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),\n! $ PRMPTR( * ), QPTR( * )\n! DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DLAEDA computes the Z vector corresponding to the merge step in the\n!> CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n!> problem.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The dimension of the symmetric tridiagonal matrix. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] TLVLS\n!> \\verbatim\n!> TLVLS is INTEGER\n!> The total number of merging levels in the overall divide and\n!> conquer tree.\n!> \\endverbatim\n!>\n!> \\param[in] CURLVL\n!> \\verbatim\n!> CURLVL is INTEGER\n!> The current level in the overall merge routine,\n!> 0 <= curlvl <= tlvls.\n!> \\endverbatim\n!>\n!> \\param[in] CURPBM\n!> \\verbatim\n!> CURPBM is INTEGER\n!> The current problem in the current level in the overall\n!> merge routine (counting from upper left to lower right).\n!> \\endverbatim\n!>\n!> \\param[in] PRMPTR\n!> \\verbatim\n!> PRMPTR is INTEGER array, dimension (N lg N)\n!> Contains a list of pointers which indicate where in PERM a\n!> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n!> indicates the size of the permutation and incidentally the\n!> size of the full, non-deflated problem.\n!> \\endverbatim\n!>\n!> \\param[in] PERM\n!> \\verbatim\n!> PERM is INTEGER array, dimension (N lg N)\n!> Contains the permutations (from deflation and sorting) to be\n!> applied to each eigenblock.\n!> \\endverbatim\n!>\n!> \\param[in] GIVPTR\n!> \\verbatim\n!> GIVPTR is INTEGER array, dimension (N lg N)\n!> Contains a list of pointers which indicate where in GIVCOL a\n!> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n!> indicates the number of Givens rotations.\n!> \\endverbatim\n!>\n!> \\param[in] GIVCOL\n!> \\verbatim\n!> GIVCOL is INTEGER array, dimension (2, N lg N)\n!> Each pair of numbers indicates a pair of columns to take place\n!> in a Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[in] GIVNUM\n!> \\verbatim\n!> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)\n!> Each number indicates the S value to be used in the\n!> corresponding Givens rotation.\n!> \\endverbatim\n!>\n!> \\param[in] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (N**2)\n!> Contains the square eigenblocks from previous levels, the\n!> starting positions for blocks are given by QPTR.\n!> \\endverbatim\n!>\n!> \\param[in] QPTR\n!> \\verbatim\n!> QPTR is INTEGER array, dimension (N+2)\n!> Contains a list of pointers which indicate where in Q an\n!> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n!> the size of the block.\n!> \\endverbatim\n!>\n!> \\param[out] Z\n!> \\verbatim\n!> Z is DOUBLE PRECISION array, dimension (N)\n!> On output this vector contains the updating vector (the last\n!> row of the first sub-eigenvector matrix and the first row of\n!> the second sub-eigenvector matrix).\n!> \\endverbatim\n!>\n!> \\param[out] ZTEMP\n!> \\verbatim\n!> ZTEMP is DOUBLE PRECISION array, dimension (N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit.\n!> < 0: if INFO = -i, the i-th argument had an illegal value.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup auxOTHERcomputational\n!\n!> \\par Contributors:\n! ==================\n!>\n!> Jeff Rutter, Computer Science Division, University of California\n!> at Berkeley, USA\n!\n! =====================================================================\n SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,&\n GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER CURLVL, CURPBM, INFO, N, TLVLS\n! ..\n! .. Array Arguments ..\n INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),&\n PRMPTR( * ), QPTR( * )\n DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )\n! ..\n! .. Local Scalars ..\n INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,&\n PTR, ZPTR1\n! ..\n! .. External Subroutines ..\n! EXTERNAL DCOPY, DGEMV, DROT, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC DBLE, INT, SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n!\n IF( N.LT.0 ) THEN\n INFO = -1\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DLAEDA', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! Determine location of first number in second half.\n!\n MID = N / 2 + 1\n!\n! Gather last/first rows of appropriate eigenblocks into center of Z\n!\n PTR = 1\n!\n! Determine location of lowest level subproblem in the full storage\n! scheme\n!\n CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1\n!\n! Determine size of these matrices. We add HALF to the value of\n! the SQRT in case the machine underestimates one of these square\n! roots.\n!\n BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )\n BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )\n DO 10 K = 1, MID - BSIZ1 - 1\n Z( K ) = ZERO\n10 CONTINUE\n CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,&\n Z( MID-BSIZ1 ), 1 )\n CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )\n DO 20 K = MID + BSIZ2, N\n Z( K ) = ZERO\n20 CONTINUE\n!\n! Loop through remaining levels 1 -> CURLVL applying the Givens\n! rotations and permutation and then multiplying the center matrices\n! against the current Z.\n!\n PTR = 2**TLVLS + 1\n DO 70 K = 1, CURLVL - 1\n CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1\n PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )\n PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )\n ZPTR1 = MID - PSIZ1\n!\n! Apply Givens at CURR and CURR+1\n!\n DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1\n CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,&\n Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),&\n GIVNUM( 2, I ) )\n30 CONTINUE\n DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1\n CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,&\n Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),&\n GIVNUM( 2, I ) )\n40 CONTINUE\n PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )\n PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )\n DO 50 I = 0, PSIZ1 - 1\n ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )\n50 CONTINUE\n DO 60 I = 0, PSIZ2 - 1\n ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )\n60 CONTINUE\n!\n! Multiply Blocks at CURR and CURR+1\n!\n! Determine size of these matrices. We add HALF to the value of\n! the SQRT in case the machine underestimates one of these\n! square roots.\n!\n BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )\n BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+&\n 1 ) ) ) )\n IF( BSIZ1.GT.0 ) THEN\n CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),&\n BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )\n END IF\n CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), 1 )\n IF( BSIZ2.GT.0 ) THEN\n CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),&\n BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )\n END IF\n CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,&\n Z( MID+BSIZ2 ), 1 )\n!\n PTR = PTR + 2**( TLVLS-K )\n70 CONTINUE\n!\n RETURN\n!\n! End of DLAEDA\n!\n END SUBROUTINE DLAEDA\n!\n!=\n!\n!> \\brief \\b DOPGTR\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DOPGTR + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, LDQ, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DOPGTR generates a real orthogonal matrix Q which is defined as the\n!> product of n-1 elementary reflectors H(i) of order n, as returned by\n!> DSPTRD using packed storage:\n!>\n!> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n!>\n!> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangular packed storage used in previous\n!> call to DSPTRD;\n!> = 'L': Lower triangular packed storage used in previous\n!> call to DSPTRD.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix Q. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> The vectors which define the elementary reflectors, as\n!> returned by DSPTRD.\n!> \\endverbatim\n!>\n!> \\param[in] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (N-1)\n!> TAU(i) must contain the scalar factor of the elementary\n!> reflector H(i), as returned by DSPTRD.\n!> \\endverbatim\n!>\n!> \\param[out] Q\n!> \\verbatim\n!> Q is DOUBLE PRECISION array, dimension (LDQ,N)\n!> The N-by-N orthogonal matrix Q.\n!> \\endverbatim\n!>\n!> \\param[in] LDQ\n!> \\verbatim\n!> LDQ is INTEGER\n!> The leading dimension of the array Q. LDQ >= max(1,N).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (N-1)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, LDQ, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I, IINFO, IJ, J\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL DORG2L, DORG2R, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN\n INFO = -6\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DOPGTR', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n IF( UPPER ) THEN\n!\n! Q was determined by a call to DSPTRD with UPLO = 'U'\n!\n! Unpack the vectors which define the elementary reflectors and\n! set the last row and column of Q equal to those of the unit\n! matrix\n!\n IJ = 2\n DO 20 J = 1, N - 1\n DO 10 I = 1, J - 1\n Q( I, J ) = AP( IJ )\n IJ = IJ + 1\n10 CONTINUE\n IJ = IJ + 2\n Q( N, J ) = ZERO\n20 CONTINUE\n DO 30 I = 1, N - 1\n Q( I, N ) = ZERO\n30 CONTINUE\n Q( N, N ) = ONE\n!\n! Generate Q(1:n-1,1:n-1)\n!\n CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )\n!\n ELSE\n!\n! Q was determined by a call to DSPTRD with UPLO = 'L'.\n!\n! Unpack the vectors which define the elementary reflectors and\n! set the first row and column of Q equal to those of the unit\n! matrix\n!\n Q( 1, 1 ) = ONE\n DO 40 I = 2, N\n Q( I, 1 ) = ZERO\n40 CONTINUE\n IJ = 3\n DO 60 J = 2, N\n Q( 1, J ) = ZERO\n DO 50 I = J + 1, N\n Q( I, J ) = AP( IJ )\n IJ = IJ + 1\n50 CONTINUE\n IJ = IJ + 2\n60 CONTINUE\n IF( N.GT.1 ) THEN\n!\n! Generate Q(2:n,2:n)\n!\n CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, IINFO )\n END IF\n END IF\n RETURN\n!\n! End of DOPGTR\n!\n END SUBROUTINE DOPGTR\n!\n!=\n!\n!> \\brief \\b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DORG2L + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, K, LDA, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DORG2L generates an m by n real matrix Q with orthonormal columns,\n!> which is defined as the last n columns of a product of k elementary\n!> reflectors of order m\n!>\n!> Q = H(k) . . . H(2) H(1)\n!>\n!> as returned by DGEQLF.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix Q. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix Q. M >= N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of elementary reflectors whose product defines the\n!> matrix Q. N >= K >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the (n-k+i)-th column must contain the vector which\n!> defines the elementary reflector H(i), for i = 1,2,...,k, as\n!> returned by DGEQLF in the last k columns of its array\n!> argument A.\n!> On exit, the m by n matrix Q.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The first dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[in] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (K)\n!> TAU(i) must contain the scalar factor of the elementary\n!> reflector H(i), as returned by DGEQLF.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument has an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, K, LDA, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, II, J, L\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLARF, DSCAL, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n IF( M.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 .OR. N.GT.M ) THEN\n INFO = -2\n ELSE IF( K.LT.0 .OR. K.GT.N ) THEN\n INFO = -3\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = -5\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DORG2L', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.LE.0 ) RETURN\n!\n! Initialise columns 1:n-k to columns of the unit matrix\n!\n DO 20 J = 1, N - K\n DO 10 L = 1, M\n A( L, J ) = ZERO\n10 CONTINUE\n A( M-N+J, J ) = ONE\n20 CONTINUE\n!\n DO 40 I = 1, K\n II = N - K + I\n!\n! Apply H(i) to A(1:m-k+i,1:n-k+i) from the left\n!\n A( M-N+II, II ) = ONE\n CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,&\n LDA, WORK )\n CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )\n A( M-N+II, II ) = ONE - TAU( I )\n!\n! Set A(m-k+i+1:m,n-k+i) to zero\n!\n DO 30 L = M - N + II + 1, M\n A( L, II ) = ZERO\n30 CONTINUE\n40 CONTINUE\n RETURN\n!\n! End of DORG2L\n!\n END SUBROUTINE DORG2L\n!\n!=\n!\n!> \\brief \\b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DORG2R + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, K, LDA, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DORG2R generates an m by n real matrix Q with orthonormal columns,\n!> which is defined as the first n columns of a product of k elementary\n!> reflectors of order m\n!>\n!> Q = H(1) H(2) . . . H(k)\n!>\n!> as returned by DGEQRF.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix Q. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix Q. M >= N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] K\n!> \\verbatim\n!> K is INTEGER\n!> The number of elementary reflectors whose product defines the\n!> matrix Q. N >= K >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the i-th column must contain the vector which\n!> defines the elementary reflector H(i), for i = 1,2,...,k, as\n!> returned by DGEQRF in the first k columns of its array\n!> argument A.\n!> On exit, the m-by-n matrix Q.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The first dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[in] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (K)\n!> TAU(i) must contain the scalar factor of the elementary\n!> reflector H(i), as returned by DGEQRF.\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument has an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, K, LDA, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, J, L\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLARF, DSCAL, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n IF( M.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 .OR. N.GT.M ) THEN\n INFO = -2\n ELSE IF( K.LT.0 .OR. K.GT.N ) THEN\n INFO = -3\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = -5\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DORG2R', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.LE.0 ) RETURN\n!\n! Initialise columns k+1:n to columns of the unit matrix\n!\n DO 20 J = K + 1, N\n DO 10 L = 1, M\n A( L, J ) = ZERO\n10 CONTINUE\n A( J, J ) = ONE\n20 CONTINUE\n!\n DO 40 I = K, 1, -1\n!\n! Apply H(i) to A(i:m,i:n) from the left\n!\n IF( I.LT.N ) THEN\n A( I, I ) = ONE\n CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),&\n A( I, I+1 ), LDA, WORK )\n END IF\n IF( I.LT.M ) CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )\n A( I, I ) = ONE - TAU( I )\n!\n! Set A(1:i-1,i) to zero\n!\n DO 30 L = 1, I - 1\n A( L, I ) = ZERO\n30 CONTINUE\n40 CONTINUE\n RETURN\n!\n! End of DORG2R\n!\n END SUBROUTINE DORG2R\n!\n!========================================================================\n!\n! BLAS\n!\n!> \\brief \\b DROT\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION C,S\n! INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*),DY(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DROT applies a plane rotation.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION C,S\n INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*),DY(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n DOUBLE PRECISION DTEMP\n INTEGER I,IX,IY\n! ..\n IF (N.LE.0) RETURN\n IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN\n!\n! code for both increments equal to 1\n!\n DO I = 1,N\n DTEMP = C*DX(I) + S*DY(I)\n DY(I) = C*DY(I) - S*DX(I)\n DX(I) = DTEMP\n END DO\n ELSE\n!\n! code for unequal increments or equal increments not equal\n! to 1\n!\n IX = 1\n IY = 1\n IF (INCX.LT.0) IX = (-N+1)*INCX + 1\n IF (INCY.LT.0) IY = (-N+1)*INCY + 1\n DO I = 1,N\n DTEMP = C*DX(IX) + S*DY(IY)\n DY(IY) = C*DY(IY) - S*DX(IX)\n DX(IX) = DTEMP\n IX = IX + INCX\n IY = IY + INCY\n END DO\n END IF\n RETURN\n END SUBROUTINE DROT\n!\n!=\n!\n!> \\brief \\b DNRM2\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION X(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DNRM2 returns the euclidean norm of a vector via the function\n!> name, so that\n!>\n!> DNRM2 := sqrt( x'*x )\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> -- This version written on 25-October-1982.\n!> Modified on 14-October-1993 to inline the call to DLASSQ.\n!> Sven Hammarling, Nag Ltd.\n!> \\endverbatim\n!>\n! =====================================================================\n DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION X(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ\n INTEGER IX\n! ..\n! .. Intrinsic Functions ..\n INTRINSIC ABS,SQRT\n! ..\n IF (N.LT.1 .OR. INCX.LT.1) THEN\n NORM = ZERO\n ELSE IF (N.EQ.1) THEN\n NORM = ABS(X(1))\n ELSE\n SCALE = ZERO\n SSQ = ONE\n! The following loop is equivalent to this call to the LAPACK\n! auxiliary routine:\n! CALL DLASSQ( N, X, INCX, SCALE, SSQ )\n!\n DO 10 IX = 1,1 + (N-1)*INCX,INCX\n IF (X(IX).NE.ZERO) THEN\n ABSXI = ABS(X(IX))\n IF (SCALE.LT.ABSXI) THEN\n SSQ = ONE + SSQ* (SCALE/ABSXI)**2\n SCALE = ABSXI\n ELSE\n SSQ = SSQ + (ABSXI/SCALE)**2\n END IF\n END IF\n10 CONTINUE\n NORM = SCALE*SQRT(SSQ)\n END IF\n!\n DNRM2 = NORM\n RETURN\n!\n! End of DNRM2.\n!\n END FUNCTION DNRM2\n!\n!=\n!\n!> \\brief \\b DGER\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER INCX,INCY,LDA,M,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGER performs the rank 1 operation\n!>\n!> A := alpha*x*y**T + A,\n!>\n!> where alpha is a scalar, x is an m element vector, y is an n element\n!> vector and A is an m by n matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> On entry, M specifies the number of rows of the matrix A.\n!> M must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the number of columns of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( m - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the m\n!> element vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCY ) ).\n!> Before entry, the incremented array Y must contain the n\n!> element vector y.\n!> \\endverbatim\n!>\n!> \\param[in] INCY\n!> \\verbatim\n!> INCY is INTEGER\n!> On entry, INCY specifies the increment for the elements of\n!> Y. INCY must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n!> Before entry, the leading m by n part of the array A must\n!> contain the matrix of coefficients. On exit, A is\n!> overwritten by the updated matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. LDA must be at least\n!> max( 1, m ).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER INCX,INCY,LDA,M,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),X(*),Y(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JY,KX\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (M.LT.0) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (INCX.EQ.0) THEN\n INFO = 5\n ELSE IF (INCY.EQ.0) THEN\n INFO = 7\n ELSE IF (LDA.LT.MAX(1,M)) THEN\n INFO = 9\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DGER ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN\n!\n! Start the operations. In this version the elements of A are\n! accessed sequentially with one pass through A.\n!\n IF (INCY.GT.0) THEN\n JY = 1\n ELSE\n JY = 1 - (N-1)*INCY\n END IF\n IF (INCX.EQ.1) THEN\n DO 20 J = 1,N\n IF (Y(JY).NE.ZERO) THEN\n TEMP = ALPHA*Y(JY)\n DO 10 I = 1,M\n A(I,J) = A(I,J) + X(I)*TEMP\n10 CONTINUE\n END IF\n JY = JY + INCY\n20 CONTINUE\n ELSE\n IF (INCX.GT.0) THEN\n KX = 1\n ELSE\n KX = 1 - (M-1)*INCX\n END IF\n DO 40 J = 1,N\n IF (Y(JY).NE.ZERO) THEN\n TEMP = ALPHA*Y(JY)\n IX = KX\n DO 30 I = 1,M\n A(I,J) = A(I,J) + X(IX)*TEMP\n IX = IX + INCX\n30 CONTINUE\n END IF\n JY = JY + INCY\n40 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DGER .\n!\n END SUBROUTINE DGER\n!\n!=\n!\n!> \\brief \\b DSPMV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA,BETA\n! INTEGER INCX,INCY,N\n! CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP(*),X(*),Y(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSPMV performs the matrix-vector operation\n!>\n!> y := alpha*A*x + beta*y,\n!>\n!> where alpha and beta are scalars, x and y are n element vectors and\n!> A is an n by n symmetric matrix, supplied in packed form.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the upper or lower\n!> triangular part of the matrix A is supplied in the packed\n!> array AP as follows:\n!>\n!> UPLO = 'U' or 'u' The upper triangular part of A is\n!> supplied in AP.\n!>\n!> UPLO = 'L' or 'l' The lower triangular part of A is\n!> supplied in AP.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array of DIMENSION at least\n!> ( ( n*( n + 1 ) )/2 ).\n!> Before entry with UPLO = 'U' or 'u', the array AP must\n!> contain the upper triangular part of the symmetric matrix\n!> packed sequentially, column by column, so that AP( 1 )\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n!> and a( 2, 2 ) respectively, and so on.\n!> Before entry with UPLO = 'L' or 'l', the array AP must\n!> contain the lower triangular part of the symmetric matrix\n!> packed sequentially, column by column, so that AP( 1 )\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n!> and a( 3, 1 ) respectively, and so on.\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in] BETA\n!> \\verbatim\n!> BETA is DOUBLE PRECISION.\n!> On entry, BETA specifies the scalar beta. When BETA is\n!> supplied as zero then Y need not be set on input.\n!> \\endverbatim\n!>\n!> \\param[in,out] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCY ) ).\n!> Before entry, the incremented array Y must contain the n\n!> element vector y. On exit, Y is overwritten by the updated\n!> vector y.\n!> \\endverbatim\n!>\n!> \\param[in] INCY\n!> \\verbatim\n!> INCY is INTEGER\n!> On entry, INCY specifies the increment for the elements of\n!> Y. INCY must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!> The vector and matrix arguments are not referenced when N = 0, or M = 0\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA,BETA\n INTEGER INCX,INCY,N\n CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP(*),X(*),Y(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP1,TEMP2\n INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (INCX.EQ.0) THEN\n INFO = 6\n ELSE IF (INCY.EQ.0) THEN\n INFO = 9\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DSPMV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN\n!\n! Set up the start points in X and Y.\n!\n IF (INCX.GT.0) THEN\n KX = 1\n ELSE\n KX = 1 - (N-1)*INCX\n END IF\n IF (INCY.GT.0) THEN\n KY = 1\n ELSE\n KY = 1 - (N-1)*INCY\n END IF\n!\n! Start the operations. In this version the elements of the array AP\n! are accessed sequentially with one pass through AP.\n!\n! First form y := beta*y.\n!\n IF (BETA.NE.ONE) THEN\n IF (INCY.EQ.1) THEN\n IF (BETA.EQ.ZERO) THEN\n DO 10 I = 1,N\n Y(I) = ZERO\n10 CONTINUE\n ELSE\n DO 20 I = 1,N\n Y(I) = BETA*Y(I)\n20 CONTINUE\n END IF\n ELSE\n IY = KY\n IF (BETA.EQ.ZERO) THEN\n DO 30 I = 1,N\n Y(IY) = ZERO\n IY = IY + INCY\n30 CONTINUE\n ELSE\n DO 40 I = 1,N\n Y(IY) = BETA*Y(IY)\n IY = IY + INCY\n40 CONTINUE\n END IF\n END IF\n END IF\n IF (ALPHA.EQ.ZERO) RETURN\n KK = 1\n IF (LSAME(UPLO,'U')) THEN\n!\n! Form y when AP contains the upper triangle.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 60 J = 1,N\n TEMP1 = ALPHA*X(J)\n TEMP2 = ZERO\n K = KK\n DO 50 I = 1,J - 1\n Y(I) = Y(I) + TEMP1*AP(K)\n TEMP2 = TEMP2 + AP(K)*X(I)\n K = K + 1\n50 CONTINUE\n Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2\n KK = KK + J\n60 CONTINUE\n ELSE\n JX = KX\n JY = KY\n DO 80 J = 1,N\n TEMP1 = ALPHA*X(JX)\n TEMP2 = ZERO\n IX = KX\n IY = KY\n DO 70 K = KK,KK + J - 2\n Y(IY) = Y(IY) + TEMP1*AP(K)\n TEMP2 = TEMP2 + AP(K)*X(IX)\n IX = IX + INCX\n IY = IY + INCY\n70 CONTINUE\n Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2\n JX = JX + INCX\n JY = JY + INCY\n KK = KK + J\n80 CONTINUE\n END IF\n ELSE\n!\n! Form y when AP contains the lower triangle.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 100 J = 1,N\n TEMP1 = ALPHA*X(J)\n TEMP2 = ZERO\n Y(J) = Y(J) + TEMP1*AP(KK)\n K = KK + 1\n DO 90 I = J + 1,N\n Y(I) = Y(I) + TEMP1*AP(K)\n TEMP2 = TEMP2 + AP(K)*X(I)\n K = K + 1\n90 CONTINUE\n Y(J) = Y(J) + ALPHA*TEMP2\n KK = KK + (N-J+1)\n100 CONTINUE\n ELSE\n JX = KX\n JY = KY\n DO 120 J = 1,N\n TEMP1 = ALPHA*X(JX)\n TEMP2 = ZERO\n Y(JY) = Y(JY) + TEMP1*AP(KK)\n IX = JX\n IY = JY\n DO 110 K = KK + 1,KK + N - J\n IX = IX + INCX\n IY = IY + INCY\n Y(IY) = Y(IY) + TEMP1*AP(K)\n TEMP2 = TEMP2 + AP(K)*X(IX)\n110 CONTINUE\n Y(JY) = Y(JY) + ALPHA*TEMP2\n JX = JX + INCX\n JY = JY + INCY\n KK = KK + (N-J+1)\n120 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DSPMV .\n!\n END SUBROUTINE DSPMV\n!\n!=\n!\n!> \\brief \\b DAXPY\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION DA\n! INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION DX(*),DY(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DAXPY constant times a vector plus a vector.\n!> uses unrolled loops for increments equal to one.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level1\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> jack dongarra, linpack, 3/11/78.\n!> modified 12/3/93, array(1) declarations changed to array(*)\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)\n!\n! -- Reference BLAS level1 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION DA\n INTEGER INCX,INCY,N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION DX(*),DY(*)\n! ..\n!\n! =====================================================================\n!\n! .. Local Scalars ..\n INTEGER I,IX,IY,M,MP1\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MOD\n! ..\n IF (N.LE.0) RETURN\n IF (DA.EQ.0.0d0) RETURN\n IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN\n!\n! code for both increments equal to 1\n!\n!\n! clean-up loop\n!\n M = MOD(N,4)\n IF (M.NE.0) THEN\n DO I = 1,M\n DY(I) = DY(I) + DA*DX(I)\n END DO\n END IF\n IF (N.LT.4) RETURN\n MP1 = M + 1\n DO I = MP1,N,4\n DY(I) = DY(I) + DA*DX(I)\n DY(I+1) = DY(I+1) + DA*DX(I+1)\n DY(I+2) = DY(I+2) + DA*DX(I+2)\n DY(I+3) = DY(I+3) + DA*DX(I+3)\n END DO\n ELSE\n!\n! code for unequal increments or equal increments\n! not equal to 1\n!\n IX = 1\n IY = 1\n IF (INCX.LT.0) IX = (-N+1)*INCX + 1\n IF (INCY.LT.0) IY = (-N+1)*INCY + 1\n DO I = 1,N\n DY(IY) = DY(IY) + DA*DX(IX)\n IX = IX + INCX\n IY = IY + INCY\n END DO\n END IF\n RETURN\n END SUBROUTINE DAXPY\n!\n!=\n!\n!> \\brief \\b DSPR2\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER INCX,INCY,N\n! CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP(*),X(*),Y(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DSPR2 performs the symmetric rank 2 operation\n!>\n!> A := alpha*x*y**T + alpha*y*x**T + A,\n!>\n!> where alpha is a scalar, x and y are n element vectors and A is an\n!> n by n symmetric matrix, supplied in packed form.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the upper or lower\n!> triangular part of the matrix A is supplied in the packed\n!> array AP as follows:\n!>\n!> UPLO = 'U' or 'u' The upper triangular part of A is\n!> supplied in AP.\n!>\n!> UPLO = 'L' or 'l' The lower triangular part of A is\n!> supplied in AP.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha.\n!> \\endverbatim\n!>\n!> \\param[in] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in] Y\n!> \\verbatim\n!> Y is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCY ) ).\n!> Before entry, the incremented array Y must contain the n\n!> element vector y.\n!> \\endverbatim\n!>\n!> \\param[in] INCY\n!> \\verbatim\n!> INCY is INTEGER\n!> On entry, INCY specifies the increment for the elements of\n!> Y. INCY must not be zero.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array of DIMENSION at least\n!> ( ( n*( n + 1 ) )/2 ).\n!> Before entry with UPLO = 'U' or 'u', the array AP must\n!> contain the upper triangular part of the symmetric matrix\n!> packed sequentially, column by column, so that AP( 1 )\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n!> and a( 2, 2 ) respectively, and so on. On exit, the array\n!> AP is overwritten by the upper triangular part of the\n!> updated matrix.\n!> Before entry with UPLO = 'L' or 'l', the array AP must\n!> contain the lower triangular part of the symmetric matrix\n!> packed sequentially, column by column, so that AP( 1 )\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n!> and a( 3, 1 ) respectively, and so on. On exit, the array\n!> AP is overwritten by the lower triangular part of the\n!> updated matrix.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER INCX,INCY,N\n CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP(*),X(*),Y(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP1,TEMP2\n INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (INCX.EQ.0) THEN\n INFO = 5\n ELSE IF (INCY.EQ.0) THEN\n INFO = 7\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DSPR2 ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN\n!\n! Set up the start points in X and Y if the increments are not both\n! unity.\n!\n IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN\n IF (INCX.GT.0) THEN\n KX = 1\n ELSE\n KX = 1 - (N-1)*INCX\n END IF\n IF (INCY.GT.0) THEN\n KY = 1\n ELSE\n KY = 1 - (N-1)*INCY\n END IF\n JX = KX\n JY = KY\n END IF\n!\n! Start the operations. In this version the elements of the array AP\n! are accessed sequentially with one pass through AP.\n!\n KK = 1\n IF (LSAME(UPLO,'U')) THEN\n!\n! Form A when upper triangle is stored in AP.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 20 J = 1,N\n IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN\n TEMP1 = ALPHA*Y(J)\n TEMP2 = ALPHA*X(J)\n K = KK\n DO 10 I = 1,J\n AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2\n K = K + 1\n10 CONTINUE\n END IF\n KK = KK + J\n20 CONTINUE\n ELSE\n DO 40 J = 1,N\n IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN\n TEMP1 = ALPHA*Y(JY)\n TEMP2 = ALPHA*X(JX)\n IX = KX\n IY = KY\n DO 30 K = KK,KK + J - 1\n AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2\n IX = IX + INCX\n IY = IY + INCY\n30 CONTINUE\n END IF\n JX = JX + INCX\n JY = JY + INCY\n KK = KK + J\n40 CONTINUE\n END IF\n ELSE\n!\n! Form A when lower triangle is stored in AP.\n!\n IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN\n DO 60 J = 1,N\n IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN\n TEMP1 = ALPHA*Y(J)\n TEMP2 = ALPHA*X(J)\n K = KK\n DO 50 I = J,N\n AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2\n K = K + 1\n50 CONTINUE\n END IF\n KK = KK + N - J + 1\n60 CONTINUE\n ELSE\n DO 80 J = 1,N\n IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN\n TEMP1 = ALPHA*Y(JY)\n TEMP2 = ALPHA*X(JX)\n IX = JX\n IY = JY\n DO 70 K = KK,KK + N - J\n AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2\n IX = IX + INCX\n IY = IY + INCY\n70 CONTINUE\n END IF\n JX = JX + INCX\n JY = JY + INCY\n KK = KK + N - J + 1\n80 CONTINUE\n END IF\n END IF\n!\n RETURN\n!\n! End of DSPR2 .\n!\n END SUBROUTINE DSPR2\n!\n!=\n!\n!> \\brief \\b DTRMV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,LDA,N\n! CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),X(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTRMV performs one of the matrix-vector operations\n!>\n!> x := A*x, or x := A**T*x,\n!>\n!> where x is an n element vector and A is an n by n unit, or non-unit,\n!> upper or lower triangular matrix.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the matrix is an upper or\n!> lower triangular matrix as follows:\n!>\n!> UPLO = 'U' or 'u' A is an upper triangular matrix.\n!>\n!> UPLO = 'L' or 'l' A is a lower triangular matrix.\n!> \\endverbatim\n!>\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> On entry, TRANS specifies the operation to be performed as\n!> follows:\n!>\n!> TRANS = 'N' or 'n' x := A*x.\n!>\n!> TRANS = 'T' or 't' x := A**T*x.\n!>\n!> TRANS = 'C' or 'c' x := A**T*x.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> On entry, DIAG specifies whether or not A is unit\n!> triangular as follows:\n!>\n!> DIAG = 'U' or 'u' A is assumed to be unit triangular.\n!>\n!> DIAG = 'N' or 'n' A is not assumed to be unit\n!> triangular.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n!> Before entry with UPLO = 'U' or 'u', the leading n by n\n!> upper triangular part of the array A must contain the upper\n!> triangular matrix and the strictly lower triangular part of\n!> A is not referenced.\n!> Before entry with UPLO = 'L' or 'l', the leading n by n\n!> lower triangular part of the array A must contain the lower\n!> triangular matrix and the strictly upper triangular part of\n!> A is not referenced.\n!> Note that when DIAG = 'U' or 'u', the diagonal elements of\n!> A are not referenced either, but are assumed to be unity.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. LDA must be at least\n!> max( 1, n ).\n!> \\endverbatim\n!>\n!> \\param[in,out] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x. On exit, X is overwritten with the\n!> tranformed vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!> The vector and matrix arguments are not referenced when N = 0, or M = 0\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,LDA,N\n CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),X(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JX,KX\n LOGICAL NOUNIT\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.&\n .NOT.LSAME(TRANS,'C')) THEN\n INFO = 2\n ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN\n INFO = 3\n ELSE IF (N.LT.0) THEN\n INFO = 4\n ELSE IF (LDA.LT.MAX(1,N)) THEN\n INFO = 6\n ELSE IF (INCX.EQ.0) THEN\n INFO = 8\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DTRMV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF (N.EQ.0) RETURN\n!\n NOUNIT = LSAME(DIAG,'N')\n!\n! Set up the start point in X if the increment is not unity. This\n! will be ( N - 1 )*INCX too small for descending loops.\n!\n IF (INCX.LE.0) THEN\n KX = 1 - (N-1)*INCX\n ELSE IF (INCX.NE.1) THEN\n KX = 1\n END IF\n!\n! Start the operations. In this version the elements of A are\n! accessed sequentially with one pass through A.\n!\n IF (LSAME(TRANS,'N')) THEN\n!\n! Form x := A*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n IF (INCX.EQ.1) THEN\n DO 20 J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = X(J)\n DO 10 I = 1,J - 1\n X(I) = X(I) + TEMP*A(I,J)\n10 CONTINUE\n IF (NOUNIT) X(J) = X(J)*A(J,J)\n END IF\n20 CONTINUE\n ELSE\n JX = KX\n DO 40 J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = X(JX)\n IX = KX\n DO 30 I = 1,J - 1\n X(IX) = X(IX) + TEMP*A(I,J)\n IX = IX + INCX\n30 CONTINUE\n IF (NOUNIT) X(JX) = X(JX)*A(J,J)\n END IF\n JX = JX + INCX\n40 CONTINUE\n END IF\n ELSE\n IF (INCX.EQ.1) THEN\n DO 60 J = N,1,-1\n IF (X(J).NE.ZERO) THEN\n TEMP = X(J)\n DO 50 I = N,J + 1,-1\n X(I) = X(I) + TEMP*A(I,J)\n50 CONTINUE\n IF (NOUNIT) X(J) = X(J)*A(J,J)\n END IF\n60 CONTINUE\n ELSE\n KX = KX + (N-1)*INCX\n JX = KX\n DO 80 J = N,1,-1\n IF (X(JX).NE.ZERO) THEN\n TEMP = X(JX)\n IX = KX\n DO 70 I = N,J + 1,-1\n X(IX) = X(IX) + TEMP*A(I,J)\n IX = IX - INCX\n70 CONTINUE\n IF (NOUNIT) X(JX) = X(JX)*A(J,J)\n END IF\n JX = JX - INCX\n80 CONTINUE\n END IF\n END IF\n ELSE\n!\n! Form x := A**T*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n IF (INCX.EQ.1) THEN\n DO 100 J = N,1,-1\n TEMP = X(J)\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 90 I = J - 1,1,-1\n TEMP = TEMP + A(I,J)*X(I)\n90 CONTINUE\n X(J) = TEMP\n100 CONTINUE\n ELSE\n JX = KX + (N-1)*INCX\n DO 120 J = N,1,-1\n TEMP = X(JX)\n IX = JX\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 110 I = J - 1,1,-1\n IX = IX - INCX\n TEMP = TEMP + A(I,J)*X(IX)\n110 CONTINUE\n X(JX) = TEMP\n JX = JX - INCX\n120 CONTINUE\n END IF\n ELSE\n IF (INCX.EQ.1) THEN\n DO 140 J = 1,N\n TEMP = X(J)\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 130 I = J + 1,N\n TEMP = TEMP + A(I,J)*X(I)\n130 CONTINUE\n X(J) = TEMP\n140 CONTINUE\n ELSE\n JX = KX\n DO 160 J = 1,N\n TEMP = X(JX)\n IX = JX\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 150 I = J + 1,N\n IX = IX + INCX\n TEMP = TEMP + A(I,J)*X(IX)\n150 CONTINUE\n X(JX) = TEMP\n JX = JX + INCX\n160 CONTINUE\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DTRMV .\n!\n END SUBROUTINE DTRMV\n!> \\brief \\b DTRMM\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER LDA,LDB,M,N\n! CHARACTER DIAG,SIDE,TRANSA,UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A(LDA,*),B(LDB,*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTRMM performs one of the matrix-matrix operations\n!>\n!> B := alpha*op( A )*B, or B := alpha*B*op( A ),\n!>\n!> where alpha is a scalar, B is an m by n matrix, A is a unit, or\n!> non-unit, upper or lower triangular matrix and op( A ) is one of\n!>\n!> op( A ) = A or op( A ) = A**T.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] SIDE\n!> \\verbatim\n!> SIDE is CHARACTER*1\n!> On entry, SIDE specifies whether op( A ) multiplies B from\n!> the left or right as follows:\n!>\n!> SIDE = 'L' or 'l' B := alpha*op( A )*B.\n!>\n!> SIDE = 'R' or 'r' B := alpha*B*op( A ).\n!> \\endverbatim\n!>\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the matrix A is an upper or\n!> lower triangular matrix as follows:\n!>\n!> UPLO = 'U' or 'u' A is an upper triangular matrix.\n!>\n!> UPLO = 'L' or 'l' A is a lower triangular matrix.\n!> \\endverbatim\n!>\n!> \\param[in] TRANSA\n!> \\verbatim\n!> TRANSA is CHARACTER*1\n!> On entry, TRANSA specifies the form of op( A ) to be used in\n!> the matrix multiplication as follows:\n!>\n!> TRANSA = 'N' or 'n' op( A ) = A.\n!>\n!> TRANSA = 'T' or 't' op( A ) = A**T.\n!>\n!> TRANSA = 'C' or 'c' op( A ) = A**T.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> On entry, DIAG specifies whether or not A is unit triangular\n!> as follows:\n!>\n!> DIAG = 'U' or 'u' A is assumed to be unit triangular.\n!>\n!> DIAG = 'N' or 'n' A is not assumed to be unit\n!> triangular.\n!> \\endverbatim\n!>\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> On entry, M specifies the number of rows of B. M must be at\n!> least zero.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the number of columns of B. N must be\n!> at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] ALPHA\n!> \\verbatim\n!> ALPHA is DOUBLE PRECISION.\n!> On entry, ALPHA specifies the scalar alpha. When alpha is\n!> zero then A is not referenced and B need not be set before\n!> entry.\n!> \\endverbatim\n!>\n!> \\param[in] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m\n!> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.\n!> Before entry with UPLO = 'U' or 'u', the leading k by k\n!> upper triangular part of the array A must contain the upper\n!> triangular matrix and the strictly lower triangular part of\n!> A is not referenced.\n!> Before entry with UPLO = 'L' or 'l', the leading k by k\n!> lower triangular part of the array A must contain the lower\n!> triangular matrix and the strictly upper triangular part of\n!> A is not referenced.\n!> Note that when DIAG = 'U' or 'u', the diagonal elements of\n!> A are not referenced either, but are assumed to be unity.\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> On entry, LDA specifies the first dimension of A as declared\n!> in the calling (sub) program. When SIDE = 'L' or 'l' then\n!> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'\n!> then LDA must be at least max( 1, n ).\n!> \\endverbatim\n!>\n!> \\param[in,out] B\n!> \\verbatim\n!> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ).\n!> Before entry, the leading m by n part of the array B must\n!> contain the matrix B, and on exit is overwritten by the\n!> transformed matrix.\n!> \\endverbatim\n!>\n!> \\param[in] LDB\n!> \\verbatim\n!> LDB is INTEGER\n!> On entry, LDB specifies the first dimension of B as declared\n!> in the calling (sub) program. LDB must be at least\n!> max( 1, m ).\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level3\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 3 Blas routine.\n!>\n!> -- Written on 8-February-1989.\n!> Jack Dongarra, Argonne National Laboratory.\n!> Iain Duff, AERE Harwell.\n!> Jeremy Du Croz, Numerical Algorithms Group Ltd.\n!> Sven Hammarling, Numerical Algorithms Group Ltd.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)\n!\n! -- Reference BLAS level3 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER LDA,LDB,M,N\n CHARACTER DIAG,SIDE,TRANSA,UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A(LDA,*),B(LDB,*)\n! ..\n!\n! =====================================================================\n!\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,J,K,NROWA\n LOGICAL LSIDE,NOUNIT,UPPER\n! ..\n! .. Parameters ..\n DOUBLE PRECISION ONE,ZERO\n PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)\n! ..\n!\n! Test the input parameters.\n!\n LSIDE = LSAME(SIDE,'L')\n IF (LSIDE) THEN\n NROWA = M\n ELSE\n NROWA = N\n END IF\n NOUNIT = LSAME(DIAG,'N')\n UPPER = LSAME(UPLO,'U')\n!\n INFO = 0\n IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN\n INFO = 1\n ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN\n INFO = 2\n ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. &\n (.NOT.LSAME(TRANSA,'T')) .AND.&\n (.NOT.LSAME(TRANSA,'C'))) THEN\n INFO = 3\n ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN\n INFO = 4\n ELSE IF (M.LT.0) THEN\n INFO = 5\n ELSE IF (N.LT.0) THEN\n INFO = 6\n ELSE IF (LDA.LT.MAX(1,NROWA)) THEN\n INFO = 9\n ELSE IF (LDB.LT.MAX(1,M)) THEN\n INFO = 11\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DTRMM ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF (M.EQ.0 .OR. N.EQ.0) RETURN\n!\n! And when alpha.eq.zero.\n!\n IF (ALPHA.EQ.ZERO) THEN\n DO 20 J = 1,N\n DO 10 I = 1,M\n B(I,J) = ZERO\n10 CONTINUE\n20 CONTINUE\n RETURN\n END IF\n!\n! Start the operations.\n!\n IF (LSIDE) THEN\n IF (LSAME(TRANSA,'N')) THEN\n!\n! Form B := alpha*A*B.\n!\n IF (UPPER) THEN\n DO 50 J = 1,N\n DO 40 K = 1,M\n IF (B(K,J).NE.ZERO) THEN\n TEMP = ALPHA*B(K,J)\n DO 30 I = 1,K - 1\n B(I,J) = B(I,J) + TEMP*A(I,K)\n30 CONTINUE\n IF (NOUNIT) TEMP = TEMP*A(K,K)\n B(K,J) = TEMP\n END IF\n40 CONTINUE\n50 CONTINUE\n ELSE\n DO 80 J = 1,N\n DO 70 K = M,1,-1\n IF (B(K,J).NE.ZERO) THEN\n TEMP = ALPHA*B(K,J)\n B(K,J) = TEMP\n IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)\n DO 60 I = K + 1,M\n B(I,J) = B(I,J) + TEMP*A(I,K)\n60 CONTINUE\n END IF\n70 CONTINUE\n80 CONTINUE\n END IF\n ELSE\n!\n! Form B := alpha*A**T*B.\n!\n IF (UPPER) THEN\n DO 110 J = 1,N\n DO 100 I = M,1,-1\n TEMP = B(I,J)\n IF (NOUNIT) TEMP = TEMP*A(I,I)\n DO 90 K = 1,I - 1\n TEMP = TEMP + A(K,I)*B(K,J)\n90 CONTINUE\n B(I,J) = ALPHA*TEMP\n100 CONTINUE\n110 CONTINUE\n ELSE\n DO 140 J = 1,N\n DO 130 I = 1,M\n TEMP = B(I,J)\n IF (NOUNIT) TEMP = TEMP*A(I,I)\n DO 120 K = I + 1,M\n TEMP = TEMP + A(K,I)*B(K,J)\n120 CONTINUE\n B(I,J) = ALPHA*TEMP\n130 CONTINUE\n140 CONTINUE\n END IF\n END IF\n ELSE\n IF (LSAME(TRANSA,'N')) THEN\n!\n! Form B := alpha*B*A.\n!\n IF (UPPER) THEN\n DO 180 J = N,1,-1\n TEMP = ALPHA\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 150 I = 1,M\n B(I,J) = TEMP*B(I,J)\n150 CONTINUE\n DO 170 K = 1,J - 1\n IF (A(K,J).NE.ZERO) THEN\n TEMP = ALPHA*A(K,J)\n DO 160 I = 1,M\n B(I,J) = B(I,J) + TEMP*B(I,K)\n160 CONTINUE\n END IF\n170 CONTINUE\n180 CONTINUE\n ELSE\n DO 220 J = 1,N\n TEMP = ALPHA\n IF (NOUNIT) TEMP = TEMP*A(J,J)\n DO 190 I = 1,M\n B(I,J) = TEMP*B(I,J)\n190 CONTINUE\n DO 210 K = J + 1,N\n IF (A(K,J).NE.ZERO) THEN\n TEMP = ALPHA*A(K,J)\n DO 200 I = 1,M\n B(I,J) = B(I,J) + TEMP*B(I,K)\n200 CONTINUE\n END IF\n210 CONTINUE\n220 CONTINUE\n END IF\n ELSE\n!\n! Form B := alpha*B*A**T.\n!\n IF (UPPER) THEN\n DO 260 K = 1,N\n DO 240 J = 1,K - 1\n IF (A(J,K).NE.ZERO) THEN\n TEMP = ALPHA*A(J,K)\n DO 230 I = 1,M\n B(I,J) = B(I,J) + TEMP*B(I,K)\n230 CONTINUE\n END IF\n240 CONTINUE\n TEMP = ALPHA\n IF (NOUNIT) TEMP = TEMP*A(K,K)\n IF (TEMP.NE.ONE) THEN\n DO 250 I = 1,M\n B(I,K) = TEMP*B(I,K)\n250 CONTINUE\n END IF\n260 CONTINUE\n ELSE\n DO 300 K = N,1,-1\n DO 280 J = K + 1,N\n IF (A(J,K).NE.ZERO) THEN\n TEMP = ALPHA*A(J,K)\n DO 270 I = 1,M\n B(I,J) = B(I,J) + TEMP*B(I,K)\n270 CONTINUE\n END IF\n280 CONTINUE\n TEMP = ALPHA\n IF (NOUNIT) TEMP = TEMP*A(K,K)\n IF (TEMP.NE.ONE) THEN\n DO 290 I = 1,M\n B(I,K) = TEMP*B(I,K)\n290 CONTINUE\n END IF\n300 CONTINUE\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DTRMM .\n!\n END SUBROUTINE DTRMM\n!\n!> \\brief \\b DPPTRI\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DPPTRI + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DPPTRI computes the inverse of a real symmetric positive definite\n!> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n!> computed by DPPTRF.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangular factor is stored in AP;\n!> = 'L': Lower triangular factor is stored in AP.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the triangular factor U or L from the Cholesky\n!> factorization A = U**T*U or A = L*L**T, packed columnwise as\n!> a linear array. The j-th column of U or L is stored in the\n!> array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n!>\n!> On exit, the upper or lower triangle of the (symmetric)\n!> inverse of A, overwriting the input factor U or L.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, the (i,i) element of the factor U or L is\n!> zero, and the inverse could not be computed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n! =====================================================================\n SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J, JC, JJ, JJN\n DOUBLE PRECISION AJJ\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DDOT\n! EXTERNAL LSAME, DDOT\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DPPTRI', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n! Invert the triangular Cholesky factor U or L.\n!\n CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )\n IF( INFO.GT.0 ) RETURN\n!\n IF( UPPER ) THEN\n!\n! Compute the product inv(U) * inv(U)**T.\n!\n JJ = 0\n! DO 10 J = 1, N\n DO J = 1, N\n JC = JJ + 1\n JJ = JJ + J\n IF( J.GT.1 ) &\n CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )\n AJJ = AP( JJ )\n CALL DSCAL( J, AJJ, AP( JC ), 1 )\n enddo\n!10 CONTINUE\n!\n ELSE\n!\n! Compute the product inv(L)**T * inv(L).\n!\n JJ = 1\n! DO 20 J = 1, N\n DO J = 1, N\n JJN = JJ + N - J + 1\n AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )\n IF( J.LT.N ) &\n CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, &\n AP( JJN ), AP( JJ+1 ), 1 )\n JJ = JJN\n enddo\n!20 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DPPTRI\n!\n END SUBROUTINE DPPTRI\n\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n\n!> \\brief \\b DSPR\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)\n! \n! .. Scalar Arguments ..\n! DOUBLE PRECISION ALPHA\n! INTEGER INCX,N\n! CHARACTER UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP(*),X(*)\n! ..\n! \n!\n!> \\par Purpose:\n!\n! =============\n!\n!>\n!\n!> \\verbatim\n\n!>\n!> DSPR performs the symmetric rank 1 operation\n!>\n!> A := alpha*x*x**T + A,!\n!>\n!> where alpha is a real scalar, x is an n element vector and A is an\n!\n!> n by n symmetric matrix, supplied in packed form.\n!\n!> \\endverbatim\n!\n!\n!\n! Arguments:\n!\n! ==========!\n!\n!\n!> \\param[in] UPLO\n!\n!> \\verbatim\n!\n!> UPLO is CHARACTER*1\n!\n!> On entry, UPLO specifies whether the upper or lower\n!\n!> triangular part of the matrix A is supplied in the packed\n!\n!> array AP as follows:\n!\n!>\n!\n!> UPLO = 'U' or 'u' The upper triangular part of A is\n!\n!> supplied in AP.\n!\n!>\n!\n!> UPLO = 'L' or 'l' The lower triangular part of A is\n!\n!> supplied in AP.\n!\n!> \\endverbatim\n!\n!>\n!\n!> \\param[in] N\n!\n!> \\verbatim\n!\n!> N is INTEGER\n!\n!> On entry, N specifies the order of the matrix A.\n!\n!> N must be at least zero.\n!\n!> \\endverbatim\n!\n!>\n!\n!> \\param[in] ALPHA\n!\n!> \\verbatim\n!\n!> ALPHA is DOUBLE PRECISION.\n!\n!> On entry, ALPHA specifies the scalar alpha.\n!\n!> \\endverbatim\n!\n!>\n!\n!> \\param[in] X\n!\n!> \\verbatim\n!\n!> X is DOUBLE PRECISION array of dimension at least\n!\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!\n!> Before entry, the incremented array X must contain the n\n!\n!> element vector x.\n!\n!> \\endverbatim\n!\n!>\n!\n!> \\param[in] INCX\n!\n!> \\verbatim\n!\n!> INCX is INTEGER\n!\n!> On entry, INCX specifies the increment for the elements of\n!\n!> X. INCX must not be zero.\n!\n!> \\endverbatim\n!\n!>\n!\n!> \\param[in,out] AP\n!\n!> \\verbatim\n!\n!> AP is DOUBLE PRECISION array of DIMENSION at least\n!\n!> ( ( n*( n + 1 ) )/2 ).\n!\n!> Before entry with UPLO = 'U' or 'u', the array AP must\n!\n!> contain the upper triangular part of the symmetric matrix\n!\n!> packed sequentially, column by column, so that AP( 1 )\n!\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n!\n!> and a( 2, 2 ) respectively, and so on. On exit, the array\n!\n!> AP is overwritten by the upper triangular part of the\n!\n!> updated matrix.\n!\n!> Before entry with UPLO = 'L' or 'l', the array AP must\n!\n!> contain the lower triangular part of the symmetric matrix\n!\n!> packed sequentially, column by column, so that AP( 1 )\n!\n!> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n!\n!> and a( 3, 1 ) respectively, and so on. On exit, the array\n!\n!> AP is overwritten by the lower triangular part of the\n!\n!> updated matrix.\n!\n!> \\endverbatim\n!\n!\n!\n! Authors:\n!\n! ========\n!\n!\n!\n!> \\author Univ. of Tennessee \n!\n!> \\author Univ. of California Berkeley \n!\n!> \\author Univ. of Colorado Denver \n!\n!> \\author NAG Ltd. \n!\n!\n!\n!> \\date November 2011\n!\n!\n!\n!> \\ingroup double_blas_level2\n!\n!\n!\n!> \\par Further Details:\n!\n! =====================\n!\n!>\n!\n!> \\verbatim\n!\n!>\n!\n!> Level 2 Blas routine.\n!\n!>\n!\n!> -- Written on 22-October-1986.\n!\n!> Jack Dongarra, Argonne National Lab.\n!\n!> Jeremy Du Croz, Nag Central Office.\n!\n!> Sven Hammarling, Nag Central Office.\n!\n!> Richard Hanson, Sandia National Labs.\n!\n!> \\endverbatim\n!\n!>\n!\n! =====================================================================\n SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)\n!\n!\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n!\n! .. Scalar Arguments ..\n DOUBLE PRECISION ALPHA\n INTEGER INCX,N\n CHARACTER UPLO\n!\n! ..\n!\n! .. Array Arguments ..\n DOUBLE PRECISION AP(*),X(*)\n!\n! ..\n!\n!\n!\n! =====================================================================\n!\n!\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n!\n! ..\n!\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JX,K,KK,KX\n!\n! ..\n!\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n!\n! ..\n!\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n!\n! ..\n!\n!\n!\n! Test the input parameters.\n!\n\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (N.LT.0) THEN\n INFO = 2\n ELSE IF (INCX.EQ.0) THEN\n INFO = 5\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DSPR ',INFO)\n RETURN\n END IF\n!\n!\n!\n! Quick return if possible.\n!\n\n!\n IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN\n!\n!\n!\n! Set the start point in X if the increment is not unity.\n!\n IF (INCX.LE.0) THEN\n KX = 1 - (N-1)*INCX\n ELSE IF (INCX.NE.1) THEN\n KX = 1\n END IF\n!\n!\n!\n! Start the operations. In this version the elements of the array AP\n!\n! are accessed sequentially with one pass through AP.\n!\n KK = 1\n IF (LSAME(UPLO,'U')) THEN\n!\n!\n!\n! Form A when upper triangle is stored in AP.\n!\n IF (INCX.EQ.1) THEN\n! DO 20 J = 1,N\n DO J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = ALPHA*X(J)\n K = KK\n! DO 10 I = 1,J\n DO I = 1,J\n AP(K) = AP(K) + X(I)*TEMP\n K = K + 1\n ENDDO\n! 10 CONTINUE\n END IF\n KK = KK + J\n enddo\n! 20 CONTINUE\n ELSE\n JX = KX\n! DO 40 J = 1,N\n DO J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = ALPHA*X(JX)\n IX = KX\n! DO 30 K = KK,KK + J - 1\n DO K = KK,KK + J - 1\n AP(K) = AP(K) + X(IX)*TEMP\n IX = IX + INCX\n enddo\n! 30 CONTINUE\n END IF\n JX = JX + INCX\n KK = KK + J\n enddo\n! 40 CONTINUE\n END IF\n ELSE\n!\n!\n!\n! Form A when lower triangle is stored in AP.\n!\n IF (INCX.EQ.1) THEN\n! DO 60 J = 1,N\n DO J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = ALPHA*X(J)\n K = KK\n! DO 50 I = J,N\n DO I = J,N\n AP(K) = AP(K) + X(I)*TEMP\n K = K + 1\n enddo\n!50 CONTINUE\n END IF\n KK = KK + N - J + 1\n enddo\n! 60 CONTINUE\n ELSE\n JX = KX\n! DO 80 J = 1,N\n DO J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = ALPHA*X(JX)\n IX = JX\n! DO 70 K = KK,KK + N - J\n DO K = KK,KK + N - J\n AP(K) = AP(K) + X(IX)*TEMP\n IX = IX + INCX\n enddo\n!70 CONTINUE\n END IF\n JX = JX + INCX\n KK = KK + N - J + 1\n enddo\n! 80 CONTINUE\n END IF\n END IF\n\n!\n RETURN\n\n!\n! End of DSPR .\n\n!\n END SUBROUTINE DSPR\n!\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n!\n\n!> \\brief \\b DTPTRI\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DTPTRI + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER DIAG, UPLO\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTPTRI computes the inverse of a real upper or lower triangular\n!> matrix A stored in packed format.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': A is upper triangular;\n!> = 'L': A is lower triangular.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> = 'N': A is non-unit triangular;\n!> = 'U': A is unit triangular.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the upper or lower triangular matrix A, stored\n!> columnwise in a linear array. The j-th column of A is stored\n!> in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n!> See below for further details.\n!> On exit, the (triangular) inverse of the original matrix, in\n!> the same packed storage format.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, A(i,i) is exactly zero. The triangular\n!> matrix is singular and its inverse can not be computed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> A triangular matrix A can be transferred to packed storage using one\n!> of the following program segments:\n!>\n!> UPLO = 'U': UPLO = 'L':\n!>\n!> JC = 1 JC = 1\n!> DO 2 J = 1, N DO 2 J = 1, N\n!> DO 1 I = 1, J DO 1 I = J, N\n!> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n!> 1 CONTINUE 1 CONTINUE\n!> JC = JC + J JC = JC + N - J + 1\n!> 2 CONTINUE 2 CONTINUE\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER DIAG, UPLO\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL NOUNIT, UPPER\n INTEGER J, JC, JCLAST, JJ\n DOUBLE PRECISION AJJ\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL, DTPMV, XERBLA\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n NOUNIT = LSAME( DIAG, 'N' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN\n INFO = -2\n ELSE IF( N.LT.0 ) THEN\n INFO = -3\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DTPTRI', -INFO )\n RETURN\n END IF\n!\n! Check for singularity if non-unit.\n!\n IF( NOUNIT ) THEN\n IF( UPPER ) THEN\n JJ = 0\n! DO 10 INFO = 1, N\n DO INFO = 1, N\n JJ = JJ + INFO\n IF( AP( JJ ).EQ.ZERO ) RETURN\n enddo\n!10 CONTINUE\n ELSE\n JJ = 1\n! DO 20 INFO = 1, N\n DO INFO = 1, N\n IF( AP( JJ ).EQ.ZERO ) RETURN\n JJ = JJ + N - INFO + 1\n enddo\n!20 CONTINUE\n END IF\n INFO = 0\n END IF\n!\n IF( UPPER ) THEN\n!\n! Compute inverse of upper triangular matrix.\n!\n JC = 1\n! DO 30 J = 1, N\n DO J = 1, N\n IF( NOUNIT ) THEN\n AP( JC+J-1 ) = ONE / AP( JC+J-1 )\n AJJ = -AP( JC+J-1 )\n ELSE\n AJJ = -ONE\n END IF\n!\n! Compute elements 1:j-1 of j-th column.\n!\n CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, AP( JC ), 1 )\n CALL DSCAL( J-1, AJJ, AP( JC ), 1 )\n JC = JC + J\n enddo\n! 30 CONTINUE\n!\n ELSE\n!\n! Compute inverse of lower triangular matrix.\n!\n JC = N*( N+1 ) / 2\n! DO 40 J = N, 1, -1\n DO J = N, 1, -1\n IF( NOUNIT ) THEN\n AP( JC ) = ONE / AP( JC )\n AJJ = -AP( JC )\n ELSE\n AJJ = -ONE\n END IF\n IF( J.LT.N ) THEN\n!\n! Compute elements j+1:n of j-th column.\n!\n CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,&\n AP( JCLAST ), AP( JC+1 ), 1 )\n CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )\n END IF\n JCLAST = JC\n JC = JC - N + J - 2\n enddo\n! 40 CONTINUE\n END IF\n!\n RETURN\n!\n! End of DTPTRI\n!\n END SUBROUTINE DTPTRI\n!\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n!\n!> \\brief \\b DTPMV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,N\n! CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP(*),X(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTPMV performs one of the matrix-vector operations\n!>\n!> x := A*x, or x := A**T*x,\n!>\n!> where x is an n element vector and A is an n by n unit, or non-unit,\n!> upper or lower triangular matrix, supplied in packed form.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the matrix is an upper or\n!> lower triangular matrix as follows:\n!>\n!> UPLO = 'U' or 'u' A is an upper triangular matrix.\n!>\n!> UPLO = 'L' or 'l' A is a lower triangular matrix.\n!> \\endverbatim\n!>\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> On entry, TRANS specifies the operation to be performed as\n!> follows:\n!>\n!> TRANS = 'N' or 'n' x := A*x.\n!>\n!> TRANS = 'T' or 't' x := A**T*x.\n!>\n!> TRANS = 'C' or 'c' x := A**T*x.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> On entry, DIAG specifies whether or not A is unit\n!> triangular as follows:\n!>\n!> DIAG = 'U' or 'u' A is assumed to be unit triangular.\n!>\n!> DIAG = 'N' or 'n' A is not assumed to be unit\n!> triangular.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array of DIMENSION at least\n!> ( ( n*( n + 1 ) )/2 ).\n!> Before entry with UPLO = 'U' or 'u', the array AP must\n!> contain the upper triangular matrix packed sequentially,\n!> column by column, so that AP( 1 ) contains a( 1, 1 ),\n!> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )\n!> respectively, and so on.\n!> Before entry with UPLO = 'L' or 'l', the array AP must\n!> contain the lower triangular matrix packed sequentially,\n!> column by column, so that AP( 1 ) contains a( 1, 1 ),\n!> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )\n!> respectively, and so on.\n!> Note that when DIAG = 'U' or 'u', the diagonal elements of\n!> A are not referenced, but are assumed to be unity.\n!> \\endverbatim\n!>\n!> \\param[in,out] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element vector x. On exit, X is overwritten with the\n!> tranformed vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!> The vector and matrix arguments are not referenced when N = 0, or M = 0\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,N\n CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP(*),X(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JX,K,KK,KX\n LOGICAL NOUNIT\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.&\n .NOT.LSAME(TRANS,'C')) THEN\n INFO = 2\n ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN\n INFO = 3\n ELSE IF (N.LT.0) THEN\n INFO = 4\n ELSE IF (INCX.EQ.0) THEN\n INFO = 7\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DTPMV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF (N.EQ.0) RETURN\n!\n NOUNIT = LSAME(DIAG,'N')\n!\n! Set up the start point in X if the increment is not unity. This\n! will be ( N - 1 )*INCX too small for descending loops.\n!\n IF (INCX.LE.0) THEN\n KX = 1 - (N-1)*INCX\n ELSE IF (INCX.NE.1) THEN\n KX = 1\n END IF\n!\n! Start the operations. In this version the elements of AP are\n! accessed sequentially with one pass through AP.\n!\n IF (LSAME(TRANS,'N')) THEN\n!\n! Form x:= A*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n KK = 1\n IF (INCX.EQ.1) THEN\n! DO 20 J = 1,N\n DO J = 1,N\n IF (X(J).NE.ZERO) THEN\n TEMP = X(J)\n K = KK\n! DO 10 I = 1,J - 1\n DO I = 1,J - 1\n X(I) = X(I) + TEMP*AP(K)\n K = K + 1\n enddo\n!10 CONTINUE\n IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)\n END IF\n KK = KK + J\n enddo\n!20 CONTINUE\n ELSE\n JX = KX\n! DO 40 J = 1,N\n DO J = 1,N\n IF (X(JX).NE.ZERO) THEN\n TEMP = X(JX)\n IX = KX\n! DO 30 K = KK,KK + J - 2\n DO K = KK,KK + J - 2\n X(IX) = X(IX) + TEMP*AP(K)\n IX = IX + INCX\n enddo\n!30 CONTINUE\n IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)\n END IF\n JX = JX + INCX\n KK = KK + J\n enddo\n!40 CONTINUE\n END IF\n ELSE\n KK = (N* (N+1))/2\n IF (INCX.EQ.1) THEN\n! DO 60 J = N,1,-1\n DO J = N,1,-1\n IF (X(J).NE.ZERO) THEN\n TEMP = X(J)\n K = KK\n! DO 50 I = N,J + 1,-1\n DO I = N,J + 1,-1\n X(I) = X(I) + TEMP*AP(K)\n K = K - 1\n enddo\n!50 CONTINUE\n IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)\n END IF\n KK = KK - (N-J+1)\n enddo\n!60 CONTINUE\n ELSE\n KX = KX + (N-1)*INCX\n JX = KX\n! DO 80 J = N,1,-1\n DO J = N,1,-1\n IF (X(JX).NE.ZERO) THEN\n TEMP = X(JX)\n IX = KX\n! DO 70 K = KK,KK - (N- (J+1)),-1\n DO K = KK,KK - (N- (J+1)),-1\n X(IX) = X(IX) + TEMP*AP(K)\n IX = IX - INCX\n enddo\n!70 CONTINUE\n IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)\n END IF\n JX = JX - INCX\n KK = KK - (N-J+1)\n enddo\n!80 CONTINUE\n END IF\n END IF\n ELSE\n!\n! Form x := A**T*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n KK = (N* (N+1))/2\n IF (INCX.EQ.1) THEN\n! DO 100 J = N,1,-1\n DO J = N,1,-1\n TEMP = X(J)\n IF (NOUNIT) TEMP = TEMP*AP(KK)\n K = KK - 1\n! DO 90 I = J - 1,1,-1\n DO I = J - 1,1,-1\n TEMP = TEMP + AP(K)*X(I)\n K = K - 1\n enddo\n!90 CONTINUE\n X(J) = TEMP\n KK = KK - J\n enddo\n!100 CONTINUE\n ELSE\n JX = KX + (N-1)*INCX\n! DO 120 J = N,1,-1\n DO J = N,1,-1\n TEMP = X(JX)\n IX = JX\n IF (NOUNIT) TEMP = TEMP*AP(KK)\n! DO 110 K = KK - 1,KK - J + 1,-1\n DO K = KK - 1,KK - J + 1,-1\n IX = IX - INCX\n TEMP = TEMP + AP(K)*X(IX)\n!110 CONTINUE\n enddo\n X(JX) = TEMP\n JX = JX - INCX\n KK = KK - J\n!120 CONTINUE\n enddo\n END IF\n ELSE\n KK = 1\n IF (INCX.EQ.1) THEN\n! DO 140 J = 1,N\n DO J = 1,N\n TEMP = X(J)\n IF (NOUNIT) TEMP = TEMP*AP(KK)\n K = KK + 1\n! DO 130 I = J + 1,N\n DO I = J + 1,N\n TEMP = TEMP + AP(K)*X(I)\n K = K + 1\n!130 CONTINUE\n enddo\n X(J) = TEMP\n KK = KK + (N-J+1)\n!140 CONTINUE\n enddo\n ELSE\n JX = KX\n! DO 160 J = 1,N\n DO J = 1,N\n TEMP = X(JX)\n IX = JX\n IF (NOUNIT) TEMP = TEMP*AP(KK)\n! DO 150 K = KK + 1,KK + N - J\n DO K = KK + 1,KK + N - J\n IX = IX + INCX\n TEMP = TEMP + AP(K)*X(IX)\n!150 CONTINUE\n enddo\n X(JX) = TEMP\n JX = JX + INCX\n KK = KK + (N-J+1)\n!160 CONTINUE\n enddo\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DTPMV .\n!\n END SUBROUTINE DTPMV\n!\n!> \\brief \\b DPPTRF\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DPPTRF + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n! \n! .. Scalar Arguments ..\n! CHARACTER UPLO\n! INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DPPTRF computes the Cholesky factorization of a real symmetric\n!> positive definite matrix A stored in packed format.\n!>\n!> The factorization has the form\n!> A = U**T * U, if UPLO = 'U', or\n!> A = L * L**T, if UPLO = 'L',\n!> where U is an upper triangular matrix and L is lower triangular.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> = 'U': Upper triangle of A is stored;\n!> = 'L': Lower triangle of A is stored.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The order of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)\n!> On entry, the upper or lower triangle of the symmetric matrix\n!> A, packed columnwise in a linear array. The j-th column of A\n!> is stored in the array AP as follows:\n!> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n!> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n!> See below for further details.\n!>\n!> On exit, if INFO = 0, the triangular factor U or L from the\n!> Cholesky factorization A = U**T*U or A = L*L**T, in the same\n!> storage format as A.\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> > 0: if INFO = i, the leading minor of order i is not\n!> positive definite, and the factorization could not be\n!> completed.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup doubleOTHERcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> The packed storage scheme is illustrated by the following example\n!> when N = 4, UPLO = 'U':\n!>\n!> Two-dimensional storage of the symmetric matrix A:\n!>\n!> a11 a12 a13 a14\n!> a22 a23 a24\n!> a33 a34 (aij = aji)\n!> a44\n!>\n!> Packed storage of the upper triangle of A:\n!>\n!> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n!\n! -- LAPACK computational routine (version 3.4.0) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n CHARACTER UPLO\n INTEGER INFO, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE, ZERO\n PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )\n! ..\n! .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J, JC, JJ\n DOUBLE PRECISION AJJ\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! DOUBLE PRECISION DDOT\n! EXTERNAL LSAME, DDOT\n! ..\n! .. External Subroutines ..\n! EXTERNAL DSCAL, DSPR, DTPSV, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC SQRT\n! ..\n! .. Executable Statements ..\n!\n! Test the input parameters.\n!\n INFO = 0\n UPPER = LSAME( UPLO, 'U' )\n IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DPPTRF', -INFO )\n RETURN\n END IF\n!\n! Quick return if possible\n!\n IF( N.EQ.0 ) RETURN\n!\n IF( UPPER ) THEN\n!\n! Compute the Cholesky factorization A = U**T*U.\n!\n JJ = 0\n! DO 10 J = 1, N\n DO J = 1, N\n JC = JJ + 1\n JJ = JJ + J\n!\n! Compute elements 1:J-1 of column J.\n!\n IF( J.GT.1 ) &\n CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,AP( JC ),1 )\n!\n! Compute U(J,J) and test for non-positive-definiteness.\n!\n AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )\n IF( AJJ.LE.ZERO ) THEN\n AP( JJ ) = AJJ\n GO TO 30\n END IF\n AP( JJ ) = SQRT( AJJ )\n!10 CONTINUE\n enddo\n ELSE\n!\n! Compute the Cholesky factorization A = L*L**T.\n!\n JJ = 1\n! DO 20 J = 1, N\n DO J = 1, N\n!\n! Compute L(J,J) and test for non-positive-definiteness.\n!\n AJJ = AP( JJ )\n IF( AJJ.LE.ZERO ) THEN\n AP( JJ ) = AJJ\n GO TO 30\n END IF\n AJJ = SQRT( AJJ )\n AP( JJ ) = AJJ\n!\n! Compute elements J+1:N of column J and update the trailing\n! submatrix.\n!\n IF( J.LT.N ) THEN\n CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )\n CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, AP( JJ+N-J+1 ) )\n JJ = JJ + N - J + 1\n END IF\n!20 CONTINUE\n enddo\n END IF\n GO TO 40\n!\n30 CONTINUE\n INFO = J\n!\n40 CONTINUE\n RETURN\n!\n! End of DPPTRF\n!\n END SUBROUTINE DPPTRF\n!\n!> \\brief \\b DTPSV\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)\n! \n! .. Scalar Arguments ..\n! INTEGER INCX,N\n! CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION AP(*),X(*)\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DTPSV solves one of the systems of equations\n!>\n!> A*x = b, or A**T*x = b,\n!>\n!> where b and x are n element vectors and A is an n by n unit, or\n!> non-unit, upper or lower triangular matrix, supplied in packed form.\n!>\n!> No test for singularity or near-singularity is included in this\n!> routine. Such tests must be performed before calling this routine.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] UPLO\n!> \\verbatim\n!> UPLO is CHARACTER*1\n!> On entry, UPLO specifies whether the matrix is an upper or\n!> lower triangular matrix as follows:\n!>\n!> UPLO = 'U' or 'u' A is an upper triangular matrix.\n!>\n!> UPLO = 'L' or 'l' A is a lower triangular matrix.\n!> \\endverbatim\n!>\n!> \\param[in] TRANS\n!> \\verbatim\n!> TRANS is CHARACTER*1\n!> On entry, TRANS specifies the equations to be solved as\n!> follows:\n!>\n!> TRANS = 'N' or 'n' A*x = b.\n!>\n!> TRANS = 'T' or 't' A**T*x = b.\n!>\n!> TRANS = 'C' or 'c' A**T*x = b.\n!> \\endverbatim\n!>\n!> \\param[in] DIAG\n!> \\verbatim\n!> DIAG is CHARACTER*1\n!> On entry, DIAG specifies whether or not A is unit\n!> triangular as follows:\n!>\n!> DIAG = 'U' or 'u' A is assumed to be unit triangular.\n!>\n!> DIAG = 'N' or 'n' A is not assumed to be unit\n!> triangular.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> On entry, N specifies the order of the matrix A.\n!> N must be at least zero.\n!> \\endverbatim\n!>\n!> \\param[in] AP\n!> \\verbatim\n!> AP is DOUBLE PRECISION array of DIMENSION at least\n!> ( ( n*( n + 1 ) )/2 ).\n!> Before entry with UPLO = 'U' or 'u', the array AP must\n!> contain the upper triangular matrix packed sequentially,\n!> column by column, so that AP( 1 ) contains a( 1, 1 ),\n!> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )\n!> respectively, and so on.\n!> Before entry with UPLO = 'L' or 'l', the array AP must\n!> contain the lower triangular matrix packed sequentially,\n!> column by column, so that AP( 1 ) contains a( 1, 1 ),\n!> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )\n!> respectively, and so on.\n!> Note that when DIAG = 'U' or 'u', the diagonal elements of\n!> A are not referenced, but are assumed to be unity.\n!> \\endverbatim\n!>\n!> \\param[in,out] X\n!> \\verbatim\n!> X is DOUBLE PRECISION array of dimension at least\n!> ( 1 + ( n - 1 )*abs( INCX ) ).\n!> Before entry, the incremented array X must contain the n\n!> element right-hand side vector b. On exit, X is overwritten\n!> with the solution vector x.\n!> \\endverbatim\n!>\n!> \\param[in] INCX\n!> \\verbatim\n!> INCX is INTEGER\n!> On entry, INCX specifies the increment for the elements of\n!> X. INCX must not be zero.\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date November 2011\n!\n!> \\ingroup double_blas_level2\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> Level 2 Blas routine.\n!>\n!> -- Written on 22-October-1986.\n!> Jack Dongarra, Argonne National Lab.\n!> Jeremy Du Croz, Nag Central Office.\n!> Sven Hammarling, Nag Central Office.\n!> Richard Hanson, Sandia National Labs.\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)\n!\n! -- Reference BLAS level2 routine (version 3.4.0) --\n! -- Reference BLAS is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! November 2011\n!\n! .. Scalar Arguments ..\n INTEGER INCX,N\n CHARACTER DIAG,TRANS,UPLO\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION AP(*),X(*)\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ZERO\n PARAMETER (ZERO=0.0D+0)\n! ..\n! .. Local Scalars ..\n DOUBLE PRECISION TEMP\n INTEGER I,INFO,IX,J,JX,K,KK,KX\n LOGICAL NOUNIT\n! ..\n! .. External Functions ..\n! LOGICAL LSAME\n! EXTERNAL LSAME\n! ..\n! .. External Subroutines ..\n! EXTERNAL XERBLA\n! ..\n!\n! Test the input parameters.\n!\n INFO = 0\n IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN\n INFO = 1\n ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. &\n .NOT.LSAME(TRANS,'C')) THEN\n INFO = 2\n ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN\n INFO = 3\n ELSE IF (N.LT.0) THEN\n INFO = 4\n ELSE IF (INCX.EQ.0) THEN\n INFO = 7\n END IF\n IF (INFO.NE.0) THEN\n CALL XERBLA('DTPSV ',INFO)\n RETURN\n END IF\n!\n! Quick return if possible.\n!\n IF (N.EQ.0) RETURN\n!\n NOUNIT = LSAME(DIAG,'N')\n!\n! Set up the start point in X if the increment is not unity. This\n! will be ( N - 1 )*INCX too small for descending loops.\n!\n IF (INCX.LE.0) THEN\n KX = 1 - (N-1)*INCX\n ELSE IF (INCX.NE.1) THEN\n KX = 1\n END IF\n!\n! Start the operations. In this version the elements of AP are\n! accessed sequentially with one pass through AP.\n!\n IF (LSAME(TRANS,'N')) THEN\n!\n! Form x := inv( A )*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n KK = (N* (N+1))/2\n IF (INCX.EQ.1) THEN\n! DO 20 J = N,1,-1\n DO J = N,1,-1\n IF (X(J).NE.ZERO) THEN\n IF (NOUNIT) X(J) = X(J)/AP(KK)\n TEMP = X(J)\n K = KK - 1\n! DO 10 I = J - 1,1,-1\n DO I = J - 1,1,-1\n X(I) = X(I) - TEMP*AP(K)\n K = K - 1\n!10 CONTINUE\n enddo\n END IF\n KK = KK - J\n!20 CONTINUE\n enddo\n ELSE\n JX = KX + (N-1)*INCX\n! DO 40 J = N,1,-1\n DO J = N,1,-1\n IF (X(JX).NE.ZERO) THEN\n IF (NOUNIT) X(JX) = X(JX)/AP(KK)\n TEMP = X(JX)\n IX = JX\n! DO 30 K = KK - 1,KK - J + 1,-1\n DO K = KK - 1,KK - J + 1,-1\n IX = IX - INCX\n X(IX) = X(IX) - TEMP*AP(K)\n!30 CONTINUE\n enddo\n END IF\n JX = JX - INCX\n KK = KK - J\n!40 CONTINUE\n enddo\n END IF\n ELSE\n KK = 1\n IF (INCX.EQ.1) THEN\n! DO 60 J = 1,N\n DO J = 1,N\n IF (X(J).NE.ZERO) THEN\n IF (NOUNIT) X(J) = X(J)/AP(KK)\n TEMP = X(J)\n K = KK + 1\n! DO 50 I = J + 1,N\n DO I = J + 1,N\n X(I) = X(I) - TEMP*AP(K)\n K = K + 1\n!50 CONTINUE\n enddo\n END IF\n KK = KK + (N-J+1)\n!60 CONTINUE\n enddo\n ELSE\n JX = KX\n! DO 80 J = 1,N\n DO J = 1,N\n IF (X(JX).NE.ZERO) THEN\n IF (NOUNIT) X(JX) = X(JX)/AP(KK)\n TEMP = X(JX)\n IX = JX\n! DO 70 K = KK + 1,KK + N - J\n DO K = KK + 1,KK + N - J\n IX = IX + INCX\n X(IX) = X(IX) - TEMP*AP(K)\n!70 CONTINUE\n enddo\n END IF\n JX = JX + INCX\n KK = KK + (N-J+1)\n!80 CONTINUE\n enddo\n END IF\n END IF\n ELSE\n!\n! Form x := inv( A**T )*x.\n!\n IF (LSAME(UPLO,'U')) THEN\n KK = 1\n IF (INCX.EQ.1) THEN\n! DO 100 J = 1,N\n DO J = 1,N\n TEMP = X(J)\n K = KK\n! DO 90 I = 1,J - 1\n DO I = 1,J - 1\n TEMP = TEMP - AP(K)*X(I)\n K = K + 1\n!90 CONTINUE\n enddo\n IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)\n X(J) = TEMP\n KK = KK + J\n!100 CONTINUE\n enddo\n ELSE\n JX = KX\n! DO 120 J = 1,N\n DO J = 1,N\n TEMP = X(JX)\n IX = KX\n! DO 110 K = KK,KK + J - 2\n DO K = KK,KK + J - 2\n TEMP = TEMP - AP(K)*X(IX)\n IX = IX + INCX\n!110 CONTINUE\n enddo\n IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)\n X(JX) = TEMP\n JX = JX + INCX\n KK = KK + J\n!120 CONTINUE\n enddo\n END IF\n ELSE\n KK = (N* (N+1))/2\n IF (INCX.EQ.1) THEN\n! DO 140 J = N,1,-1\n DO J = N,1,-1\n TEMP = X(J)\n K = KK\n! DO 130 I = N,J + 1,-1\n DO I = N,J + 1,-1\n TEMP = TEMP - AP(K)*X(I)\n K = K - 1\n!130 CONTINUE\n enddo\n IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)\n X(J) = TEMP\n KK = KK - (N-J+1)\n!140 CONTINUE\n enddo\n ELSE\n KX = KX + (N-1)*INCX\n JX = KX\n! DO 160 J = N,1,-1\n DO J = N,1,-1\n TEMP = X(JX)\n IX = KX\n! DO 150 K = KK,KK - (N- (J+1)),-1\n DO K = KK,KK - (N- (J+1)),-1\n TEMP = TEMP - AP(K)*X(IX)\n IX = IX - INCX\n!150 CONTINUE\n enddo\n IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)\n X(JX) = TEMP\n JX = JX - INCX\n KK = KK - (N-J+1)\n!160 CONTINUE\n enddo\n END IF\n END IF\n END IF\n!\n RETURN\n!\n! End of DTPSV .\n!\n END SUBROUTINE DTPSV\n!\n! ===================================================================\n!\n!> \\brief \\b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.\n!\n! =========== DOCUMENTATION ===========\n!\n! Online html documentation available at \n! http://www.netlib.org/lapack/explore-html/ \n!\n!> \\htmlonly\n!> Download DGEQR2 + dependencies \n!> \n!> [TGZ] \n!> \n!> [ZIP] \n!> \n!> [TXT]\n!> \\endhtmlonly \n!\n! Definition:\n! ===========\n!\n! SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n! \n! .. Scalar Arguments ..\n! INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n! \n!\n!> \\par Purpose:\n! =============\n!>\n!> \\verbatim\n!>\n!> DGEQR2 computes a QR factorization of a real m by n matrix A:\n!> A = Q * R.\n!> \\endverbatim\n!\n! Arguments:\n! ==========\n!\n!> \\param[in] M\n!> \\verbatim\n!> M is INTEGER\n!> The number of rows of the matrix A. M >= 0.\n!> \\endverbatim\n!>\n!> \\param[in] N\n!> \\verbatim\n!> N is INTEGER\n!> The number of columns of the matrix A. N >= 0.\n!> \\endverbatim\n!>\n!> \\param[in,out] A\n!> \\verbatim\n!> A is DOUBLE PRECISION array, dimension (LDA,N)\n!> On entry, the m by n matrix A.\n!> On exit, the elements on and above the diagonal of the array\n!> contain the min(m,n) by n upper trapezoidal matrix R (R is\n!> upper triangular if m >= n); the elements below the diagonal,\n!> with the array TAU, represent the orthogonal matrix Q as a\n!> product of elementary reflectors (see Further Details).\n!> \\endverbatim\n!>\n!> \\param[in] LDA\n!> \\verbatim\n!> LDA is INTEGER\n!> The leading dimension of the array A. LDA >= max(1,M).\n!> \\endverbatim\n!>\n!> \\param[out] TAU\n!> \\verbatim\n!> TAU is DOUBLE PRECISION array, dimension (min(M,N))\n!> The scalar factors of the elementary reflectors (see Further\n!> Details).\n!> \\endverbatim\n!>\n!> \\param[out] WORK\n!> \\verbatim\n!> WORK is DOUBLE PRECISION array, dimension (N)\n!> \\endverbatim\n!>\n!> \\param[out] INFO\n!> \\verbatim\n!> INFO is INTEGER\n!> = 0: successful exit\n!> < 0: if INFO = -i, the i-th argument had an illegal value\n!> \\endverbatim\n!\n! Authors:\n! ========\n!\n!> \\author Univ. of Tennessee \n!> \\author Univ. of California Berkeley \n!> \\author Univ. of Colorado Denver \n!> \\author NAG Ltd. \n!\n!> \\date September 2012\n!\n!> \\ingroup doubleGEcomputational\n!\n!> \\par Further Details:\n! =====================\n!>\n!> \\verbatim\n!>\n!> The matrix Q is represented as a product of elementary reflectors\n!>\n!> Q = H(1) H(2) . . . H(k), where k = min(m,n).\n!>\n!> Each H(i) has the form\n!>\n!> H(i) = I - tau * v * v**T\n!>\n!> where tau is a real scalar, and v is a real vector with\n!> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n!> and tau in TAU(i).\n!> \\endverbatim\n!>\n! =====================================================================\n SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n!\n! -- LAPACK computational routine (version 3.4.2) --\n! -- LAPACK is a software package provided by Univ. of Tennessee, --\n! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--\n! September 2012\n!\n! .. Scalar Arguments ..\n INTEGER INFO, LDA, M, N\n! ..\n! .. Array Arguments ..\n DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )\n! ..\n!\n! =====================================================================\n!\n! .. Parameters ..\n DOUBLE PRECISION ONE\n PARAMETER ( ONE = 1.0D+0 )\n! ..\n! .. Local Scalars ..\n INTEGER I, K\n DOUBLE PRECISION AII\n! ..\n! .. External Subroutines ..\n! EXTERNAL DLARF, DLARFG, XERBLA\n! ..\n! .. Intrinsic Functions ..\n! INTRINSIC MAX, MIN\n! ..\n! .. Executable Statements ..\n!\n! Test the input arguments\n!\n INFO = 0\n IF( M.LT.0 ) THEN\n INFO = -1\n ELSE IF( N.LT.0 ) THEN\n INFO = -2\n ELSE IF( LDA.LT.MAX( 1, M ) ) THEN\n INFO = -4\n END IF\n IF( INFO.NE.0 ) THEN\n CALL XERBLA( 'DGEQR2', -INFO )\n RETURN\n END IF\n!\n K = MIN( M, N )\n!\n DO I = 1, K\n!\n! Generate elementary reflector H(i) to annihilate A(i+1:m,i)\n!\n CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, TAU( I ) )\n IF( I.LT.N ) THEN\n!\n! Apply H(i) to A(i:m,i+1:n) from the left\n!\n AII = A( I, I )\n A( I, I ) = ONE\n CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), &\n A( I, I+1 ), LDA, WORK )\n A( I, I ) = AII\n END IF\n enddo\n RETURN\n!\n! End of DGEQR2\n! \n END SUBROUTINE DGEQR2\n!\n!====================================== list of all subroutines/functions\n!\n! SUBROUTINES included complete 2019.11.12\n! DGETRI\n! DTRTRI\n! DTRTI2\n! DCOPY\n! DGEMM\n! DGEMV\n! DGETRF\n! DGETRF2\n! DGETRS\n! DLAMRG\n! DLASWP\n! DLASYF\n! DSCAL\n! DSWAP\n! DSYMV\n! DSYR\n! DSYTF2\n! DSYTRF\n! DSYTRI\n! DTRSM \n! XERBLA\n! DSPEVD\n! DLASSQ\n! DSPTRD\n! DLARFG\n! DSTERF\n! DOPMTR\n! DLARF\n! DSPEV\n! DSTEDC\n! DLASCL\n! DSTEQR\n! DLASET\n! DLAEV2\n! DLASR\n! DLASRT\n! DLAE2\n! DLARTG\n! DLACPY\n! DLAED0\n! DLAED1\n! DLAED7\n! DLAED8\n! DLAED9\n! DLAED2\n! DLAED3\n! DLAED4\n! DLAED5\n! DLAED6\n! DLAEDA\n! DOPGTR\n! DORG2L\n! DORG2R\n! DROT\n! DGER\n! DSPMV\n! DAXPY\n! DSPR2 \n! DTRMV\n! DTRMM\n! DPPTRI\n! DSPR\n! DTPTRI\n! DTPMV\n! DPPTRF\n! DTPSV\n! DGEQR2\n! \n! Functions:\n! DDOT\n! DISNAN\n! DLAISNAN\n! DLAMCH\n! DLAMC3\n! IDAMAX\n! IEEECK\n! ILAENV\n! IPARMQ\n! LSAME\n! LSAMEN\n! DLANSP\n! DLAPY2\n! DLANST\n! ILADLC\n! ILADLR\n! DNRM2\n! \n!\nend module oclablas\n\n\n" }, { "path": "src/numlib/ocnum.F90", "content": "!\n! MODULE LUKASNUM\nMODULE OCNUM\n!\n! This is free software using LAPACK and BLAS\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n!\n!-------------------\n!\n! double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,&\n! DMAX=1.0D+36,DMIN=1.0D-36,epsx=1.0D-10,r=8.31451D0,&\n! unity=1.0D0,zero=0.0D0\n! COMPILER WARNING ABOUT UNINITIALIZED ZERO, DSMIN, DSMAX, DMAX, DMIN, UNITY\n! double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,&\n! DMAX=1.0D+36,DMIN=1.0D-36,unity=1.0D0,zero=0.0D0\n! modified to handle gas phases with fractions 1.0D-30 \n! double precision, private, parameter :: DSMIN=1.0D-33,DSMAX=1.0D+33,&\n! DMAX=1.0D+60,DMIN=1.0D-60,&\n! epsx=1.0D-10,r=8.31451D0,unity=1.0D0,zero=0.0D0\n!\n! The orignal routines LINGLD and MDINV written by H L Lukas\n! has been replaced by using LAPACK and BLAS\n!\n! MDINV was split in two to handle symmetric and general matrices.\n!\n! oclablas is a small subset of lapack and blas needed for OC\n! it is not optimized for any hardware. If you have a full LAPACK+BLAS\n! library for your hardware you should use that.\n!\n#ifdef NOLAPACK\nuse oclablas\n! compile with -DLAPACK if LAPCK not extermal\n#endif\n!\n! COMPILER WARNING ABOUT UNINITIALIZED ZERO, DSMIN, DSMAX, DMAX, DMIN, UNITY\n double precision, private, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,&\n DMAX=1.0D+36,DMIN=1.0D-36,unity=1.0D0,zero=0.0D0\n! declaration above must follow after USE\n!\nCONTAINS\n!\n!CCI\n!-----------------------------------------------------------------------\n!-----------------------------------------------------------------------\n! Development based on the work of Joao Pedro Carvalho Teuber 12/2020\n! Linear system solved by splitting approch for conditions giving square\n! mass matrix. Otherwise lingld is used\n SUBROUTINE lingldSplit(ND1,ND2,RMAT,X,N,M,NCONST,NPH)\n!-----------------------------------------------------------------------\n! Solving a system of n linear equations with n unknowns\n! | Masse 0 | |X| = | Gibbs |\n! | Ca MasseT | | | | Cig |\n!-----------------------------------------------------------------------\n implicit none\n integer M,N,ND1,ND2, NPH, NCONST\n double precision RMAT(ND1,ND2),X(ND1)\n!-----------------------------------------------------------------------\n character trans*1\n integer i,j,k,nrhs,lda,ldb,info\n integer ipiv1(n), ipiv2(n), ipiv(n)\n double precision, allocatable :: a(:,:),Masse(:, :), Gibbs(:),&\n MasseT(:, :), Cig(:)\n!\n allocate(a(n,n))\n allocate(Cig(NCONST))\n allocate(Masse(NPH, NCONST))\n allocate(Gibbs(NPH))\n allocate(MasseT(NCONST, NPH))\n!\n ipiv=0\n ipiv1=0\n ipiv2=0\n nrhs=1\n trans='N'\n lda=n\n ldb=n\n!\n do j=1,N\n do k=1,N\n a(j,k)=rmat(j,k)\n enddo\n x(j)=rmat(j,n+1)\n enddo\n do j=1,NPH\n do k=1, NCONST\n Masse(j,k) = a(j,k)\n Gibbs(j) = x(j)\n enddo\n enddo\n MasseT = transpose(Masse)\n! Solve first part of the system\n call DGETRF(NPH, NCONST,Masse, NPH,IPIV1,INFO)\n if(info.ne.0) then\n write(*,*)'lingldSplit: Error return from dgetrf',info\n goto 900\n endif\n call DGETRS(TRANS,NPH,NRHS,Masse,NPH,IPIV1,Gibbs,NPH,INFO)\n! Solve second part of the system\n! Ca = a(j+NPH,1:NCONST)\n!***********************************/BoS\n! for MQMQA calculations with fix gas phase error here\n! index of j larger than dimension of x\n!***********************************\n do j=1, NCONST\n Cig(j) = x(j+NPH) - DOT_PRODUCT(a(j+NPH,1:NCONST), Gibbs)\n enddo\n call DGETRF(NCONST, NPH, MasseT, NCONST,IPIV2,INFO)\n if(info.ne.0) then\n write(*,*)'lingldSplit: Error return from dgetrf',info\n goto 900\n endif\n call DGETRS(TRANS,NCONST,NRHS,MasseT,NCONST,IPIV2,Cig,NCONST,INFO)\n ! get solution\n do j=1, N\n if(j.LE.NCONST) then\n x(j) = Gibbs(j)\n else\n x(j) = Cig(j-NPH)\n endif\n enddo\n900 continue\n deallocate(a,Masse, Gibbs,MasseT, Cig)\n return\n END SUBROUTINE lingldSplit\n!CCI\n\n!-----------------------------------------------------------------------\n SUBROUTINE LINGLDY (ND1,ND2,RMAT,X,N,M)\n!-----------------------------------------------------------------------\n! System of n linear equations with n unknowns,\n! algorithm after Gauss with line exchange\n! ND1, ND2 = Dimensioning of RMAT and X (ND2 = ND1 + 1)\n! RMAT = matrix with right hand side as additional column, changed\n! X = result vector\n! N = number of equations and unknowns\n! M = Test for singularity (= n - rank)\n!-----------------------------------------------------------------------\n!---- COMMON VARIABLES\n! COMMON /ALLG/ DMAX,DMIN,DSMAX,DSMIN,EPSX,R,UNITY,ZERO\n! DOUBLE PRECISION DMAX,DMIN,DSMAX,DSMIN,EPSX,R,UNITY,ZERO\n!-----------------------------------------------------------------------\n!---- VARIABLES OF THE ARGUMENT LIST\n INTEGER M,N,ND1,ND2\n DOUBLE PRECISION RMAT(ND1,ND2),X(ND1)\n!-----------------------------------------------------------------------\n!---- LOCAL VARIABLES\n DOUBLE PRECISION A,B,C\n INTEGER I,I1,J,K,L,N1,NN1\n!-----------------------------------------------------------------------\n! double precision, parameter :: DSMIN=1.0D-18,DSMAX=1.0D+18,&\n! DMAX=1.0D+36,DMIN=1.0D-36,epsx=1.0D-10,r=8.31451D0,&\n! unity=1.0D0,zero=0.0D0\n! DSMIN=1.0D-18\n! DSMAX=1.0D+18\n! DMAX=1.0D+36\n! DMIN=1.0D-36\n! epsx=1.0D-10\n! r=8.31451d0\n! unity=1.0D0\n! zero=0.0D0\n!-----------------------------------------------------------------------\n! write(*,*)'enter lingld'\n N1=N+1\n NN1=N-1\n M=0\n!-----------------------------------------------------------------------\n L490: DO I=1,NN1\n I1=I+1\n A=ZERO\n L=I\n!-----------------------------------------------------------------------\n! search of pivot line\n L290: DO J=I,N\n B=ZERO\n L220: DO K=I,N\n IF(DABS(RMAT(J,K)).LT.DSMIN) GOTO 210\n IF(DABS(RMAT(J,K)).GT.DSMAX) GOTO 200\n B=B+RMAT(J,K)**2\n GOTO 220\n200 B=B+DMAX\n GOTO 220\n210 B=B+DMIN\n220 CONTINUE\n enddo L220\n IF (B.GE.DMAX) GOTO 290\n IF (DABS(RMAT(J,I))*DSMAX.LT.B) GOTO 290\n IF (DABS(RMAT(J,I)).LT.DSMIN) GOTO 290\n C=RMAT(J,I)/B*RMAT(J,I)\n IF (C.LE.A) GOTO 290\n A=C\n L=J\n290 CONTINUE\n enddo L290\n!-----------------------------------------------------------------------\n! line exchange\n IF (L.EQ.I) GOTO 400\n L300: DO J=I,N1\n C=RMAT(I,J)\n RMAT(I,J)=RMAT(L,J)\n RMAT(L,J)=C\n enddo L300\n!-----------------------------------------------------------------------\n! diagonalisation of the matrix\n400 CONTINUE\n L470: DO J=I1,N\n IF (DABS(RMAT(J,I)).LT.DSMIN.AND.DABS(RMAT(I,I)).GE.UNITY) &\n GOTO 470\n IF (DABS(RMAT(J,I)).LE.UNITY.AND.DABS(RMAT(I,I)).GT.DSMAX) &\n GOTO 470\n IF (DABS(RMAT(J,I)).LT.DMIN) GOTO 470\n IF (DABS(RMAT(J,I)).GT.DSMAX.AND.DABS(RMAT(I,I)).LE.UNITY) &\n GOTO 460\n IF (DABS(RMAT(J,I)).GE.UNITY.AND.DABS(RMAT(I,I)).LT.DSMIN) &\n GOTO 460\n IF (DABS(RMAT(I,I)).LT.DMIN) GOTO 470\n C=RMAT(J,I)/RMAT(I,I)\n L440: DO K=I1,N1\n IF (DABS(RMAT(I,K)).LT.DSMIN.AND.DABS(C).LE.UNITY) GOTO 440\n IF (DABS(RMAT(I,K)).LE.UNITY.AND.DABS(C).LT.DSMIN) GOTO 440\n IF (DABS(RMAT(I,K)).LT.DMIN.OR.DABS(C).LT.DMIN) GOTO 440\n IF (DABS(RMAT(I,K)).GT.DSMAX.AND.DABS(C).GE.UNITY) GOTO 430\n IF (DABS(RMAT(I,K)).GE.UNITY.AND.DABS(C).GT.DSMAX) GOTO 430\n RMAT(J,K)=RMAT(J,K)-RMAT(I,K)*C\n GOTO 440\n430 CALL WARNGB (3,A,B,J,K)\n440 CONTINUE\n enddo L440\n GOTO 470\n460 CALL WARNGB(3,A,B,J,I)\n470 CONTINUE\n enddo L470\n490 CONTINUE\n enddo L490\n!-----------------------------------------------------------------------\n L700: DO L=1,N\n I=N1-L\n I1=I-1\n IF (DABS(RMAT(I,N1)).LT.DSMIN.AND.DABS(RMAT(I,I)).GE.UNITY) &\n GOTO 660\n IF (DABS(RMAT(I,N1)).LE.UNITY.AND.DABS(RMAT(I,I)).GT.DSMAX) &\n GOTO 660\n IF (DABS(RMAT(I,N1)).LT.DMIN) GOTO 660\n IF (DABS(RMAT(I,N1)).GT.DSMAX.AND.DABS(RMAT(I,I)).LE.UNITY) &\n GOTO 650\n IF (DABS(RMAT(I,N1)).GE.UNITY.AND.DABS(RMAT(I,I)).LT.DSMIN) &\n GOTO 650\n IF (DABS(RMAT(I,I)).LT.DMIN) GOTO 650\n C=RMAT(I,N1)/RMAT(I,I)\n X(I)=C\n IF (I.EQ.1) GOTO 700\n L600: DO J=1,I1\n IF (DABS(RMAT(J,I)).LT.DSMIN.AND.DABS(C).LE.UNITY) GOTO 600\n IF (DABS(RMAT(J,I)).LE.UNITY.AND.DABS(C).LT.DSMIN) GOTO 600\n IF (DABS(RMAT(J,I)).LT.DMIN.OR.DABS(C).LT.DMIN) GOTO 600\n IF (DABS(RMAT(J,I)).GT.DSMAX.AND.DABS(C).GE.UNITY) GOTO 550\n IF (DABS(RMAT(J,I)).GE.UNITY.AND.DABS(C).GT.DSMAX) GOTO 550\n RMAT(J,N1)=RMAT(J,N1)-RMAT(J,I)*C\n GOTO 600\n550 CALL WARNGB (3,A,B,J,I)\n600 CONTINUE\n enddo L600\n GOTO 700\n!-----------------------------------------------------------------------\n! matrix singular, cutting of line and column to continue\n650 M=M+1\n660 X(I)=ZERO\n!-----------------------------------------------------------------------\n700 CONTINUE\n enddo L700\n! write(*,701)DSMIN,DSMAX,UNITY,DMAX,DMIN\n!701 format('LINGLD: ',5(1PE12.4))\n RETURN\n END SUBROUTINE LINGLDY\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n SUBROUTINE WARNGB (NR,A1,A2,I1,I2)\n!---- Printing of warnings, counting and stop printing after 5 times\n!-----------------------------------------------------------------------\n!---- VARIABLES OF THE ARGUMENT LIST\n INTEGER I1,I2,NR\n REAL*8 A1,A2\n!-----------------------------------------------------------------------\n!---- LOCAL VARIABLES\n INTEGER K(4)\n SAVE K\n DATA K/0,0,0,0/\n!-----------------------------------------------------------------------\n10 FORMAT (a,': Following message appears last time')\n20 FORMAT (a,': Temperature',F8.2,' above maximum Temp.:',F8.2, &\n ' IPHEXC(*,1-2) =',2I3)\n30 FORMAT (a,': Phase stability of component',I3,' of phase',I3/5X, &\n 'is not defined for T =',F8.2,', range from',F8.2,' taken')\n40 FORMAT (a,': Error in LINGLD, place(',I2,',',I2,')')\n50 FORMAT (a,': d2G/dx2 suffers from rounding, phase',I3,' type',I3, &\n ' x =',E10.3,' test',E9.2)\n90 FORMAT (a,': Subroutine WARNGB called with NR =',I3)\n!-----------------------------------------------------------------------\n! write(*,*)'enter WARNGB'\n return\n IF (NR.LT.1.OR.NR.GT.4) GOTO 900\n K(NR)=K(NR)+1\n IF (K(NR).GT.5) RETURN\n IF (K(NR).EQ.5) WRITE (*,10)'WARNGB'\n GOTO (200,300,400,500),NR\n200 WRITE (*,20)'WARNGB', A1,A2,I1,I2\n RETURN\n300 WRITE (*,30)'WARNGB', I1,I2,A1,A2\n RETURN\n400 WRITE (*,40)'WARNGB', I1,I2\n RETURN\n500 WRITE (*,50)'WARNGB', I1,I2,A1,A2\n RETURN\n900 WRITE (*,90)'WARNGB', NR\n STOP\n END SUBROUTINE WARNGB\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n SUBROUTINE PRECOND (ND1,ND2,RMAT,BADMAT)\n! This is called from matsmin, code added by Clement/Joao from CEA\n implicit none\n INTEGER ND1,ND2, J\n DOUBLE PRECISION RMAT(ND1,ND2), INVERSIBLE\n LOGICAL BADMAT\n\n BADMAT=.FALSE.\n INVERSIBLE = 1.D20\n DO J=1,ND1\n INVERSIBLE = min(INVERSIBLE,DABS(RMAT(J,J)))\n ENDDO\n IF ((INVERSIBLE.GT.0.D0).AND.(ND1.EQ.ND2-1)) THEN\n DO J=1,ND1\n RMAT(J,ND2) = RMAT(J,ND2)/RMAT(J,J)\n RMAT(J,J) = 1.0D0\n ENDDO\n ELSE\n! Added due to problems in parallel2 running all macros /2022.02.20 BOS\n! probably because NEW Y does not reinitiate\n! write(*,*)'PRECOND: Matrix illconditioned',INVERSIBLE\n BADMAT=.TRUE.\n! ignoring this message .... it does not seem to matter 2020.02.19/BoS\n! IF (ND1.NE.ND2-1) THEN\n! WRITE(*,*) 'PRECOND: No Square Matrix - no preconditiong applied'\n! ELSE\n! WRITE(*,77)ND1,ND2,INVERSIBLE\n!77 format('PRECOND: Matrix not inversible - no preconditiong applied',&\n! 2i4,1pe12.4)\n! ENDIF\n ENDIF\n RETURN\n END SUBROUTINE PRECOND\n\n SUBROUTINE LINGLD (ND1,ND2,RMAT,X,N,M)\n!-----------------------------------------------------------------------\n! Solving a system of n linear equations with n unknowns\n! USING LAPACK+BLAS\n! ND1, ND2 = Dimensioning of RMAT and X (ND2 = ND1 + 1)\n! RMAT = matrix with right hand side as additional column, changed\n! X = result vector\n! N = number of equations and unknowns\n! M = Test for singularity (= n - rank)\n!-----------------------------------------------------------------------\n implicit none\n INTEGER M,N,ND1,ND2\n DOUBLE PRECISION RMAT(ND1,ND2),X(ND1)\n!-----------------------------------------------------------------------\n character trans*1\n integer j,k,nrhs,lda,ldb,info\n integer, allocatable :: ipiv(:)\n double precision, allocatable :: a(:,:)\n!\n allocate(a(n,n))\n allocate(ipiv(n))\n ipiv=0\n! there is just one right hand side\n nrhs=1\n! right hand side is in rmat(n+1,j),j=1,n), move it to x\n do j=1,n\n do k=1,n\n a(j,k)=rmat(j,k)\n enddo\n x(j)=rmat(j,n+1)\n enddo\n! write(*,*)'Solving: ',nd1,nd2,n\n! do j=1,n\n! write(*,11)j,(rmat(j,k),k=1,n+1)\n! enddo\n! do j=1,n\n! write(*,11)j,x(j),(a(j,k),k=1,n)\n! enddo\n11 format(i3,6(1pe12.4))\n! trans='N' means no transpose\n trans='N'\n lda=n\n ldb=n\n!\n! we must first L*U factorize RMAT, the original values destroyed\n! CALL DGETRF(N,N,RMAT,LDA,IPIV,INFO)\n CALL DGETRF(N,N,A,LDA,IPIV,INFO)\n if(info.ne.0) then\n! write(*,*)'Error return dgetrf',info\n goto 900\n endif\n! right hand side in X is overwritten by solution\n CALL DGETRS(TRANS,N,NRHS,A,LDA,IPIV,X,LDB,INFO)\n! if(info.ne.0) then\n! write(*,*)'Error return dgetrs',info\n! endif\n900 continue\n! info=0 meaks OK, returning m=0 means error\n m=info\n! No warnings here, using gridminimizer may generate errors that can be ignored\n! if(info.gt.0) then\n! write(*,*)'Error solving equilibrium matrix with DGETRS'\n! else\n! write(*,*)'Solving equilibrium matrix with DGETRS',m\n! endif\n1000 continue\n!CCI\n deallocate (a, ipiv)\n!CCI\n return\n END SUBROUTINE LINGLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n SUBROUTINE MDINV (ND1,RMAT,RINV,N,IS)\n! ND2 not used and removed to eliminate confusions\n! SUBROUTINE MDINV (ND1,ND2,RMAT,RINV,N,IS)\n! SUBROUTINE MSINV (ND1,RMAT,RINV,IS)\n!-----------------------------------------------------------------------\n! Matrix inversion, symmetric matrix, DOUBLE PRECISION\n! using LAPACK (phase matrix)\n! ND1, ND2 = Dimensioning of RMAT and RINV (ND2 = ND1 + 1)\n! RINV = invers of matrix RMAT (without last column of RMAT)\n! RMAT = matrix with additional column\n! N = number of lines and columns\n! IS = Test for singularity (0 = singular, 1 = not singular)\n!-----------------------------------------------------------------------\n!\n implicit none\n integer nd1,nd2,n,is\n double precision rmat(nd1,nd1),rinv(nd1,nd1)\n!\n integer, dimension(:), allocatable :: ipiv\n double precision, dimension(:), allocatable :: work\n integer i,j,info,lda,m,lwork\n character uplo*1\n! if(nd1.ne.n) \n! write(*,*)'in mdinv: ',nd1,n\n! do not destroy RMAT\n! do i=1,nd1\n! write(*,17)nd1,(rmat(j,i),j=1,nd1)\n! enddo\n!17 format(i3,6(1pe12.4)/(3x,6e12.4))\n RINV=RMAT\n!\n lda=n\n allocate(ipiv(n))\n! nonzero ipiv(i) will signalis the original row of row i\n ipiv=0\n! upper triangular symmetric matrix\n uplo='U'\n! if called with lwork=-1 the optimal dimension of work is returned\n m=-1\n! write(*,*)'Calling dsytrf',lda,m,n\n allocate(work(800))\n CALL DSYTRF(UPLO,N,RMAT,LDA,IPIV,WORK,m,INFO)\n if(info.ne.0) then\n write(*,*)'MDINV: Error from DSYTRF: ',info\n IS=0\n goto 1000\n endif\n!\n lwork=int(work(1))\n! write(*,*)'lwork: ',nd1,n,lwork\n if(lwork.gt.700) then\n deallocate(work)\n allocate(work(lwork))\n endif\n! factorize a symmetric unpacked indefinite matrix\n CALL DSYTRF(UPLO,N,RINV,LDA,IPIV,WORK,LWORK,INFO)\n if(info.ne.0) then\n! write(*,*)'Error return from DSYTRF:',info\n is=0; goto 1000\n endif\n! invert using the factorization\n CALL DSYTRI(UPLO,N,RINV,LDA,IPIV,WORK,INFO)\n! write(*,*)'Info: ',info,n,lda,lwork\n if(info.ne.0) then\n! write(*,*)'Error return from DSYTRI: ',info\n is=0; goto 1000\n endif\n! copy solution to RINV triangle to lower\n do i=2,n\n do j=1,i-1\n RINV(i,j)=RINV(j,i)\n enddo\n enddo\n! all OK\n! write(*,*)'Matrix inverted using DSYTRI'\n is=1\n!\n1000 continue\n RETURN\n END SUBROUTINE MDINV\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n SUBROUTINE MDINVOLD(ND1,RMAT,RINV,N,IS)\n! ND2 not used and removed to eliminate confusion\n! SUBROUTINE MDINVOLD(ND1,ND2,RMAT,RINV,N,IS)\n! SUBROUTINE MGINV(ND1,RMAT,RINV,IS)\n!-----------------------------------------------------------------------\n! Matrix inversion, general matrix, DOUBLE PRECISION\n! using LAPACK for general matrix (component matrix)\n! ND1, ND2 = Dimensioning of RMAT and RINV (ND2 = ND1 + 1)\n! RINV = invers of matrix RMAT (without last column of RMAT)\n! RMAT = matrix with additional column\n! N = number of lines and columns\n! IS = Test for singularity (0 = singular, 1 = not singular)\n!-----------------------------------------------------------------------\n!\n implicit none\n integer nd1,nd2,n,is\n double precision rmat(nd1,nd1),rinv(nd1,nd1)\n integer, dimension(:), allocatable :: ipiv\n double precision, dimension(:), allocatable :: work\n integer i,j,info,lda,m,lwork\n! if(nd1.ne.n) \n! write(*,*)'in mdinv: ',nd1,n\n! do not destroy RMAT\n! do i=1,nd1\n! write(*,17)nd1,(rmat(j,i),j=1,nd1)\n! enddo\n!17 format(i3,6(1pe12.4)/(3x,6e12.4))\n! copy input matrix to solution not to destroy RMAT\n RINV=RMAT\n!\n lda=n\n allocate(ipiv(n))\n! nonzero ipiv(i) will signal the original row of row i\n ipiv=0\n! if called with lwork=-1 the optimal dimension of work is returned\n m=-1\n! write(*,*)'Calling dsytrf',lda,m,n\n allocate(work(800))\n! replaced DSY with DGE for general matrix inversion .... ????\n CALL DGETRI(N,RINV,LDA,IPIV,WORK,m,INFO)\n if(info.ne.0) then\n! write(*,*)'Error from DGETRI at 1: ',info\n IS=0\n goto 1000\n endif\n!\n lwork=int(work(1))\n! write(*,*)'lwork: ',nd1,n,lwork\n if(lwork.gt.700) then\n deallocate(work)\n allocate(work(lwork))\n endif\n! factorize an general matrix\n CALL DGETRF(N,N,RINV,LDA,IPIV,INFO)\n if(info.ne.0) then\n! write(*,*)'Error return from DGETRF:',info\n is=0; goto 1000\n endif\n! invert a general matrix using the factorization\n CALL DGETRI(N,RINV,LDA,IPIV,WORK,LWORK,INFO)\n! write(*,*)'Info: ',info,n,lda,lwork\n if(info.ne.0) then\n! write(*,*)'Error return from DGETRI: ',info\n is=0; goto 1000\n endif\n! write(*,*)'Matrix inverted using DGETRI'\n! All OK, the solution is in RINV\n is=1\n!\n1000 continue\n return\n end SUBROUTINE MDINVOLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\nEND MODULE OCNUM\n" }, { "path": "src/pmain1.F90", "content": "PROGRAM pmain1\n!************************************\n! main program for the free Open Calphad software\n!************************************\n!\n use cmon1oc\n!\n! For parallel processing\n!$ use omp_lib\n!\n implicit none\n!\n character linkdate*12\n! version moved to models/gtp3.F90\n! character linkdate*12,version*8\n TYPE(gtp_equilibrium_data), pointer :: ceq\n! these will be used later for dimensioning things and efaul\n integer i,narg,intvar(10)\n double precision dblvar(10)\n character arginline(4)*256,arg*64,date*16\n!\n! save the data of linking the program\n! call date_and_time(date)\n! write(*,*)'Stored linking date: ',date\n! This line replaced by linkocdate to the date when compilin\n linkdate='2026-04-23'\n! for example: linkdate='2026-04-23'\n! the overall version identifier is now in gtp3.F90\n! intvar and dblvar will eventually be used for allocations\n intvar(1)=30\n call init_gtp(intvar,dblvar)\n if(gx%bmperr.ne.0) then\n stop 'Error initiating GTP data structures'\n endif\n! extract arguments from the line of invocation\n! at present just a macro file name\n narg=iargc()\n if(narg.gt.4) then\n write(*,*)'OC accepts max 4 inline arguments'\n narg=4\n! else\n! write(*,*)'Inline arguments: ',narg\n endif\n do i=1,narg\n call getarg(i,arginline(i))\n! write(*,*)trim(arginline(i))\n enddo\n!\n call oc_command_monitor(version,linkdate,narg,arginline)\n!\n! we come back here with the \"back\" command in the user i/f\n! The data structure for the default equilibrium is in eqlis\n ceq=>eqlista(1)\n! additional code can be added below for some particular app\n!\n write(*,*)'A bientot'\n call deallocate_gtp(intvar,dblvar)\n!\nend PROGRAM pmain1\n" }, { "path": "src/stepmapplot/smp2.F90", "content": "! Data structures and routines for step/map/plot (using gnuplot)\n!\nMODULE ocsmp\n!\n! Copyright 2012-2021, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n!------------------------------\n!\n use liboceqplus\n! this to implement sleep\n use, intrinsic:: iso_c_binding, only: c_int\n!\n implicit none\n character*8, parameter :: smpversion='SMP-2.30'\n!\n! this interface added to sleep after GNUPLOT command\n interface\n subroutine usleep(us) bind (C)\n import c_int\n integer(c_int), value :: us\n end subroutine usleep\n end interface\n!\n! note the type map_fixph declared in matsmin.F90 (in liboceq)\n!\n! Thought for smp3. A new method to calculate diagrams with tie-line in plane\n! No fix phase but instead a fixed compostion in the middle of the tie-line\n! That means no problems changing fix phase!\n!\n! MAP_NODE records are created whenever the set of stable phases changes.\n! It can have links to two or more MAP_LINE records with calculated equilibra.\n! Initially at least one of these map_line records are empty with just \n! information of the axis to vary and direction.\n! There is a FIRST map_node record and subsequent are linked by a double linked\n! list, next and previous. All map_node records have a pointer to the first.\n! There are a special use of map_node records when the node has as many stable\n! phases as the line and it has only two lines connected:\n! - when starting following a line from a start point\n! - when the array of calculated equilibria must be saved on a file a map_node\n! record is created for each unifinished line. The map_node and map_line\n! records must be saved on the random file also and initiated for the next.\n! All map_node records must be kept for the next block. It is possible that\n! a line is being calculated leading to a node with no exits. If that node \n! is removed it will be created again and all already calculated lines exiting\n! will be calculated again ...\n!\n! MAP_LINE records are created for each line followed during the step/map. It \n! contains links to stored gtp_equilibrium_data records and some\n! additional info.\n! The stored gtp_equilibrium_data records belong to an array that can be saved\n! on a random file and the links are the index to reords in this array. The\n! gtp_equilibrium_data records are linked internallw with these indices also.\n! The map_line record has links to two map_node records representing the\n! two ends of the line. A map_line that terminates at the end of an axis will\n! have a zero link for that end of the line.\n!\n!\\begin{verbatim}\n! These are bits in the map_line status word\n! if EXCLUDEDLINE set the whole line is inactived\n! TWOSTOICH set if there are tie-lines inplane and line ends with stoich phases\n! with same composition (see for example U-O)\n integer, parameter :: EXCLUDEDLINE=0, TWOSTOICH=1\n! Bit in the MAP_NODE record\n integer, parameter :: MAPINVARIANT=0,STEPINVARIANT=1\n!\\end{verbatim}\n!\n!\n!\\begin{verbatim}\n TYPE map_line\n! This is record contains a list of calculated equilibria along a line\n! These are pointers to map_node records at start and end of line.\n type(map_node), pointer :: start,end\n! For threading this record must be separate from other threads\n! This record is created by calling calceq7 the first equilibrium of line\n type(meq_setup) :: meqrec\n! the active ceq record must be stored together with all others in order to be\n! copied from the ceq record saved with the node record when line starts\n type(gtp_equilibrium_data), pointer :: lineceq\n! this is the number of calculated equilibria for this line and the index\n! of the first and last one stored. \n! The stored equilibria has an internal next link.\n! lineid is a sequential index of the lines. done is negative if done\n! nfixphases are the number of fixed phases replacing axis conditions\n! status kan be used to delete a line\n integer number_of_equilibria,first,last,lineid,done,nfixphases,status\n! This is used during mapping to identify lines that have the same fixed phases\n! if we have 3 or more axis there can be 2 or more fix phases along the line??\n! With 2 axis there can only be one fix phase!\n type(gtp_phasetuple), dimension(:), allocatable :: linefixph\n! also save index to phr!! (do not trust ...)\n integer, dimension(:), allocatable :: linefix_phr\n! Save the phase tuplet representing the phase fix at start node here\n! If it wants to be stable at first step along a line change axis direction\n! type(gtp_phasetuple) :: nodfixph <<<< not used\n! This is the phase index in the phr array (phr has both phase and compset)\n integer nodfixph\n! We must also save the number and set of stable phases and theit amounts\n! as we will have different stable phases for different lines\n integer nstabph\n type(gtp_phasetuple), dimension(:), allocatable :: stableph\n double precision, dimension(:), allocatable :: stablepham\n! added also index to phr as that seems useful\n integer, dimension(:), allocatable :: stable_phr\n! axandir is set when linenode is created to the axis and direction for first\n! step from the node. It can be changed to another axis and direction\n! during map and indicate the current axis with active condition\n! axchange remember the equilibrum number for an axis change\n integer axandir,axchange\n! more is 1 while following the line, 0 for last equilbrium, -1 when finished\n! termerr is zero unless line terminated with error, -1 means exit not used\n! problem is nonzero if map_problems has been called\n! lasterr is the last error occured calculating this line\n integer more,termerr,problems,lasterr\n! firstinc is a value to add the the axis variable for the first equilibrium\n! to avoid finding the node point again. Evenvalue is the next value\n! to calculate during a step calculation. Both set when creating the node.\n! At start nodes they are zero\n double precision firstinc,evenvalue\n! During map the last axis values for ALL axis are stored here\n double precision, dimension(:), allocatable :: axvals\n! If tie-lines in the plane we must also check the axis values for\n! the other line as we may have to change the fix phase\n double precision, dimension(:), allocatable :: axvals2\n! save previous values of axvals to handle axis changes ...\n double precision, dimension(:), allocatable :: axvalx\n! save previous changes in axis values, for tie-line in plane\n! dxval(phase,axis)\n double precision, dimension(:,:), allocatable :: dxval\n! factor to control length of step in axis with axtive condition\n double precision :: axfact\n! data particular to a step calculation, for example scheil\n! character*24, allocatable, dimension(:) :: stepresultid\n end TYPE map_line\n!\\end{verbatim}\n!\n!-------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE map_node\n! this record organizes the step/map results. Whenever there is a \n! change of the set of stable phases a node record is created and it\n! can have links to several map_line records. The map node record has a\n! link to a gtp_equilibrium_data record (ceq) for the equilibrium at the node.\n! This is copied to the map_line record when this is activated. \n! In the map_line record an axis and direction to start is stored.\n! NOTE all gtp_equilibrium_data (ceq) records are pointers to the global\n! array as new composition sets may be created along any line.\n! The node record is identified by the set of stable phases and the\n! chemical potentials of the components. One must be able to identify the\n! node as one may find the same node following different lines.\n! locally stored linerecords for lines exiting the node\n type(map_line), dimension(:), allocatable :: linehead\n! links to other nodes\n! plotlink is used to overlay two or more map or step commands\n type(map_node), pointer :: first,next,previous,plotlink\n! saved copy of the meqrec record used to calculate the node \n type(meq_setup) :: meqrec\n! link to saved copy of the equilibrium record\n type(gtp_equilibrium_data), pointer :: nodeceq\n! link to array of saved equilibrium record. (only maptop?)\n type(map_ceqresults), pointer :: saveceq\n! copy of nodeceq in saveceq (composition sets not updated but needed for plot)\n integer savednodeceq\n! type_of_node not used?? Proposal\n! =1 step normal; =2 step_separate; =3 Scheil; =4 Tzero; =5 Paraeq; =6 NPLE\n! =10 map_tieline_inplane; =11 map_isotherm; ! =20 map_isopleth\n! lines are number of line records\n! noofstph is number of stable phases (copied from meqrec)\n! tieline_inplane is 1 if so, 0 if step, -1 if no tie-lines (only maptop)\n! number_ofaxis is the number of axis, 1=step; (only maptop)\n! artxe (extra) to indicate that the node has two stoichiom phases\n! status for some bits maybe\n! globalcheckinterval set when created from integer mapglobalcheck\n integer type_of_node,lines,noofstph,tieline_inplane,number_ofaxis,artxe\n integer status,globalcheckinterval\n! seqx is unique identifier for a map node\n! seqy unique identifier for maplines, incremented for each line (only maptop)\n integer seqx,seqy\n! nodefix is the phase held fix when calculating node\n type(gtp_phasetuple) :: nodefix\n! Value of T and P, copied from meqrec\n double precision, dimension(2) :: tpval\n! chemical potentials, copied from meqrec\n double precision, dimension(:), allocatable :: chempots\n! stable phase+compset, copied from meqrec (not used?)\n type(gtp_phasetuple), dimension(:), allocatable :: stable_phases\n end TYPE map_node\n!\\end{verbatim}\n!\n!-------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE map_axis\n! description of the axis variables used for step/map\n! The axis condition in bits and pieces\n integer nterm,istv,iref,iunit\n integer, dimension(:,:), allocatable :: indices\n type(gtp_state_variable), dimension(:), allocatable :: axcond\n double precision, dimension(:), allocatable :: coeffs\n! the min, max and increment along the axis\n double precision axmin,axmax,axinc\n! more must be initiated to 0, if nonzero replaced by a fixed phase\n! seqz is the sequential index of the condition in the list (this is not\n! changed if conditions are added (at the end) or deleted (active=1)\n! we cannot use a pointer as that depend on the current equilibrium.\n integer more,seqz\n! This is the last succesfully calculated axis value\n double precision lastaxval\n end TYPE map_axis\n!\\end{verbatim}\n! decrlared as an array with each axis as one element of the array\n!\n!-------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE map_ceqresults\n! stores calculated equilibrium records\n integer size,free,index\n TYPE(gtp_equilibrium_data), dimension(:), allocatable :: savedceq\n end TYPE map_ceqresults\n!\\end{verbatim}\n!\n!--------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE graphics_textlabel\n! To put labels on a graph we must store these in a list\n TYPE(graphics_textlabel), pointer :: nexttextlabel\n double precision xpos,ypos,textfontscale\n integer angle\n character*80 textline\n end type graphics_textlabel\n!\n!\\end{verbatim}\n!\n!------------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE plot_line\n! here various information about a line to be plotted should be stored \n! for the moment it is under construction in parallel with old structures\n! the \"plot_line\" records form a linked list starting at plotline1\n type(plot_line), pointer :: nextline\n! linetype 1=normal; 2=binary invariant; 3=ternary monovariant; 4=tieline\n! linetype -1=end of plotlines\n integer type\n integer active\n end type plot_line\n!\\end{verbatim}\n!\n!------------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE starteqlista\n! links to equilibria that are used as start points for step or map\n type(gtp_equilibrium_data), pointer :: p1\n end type starteqlista\n!\\end{verbatim}\n type (starteqlista), dimension(20) :: starteqs\n integer noofstarteq\n!\n!------------------------------------------------------------------------\n!\n!\\begin{verbatim}\n TYPE graphics_options\n! setting options for the plotting, this replaces most arguments in the call\n! to ocplot2(ndx,pltax,filename,maptop,axarr,form)\n! ndx is mumber of plot axis, pltax is text with plotaxis variables\n! filename is intermediary file (maybe not needed)\n! maptop is map_node record with all results\n! form is type of output (screen/postscript/pdf(acrobat)/gif)\n!------------------------------------------------------------------\n! status contain bits, BITS defined below (GRKEEP etc)\n! rangedefaults(i) nonzero if min/max for axis i set by user\n! axistype(i) is 1 if axis i is logscale\n! plotmin/max are user definied min/max\n! defltmin/max are default min/max (generated by the plotting software)\n integer :: status=0,rangedefaults(3)=0,axistype(2)=0,setgrid=0\n double precision, dimension(3) :: plotmin,plotmax\n double precision, dimension(3) :: dfltmin,dfltmax\n! number of axis used for calculation (STEP=1 MAP=2 or more)\n integer noofcalcax\n! scalefact is by defailt 1.0 and can be used to scale ais value, fore\n! example to plot kJ rather than J for reasonable axis\n double precision, dimension(3) :: scalefact=one\n! these define realative plot size for X and Y, normally 1.0 or less\n double precision :: xsize=1.0D0,ysize=1.0D0\n! labeldefaults(i) for axis i 0 means default text, 1 text in plotlabels\n! tielines>0 means plot a tieline every tielines calculated equilibrium\n integer :: labeldefaults(3),linett=1,tielines=0\n! plotlabel(1) is heading, 2 is x-axis text, 3 is y-axis text \n character*64, dimension(3) :: plotlabels\n! linetype is 0 for dashed lines, 1 for full lines\n! integer linestyle\n integer linetype\n! if linepoints >0 plot a symbol at each linewp point\n integer :: linewp=0\n! if true plot a triangular diagram (isothermal section)\n logical gibbstriangle\n! the set key command in GNUPLOT specifies where the line id is written\n! it can be on/off, placed inside/outside, left/right/center, top/bottom/center,\n! and some more options that may be implemented later ...\n character labelkey*48, font*32\n! filename is file to write the GNUPLOT command and data file\n! appendfile is a file name that will be appended unless empty\n character filename*256,appendfile*256\n! gnuplot terminals and keys, gnuselterm is selected terminal type (1..8)\n integer gnutermsel,gnutermax\n character*80 gnuterminal(8)\n character*8 filext(8)\n character*8 gnutermid(8)\n! firstextlabel is a pointer to a list of text label(s) \n! to be written at a given position\n TYPE(graphics_textlabel), pointer :: firsttextlabel\n! pltax are the state variables to be plotted\n! NOT USED: pform is the graphics format replaced by gnutermsel\n character pltax(2)*24,pform*32\n! The default and current ending of a plot\n character*12 :: plotenddefault='pause mouse '\n character plotend*36\n! added 18.09.24 text at lower left corner\n character (len=6) :: lowerleftcorner=' '\n! added to have larger axis texts and line titles\n integer:: textonaxis=0\n! nothing special 0, other as stepspecial: 1=separate; 2=Scheil; 3=Tzero;\n! 4=paraequil; 5=NPLE\n! but stepseparate, Tzero and paraequil works without using this.\n! For Schiel I am trying to change line color for different parts of the line\n integer :: specialdiagram=0\n#ifdef notwin\n! Garamond and Baskerville not available in GNUPLOT\n! character (len=8) :: logofont='Arial,20'\n character (len=14) :: logofont='Baskerville,20'\n#else\n! On windows system the Garamond is nicer\n character (len=16) :: logofont='Garamond Bold,20'\n#endif\n! many more options can easily be added when desired, linetypes etc\n end TYPE graphics_options\n!\\end{verbatim}\n!\n! fix status during mapping, normally 2 means fix (not used)\n integer, parameter :: MAPPHASEFIX=3\n! OS dependent values NOT BITS\n#ifdef notwin\n integer, parameter :: PLOTONWIN=0\n#else\n integer, parameter :: PLOTONWIN=1\n#endif\n!-------------------------------------------------\n! BITS for graphopt status word, do not use bit 0 and 1 ...\n! these bits are very confused ...\n! GRKEEP is set if graphics windows kept (does not really matter)\n! GRNOTITLE is set if no title plotted \n! GRISOPLETH if plot is an isopleth (no tielines)\n! GRTABLE list results in a CSV table\n integer, parameter :: GRKEEP=2, GRNOTITLE=3, GRISOPLETH=4, GRCSVTABLE=5\n!--------------------------------------------------\n! default for some colors\n character (len=6) :: monovariant='7CFF40' ! this is light green\n character (len=6) :: tielinecolor='7CFF40'\n! for trace\n logical :: plottrace=.FALSE.\n! Using memory for stored equilibria to avoid memory crash\n! Totalsaved includes all equilibria saved during multiple map \n integer totalsavedceq\n integer, parameter :: maxsavedceq=1999\n! To warn that some calculated lines are excluded from plot\n integer :: lines_excluded=0\n!\n!-------------------------------------------------\n!\n type(plot_line), pointer :: lastplotline,plotline1\n! set by user for globalcheck during STEP/MAP\n integer :: mapglobalcheck=0\n! repeated errors\n integer :: repeatederr=0\n!\n!-------------------------------------------------\n! equlibrium record used to handle fast diffusiion in calc_allslices\n! Should be initiated at each step/map command\n TYPE(gtp_equilibrium_data), target :: sliceq\n!-------------------------------------------------\n!\nCONTAINS\n\n ! routines to calculate the diagrams\n include \"smp2A.F90\"\n\n ! routines to plot the diagrams\n include \"smp2B.F90\"\n\nEND MODULE ocsmp\n\n" }, { "path": "src/stepmapplot/smp2A.F90", "content": "! These soubroutine calculate the diagram, smp2B plot it\n\n!\\addtotable subroutine map_setup\n!\\begin{verbatim}\n subroutine map_setup(maptop,nax,axarr,seqxyz,starteqs)\n! main map/step routine\n! THIS HAS BEEN SPLIT IN TWO PARTS\n! This first part tranforms all user provided or automatic start points\n! to start equilibria\n! The second goes through the list of start equiliria until it is\n! empty\n!\n! maptop is the main map_node record which will return all calculated lines.\n! nax is the number of axis (can be just one for STEP)\n! axarr is an array of records specifying the axis for the step/map\n! seqxyz are intial values for number of nodes and lines\n! starteqs is an array with equilibrium data record\n! they are linked using the ceq%next index\n implicit none\n integer nax,seqxyz(*)\n type(map_axis), dimension(nax) :: axarr\n! TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(starteqlista), dimension(*) :: starteqs\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,starteq\n type(gtp_condition), pointer :: pcond\n TYPE(map_node), pointer :: tmp\n type(map_line), pointer :: mapline\n! should this meqrec be a pointer or not??\n type(meq_setup), pointer :: meqrec\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n double precision starting,finish2,axvalok,dgm,tsave,xxx,yyy,zzz\n integer starttid,endoftime,bytdir,seqz,nrestore,termerr,lastimethiserror\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n\n! save current conditions\n character savedconditions*1024\n! for saving a copy of constitutions\n double precision, allocatable, dimension(:) :: copyofconst\n! inactive are indices of axis conditions inactivated by phases set fixed\n! inactive not used ...\n integer iadd,irem,isp,seqx,seqy,mode,halfstep,jj,ij,inactive(4),bytaxis\n integer ceqlista\n! inmap=1 turns off converge control of T\n integer, parameter :: inmap=1\n character ch1*1\n logical firststep,onetime\n!\n! write(*,*)'in map_setup'\n! save all conditions \n! call get_all_conditions(savedconditions,-1,starteqs(1)%p1)\n ij=1\n savedconditions=' '\n savecond: do jj=1,nax\n! write(*,*)'SMP2A get_one: ',ij,axarr(jj)%seqz\n call get_one_condition(ij,savedconditions,&\n axarr(jj)%seqz,starteqs(1)%p1)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0; savedconditions=' '; exit savecond\n endif\n ij=len_trim(savedconditions)+2\n enddo savecond\n! initiate sliceq for Scheilsimilation of fast diffusion\n sliceq%nexteq=-1\n! write(kou,*)'SMP2A saved: ',trim(savedconditions)\n nrestore=0\n lastimethiserror=0\n! first transform start points to start equilibria on zero phase lines\n! All axis conditions except one are converted to fix phase conditions \n! (if there is just one axis skip this)\n! One or more map_node records are created with mapline records each\n call cpu_time(starting)\n call system_clock(count=starttid)\n inactive=0\n!\n if(ocv()) write(*,*)'Entering map_setup',nax\n! if automatic statpoints requested they are generatet here\n! call auto_startpoints(maptop,nax,axarr,seqxyz,starteq)\n! ceq=>starteq\n ceq=>starteqs(1)%p1\n iadd=1\n! ceqlista=1\n21 continue\n! write(*,'(a,a,3i4)')'SMP2A Start equilibrium: ',trim(ceq%eqname),&\n! ceq%eqno,ceq%nexteq,ceq%multiuse\n! if(ceq%nexteq.gt.0) then\n! ceq=>eqlista(ceq%nexteq)\n! iadd=iadd+1\n! goto 21\n! endif\n! noofstarteq is a global variable in SMP, set by calling routine\n if(noofstarteq.gt.0) write(*,*)'There are ',noofstarteq,' start equilibria'\n! loop to change all start equilibria to start points\n! Store the start points in map_node records started from maptop\n do ceqlista=1,noofstarteq\n ceq=>starteqs(ceqlista)%p1\n! write(*,*)'SMP2A calling map_startpoint: ',trim(ceq%eqname),ceq%eqno\n! read(*,106)ch1\n106 format(a)\n! convert all axis conditions except one to fix phase\n call map_startpoint(maptop,nax,axarr,seqxyz,inactive,ceq)\n if(gx%bmperr.ne.0) then\n write(*,101)ceq%nexteq,gx%bmperr\n101 format('Failed calculate a start point: ',i4,i7)\n! ceq=>eqlista(ceq%nexteq)\n gx%bmperr=0\n goto 900\n endif\n! I have not really implemented several startpoint, I am not sure\n! if each does each have separate maptop and savesec ....\n! error if no startpoints \n if(.not.associated(maptop)) then\n write(*,*)'Cound not find a single start equilibria for',ceqlista\n! gx%bmperr=4224; goto 1100\n goto 900\n endif\n! write(*,*)'There is a MAPTOP record ...'\n! create array of equilibrium records for saving results\n seqy=maxsavedceq\n call create_saveceq(maptop%saveceq,seqy)\n if(gx%bmperr.ne.0) goto 1000\n! initiate node counter done, line counter will be incremented\n if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1\n85 format('Previous step/map results saved'/&\n 'New mapnode/line equilibria indices will start from: ',i3,i5)\n! maptop%seqy=0\n! write(*,*)'savesize: ',size(maptop%saveceq%savedceq)\n! if there are more startpoints try to convert these to start equilibria\n900 continue\n! write(*,*)'At label 900: ',gx%bmperr\n enddo\n! write(*,*)'SMP Finished loop',associated(maptop)\n if(associated(maptop)) then\n if(allocated(maptop%linehead)) then\n! Clear any error code if we have linhead allocated\n if(gx%bmperr.ne.0) gx%bmperr=0\n else\n write(*,*)'Failed to find any lines to calculate'\n goto 1000\n endif\n else\n! no maptop record\n write(*,*)'Failed finding startpoints for step/map'\n goto 1100\n endif\n!-----------------------------------------------------\n! now we should calculate all lines stored as start equilibria \n! but maybe there are no start equilibria??\n! starteq is a ceq record, mapping will use maptop record ....\n write(*,*)'SMP2A call map_doallines'\n call map_doallines(maptop,nax,axarr,seqxyz,starteq)\n! write(*,*)'SMP2A back from map_doallines'\n!-----------------------------------------------------\n1000 continue\n!--------------------------------------------------\n! Here we have now finished the step/map.\n! Set back inactive axis conditions How??\n! do ij=2,inactive(1)\n! call locate_condition(inactive(ij),pcond,ceq)\n! pcond%active=0\n! enddo\n call system_clock(count=endoftime)\n call cpu_time(finish2)\n if(gx%bmperr.ne.0) then\n write(*,1005)gx%bmperr\n1005 format('STEP/MAP terminated with error code: ',i5)\n gx%bmperr=0\n else\n write(*,1010)maptop%saveceq%free-1,finish2-starting,endoftime-starttid\n1010 format(/'Finished step/map with ',i5,' equilibria in ',&\n 1pe12.4,' CPU s and ',i7,' cc')\n endif\n if(len_trim(savedconditions).gt.0) then\n! write(*,*)'SMP2A restore: ',trim(savedconditions)\n! if(index(savedconditions,'>=').gt.0) then\n! conditions including a fix phase, do not try to restore \n! write(*,*)'SMP2A cannot restore original conditions'\n! goto 1100\n! endif\n! write(*,*)'Restoring all initial conditions: '\n! write(*,*)trim(savedconditions)\n! ij is incremented by 1 inside set_condition\n ij=0\n! SUCK, I fixed that conditions with 2 terms was not entered again but\n! after other changes to handle condition with species such as O-2\n! the same problem! Just remove all conditions and set those saved!!\n! write(*,*)'SMP2A conditions at end of step/map'\n! It may create loss of memory but ... what the heck ... buy more!\n! call list_conditions(kou,ceq)\n! write(*,*)'SMP2A remove all conditions'\n! if(nax.eq.1) then\n! write(*,*)'SMP2 Conditions can be changed by some STEP commands'\n! endif\n! goto 1100\n!-----------------------------------------------------\n! I am not sure it is critical to restore conditions ...\n! it could be some cases when conditions are modified in STEP TZERO/SCHEIL/PARA\n!-----------------------------------------------------\n! this does not work because axis and maybe other things refer to\n! conditions by index. If I remove all conditions to restore them\n! these indices become invalid \n! call set_condition('*:=none ',ij,starteqs(1)%p1)\n! call list_conditions(kou,ceq)\n ij=0\n! write(*,*)'SMP2A restore axis cond: ',trim(savedconditions)\n call set_condition(savedconditions,ij,starteqs(1)%p1)\n if(gx%bmperr.ne.0) write(*,*)'Error restoring axis conditions',gx%bmperr\n! write(*,*)'SMP2A restored conditions:'\n! call list_conditions(kou,ceq)\n else\n write(*,*)'SMP2A axis conditions could not be restored'\n endif\n1100 continue\n return\n end subroutine map_setup\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_doallines\n!\\begin{verbatim}\n subroutine map_doallines(maptop,nax,axarr,seqxyz,starteq)\n! main map/step routine\n! maptop is the main map_node record which will return all calculated lines.\n! nax is the number of axis (can be just one for STEP)\n! axarr is an array of records specifying the axis for the step/map\n! seqxyz are intial values for number of nodes and lines\n! starteq is an equilibrium data record, if there are more start equilibria\n! they are linked using the ceq%next index\n implicit none\n integer nax,seqxyz(*)\n type(map_axis), dimension(nax) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq\n type(gtp_condition), pointer :: pcond\n TYPE(map_node), pointer :: tmp\n type(map_line), pointer :: mapline\n! should this meqrec be a pointer or not??\n type(meq_setup), pointer :: meqrec\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n double precision starting,finish2,axvalok,dgm,tsave,xxx,yyy,zzz,axval\n integer starttid,endoftime,bytdir,seqz,nrestore,termerr,lastimethiserror\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n! save current conditions\n character savedconditions*1024\n! for saving a copy of constitutions\n double precision, allocatable, dimension(:) :: copyofconst\n! inactive are indices of axis conditions inactivated by phases set fixed\n! inactive not used ...\n integer iadd,irem,isp,seqx,seqy,mode,halfstep,jj,ij,inactive(4),bytaxis\n integer ceqlista,phfix,haha,lastax,mapx,lokph,lokcs,bypass\n integer trynewphase,jrem,addcheck\n! inmap=1 turns off converge control of T\n integer, parameter :: inmap=1\n character ch1*1,phasename*28\n logical firststep,onetime,noderrmess\n!\n! write(*,*)'in map_doallines'\n!-------------------------------\n! return here for each new line to be calculated\n! NOTE we can start a new thread for each line, when a node is found\n! all threads stop. \n! If the node already exists the exit corresponing to the new line removed\n! and the thread ends\n! initiate phfix, looking for crash it seems to be used before set ...\n phfix=0\n! If the node is new it is created and exits added and the thread ends.\n inactive=0\n nrestore=0\n lastimethiserror=0\n300 continue\n! this is to write a warning message once for each line\n onetime=.true. \n bytaxis=0\n firststep=.TRUE.\n! THREADPROTECTED CALL the map_findline will copy the ceq from mapnode\n if(ocv()) write(*,*)'Looking for a line to calculate'\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 1000\n! if no line we are finished!\n! write(*,*)'Back from map_findline 1: ',associated(mapline),allocated(mapfix)\n! segmentation fault crash later ...\n if(.not.associated(mapline)) goto 900\n! write(*,*)'We will start calculate line: ',mapline%lineid,mapline%axandir\n if(maptop%tieline_inplane.ne.0) then\n! for mapping we need to check how all axis varies\n allocate(mapline%axvals(nax))\n allocate(mapline%axvalx(nax))\n if(maptop%tieline_inplane.gt.0) then\n! with tie-lines in plane we must check axis variable for stable phase also\n allocate(mapline%axvals2(nax))\n! else\n! any special to do?? \n endif\n endif\n! Each thread must have separate meqrec and ceq records\n!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n ceq=>mapline%lineceq\n! ?? We may have incompatibility between ceq and meqrec if new compsets added\n! maybe meqrec should not be a pointer?\n meqrec=>mapline%meqrec\n noderrmess=.true.\n! No grid minimization and the phr is not deallocated with mode<0\n! It is necessary to generate new meqrec for each line as there may be new\n! composition sets created in other threads. But we must also specify \n! phases set fix due to the mapping to replace axis conditions. \n! We must provide an array of phase tuples with fix phases. \n! write(*,*)'Calling calceq7 for new line: ',mapline%lineid\n if(ocv()) write(*,*)'Calling calceq7 for new line: ',mapline%lineid\n! mode=-1 means no gridminimization and do not deallocate phr\n mapline%problems=0\n mapline%lasterr=0\n mode=-1\n if(ocv()) write(*,*)'This call generates mapline%meqrec for this line'\n bytdir=0\n! the save constitutions may be useful if problems ... ???\n if(allocated(copyofconst)) deallocate(copyofconst)\n! segmentation fault in this subroutine ...\n! because I checked only size(..) and not if it was allocated ...\n call save_constitutions(ceq,copyofconst)\n! segmentation fault before this output ...\n! write(*,*)'called save_constitutions: ',size(copyofconst)\n305 continue\n! to be able to handle problems copy the constitutions!!\n! if(mapline%problems.gt.0) then\n! write(*,*)'problems',mapline%problems,ceq%tpval(1)\n! endif\n! STEP/MAP with an MQMQA phase present require restoring csumx at each step\n! if(allocated(mqmqa_data%csumx)) then\n! write(*,*)'SMP reset csumx for MQMQA phase'\n! mqmqa_data%csumx=.FALSE.\n! endif\n! write(*,*)'Calling calceq7 with T=',ceq%tpval(1),mapline%axandir\n! write(*,*)'Calling calceq7 with meqrec%status:',meqrec%status\n call calceq7(mode,meqrec,mapfix,ceq)\n! write(*,*)'SMP2A Back from calceq7 ',gx%bmperr,meqrec%status\n if(gx%bmperr.ne.0) then\n! error 4187 is to set T or P to less than 0.1\n if(gx%bmperr.eq.4187) then\n goto 306\n endif\n if(mapline%number_of_equilibria.eq.0) then\n! We can add/subtract a small amount of axis condition if error at first step\n! write(*,*)'Error at first equilibrium: ',gx%bmperr,mapline%axandir\n mapline%lasterr=gx%bmperr\n mapline%problems=mapline%problems+1\n! if(bytdir.eq.1) then\n! we have tried adding a small step in axandir direction, now change direction\n! mapline%axandir=-mapline%axandir\n! elseif(bytdir.gt.1) then\n! give up\n! goto 306\n! endif\n! Extract the current value of the axis state variable items using pcond\n jj=abs(mapline%axandir)\n! write(*,*)'SMP: axandir: ',jj,gx%bmperr\n gx%bmperr=0\n if(jj.le.0 .or. jj.gt.2) then\n write(*,*)'SMP error: no axis direction! Set to 1'\n mapline%axandir=1\n jj=1\n! call list_conditions(kou,ceq)\n endif\n seqz=axarr(jj)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,pcond,zzz,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv())write(*,765)bytdir,jj,zzz,mapline%axvals(jj),axarr(jj)%axinc\n765 format('Attempt to step 1: ',i2,i3,3(1pe16.8))\n! first time bytdir=1, second time bytdir=2, compensate for first step ...\n! yyy=1.0D-2*bytdir*axarr(jj)%axinc\n! yyy=1.0D-3*bytdir*axarr(jj)%axinc\n! xxx=zzz+mapline%axandir*yyy\n xxx=zzz\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! restore constitutions, not a good idea ?? ...\n! write(*,*)'Restore constitutions 1'\n call restore_constitutions(ceq,copyofconst)\n!\n call map_problems(maptop,mapline,axarr,xxx,1)\n if(gx%bmperr.ne.0) goto 306\n if(ocv()) write(*,737)'Error at first step: ',mapline%axandir,&\n mapline%nodfixph,zzz,xxx\n737 format(a,2i3,6(1pe14.6))\n! read(*,738)ch1\n738 format(a)\n! set the condition value ... ???\n if(nax.gt.1) then\n! run time error that axvals has dimension 0 ... when step\n mapline%axvals(abs(jj))=xxx\n endif\n call condition_value(0,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv()) write(*,765)0,mapline%axandir,zzz,xxx,yyy\n! call calceq7 again, we must deallocate meqrec%phr \n deallocate(meqrec%phr)\n goto 305\n endif\n306 continue\n! write(*,*)'SMP2 Generating mapline%meqrec failed 2: ',gx%bmperr\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n! look for a new line to follow\n goto 300\n endif\n! write(*,*)'back from calceq7B'\n! if all has gone well deallocate mapfix\n if(allocated(mapfix)) deallocate(mapfix)\n! write(*,*)'SMP successfully deallocated mapfix'\n!--------------------------------\n! limit the maximum change in T and P, should be small during step/map\n meqrec%tpmaxdelta(1)=2.0D1\n meqrec%tpmaxdelta(2)=1.0D1\n bypass=0\n!--------------------------------\n! return to label 310 after each new equilibrium calculated along the same line\n! Follow the equilibria along a line. For each equilibria calculated\n! store the data. If the phase set want to change (irem or iadd>0) calculate\n! exactly the phase change, generate a node and terminate the line and then\n! look for a new line to follow.\n310 continue\n halfstep=0\n! save current value of T if trouble later ...\n tsave=ceq%tpval(1)\n! try saving constitutions ...\n if(allocated(copyofconst)) deallocate(copyofconst)\n call save_constitutions(ceq,copyofconst)\n! emergency return when two phases want to change status\n320 continue\n iadd=0\n! Note setting iadd=-1 turn on verbose inside meq_sameset\n321 continue\n irem=0\n mapline%meqrec%noofits=0\n! write(*,*)'Calling meq_sameset 7: ',mapline%number_of_equilibria,&\n! ceq%tpval(1),gx%bmperr\n!\n! call list_conditions(kou,ceq)\n!\n! write(*,*)'Calling meq_sameset ',mapline%more,mapline%number_of_equilibria\n! write(*,884)1,mapline%linefixph(1)%ixphase,&\n! mapline%linefixph(1)%compset,iadd,meqrec%nphase,abs(phfix)\n!884 format('SMP fix phase ',i1,':',i3,i2,', new fix phase: ',i3,&\n! ', number of phases: ',i3,' abs(phfix): ',i3)\n!--------------------------------------------------------------------------\n! This is where most equilibrium calculations are made\n!--------------------------------------------------------------------------\n!\n! write(*,*)'smp2A calling meq_sameset from map_doallines',ceq%tpval(1)\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,inmap,ceq)\n!\n!--------------------------------------------------------------------------\n! write(*,331)'SMP Back from meq_sameset ',mapline%number_of_equilibria,&\n! irem,iadd,gx%bmperr,phfix,ceq%tpval(1),ceq%phase_varres(4)%dgm\n331 format(a,5i5,2(F10.2))\n! write(*,884)2,mapline%linefixph(1)%ixphase,&\n! mapline%linefixph(1)%compset,iadd,meqrec%nphase,abs(phfix)\n!------------------------------------------------------------------\n! write(*,*)'SMP2A axis: ',maptop%number_ofaxis\n! goto 3000\n! suck\n if(maptop%number_ofaxis.eq.2) goto 3000\n!==================================================================\n! The code between ==== is added to avoid STEP termination because unstable\n! phases tries to be stable. It is very fragile and should not\n! be used for MAP calculations \n if(gx%bmperr.ne.0) then\n! step1 2ndtime error bug:\n write(*,'(a,F7.2,i7)')'Failed calculate equilibrium, along line, T=',&\n ceq%tpval(1),gx%bmperr\n call map_lineend(mapline,axvalok,ceq)\n axvalok=zero\n! step1 2ndtime error bug: try to find out the error, maybe atoms/formula unit\n! gx%bmperr=4500; goto 1000\n goto 300\n endif\n gx%bmperr=0; trynewphase=0; addcheck=0; jrem=0\n! We may have to extract the axis condition ?? \n jj=abs(mapline%axandir)\n! write(*,*)'SMP2A axandir: ',jj\n if(jj.le.0 .or. jj.gt.2) then\n write(*,*)'SMP error: no axis direction! Set to 1'\n mapline%axandir=1\n jj=1\n! call list_conditions(kou,ceq)\n endif\n seqz=axarr(jj)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! end extracting axis condition\n! write(*,'(a,F10.2,4i4)')'SMP2A new phase and T axis?',ceq%tpval(1),&\n! maptop%number_ofaxis,iadd,pcond%statev\n! Return here if map_calcnode return with error code 4223\n716 continue\n baddata: if(iadd.gt.0 .and. pcond%statev.eq.1 .and. &\n maptop%number_ofaxis.eq.1) then\n! If a new phase is stable and axis is T and we have only one axis then\n! make a second call with same conditions to check if really stable\n717 continue\n if(trynewphase.gt.4) then\n! we have tried 4 times with different new phases trying to be stable\n write(*,*)'SMP2A cannot find which phase to set stable',trynewphase\n gx%bmperr=4399; exit baddata\n! elseif(trynewphase.eq.3) then\n! restore original phase constitutions .... does not help\n! call restore_constitutions(ceq,copyofconst)\n endif\n trynewphase=trynewphase+1\n addcheck=iadd; iadd=0\n call meq_sameset(jrem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,&\n inmap,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2A reset error in meq_sameset',gx%bmperr\n gx%bmperr=0\n endif\n! call get_phasetup_name(meqrec%phr(iadd)%phtupix,phasename)\n! write(*,'(a,F10.2,a,a)')'SMP2A test at T=',&\n! ceq%tpval(1),' for stablility of ',trim(phasename)\n! exit if no phase wants to be stable, loop if a different one\n if(iadd.gt.0 .and. iadd.ne.addcheck) then\n! cycle baddata this would have been elegant .... if allowed\n call get_phasetup_name(meqrec%phr(addcheck)%phtupix,phasename)\n write(*,'(a,a,a,F10.2,2i5)')'SMP2A test if ',phasename(1:16),&\n ' is stable at T=',ceq%tpval(1),&\n meqrec%phr(addcheck)%phtupix,meqrec%phr(iadd)%phtupix\n goto 717\n endif\n! exit if iadd=0 or same twice to calculate node\n endif baddata\n!==================================================================\n!------------------------------------------------------------------\n! we come back here if iadd was 0 but removed as \n3000 continue\n! new global check for stable and metastable phases\n! write(*,*)'SMP error 6A:',mapline%number_of_equilibria,&\n! maptop%globalcheckinterval\n phasecheck: if(gx%bmperr.eq.0 .and. iadd.eq.0 .and. irem.eq.0) then\n! write(*,*)'SMP error 6B:',mapline%number_of_equilibria,&\n! maptop%globalcheckinterval\n! if(maptop%globalcheckinterval.le.0) then\n! write(*,*)'SMP maptop%globalcheckinterval:',maptop%globalcheckinterval\n! maptop%globalcheckinterval=10\n! endif\n checkinterval: if(maptop%globalcheckinterval.gt.0) then\n if(mod(mapline%number_of_equilibria,maptop%globalcheckinterval).eq.0)&\n then\n! this may set error code if equilibrium should be recalculated\n! and it may change constitutions of metastable phases\n! write(*,'(a,i5)')'SMP check_all_phases at equilibrium: ',&\n! mapline%number_of_equilibria\n jj=0\n call check_all_phases(jj,ceq)\n if(gx%bmperr.ne.0) then\n! if(associated(mapline%lineceq,ceq)) then\n! This is true and dangerous but I will be careful programming ...\n! write(*,*)'SMP ceq is same as mapline%lineceq'\n! else\n! write(*,*)'SMP ceq is NOT same as mapline%lineceq'\n! endif\n! call get_phase_compset(iph,ics,lokph,lokres)\n if(gx%bmperr.eq.4366) then\n! terminate line and call gridminimizer\n! write(*,*)'SMP check_all_phases require gridminimizer',jj\n gx%bmperr=0\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) goto 321\n elseif(gx%bmperr.eq.4365) then\n! write(*,*)'SMP check_all_phases error, call map_halfstep:',jj\n gx%bmperr=0\n! we have to convert jj=iph*10+ics to index in mapline%meqrec%phr\n! Check if constitution is the one se in check_all_phases\n! write(*,95)(yarr(ii),ii=1,jj)\n!95 format('3Y gridy: ',10(F7.4))\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) goto 321\n endif\n! otherwise ignore any errors\n gx%bmperr=0\n endif\n endif\n endif checkinterval\n endif phasecheck\n!------------------------------------------------------------------\n! write(*,*)'SMP looking for error 7:'\n sameseterror: if(gx%bmperr.ne.0) then\n! write(*,*)'Error in meq_sameset called from smp',gx%bmperr\n! if error 4359 (slow convergence), 4204 (too many its) take smaller step ...\n! error 4195 means negative phase amounts\n491 continue\n if(gx%bmperr.eq.4195 .or. gx%bmperr.eq.4359 &\n .or. gx%bmperr.eq.4204) then\n! I am not sure there is really any change for the equilibrium calculated ...\n! write(*,317)'Trying half step: ',halfstep,mapline%axandir,&\n! mapline%number_of_equilibria,lastimethiserror,ceq%tpval(1)\n317 format(a,2i3,2i4,f9.2)\n if(mapline%number_of_equilibria-lastimethiserror.gt.10) then\n lastimethiserror=mapline%number_of_equilibria\n! if(mapline%meqrec%noofits-lastimethiserror.gt.10) then\n! lastimethiserror=mapline%meqrec%noofits\n gx%bmperr=0\n mapline%axfact=1.0D-2\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n! write(*,*)'Back from halfstep 1',halfstep,gx%bmperr\n if(gx%bmperr.eq.0) goto 321\n endif\n elseif(gx%bmperr.eq.4364) then\n! Two stoichiometric phases with same composition stable, we have\n! to calculated an invariant equilibrium T in a different way.\n! if tielines in plane create nodepoint otherwise I do not know what to do\n if(maptop%tieline_inplane.gt.0) then\n! dummy values (for the moment)\n axval=ceq%tpval(1)\n haha=mapx\n phfix=iadd\n lastax=abs(mapline%axandir)\n! maybe save last calculated equilibrium as endpoint of current line?\n! Collecting values needed fot map_newnode\n! irem is last fix phase, haha is entered phase, phfix is new stable phase\n! write(*,219)'SMP call map_newnode: ',lastax,axval,&\n! ceq%tpval(1),meqrec%nstph,irem,haha,phfix\n!219 format(a,i2,2F12.4,5i5)\n! list current settings: is content of mapline%meqrec same as meqrec??\n! write(*,885)mapline%nfixphases,&\n! mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset,&\n! mapline%meqrec%nv,mapline%meqrec%iphl(1),&\n! mapline%meqrec%iphl(2)\n!885 format('SMP Fixed phase:',i2,': ',i3,i2,', entered: ',i2,': ',5i3)\n mapline%status=ibset(mapline%status,TWOSTOICH)\n call map_newnode(mapline,meqrec,maptop,axval,lastax,axarr,&\n phfix,haha,ceq)\n if(gx%bmperr.ne.0) then\n! give up on this line, map_lineend set error code to zero\n write(*,*)'Failed create node point, terminate and take next',&\n gx%bmperr\n call map_lineend(mapline,axvalok,ceq)\n axvalok=zero\n endif\n endif\n endif\n! give up this line, reset error code and check if there are more lines\n gx%bmperr=0\n goto 805\n endif sameseterror\n! write(*,323)'Calc line: ',gx%bmperr,irem,iadd,mapline%axandir,&\n! mapline%meqrec%noofits,mapline%meqrec%nstph,ceq%tpval(1)\n if(ocv())write(*,323)'Calc line: ',gx%bmperr,irem,iadd,mapline%axandir,&\n mapline%meqrec%noofits,mapline%meqrec%nstph,ceq%tpval(1)\n323 format(a,i5,2i3,2i4,i3,f10.2)\n if(iadd.gt.0) then\n! check if it is a closing miscibility gap or loss of ordering\n! remove iadd if it is a phase with same composition as an already stable one\n if(same_composition(iadd,mapline%meqrec%phr,mapline%meqrec,ceq,dgm)) &\n iadd=0\n endif\n! write(*,*)'Check if same phase: ',iadd\n330 continue\n if(gx%bmperr.eq.0 .and. irem.eq.0 .and. iadd.eq.0) then\n! no error and no change of phase set, just store the calculated equilibrium.\n! and calculate another point along the line\n! write(*,*)'hms: Storing equilibrium',&\n! mapline%number_of_equilibria,maptop%globalcheckinterval\n if(mapline%number_of_equilibria.gt.10 .and. mapline%nodfixph.gt.0) then\n! we have managed 3 steps, set phase at start node as entered (if dormant)\n if(meqrec%phr(mapline%nodfixph)%phasestatus.eq.PHDORM) then\n! write(*,*)'Phase set entered ',mapline%nodfixph\n meqrec%phr(mapline%nodfixph)%phasestatus=PHENTUNST\n endif\n endif\n! mapline%problems=0\n! nrestore=0\n call map_store(mapline,axarr,nax,maptop%saveceq)\n if(gx%bmperr.ne.0 .or. mapline%more.eq.0) then\n! Test if we are running out of memory \n if(gx%bmperr.eq.4219) goto 1000\n if(gx%bmperr.eq.4360) then\n! too big difference in some axis, take halfstep\n! write(*,*)'Take a half step',halfstep\n gx%bmperr=0; halfstep=halfstep+1\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) goto 321\n endif\n! terminate line any error code will be cleared inside map_lineend. \n! write(*,*)'Calling map_lineend 1'\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n goto 300\n endif\n! stored last calculated equilibrium \n mapline%problems=0\n nrestore=0\n! check which axis variable changes most rapidly, maybe change step axis\n! (for tie-lines in plane check axis values for all phases)\n! and take a step in this axis variable making sure it inside the limits\n! and continue, else terminate and take another start equilibrium\n! Normally do not change the phase kept fix.\n! write(*,*)'hms: taking a step'\n call map_step(maptop,mapline,mapline%meqrec,mapline%meqrec%phr,&\n axvalok,nax,axarr,ceq)\n! write(*,*)'Back from map_step 1',mapline%more,&\n! mapline%number_of_equilibria,gx%bmperr\n if(gx%bmperr.ne.0) then\n! write(*,*)'SMP2A error return from map_step 1: ',gx%bmperr\n gx%bmperr=0\n if(meqrec%tpindep(1)) then\n! write(*,*)'SMP2A restore T 1: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) then\n! jump back without setting halfstep=0, setting iadd=-1 turn on debug output \n! iadd=-1\n goto 321\n endif\n endif\n! if mapline%more>0 continue, otherwise line has terminated at axis limit\n! check if there are other nodes with lines to calculate\n! write(*,*)'Back from step:',gx%bmperr,mapline%more,ceq%tpval(1)\n! if mapline%more>=0 there is no error and a new equilibrium to calculate\n! if mapline%more<0 the line has ended at axis limit or there is an error\n if(mapline%more.ge.0) goto 310\n if(gx%bmperr.ne.0) then\n! write(*,*)'SMP2A Error stepping to next equilibria, ',gx%bmperr\n endif\n! any error code will be cleared inside map_lineend.\n! write(*,*)'Calling map_lineend 1'\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n! look for a new line to follow\n goto 300\n! finish thread started at label 300 ??\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n elseif(gx%bmperr.ne.0) then\n! write(*,*)'Error return from meq_sameset: ',gx%bmperr,mapline%lasterr,&\n! ceq%tpval(1)\n termerr=gx%bmperr\n gx%bmperr=0\n if(meqrec%tpindep(1)) then\n if(ocv()) write(*,*)'Restoring T 2: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n! also restore constitutions\n nrestore=nrestore+1\n if(nrestore.lt.3) then\n! write(*,*)'Restore constitutions 2',nrestore\n call restore_constitutions(ceq,copyofconst)\n!\n! take smaller steps!\n mapline%axfact=1.0D-2\n! write(*,552)'Call halfstep: ',bytaxis,nrestore,&\n! mapline%number_of_equilibria,axvalok\n552 format(a,3i3,2(1pe12.4))\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) then\n! jump back without setting halfstep=0, setting iadd=-1 turns on debug output \n! iadd=-1\n goto 321\n endif\n elseif(nax.gt.1 .and. bytaxis.eq.0) then\n! write(*,*)'Restore last OK: ',mapline%number_of_equilibria,nrestore,&\n! axvalok\n call restore_constitutions(ceq,copyofconst)\n if(meqrec%tpindep(1)) then\n if(ocv()) write(*,*)'Restoring T 3: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n if(ocv()) write(*,555)'Repeated error 7, try to change axis',&\n gx%bmperr,ceq%tpval(1),axvalok,tsave\n555 format(a,i5,3F8.2)\n gx%bmperr=0\n bytaxis=1\n! Make sure that the current axis has the last successfully calculated value\n! as prescribed value\n call locate_condition(axarr(abs(mapline%axandir))%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(1,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(0,pcond,axvalok,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,19)'Force changeaxis: ',mapline%axandir,gx%bmperr,axvalok,xxx\n19 format(a,i3,i5,2(1pe14.6))\n!\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,&\n nax,axarr,axvalok,ceq)\n! write(*,*)'new changeaxis: ',mapline%axandir,gx%bmperr,axvalok\n! call list_conditions(kou,ceq)\n if(gx%bmperr.eq.0) goto 320\n endif\n! Giv up, terminate the line and check if there are other lines to calculate\n! macro map1 ends at composition axis end still with T axis as variable !!\n! write(*,*)'Calling map_lineend 3',nrestore,termerr\n gx%bmperr=termerr\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n! find a new line\n goto 300\n endif\n!------------------------------------------------------------\n379 continue\n phasechange: if(irem.gt.0 .and. iadd.gt.0) then\n! We can also have a stoichiometic phase with ALLOTROPIC transformation\n! which will change form one to another at a fix T\n if(allotropes(irem,iadd,meqrec%noofits,ceq)) then\n irem=0\n goto 379\n endif\n! if there is phase which wants to appear and another disappear then\n! first check if they are the composition sets of the same phase\n! calculate with half the step 5 times. If axvalok=0 no previous axis value\n! BUG: Problems here for map5.OCM, when matsmin compiled with -O2\n! two extra composition sets of BCC and LIQUID wanted to appear.\n! Will lok at that later ...\n if(onetime) then\n! write(*,22)'SMP: phases appear and disappear at same time: ',&\n! iadd,irem,phasetuple(iadd)%lokph,phasetuple(irem)%lokph\n22 format(a,4i4)\n onetime=.false.\n endif\n! write(*,*)\n! restore constitutions\n! write(*,*)'Restore constitutions 3',halfstep,axvalok,ceq%tpval(1)\n call restore_constitutions(ceq,copyofconst)\n call map_halfstep(halfstep,1,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) then\n! jump back without setting halfstep=0\n goto 320\n elseif(nax.gt.1 .and. bytaxis.eq.0) then\n! try to change axis with active condition.\n if(meqrec%tpindep(1)) then\n if(ocv()) write(*,*)'Restoring T 4: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n write(*,557)gx%bmperr,ceq%tpval(1),axvalok\n557 format('Repeated error 8, try to change axis',i5,F8.2,1pe14.6)\n gx%bmperr=0\n bytaxis=1\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,nax,axarr,&\n axvalok,ceq)\n if(gx%bmperr.eq.0) goto 320\n call map_lineend(mapline,axvalok,ceq)\n else\n! there is an error, take another line\n call map_lineend(mapline,axvalok,ceq)\n endif\n!-----------------------------------------------------\n! phasechange elseif: a new phase stable or a stable wants to disappear\n elseif(irem.gt.0 .or. iadd.gt.0) then\n! write(*,*)'SMP2A new phase 2: ',iadd,irem,mapline%nodfixph,&\n! mapline%number_of_equilibria\n if(mapline%number_of_equilibria.lt.2 .and.&\n ((irem.gt.0 .and. irem.eq.mapline%nodfixph) .or. &\n (iadd.gt.0 .and. iadd.eq.mapline%nodfixph))) then\n mapline%axandir=-mapline%axandir\n write(*,*)'Ignore same phase as at startnode: ',1,mapline%nodfixph\n write(*,*)'Phase set dormant ',mapline%nodfixph\n meqrec%phr(mapline%nodfixph)%phasestatus=PHDORM\n! if iadd or irem is equal to mapline%nodfixph change\n! direction of the axis\n irem=0; iadd=0\n goto 320\n elseif(mapline%number_of_equilibria.le.5 .and.&\n ((irem.gt.0 .and. irem.eq.mapline%nodfixph) .or. &\n (iadd.gt.0 .and. iadd.eq.mapline%nodfixph))) then\n! write(*,*)'Startnode phase ignored: ',2,mapline%nodfixph,&\n! ceq%tpval(1)\n iadd=0; irem=0\n! set the phase dormant and decrease step\n! write(*,559)mapline%nodfixph,axvalok\n559 format('Phase set dormant ',i5,1pe14.6)\n meqrec%phr(mapline%nodfixph)%phasestatus=PHDORM\n call map_halfstep(halfstep,1,axvalok,mapline,axarr,ceq)\n if(gx%bmperr.eq.0) then\n! jump back without setting halfstep=0\n goto 320\n elseif(nax.gt.1 .and. bytaxis.eq.0) then\n! try to change axis with active condition.\n if(meqrec%tpindep(1)) then\n if(ocv()) write(*,*)'Restoring T 7: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n! try to change fix phase ...\n write(*,*)'Trying to change fix phase'\n gx%bmperr=0\n! if active axis condition is extensive we must change condition value!!\n!\n bytaxis=abs(mapline%axandir)\n call locate_condition(axarr(bytaxis)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot locate condition: ',axarr(bytaxis)%seqz\n goto 1000\n endif\n svrrec=>pcond%statvar(1)\n call condition_value(1,pcond,zzz,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(svrrec%argtyp.eq.1 .and. svrrec%statevarid.ge.10) then\n! 0 is not good check, it can be a component\n! NOTE: If we extract value for currect fix phase we must change axvals/axvals2\n! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset\n \n svrtarget=svrrec\n svrtarget%argtyp=3\n svrtarget%phase=mapline%stableph(1)%ixphase\n svrtarget%compset=mapline%stableph(1)%compset\n! This extracts the composition of the entered phase for first new line\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,xxx,ceq)\n! write(*,*)'Old/New axis condition: ',zzz,xxx,pcond%prescribed\n! else\n! write(*,*)'Axis is potential, same value',svrrec%statevarid\n endif\n!-------------------------------------------------\n call map_bytfixphase(mapline,nax,mapline%meqrec,xxx,ceq)\n if(gx%bmperr.eq.0) then\n axvalok=zero; goto 320\n endif\n!\n write(*,561)gx%bmperr,ceq%tpval(1),axvalok\n561 format('Repeated error 9, try to change axis',i5,F8.2,1pe14.6)\n write(*,*)'Trying to change axis with acitive condition'\n gx%bmperr=0\n bytaxis=1\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,&\n nax,axarr,axvalok,ceq)\n if(gx%bmperr.eq.0) goto 320\n call map_lineend(mapline,axvalok,ceq)\n else\n! there is a persistent error, take another line, set error code\n if(gx%bmperr.eq.0) then\n write(*,*)'SMP2A persistent error?'\n gx%bmperr=4399\n endif\n call map_lineend(mapline,axvalok,ceq)\n endif\n endif\n if(mapline%more.eq.0) then\n! This is the last equilibrium at axis limit\n if(irem.gt.0) then\n! terminate the line and check if there are other lines to calculate\n call map_lineend(mapline,axvalok,ceq)\n goto 300\n elseif(iadd.gt.0) then\n if(ocv()) write(*,*)'New phase at axis limit, IGNORE',iadd\n meqrec%phr(iadd)%dormlink=meqrec%dormlink\n meqrec%dormlink=iadd\n meqrec%phr(iadd)%phasestatus=PHDORM\n! meqrec%phr(iadd)%curd%status2=&\n! ibset(meqrec%phr(iadd)%curd%status2,CSSUS)\n! meqrec%phr(iadd)%curd%status2=&\n! ibset(meqrec%phr(iadd)%curd%status2,CSFIXDORM)\n goto 320\n endif\n endif\n! write(*,*)'New set of stable phases: ',iadd,irem,ceq%tpval(1)\n! calculate the exact value of the variable axis for the phase change\n! then check if we have already found this node point and if not\n! generate new start points with and without the phase\n! HERE WE CREATE A NODE WITH NEW EXIT LINES\n call map_calcnode(irem,iadd,maptop,mapline,mapline%meqrec,axarr,ceq)\n! segmentation fault in map_calcnode 170518 !!\n! write(*,*)'Back from map_calcnode',gx%bmperr,irem,iadd,noderrmess\n if((gx%bmperr.ne.0 .or. irem.ne.0 .or. iadd.ne.0) .and. noderrmess) then\n write(*,777)gx%bmperr,irem,iadd,ceq%tpval(1)\n777 format('SMP2A problem calculating node: ',3i5,' at T=',F8.2)\n! this occured in an STEP caculation for an 18 element nuclear fuel, \n! If only one axis return to calculate line\n! segmentation fault using debugged compiled OC6\n! write(*,*)'SMP2A step-epz.OCM oc6D seg fault after this'\n! write(*,*)'SMP2A associated? ',associated(maptop),associated(pcond)\n! write(*,*)'SMP2A ',maptop%number_ofaxis,pcond%statev\n! pcond not associated !! just ignore it? YES\n noderrmess=.false.\n! if(maptop%number_ofaxis.eq.1 .and. pcond%statev.eq.1) then\n if(maptop%number_ofaxis.eq.1) then\n gx%bmperr=0\n! write(*,*)'SMP2A tries to continue'\n! call list_conditions(kou,ceq)\n call restore_constitutions(ceq,copyofconst)\n gx%bmperr=0; goto 716\n endif\n endif\n noderror: if(gx%bmperr.ne.0) then\n! if error one can try to calculate using a shorter step or other things ...\n! write(*,*)'SMP2A Error return from map_calcnode: ',gx%bmperr\n if(gx%bmperr.eq.4353) then\n! this means node point not global, the line leading to this is set inactive\n! and we should not generate any startpoint. \n write(*,*)'Setting line inactive',mapline%lineid\n mapline%status=ibset(mapline%status,EXCLUDEDLINE)\n call map_lineend(mapline,axvalok,ceq)\n goto 805\n endif\n if(meqrec%tpindep(1)) then\n! restore the original temperature, maybe also compositions ...\n! write(*,*)'Restored T 5: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n! restore here creates an infinite loop with no axis increment in map2-crmo\n! write(*,*)'SMP2A oc6D restore_constitutions 4'\n! segmentation fault with step_epz.OCM, in gtp3X.F90\n call restore_constitutions(ceq,copyofconst)\n! write(*,800)'SMP2A map_calcnode error, trying smaller step: ',&\n! gx%bmperr,mapline%lasterr,axvalok\n800 format(a,3i5,1pe12.4)\n gx%bmperr=0\n! write(*,*)'SMP2A Restore call map_halfstep'\n call map_halfstep(halfstep,0,axvalok,mapline,axarr,ceq)\n! write(*,*)'back from halfstep 2',halfstep,gx%bmperr\n! if(gx%bmperr.eq.0.and. halfstep.le.5) then\n! write(*,*)'SMP2A back from halfstep',gx%bmperr,halfstep\n if(gx%bmperr.eq.0.and. halfstep.le.4) then\n goto 320\n elseif(nax.gt.1 .and. bytaxis.eq.0) then\n! try to change axis with active condition.\n if(ocv()) write(*,*)'Trying to change axis with active condition'\n gx%bmperr=0\n if(meqrec%tpindep(1)) then\n if(ocv()) write(*,*)'Restoring T 6: ',tsave,axvalok\n ceq%tpval(1)=tsave\n endif\n if(ocv()) write(*,803)'Repeated error 2, try to change axis',&\n gx%bmperr,halfstep,ceq%tpval(1)\n803 format(a,i5,i3,1pe12.4)\n bytaxis=1; gx%bmperr=0\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,&\n nax,axarr,axvalok,ceq)\n if(gx%bmperr.eq.0) goto 320\n call map_lineend(mapline,axvalok,ceq)\n! elseif(bypass.eq.0) then\n! Problem with 18 component system a phase pops up and down\n! Cleanup needed ...\n! bypass=1\n! write(*,*)'SMP2A problem calculate node, try bypass'\n! goto 310\n else\n! write(*,*)' *** Repeated errors calling map_calcnode,',&\n! ' terminate line',gx%bmperr\n! terminate line and follow another line, error reset inside map_lineend\n if(gx%bmperr.eq.0) gx%bmperr=4369\n call map_lineend(mapline,axvalok,ceq)\n endif\n endif noderror\n! we come here if a new node has been calculated and stored\n axvalok=zero\n else\n! phasechance: else: Here neither iadd or irem>0, we should never be here\n! and no error ... we should go back to label 300\n write(*,*)'SMPA no phase change?',gx%bmperr,iadd,irem\n stop 'Report this error to the OC development team!'\n endif phasechange\n! we have finished a line and look for another at label 300\n805 continue\n write(kou,808)mapline%number_of_equilibria,ceq%tpval(1),axarr(1)%lastaxval\n808 format('Finishing line with ',i5,' equilibria at T=',0pF8.2,&\n ', xaxis:',1pe12.4,' ')\n mapline%problems=0\n mapline%lasterr=0\n goto 300\n!-----------------------------------------------------\n! we come here when there are no more lines to calculate\n900 continue\n!-----------------------------------------------------\n! jump here if faital errors above\n1000 continue\n if(gx%bmperr.ne.0) write(*,*)'Exit map_doallines due to error:',gx%bmperr\n!--------------------------------------------------\n return\n end subroutine map_doallines\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bombmatta\n!\\begin{verbatim}\n subroutine bombmatta(maptop,nax,axarr,seqxyz,starteqs)\n! calculate a number of equilibria inside the region of x and y\n!\n! nax is the number of axis (can be just one for STEP)\n! axarr is an array of records specifying the axis for the step/map\n! seqxyz are intial values for number of nodes and lines\n! starteq is an equilibrium data record, if there are more start equilibria\n! they are linked using the ceq%next index\n implicit none\n integer nax,seqxyz(*)\n type(map_axis), dimension(nax) :: axarr\n! TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(starteqlista), dimension(*) :: starteqs\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,starteq\n type(gtp_condition), pointer :: xcond,ycond\n type(gtp_phase_varres), pointer :: phres\n integer s1,s2,s3,n1,n2,lokcs,nel,globalstatus,iph,potax,touse,newset\n integer, allocatable, dimension(:,:) :: phstable,phused\n double precision xval,yval,xlen,ylen\n integer, parameter :: nss=5\n! start in the middle, close to end points at the end\n double precision, dimension(nss), parameter :: axinc=&\n [0.49D0, 0.78D0, 0.22D0, 0.01D0, 0.99D0]\n character name*24\n double precision, dimension(nss*nss) :: xuse,yuse\n!\n starteq=>starteqs(1)%p1\n if(nax.ne.2) then\n write(*,*)'S2A only for map with 2 axis'\n goto 1000\n endif\n nel=noel()\n if(allocated(phstable)) then\n deallocate(phstable)\n deallocate(phused)\n endif\n newset=nooftup()\n! there cannot be more than nel phases stable\n allocate(phstable(0:nel,nss*nss+5))\n allocate(phused(0:nel,2*nss))\n phstable=0\n write(*,*)'S2A allocate phstable: ',nel,50,size(phstable),newset\n ceq=>starteq\n! supress messages from minimizer\n globalstatus=globaldata%status\n globaldata%status=ibset(globaldata%status,GSSILENT)\n potax=0\n! extrahera axis variables and their min and max\n! identify any potential axis, statevarid=1=T; 2=P; 3=MU, 4=AC; 5=LNAC\n call locate_condition(axarr(1)%seqz,xcond,ceq)\n if(xcond%statvar(1)%statevarid.le.5) potax=1\n call locate_condition(axarr(2)%seqz,ycond,ceq)\n if(ycond%statvar(1)%statevarid.le.5) potax=2\n if(gx%bmperr.ne.0) goto 1000\n if(potax.gt.0) write(*,*)'S2A potential axis: ',potax\n xlen=axarr(1)%axmax-axarr(1)%axmin\n ylen=axarr(2)%axmax-axarr(2)%axmin\n write(*,*)'S2A axis length: ',xlen,ylen\n! start loop\n n1=0\n xloop: do s1=1,nss\n! calculate at intervals 0.02 0.1 0.3 0.5 0.7 0.9 0.98 in x and y axis (49 eq)\n! set condionon on x axis\n xval=axarr(1)%axmin+axinc(s1)*xlen\n! first argument 0 is to set condition, 1 means extract value\n call condition_value(0,xcond,xval,ceq)\n if(gx%bmperr.ne.0) cycle xloop\n yloop: do s2=1,nss\n yval=axarr(2)%axmin+axinc(s2)*ylen\n write(*,'(a,i2,4(1pe12.4))')'S2A x,y: ',n1+1,xval,yval\n! set condition on y axis\n call condition_value(0,ycond,yval,ceq)\n if(gx%bmperr.ne.0) cycle yloop\n call calceq2(1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'S2A failed calculation',gx%bmperr\n gx%bmperr=0; cycle yloop\n endif\n n1=n1+1\n xuse(n1)=xval\n yuse(n1)=yval\n! loop to extract stable phases, there can be new composition sets\n n2=0\n! start from 2 as first phase_varres is the stable_el_refernce phase\n do lokcs=2,nooftup()\n phres=>ceq%phase_varres(lokcs)\n if(phres%phstate.ge.PHENTSTAB) then\n n2=n2+1\n iph=phres%phlink\n call get_phase_name(iph,1,name)\n if(gx%bmperr.ne.0) gx%bmperr=0\n write(*,'(a,2i2,i5,2x,a)')'S2A stable:',s1,n1,lokcs,trim(name)\n! save lokcs as we can have several composition sets\n phstable(n2,n1)=lokcs\n endif\n enddo\n! number of stable phases at this equilibrium\n phstable(0,n1)=n2\n enddo yloop\n enddo xloop\n! we have calculate all 25 equilibria\n do s1=1,n1\n write(*,'(a,i3,2x,i2,2x,5i5)')'S2A equil: ',s1,(phstable(s2,s1),s2=0,nel)\n enddo\n! now decide which points to use as start points, skip points with \n phused=0\n touse=0\n! skip points with phases already used\n all: do s1=1,n1\n if(phstable(0,s1).eq.0) cycle all\n write(*,'(a,5i5)')'S2A compare equil',s1,n1,phstable(0,s1),touse\n phases: do s2=1,phstable(0,s1)\n newset1: do s3=1,touse\n! compare with saved equil, skip if an equilibrium has the same phases\n if(phstable(s2,s1).eq.phused(s2,s3)) cycle newset1\n enddo newset1\n enddo phases\n! if s3 is less than touse we have an equil with a new set of phases\n write(*,*)'S2A skip as same: ',s3,touse\n if(touse.gt.0 .and. s3.gt.touse) cycle all\n! this equilibrium has a new set of phases\n touse=touse+1\n do s3=1,phstable(0,s1)\n phused(s3,touse)=phstable(s3,s1)\n enddo\n write(*,'(a,i3,2x,2F12.5,i2,2x,5i5)')'S2A use: ',s1,xuse(s1),yuse(s1),&\n (phused(s2,s1),s2=0,nel)\n enddo all\n newset=nooftup()-newset\n if(newset.gt.0) write(*,*)'S2A created ',newset,' composition sets'\n write(*,*)'S2A equilibria to use: ',touse\n1000 continue\n! reset the globaldata%status\n globaldata%status=globalstatus\n return\n end subroutine bombmatta\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_startpoint\n!\\begin{verbatim}\n subroutine map_startpoint(maptop,nax,axarr,seqxyz,inactive,ceq)\n! convert a start equilibrium to a start point replacing all but one axis\n! conditions with fix phases. The start equilibrium must be already\n! calculated. ceq is a datastructure with all relevant data for the equilibrium\n! A copy of ceq and the corresponing meqrec must be made and linked from maprec\n! the axis conditions replaced by fix phases are inactive\n! maptop is returned as a first nodepoint(although it is not a node)\n! nax is number of axis, axarr records with axis information\n! seqxyz is array with indices for numbering nodepoints and lines\n! inactive is used for map to replaced axis by fix phase\n! and for step inactive(1) nonzero means create just one linehead\n! ceq is equilibrium record\n implicit none\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(map_node), pointer :: maptop\n integer nax,seqxyz(*)\n integer inactive(*)\n type(map_axis), dimension(nax) :: axarr\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: neweq\n TYPE(gtp_condition), pointer :: condition,lastcond\n type(meq_setup), pointer :: meqrec\n TYPE(map_line), pointer :: mapline\n TYPE(map_line), dimension(3) :: tmpline\n TYPE(map_node), pointer :: mapnode,tmpnode\n type(gtp_phasetuple), dimension(3) :: forbidden\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n type(gtp_phasetuple), dimension(:), allocatable :: mapfixph\n integer mode,axactive,iax,jp,ieq,naxvar,seqx,kp,zz,kpos,seqy\n character eqname*24\n double precision value\n!\n write(*,*)\"Entering map_startpoint\",nax\n nullify(tmpnode)\n! replace all but one axis conditions with fix phases. In ceq we have\n! a calculated equilibrium with all conditions. make sure it works\n! (without global minimization). We will save the meq_setup record!\n! write(*,*)'meq_startpoint: allocating meqrec'\n allocate(meqrec)\n meqrec%status=0\n! We must use mode=-1 for map_replaceaxis below has to calculate several equil\n! and the phr array must not be deallocated. mapfix will be used later to\n! indicate fix and stable phases for different lines (maybe ...)\n mode=-1\n if(allocated(mapfix)) deallocate(mapfix)\n! nullify(mapfix)\n! write(*,*)'SMP2A meq_startpoint: after allocating meqrec 1'\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n! try using grid minimizer\n gx%bmperr=0\n! most data inside meqrec like meqrec%phr are deallocated inside calceq7\n! but calling it with mode=-1 it is kept so it must be deallocated here \n! BUG here 2019.03.03 not allocated!\n if(allocated(meqrec%phr)) deallocate(meqrec%phr)\n call calceq7(1,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calling calceq7 in map_startpoint A',gx%bmperr\n goto 1000\n endif\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calling calceq7 in map_startpoint B',gx%bmperr\n goto 1000\n endif\n endif\n! check if equilibrium inside axis limits ...\n do iax=1,nax\n call locate_condition(axarr(iax)%seqz,condition,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,condition,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(value.lt.axarr(iax)%axmin .or. value.gt.axarr(iax)%axmax) then\n write(*,*)'Startpoint outside axis limits',iax,value\n gx%bmperr=4225; goto 1000\n endif\n enddo\n! write(*,1001)'After calceq7: ',(meqrec%phr(jp)%curd%amfu,&\n! jp=1,meqrec%nphase)\n1001 format(a,6(1pe12.4))\n200 continue\n!---------------------------------- moved before creating first linehead\n! create map_node normally with two exiting lines but in some cases more.\n if(associated(maptop)) then\n! we have already a maptop record, add a new mapnode at the circular list end\n! set appropriate next/previous/first links\n tmpnode=>maptop%previous\n allocate(maptop%previous)\n! initiate all status bits to zero\n maptop%previous%status=0\n tmpnode%next=>maptop%previous\n mapnode=>maptop%previous\n! initiate mapnode\n mapnode%noofstph=-1\n mapnode%previous=>tmpnode\n mapnode%next=>maptop\n mapnode%first=>maptop\n mapnode%seqx=tmpnode%seqx+1\n mapnode%nodefix%ixphase=0\n mapnode%status=0\n mapnode%artxe=0\n mapnode%globalcheckinterval=mapglobalcheck\n! write(*,*)'creating another mapnode record',mapnode%seqx\n! nullify here indicates more than one node record\n nullify(tmpnode)\n else\n! This is the first (and maybe only) mapnode record (later maptop)\n! write(*,*)'Creating first maptop'\n! UNFINISHED: VALGRIND indicates loss of >24000 bytes in map_startpoint \n allocate(maptop)\n mapnode=>maptop\n! inititate status and links\n mapnode%status=0\n mapnode%noofstph=meqrec%nstph\n mapnode%savednodeceq=-1\n! mapnode%noofstph=-1\n mapnode%next=>mapnode\n mapnode%previous=>mapnode\n mapnode%first=>mapnode\n mapnode%number_ofaxis=nax\n mapnode%nodefix%ixphase=0\n mapnode%status=0\n mapnode%artxe=0\n! type_of_node =1 step special; =2 step scheil; =3 step tzero;\n! =4 step paraequil; =5 step nple\n! same indices used in stepspecial in pmon\n mapnode%type_of_node=0\n mapnode%globalcheckinterval=mapglobalcheck\n! if there is a previous MAP/STEP then \n! seqx and seqy pass on the last used indices for _MAPNODE and _MAPLINE\n! write(*,*)'Seqxyz 1: ',seqxyz(1),seqxyz(2)\n! seqx is set to 0 here, will be increemented by 1 at copy_equilibrium\n mapnode%seqx=seqxyz(1)\n mapnode%seqy=seqxyz(2)\n if(ocv()) write(*,*)'created maptop',maptop%seqx\n! set the tieline_inplane or not\n! For step calculation, tieline_inplane=0\n! if there are more than one condition on an extensive_variable\n! that is not an axis variable then no tielines in plane, tieline_inplane=-1\n! If there are tie_lines in plane then tieline_inplane=1\n mapnode%tieline_inplane=tieline_inplane(nax,axarr,ceq)\n if(mapnode%tieline_inplane.lt.0) then\n write(*,*)'Mapping without tie-lines in the plane'\n endif\n tmpnode=>maptop\n! forgetting to do this created a crash when plotting ...\n nullify(maptop%plotlink)\n endif\n!\n!-----------------------------------------------------------------\n! if naxvar>1 find a phase to set fix to replace an axis variable\n naxvar=nax\n if(naxvar.gt.1) then\n! in tmpline info on fix/stable phases to be stored in linehead records\n call map_replaceaxis(meqrec,axactive,ieq,nax,axarr,tmpline,inactive,&\n forbidden,ceq)\n if(ocv()) write(*,205)'Back from replaceaxis with: ',gx%bmperr,&\n axactive,ieq,&\n tmpline(1)%linefixph(1)%ixphase,tmpline(1)%linefixph(1)%compset,&\n tmpline(1)%stableph(1)%ixphase,tmpline(1)%stableph(1)%compset\n205 format(a,3i5,5x,2(2i3))\n if(gx%bmperr.ne.0) goto 1000\n if(ieq.gt.2) then\n write(*,*)'Ignoring 3rd exit from invariant!'\n ieq=2\n endif\n else\n! only one axis, i.e. a step command, create a map_node record with 2 lines\n axactive=1\n if(inactive(1).eq.0) then\n ieq=2\n else\n ieq=1\n endif\n endif\n \n! write(*,1001)'After replace: ',(meqrec%phr(jp)%curd%amfu,&\n! jp=1,meqrec%nphase)\n!-----------------------------------------------------------------------\n! finished converting a start equilibrium to a start point, \n! mapnode%type_of_node=0\n mapnode%lines=ieq\n! debug listing of links for maptop ...\n! write(*,*)'maptop: ',maptop%noofstph\n! write(*,*)'maptop next: ',maptop%next%noofstph\n! write(*,*)'maptop prev: ',maptop%previous%noofstph\n! write(*,*)'maptop next next: ',maptop%next%next%noofstph\n! write(*,*)'maptop prev prev: ',maptop%previous%previous%noofstph\n! write(*,*)'maptop next prev: ',maptop%next%previous%noofstph\n! if(associated(maptop,maptop%next)) then\n! write(*,*)'maptop and maptop%next is same record'\n! endif\n!\n! Save the T, P and chemical potentials\n allocate(mapnode%chempots(meqrec%nrel))\n do jp=1,meqrec%nrel\n mapnode%chempots(jp)=ceq%cmuval(jp)\n enddo\n mapnode%tpval=ceq%tpval\n mapnode%nodeceq=>ceq\n!-----------------------------------------------------------------------\n if(ocv()) write(*,*)'allocating lineheads: ',ieq,maptop%seqy\n! ensure mapnode%lines is correctly set\n allocate(mapnode%linehead(ieq))\n mapnode%lines=ieq\n! mapnode%type_of_node=0\n! meqrec%status\n do jp=1,ieq\n mapnode%linehead(ieq)%meqrec%status=0\n enddo\n! we can have 3 or more exits if starting inside a 3 phase triagle for isotherm\n if(ieq.lt.3) then\n! STEP command: set one exit in each direction of the active axis axactive\n! or we found a phase to set fix in a map command?\n! do jp=1,2\n do jp=1,ieq\n!--------------------- code moved from map_findline\n! make a copy of the equilibrium record\n if(ocv()) write(*,*)'We found a line from node: ',mapnode%seqx\n eqname='_MAPLINE_'\n! kpos=10 means write number from position 10\n kpos=10\n seqy=maptop%seqy+1\n call wriint(eqname,kpos,seqy)\n! write(*,*)'Calling copy_equilibrium'\n call copy_equilibrium(neweq,eqname,mapnode%nodeceq)\n! write(*,*)'back from copy_equilibrium 6'\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating equilibrium: ',eqname\n goto 1000\n endif\n maptop%seqy=seqy\n!------------------------------ end code copied\n! one line has +axactive, the other -axactive\n if(ieq.eq.2) then\n mapnode%linehead(jp)%axandir=(3-2*jp)*axactive\n else\n! this is used for Scheil-Gulliver step with just one axis\n! write(*,*)'SMP2A Scheil map_startpoint: ',inactive(1),jp,ieq\n mapnode%linehead(jp)%axandir=inactive(1)\n endif\n mapnode%linehead(jp)%number_of_equilibria=0\n mapnode%linehead(jp)%first=0\n mapnode%linehead(jp)%last=0\n! mapnode%linehead(jp)%axchange=0\n! careful balance between map4 (U-O) and Fe-Mo (map5) macros\n mapnode%linehead(jp)%axchange=-1\n! mapnode%linehead(jp)%axchange=-2\n! lineid is set when calculations along the line starts\n! mapnode%linehead(jp)%lineid=0\n mapnode%linehead(jp)%done=0\n mapnode%linehead(jp)%status=0\n mapnode%linehead(jp)%more=1\n mapnode%linehead(jp)%termerr=0\n mapnode%linehead(jp)%firstinc=zero\n! saving equilibrium pointer in lineceq\n mapnode%linehead(jp)%lineceq=>neweq\n! mapnode%linehead(jp)%evenvalue=zero\n! to ensure small initial steps\n mapnode%linehead(jp)%evenvalue=value+(3-2*jp)*axarr(1)%axinc\n! write(*,*)'evenvalue: ',mapnode%linehead(jp)%evenvalue,value\n mapnode%linehead(jp)%start=>mapnode\n mapnode%linehead(jp)%axfact=1.0D-2\n! this is set to zero indicating the stable phases are saved in ceq record\n mapnode%linehead(jp)%nstabph=0\n mapnode%linehead(jp)%lineid=seqy\n! write(*,*)'mapline%lineid assigned',seqy\n mapnode%linehead(jp)%nodfixph=0\n! %more is 1 while line is calculated, 0 means terminated at axis limit\n! > 0 means error code <0 means exit removed ?? or is it %done ??\n mapnode%linehead(jp)%more=1\n!-------------------------\n if(maptop%tieline_inplane.lt.0) then\n! tie-lines not in plane, code just copied with some mods from tielines in plane\n kp=tmpline(1)%nfixphases\n mapnode%linehead(jp)%nfixphases=kp\n allocate(mapnode%linehead(jp)%linefixph(kp))\n allocate(mapnode%linehead(jp)%linefix_phr(kp))\n! write(*,454)jp,axactive,mapnode%linehead(jp)%axandir,kp\n454 format('Axis direction etc: ',i2,2i4,2x,i3)\n do zz=1,kp\n mapnode%linehead(jp)%linefixph(zz)=tmpline(1)%linefixph(zz)\n mapnode%linehead(jp)%linefix_phr(zz)=tmpline(1)%linefix_phr(zz)\n enddo\n! we can have many stable phases\n mapnode%linehead(jp)%nstabph=tmpline(1)%nstabph\n allocate(mapnode%linehead(jp)%stableph(tmpline(1)%nstabph))\n allocate(mapnode%linehead(jp)%stablepham(tmpline(1)%nstabph))\n allocate(mapnode%linehead(jp)%stable_phr(tmpline(1)%nstabph))\n do kp=1,mapnode%linehead(jp)%nstabph\n mapnode%linehead(jp)%stableph(kp)=tmpline(1)%stableph(kp)\n mapnode%linehead(jp)%stablepham(kp)=tmpline(1)%stablepham(kp)\n mapnode%linehead(jp)%stable_phr(kp)=tmpline(1)%stable_phr(kp)\n enddo\n! write(*,*)'allocated size of stableph 1: ',jp,&\n! size(mapnode%linehead(jp)%stableph)\n if(ocv())write(*,27)'We have a startpoint for no tie-lines map:',&\n! axactive,mapnode%linehead(jp)%linefixph(1)%phaseix,&\n axactive,mapnode%linehead(jp)%linefixph(1)%ixphase,&\n mapnode%linehead(jp)%linefixph(1)%compset,&\n mapnode%linehead(jp)%nstabph,&\n (mapnode%linehead(jp)%stableph(kp)%ixphase,&\n mapnode%linehead(jp)%stableph(kp)%compset,&\n kp=1,mapnode%linehead(jp)%nstabph)\n27 format(a,i3,5x,2i3,5x,i3,2x,10(i5,i2))\n!------------------------- below for tielines in plane\n elseif(maptop%tieline_inplane.gt.0) then\n! if there are 2 axis there is one fix phase, if 3 axis there are two\n! This is not really necessary here but for other nodes with branches it is\n kp=tmpline(1)%nfixphases\n! write(*,*)'tip: Number of fixed phases: ',jp,kp\n mapnode%linehead(jp)%nfixphases=kp\n allocate(mapnode%linehead(jp)%linefixph(kp))\n allocate(mapnode%linehead(jp)%linefix_phr(kp))\n do zz=1,kp\n mapnode%linehead(jp)%linefixph(zz)=tmpline(1)%linefixph(zz)\n mapnode%linehead(jp)%linefix_phr(zz)=tmpline(1)%linefix_phr(zz)\n enddo\n! there is just one stable phase\n allocate(mapnode%linehead(jp)%stableph(1))\n allocate(mapnode%linehead(jp)%stable_phr(1))\n mapnode%linehead(jp)%nstabph=1\n mapnode%linehead(jp)%stableph=tmpline(1)%stableph\n mapnode%linehead(jp)%stable_phr=tmpline(1)%stable_phr\n! WOW I forgot to allocate stablepham\n if(allocated(tmpline(1)%stableph)) then\n kp=size(tmpline(1)%stableph)\n allocate(mapnode%linehead(jp)%stablepham(kp))\n else\n write(*,*)'SMP: no stablepham array allocated'\n stop\n endif\n if(ocv()) write(*,25)'We have saved a startpoint for map:',&\n! axactive,mapnode%linehead(jp)%linefixph(1)%phaseix,&\n axactive,mapnode%linehead(jp)%linefixph(1)%ixphase,&\n mapnode%linehead(jp)%linefixph(1)%compset,&\n mapnode%linehead(jp)%nstabph,&\n mapnode%linehead(jp)%stableph(1)%ixphase,&\n mapnode%linehead(jp)%stableph(1)%compset\n25 format(a,i3,5x,2i3,5x,i3,2x,2i3)\n!------------------------- below for STEP\n else\n! this is for STEP\n if(ocv()) write(*,*)'For STEP no need of fixed phases.'\n! write(*,*)'SMP2A Scheil step here?'\n mapnode%linehead(jp)%nfixphases=0\n allocate(mapnode%linehead(jp)%stableph(meqrec%nstph))\n allocate(mapnode%linehead(jp)%stable_phr(meqrec%nstph))\n! UNFINISHED check why no allocation of stablepham ??\n mapnode%linehead(jp)%nstabph=meqrec%nstph\n do kp=1,mapnode%linehead(jp)%nstabph\n zz=meqrec%stphl(kp)\n mapnode%linehead(jp)%stableph(kp)%ixphase=meqrec%phr(zz)%iph\n mapnode%linehead(jp)%stableph(kp)%compset=meqrec%phr(zz)%ics\n mapnode%linehead(jp)%stable_phr(kp)=zz\n enddo\n endif\n!-------------------------\n nullify(mapnode%linehead(jp)%end)\n mapnode%linehead(jp)%nodfixph=0\n enddo\n else\n! when more than two exits the set of stable phases must be different for\n! each line. This can happen if we start in a three-phase region in an\n! isothermal section with tie-lines in plane\n write(*,*)'Cannot handle more than two exits from start equilibrium'\n gx%bmperr=4226; goto 1000\n endif\n! mapnode must have pointers to its own copies of ceq and meqrec\n eqname='_MAPNODE_'\n jp=10\n! maptop%next is the most recent created mapnode ??\n seqx=maptop%next%seqx+1\n! write(*,*)'SMP2A New mapnode index: ',seqx,&\n! maptop%next%seqx,maptop%previous%seqx\n seqx=max(maptop%next%seqx,maptop%previous%seqx)+1\n maptop%next%seqx=seqx\n! write(*,666)seqx,maptop%seqx,maptop%next%seqx,maptop%previous%seqx\n666 format('maptop seqx: ',10i3)\n call wriint(eqname,jp,seqx)\n! make a copy of ceq in a new equilibrium record with the pointer neweq\n! This copy is a record in the array \"eqlista\" of equilibrium record, thus\n! it will be updated if new composition sets are created in other threads.\n call copy_equilibrium(neweq,eqname,ceq)\n! write(*,*)'Created MAPNODE ',seqx\n if(gx%bmperr.ne.0) then\n write(*,*)'Error in startpoint creating equilibrium: ',eqname\n goto 1000\n endif\n if(associated(mapnode,maptop)) maptop%seqx=seqx\n mapnode%nodeceq=>neweq\n! If the new node has two stoichiometric phases then mapline%status\n! Copy the current meqrec to mapnode, the mapline records\n! will generate their own new meqrec records when they are activated\n! if the phr array is allocated then deallocate it as it is no longer needed\n if(allocated(meqrec%phr)) then\n deallocate(meqrec%phr)\n endif\n mapnode%meqrec=meqrec\n! trying to reduce memory loss\n deallocate(meqrec)\n! write(*,*)'We are here 15!'\n! NOTE: The phr array has been deallocated, maybe it should be kept ...\n! but then we must change mode to -1 in the call to calceq7 above\n!---------------------\n! The lines below must be done when creating the mapnod%linehead record\n! we must have separate copies of meqrec and ceq for use in each thread\n! mapline%meqrec=mapnode%meqrec\n! mapline%ceq=mapnode%ceq\n! finished what must be done when creating mapnode%linehead\n!\n if(ocv()) write(*,*)'Exiting map_startpoint',gx%bmperr\n1000 continue\n if(gx%bmperr.ne.0 .and. associated(tmpnode)) then\n! we have created a maptop record but then had an error, nullify mapnode\n write(*,*)'Nullifying maptop: ',gx%bmperr\n nullify(maptop)\n endif\n return\n end subroutine map_startpoint\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_replaceaxis\n!\\begin{verbatim}\n subroutine map_replaceaxis(meqrec,axactive,ieq,nax,axarr,tmpline,&\n inactive,forbidden,ceq)\n! replace an axis condition with a fix phase\n! meqrec is equilibrium calculation record\n! axactive is the axis with active condition, ieq is number of exiting lines\n! ieq is the number of lines exiting from the startpoint\n! nax is number of axis, axarr are description of the axis\n! axarr is array with axis records\n! tmpline is to transfer some line data to calling routine\n! inactive is not really used.\n! forbidden are phasetupes with forbidden phases\n! ceq is equilibrium record\n implicit none\n type(meq_setup), pointer :: meqrec\n integer nax,axactive,ieq\n type(map_axis), dimension(nax) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_line), dimension(3) :: tmpline\n integer inactive(*)\n type(gtp_phasetuple), dimension(*) :: forbidden\n!\\end{verbatim}\n integer iph,jph,naxvar,iax,tip,jj,jax,irem,iadd,kj,nrel,sj,kax\n integer ics,lokph,lokcs,kph,kcs,forbiddenix,sph,mapx\n double precision aval,avalm,xxx,yyy,savamfu(3)\n! dummy phase tuple, maybe use nullify instead?\n type(gtp_phasetuple) :: zerotup\n type(gtp_condition), pointer :: pcond\n integer, dimension(:), allocatable :: axis_withnocond\n! handle change of condition value\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n! turns off converge control for T\n integer, parameter :: inmap=1\n!\n zerotup%lokph=0\n zerotup%compset=0\n zerotup%ixphase=0\n zerotup%lokvares=0\n zerotup%nextcs=0\n!\n nrel=noel()\n tip=tieline_inplane(nax,axarr,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'In map_replaceaxis ',tip\n!-----------------------------------------------------------------\n! check if start point is an invariant equilibria, can easily happen in \n! ternary isotherms\n if(inveq(jj,ceq)) then\n if(tip.gt.0) then\n! ignore this for less than 3 components\n if(nrel.eq.3) then\n! we are in an isothermal triangle, 3 startlines\n write(*,*)'Start equilibrium is invariant',jj\n ieq=3\n! goto 1000\n elseif(nrel.gt.3) then\n! I do not know what kind of equilibrium this is\n write(*,160)\n160 format('Start equilibrium invariant with tie-lines in plane',&\n ' but not 3 components'/'I do not know how to handle this')\n gx%bmperr=4399\n goto 1000\n endif\n else\n! start equilibrium for a system without tie-lines in plane is invariant\n! a rare case\n write(*,161)\n161 format('Start equilibrium invariant without tie-lines in plane'/&\n 'I do not know how to handle this')\n gx%bmperr=4399\n goto 1000\n endif\n endif\n naxvar=nax\n! zero the number of fix phases and allocate data for the lines needed\n tmpline%nfixphases=0\n allocate(tmpline(1)%linefixph(naxvar-1))\n allocate(tmpline(1)%linefix_phr(naxvar-1))\n!========================================================== tie-lines in plane\n tieline_in_plane: if(tip.eq.1) then\n! We have tie-lines in the plane, only one stable phase in addition to fix\n! write(*,*)'map_replaceaxis: allocate: tmpline(1)%stableph(1)'\n allocate(tmpline(1)%stableph(1))\n allocate(tmpline(1)%stablepham(1))\n allocate(tmpline(1)%stable_phr(1))\n allocate(axis_withnocond(nax))\n axis_withnocond=0\n stablephases: if(meqrec%nstph.gt.1) then\n! and we have two or more stable phase, we can directly generate startpoints\n100 continue\n if(meqrec%nstph.eq.3) then\n! this is a unique case when we must create 3 lines\n! write(*,*)'Startpoint inside invariant not yet implemented'\n! gx%bmperr=4399; goto 1000\n!\n! save some data ...??\n! do jph=1,3\n! jj=meqrec%stphl(jph)\n! savamfu(iph)=meqrec%phr(jj)%curd%amfu\n! stableph(1,jph)=meqrec%phr(jj)%iph\n! stableph(2,jph)=meqrec%phr(jj)%ics\n! enddo\n! loop for the 3 stable phases setting one of them as fix in turn\n meqrec%nfixph=1\n meqrec%nstph=1\n forbiddenix=3\n fixphaseloop: do jph=1,3\n! all phases are already set as stable\n kj=meqrec%stphl(jph)\n! write(*,*)'tmpline 1: ',jph,kj\n if(jph.gt.1) then\n allocate(tmpline(jph)%linefixph(1))\n allocate(tmpline(jph)%linefix_phr(1))\n allocate(tmpline(jph)%stableph(1))\n allocate(tmpline(jph)%stablepham(1))\n allocate(tmpline(jph)%stable_phr(1))\n endif\n! do we need to set values in meqrec??\n! meqrec%fixph(1,1)=meqrec%phr(kj)%iph\n! meqrec%fixph(2,1)=meqrec%phr(kj)%ics\n! meqrec%fixpham(1)=zero\n tmpline(jph)%nfixphases=1\n tmpline(jph)%linefixph(1)=zerotup\n! write(*,*)'tmpline 2A: ',jph,kj\n! write(*,*)'tmpline 2C: ',allocated(meqrec%phr)\n! write(*,*)'tmpline 2B: ',meqrec%phr(kj)%iph\n! write(*,*)'tmpline 2C: ',allocated(tmpline(jph)%linefixph)\n tmpline(jph)%linefix_phr(1)=kj\n tmpline(jph)%linefixph(1)%ixphase=meqrec%phr(kj)%iph\n! write(*,*)'SMP2A tmpline 3: ',jph,kj\n tmpline(jph)%linefixph(1)%compset=meqrec%phr(kj)%ics\n! write(*,*)'SMP2A tmpline 4: ',jph,kj\n tmpline(jph)%nstabph=1\n kph=jph+1\n if(kph.gt.3) kph=1\n sph=meqrec%stphl(kph)\n tmpline(jph)%axandir=1\n write(*,*)'tmpline',kph,sph,tmpline(jph)%axandir\n tmpline(jph)%stableph(1)=zerotup\n tmpline(jph)%stableph(1)%ixphase=meqrec%phr(sph)%iph\n tmpline(jph)%stableph(1)%compset=meqrec%phr(sph)%ics\n tmpline(jph)%stablepham(1)=one\n tmpline(jph)%stable_phr(1)=sph\n! lines: (fix,stable,forbidden) : (1,2,3); (2,3,1); (3,1,2)\n! we must mark the third phase as forbidden !!!\n jj=meqrec%stphl(forbiddenix)\n write(*,*)'tmpline 5',forbiddenix,jj\n forbidden(jph)=zerotup\n forbidden(jph)%ixphase=meqrec%phr(jj)%iph\n forbidden(jph)%compset=meqrec%phr(jj)%ics\n forbiddenix=forbiddenix+1\n if(forbiddenix.gt.3) forbiddenix=1\n enddo fixphaseloop\n write(*,65)'Lines: ',&\n tmpline(1)%linefixph(1)%ixphase,&\n tmpline(1)%stableph(1)%ixphase,forbidden(1)%ixphase,&\n tmpline(2)%linefixph(1)%ixphase,&\n tmpline(2)%stableph(1)%ixphase,forbidden(2)%ixphase,&\n tmpline(3)%linefixph(1)%ixphase,&\n tmpline(3)%stableph(1)%ixphase,forbidden(3)%ixphase\n65 format(a,3i4,5x,3i4,5x,3i4)\n! we should set the axis composition to the stable phase ...\n! and we should test ...\n goto 1000\n! this is end of generating startpoint from a ternary isothermal triangle\n endif\n write(*,*)'Tie-lines in the plane and start equilibrium with',&\n ' several stable phases'\n jax=0\n! call list_conditions(kou,ceq)\n do iax=1,nax\n call locate_condition(axarr(iax)%seqz,pcond,ceq)\n! skip axis already removed\n if(pcond%active.eq.1) cycle\n if(pcond%statev.ge.10) then\n! Best to replace an extensive variable with a fix phase\n! But we cannot use a condition N=1 or B=1 for example. It must depend on\n! a component\n! write(*,*)'Condition 1: ',iax,pcond%seqz\n! if(pcond%indices(1,1).eq.0) cycle\n if(pcond%statvar(1)%argtyp.eq.0) cycle\n! write(*,*)'Condition 2: ',iax,pcond%indices(1,1)\n jax=iax; exit\n endif\n enddo\n if(jax.eq.0) then\n! we must accept to replace a potential axis, use one depending on a component\n! If we have a P-T diagram? This would not work\n do iax=1,nax\n call locate_condition(axarr(iax)%seqz,pcond,ceq)\n if(pcond%statev.gt.2) then\n jax=iax; exit\n endif\n enddo\n endif\n!----------------------------------------------\n! determine a phase to set fix with zero amount\n avalm=1.0D5\n if(ocv()) write(*,*)'Removing axis ',jax,&\n ', looking for the phase to fix'\n! select the phase with smallest amount ... phr has been deallocated ...\n! aval=ceq%phase_varres(lokcs)%amfu\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n! amfu is amount formula units, abnorm(1) is atoms/formula units\n aval=meqrec%phr(jj)%curd%amfu*meqrec%phr(jj)%curd%abnorm(1)\n if(aval.lt.avalm) then\n kph=meqrec%phr(jj)%iph\n kcs=meqrec%phr(jj)%ics\n kj=jj\n avalm=aval\n! we have 2 stable phases, jph is 1 or 2\n sj=3-jph\n endif\n enddo\n! The phase meqrec%phr(kj)%iph/ics should be set fix \n sj=meqrec%stphl(sj)\n! write(*,73)'Fix phase: ',kj,meqrec%phr(kj)%iph,meqrec%phr(kj)%ics,&\n! ' Stable phase: ',sj,meqrec%phr(sj)%iph,meqrec%phr(sj)%ics\n73 format(a,3i4,a,3i4)\n meqrec%phr(kj)%curd%dgm=zero\n meqrec%phr(kj)%curd%amfu=zero\n meqrec%phr(kj)%stable=1\n meqrec%phr(kj)%phasestatus=PHFIXED\n! The array fixph contains also phases with explicit condition to be fixed\n meqrec%nfixph=meqrec%nfixph+1\n meqrec%fixph(1,meqrec%nfixph)=kph\n meqrec%fixph(2,meqrec%nfixph)=kcs\n meqrec%fixpham(meqrec%nfixph)=zero\n! and the axis condition pcond should be removed\n pcond%active=1\n inactive(1)=inactive(1)+1\n inactive(inactive(1))=pcond%seqz\n! meqrec%inactiveaxis(1)=pcond%seqz\n! write(*,77)jax,pcond%seqz,pcond%prescribed\n77 format(' Removing condition: ',2i3,2(1pe12.4))\n! We have tried not to replace T or P,\n! but if this is done it must be indicated specially like this\n if(pcond%statev.eq.1) then\n meqrec%tpindep(1)=.TRUE.\n if(ocv()) write(*,*)'Marking that T is variable'\n elseif(pcond%statev.eq.2) then\n meqrec%tpindep(2)=.TRUE.\n endif\n! set amount of stable phase\n meqrec%phr(sj)%curd%amfu=one\n! if both axis are extensive (isothermal section) modify active axis condition\n! to be the composition of the stable phase\n kax=3-jax\n call locate_condition(axarr(kax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot locate condition: ',axarr(kax)%seqz\n goto 1000\n endif\n! first argument 1 means extract value of condition\n call condition_value(1,pcond,xxx,ceq)\n if(pcond%statev.ge.10) then\n! write(*,*)'isothermal section'\n svrrec=>pcond%statvar(1)\n! NOTE: If we change fix/entered phase we must change axvals/axvals2\n svrtarget=svrrec\n svrtarget%argtyp=3\n svrtarget%phase=meqrec%phr(sj)%iph\n svrtarget%compset=meqrec%phr(sj)%ics\n! This extracts the composition of the entered phase for first new line\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,yyy,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,71)jax,xxx,yyy\n71 format('Change ',i3,' axis condition from/to ',2F10.6)\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,yyy,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot set axis condition'\n gx%bmperr=4399; goto 1000\n endif\n endif\n!---------------------------------------------------\n! calculate the equilibrium with the new set of conditions\n if(ocv()) write(*,*)'Calling meq_sameset inside map_replaceaxis'\n irem=0; iadd=0;\n! write(*,*)'smp2A calling meq_sameset from map_replaceaxis'\n call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calling meq_sameset in startpoint: ',gx%bmperr\n goto 1000\n elseif(irem.gt.0 .or. iadd.gt.0) then\n write(*,*)'Change of phase set in startpoint...',irem,iadd\n gx%bmperr=4227; goto 1000\n endif\n!------------------------------------------------------\n if(ocv()) write(*,*)'A successful calculation with one axis',&\n ' condition replaced by a fix phase.'\n if(ocv()) write(*,*)'Released axis: ',jax,' fix phase: ',kph,kcs\n axis_withnocond(jax)=1\n naxvar=naxvar-1\n if(naxvar.eq.1) then\n! when we are here we have a start point and can determine the number of exits\n! for the moment just assume 2nd axis is the remaining condition!!\n tmpline(1)%nfixphases=1\n tmpline(1)%linefixph=zerotup\n! kj and kph set in loop above ... hope they have not changed\n tmpline(1)%linefixph%ixphase=kph\n tmpline(1)%linefixph%compset=kcs\n tmpline(1)%linefix_phr=kj\n tmpline(1)%nstabph=0\n! Note meqrec%phr is a TYPE meq_phase with an link curd to phase_varres\n! meqrec%phr is a more complex TYPE\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(jj)%iph.eq.kph .and.&\n meqrec%phr(jj)%ics.eq.kcs) cycle\n tmpline(1)%stableph(1)=zerotup\n tmpline(1)%stableph(1)%ixphase=meqrec%phr(jj)%iph\n tmpline(1)%stableph(1)%compset=meqrec%phr(jj)%ics\n tmpline(1)%stable_phr(1)=jj\n tmpline(1)%nstabph=tmpline(1)%nstabph+1\n! tmpline(1)%nstabph=1\n! why exit?? Maybe because there can only be a single phase!!\n! exit\n enddo\n if(tmpline(1)%nstabph.eq.0) then\n write(*,*)'No stable phase !!'\n stop\n endif\n! This is the axis with active condition\n axactive=2\n ieq=2\n else\n write(*,*)'Not implemented more than 2 axis'\n gx%bmperr=4228; goto 1000\n endif\n! ========================================== tie-lines in plane and one phase\n else ! we have just a single phase stable we must move in some direction\n! ceq%multiuse is direction\n! write(*,*)'SMP2A Tie-line in plane and single phase,',&\n! ' This may not work ... '\n call map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif stablephases\n! ============================================= no tie-lines in plane\n else !tie-lines NOT in the plane\n! I am not sure what stableph and axis_withnocond are used for ...\n! write(*,*)'SMP2A multiple startpoint without tie-lines in plane not allowed'\n! gx%bmperr=4399; goto 1000\n allocate(axis_withnocond(nax))\n axis_withnocond=0\n call map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif tieline_in_plane\n! \n! check if more axis must be released\n900 continue\n if(nax.gt.2) then\n write(*,*)'SMP2A Cannot handle more than 2 axis at present'\n gx%bmperr=4228\n endif\n1000 continue\n! write(*,*)'Return from map_replaceaxis with conditions: '\n! call list_conditions(kou,ceq)\n return\n end subroutine map_replaceaxis\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_startline\n!\\begin{verbatim}\n subroutine map_startline(meqrec,axactive,ieq,nax,axarr,tmpline,ceq)\n! find a phase to fix to replace an axis condition when we \n! do not have tie-lines in the plane or when we \n! have tie-lines in the plane but start in a single phase region\n! meqrec is equilibrium record already initiated\n! axactive is set to the axis with active condition\n! ieq is the number of lines exiting from the startpoint\n! nax is number of axis, axarr are description of the axis\n! axarr are axis records\n! tmpline is a line record ... not needed ... ??\n implicit none\n integer nax,axactive,ieq\n type(meq_setup), pointer :: meqrec\n type(map_line), dimension(2) :: tmpline\n type(map_axis), dimension(nax) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jax,iax,idir,irem,iadd,iph,jj,jph,kph,ll,mapx\n integer :: maxtry=0\n integer, parameter :: nstabphdim=20\n! data for more than 3 axis ...\n integer axfree(5)\n double precision curval,startval\n type(gtp_condition), pointer :: pcond\n! turns off converge control for T\n integer, parameter :: inmap=1\n save maxtry\n! with 3 or more axes one will have several linefixph\n!\n! write(*,*)'In map_startline, find a phase to set fix',ceq%multiuse\n! start in negative direction unless direction given\n axfree=0\n idir=-1\n if(ceq%multiuse.ne.0) then\n if(abs(ceq%multiuse).gt.nax) then\n write(*,*)'Error in direction, no such axis, ',ceq%eqno,ceq%multiuse\n! this can happen for startpoints. 21 is lower left, 22 is lower right\n! 23 is upper left, 24 is upper right and 30 is in the middle \n! Try to generate several directions for each, at present just one\n if(ceq%multiuse.eq.21) then\n! directions +1 and +2\n call list_conditions(kou,ceq)\n jax=1; idir=1\n elseif(ceq%multiuse.eq.22) then\n! directions +1 and -2\n call list_conditions(kou,ceq)\n jax=2; idir=-1\n elseif(ceq%multiuse.eq.23) then\n! directions -1 and +2\n call list_conditions(kou,ceq)\n jax=1; idir=-1\n elseif(ceq%multiuse.eq.24) then\n! directions -1 and -2\n call list_conditions(kou,ceq)\n jax=2; idir=-1\n elseif(ceq%multiuse.eq.30) then\n! all 4 directions ...\n call list_conditions(kou,ceq)\n else\n write(*,*)'Error in direction, no such axis, ',ceq%multiuse\n gx%bmperr=4229; goto 1000\n endif\n else\n! direction is +/-axis\n! write(*,*)'SMP2A direction: ',ceq%multiuse\n if(ceq%multiuse.gt.0) idir=1\n jax=abs(ceq%multiuse)\n call locate_condition(axarr(jax)%seqz,pcond,ceq)\n! write(*,*)'SMP2A axis condition: ',pcond%statev,gx%bmperr\n if(gx%bmperr.ne.0) goto 1000\n endif\n else\n! no axis selected\n! write(*,*)'SMP2A no direction',ceq%multiuse,nax\n jax=0\n idir=-1\n findax: do iax=1,nax\n call locate_condition(axarr(iax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%statev.lt.10) then\n! this means intensive variable (T,P chemical potential)\n idir=-1; jax=iax; exit findax\n endif\n enddo findax\n! both axis are extensive, take the first axix\n if(jax.eq.0) jax=1\n call locate_condition(axarr(jax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Searching for phase to fix along axis: ',jax\n endif\n call condition_value(1,pcond,curval,ceq)\n! write(*,'(a,3i4,F10.2)')'SMP2A initial value: ',gx%bmperr,jax,idir,curval\n if(gx%bmperr.ne.0) goto 1000\n! it seems OK until here ....\n startval=curval\n! increment axis variable using axinc and calculate with meq_sameset\n100 continue\n curval=curval+idir*axarr(jax)%axinc\n call condition_value(0,pcond,curval,ceq)\n! write(*,'(a,i5,F12.5)')'SMP2A current value: ',gx%bmperr,curval\n if(gx%bmperr.ne.0) goto 1000\n irem=0; iadd=0; meqrec%noofits=0\n! write(*,*)'SMP2A calling meq_sameset from map_startline 1'\n call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq)\n! if(ocv()) write(*,110)'Search for phase change: ',&\n! write(*,110)'Search for phase change: ',&\n! idir*jax,gx%bmperr,irem,iadd,ceq%tpval(1),curval,axarr(jax)%axinc\n110 format(a,i2,3i5,2x,F8.2,2(1pe12.4))\n maxtry=maxtry+1\n if(maxtry.gt.1000) then\n write(*,*)'SMP2A eternal loop: ',maxtry\n stop\n endif\n if(gx%bmperr.ne.0) goto 1000\n nophasechange: if(irem.eq.0 .and. iadd.eq.0) then\n if(idir.lt.0) then\n if(curval.le.axarr(jax)%axmin) then\n! change direction\n idir=1\n curval=startval\n endif\n elseif(idir.gt.0) then\n if(curval.ge.axarr(jax)%axmax) then\n write(*,*)'No phase change along this axis'\n goto 1010\n endif\n endif\n goto 100\n endif nophasechange\n!----------------------------------------------------------\n! we found a phase to set fix!\n meqrec%nfixph=meqrec%nfixph+1\n write(*,*)'SMP2A meqrec%nfixph and nax:',meqrec%nfixph,nax\n! This is written to handle several axis i.e. several fix phases.\n! write(*,*)'SMP2A found a phase change: ',irem,iadd\n fixfas: if(irem.gt.0) then\n if(meqrec%nstph.eq.1) then\n write(*,*)'Attempt to set the only phase as fix!'\n gx%bmperr=4230; goto 1000\n endif\n! write(*,*)'Remove axis condition and set stable phase fix: ',irem\n! phase already in lists, just mark it is no fixed with zero amount\n meqrec%phr(irem)%stable=1\n meqrec%phr(irem)%curd%amfu=zero\n meqrec%phr(irem)%curd%dgm=zero\n! set that the phase has fixed amount\n meqrec%phr(irem)%phasestatus=PHFIXED\n meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(irem)%iph\n meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(irem)%ics\n kph=irem\n!---------------------------------------------------------------\n else !fixfas iadd\n! write(*,*)'SMP2A set new phase fix: ',iadd\n if(meqrec%nstph.eq.meqrec%maxsph) then\n write(*,*)'Too many phases stable',meqrec%maxsph\n gx%bmperr=4231; goto 1000\n endif\n! copied from meq_phaseset\n! the phase must be added in sequential order of phase and composition set no\n findplace: do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(iadd)%iph.gt.meqrec%phr(jj)%iph) then\n cycle\n endif\n if(meqrec%phr(iadd)%iph.lt.meqrec%phr(jj)%iph) then\n exit\n endif\n! if same phase number compare composition set numbers\n if(meqrec%phr(iadd)%iph.eq.meqrec%phr(jj)%iph) then\n if(meqrec%phr(iadd)%ics.gt.meqrec%phr(jj)%ics) then\n cycle\n else\n exit\n endif\n endif\n enddo findplace\n do kph=meqrec%nstph,jph,-1\n meqrec%stphl(kph+1)=meqrec%stphl(kph)\n enddo\n! write(*,*)'SMP2A still trying to fix conditions ...'\n! phase added at jph, (note jph may be equal to nstph+1)\n meqrec%stphl(jph)=iadd\n meqrec%nstph=meqrec%nstph+1\n meqrec%phr(iadd)%itadd=meqrec%noofits\n meqrec%phr(iadd)%curd%dgm=zero\n meqrec%phr(iadd)%stable=1\n! set that the phase has fixed amount\n meqrec%phr(iadd)%phasestatus=PHFIXED\n meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(iadd)%iph\n meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(iadd)%ics\n kph=iadd\n endif fixfas\n! meqrec%nfixph is used to reduce the number of variables in the system\n! matrix. Fix phases have no variable amount.\n meqrec%fixpham(meqrec%nfixph)=zero\n!\n! write(*,*)'Now release axis condition: ',kph,pcond%active\n! Must not forget to set if T or P is variable!\n pcond%active=1\n if(pcond%statev.eq.1) then\n meqrec%tpindep(1)=.TRUE.\n elseif(pcond%statev.eq.2) then\n meqrec%tpindep(2)=.TRUE.\n endif\n! calling meq_sameset with iadd=-1 turn on verbose\n irem=0; iadd=0\n! write(*,*)'SMP2A calling meq_sameset from map_startline 2'\n call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq)\n! if(ocv()) write(*,110)'meq_sameset calculated: ',&\n if(gx%bmperr.gt.0) then\n write(*,*)'Failed to calculate with fix phase',gx%bmperr\n goto 1000\n elseif(iadd.gt.0 .or. irem.gt.0) then\n write(*,*)'Another phase want to be stable: ',iadd,irem\n gx%bmperr=4232; goto 1000\n endif\n if(nax.gt.2) then\n! handling of more than 2 axes\n! unfinished vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv below\n axfree(jax)=1\n write(*,*)'SMP2A more than 2 axes, fix phase: ',meqrec%nfixph,nax,jax\n do kph=1,meqrec%nfixph\n write(*,*)'smp2a: linefix: ',meqrec%fixph(1,kph),meqrec%fixph(2,kph)\n enddo\n if(nax-meqrec%nfixph.gt.1) then\n write(*,'(a,5i3)')'smp2a axfree: ',axfree\n! more than 2 axis, more than 1 fix phase along the line\n! Hm what is linefix_phr used for when one can have several fix phases???\n moreax: do jax=1,nax\n! skip axis already replaced by fix phase but accept any other\n if(axfree(jax).ne.0) cycle moreax\n call locate_condition(axarr(jax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,pcond,curval,ceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo moreax\n if(jax.gt.nax) stop 'no such axis'\n! it seems OK until here ....\n startval=curval\n! return seaching for another phase to set fix\n write(*,*)'smp2a tries to replace axis ?',jax,curval\n goto 100\n endif\n! unfinished ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ above\n!>>>>>>>>>>>>> we have not finished mapping with 3 or more axis\n endif\n! write(*,110)'SMP2A start calculated: ',0,gx%bmperr,irem,iadd,ceq%tpval(1)\n! if(gx%bmperr.ne.0) goto 1000\n!\n! we must return some values\n! write(*,*)'SMP2A now create start node and line equilibria'\n! two exits\n ieq=2\n if(nax.gt.2) then\n write(*,*)'SMP2A sorry not implemented more than 2 axis'\n gx%bmperr=4399; goto 1000\n else\n! active axis, the remaining one, if jax=1 then 2, if jax=2 then 1\n axactive=3-jax\n! templine is map_line record, some data must be set\n tmpline(1)%nfixphases=1\n tmpline(1)%linefixph%ixphase=meqrec%phr(kph)%iph\n tmpline(1)%linefixph%compset=meqrec%phr(kph)%ics\n tmpline(1)%linefix_phr=kph\n endif\n! allocate space for all stable phases minus one as fix, may already be alloc\n! The number of stable phases can vary for different MAP commands\n if(allocated(tmpline(1)%stableph)) then\n deallocate(tmpline(1)%stableph)\n deallocate(tmpline(1)%stablepham)\n deallocate(tmpline(1)%stable_phr)\n endif\n! write(*,*)'map_startline: allocate 2: ',nstabphdim\n allocate(tmpline(1)%stableph(nstabphdim))\n allocate(tmpline(1)%stablepham(nstabphdim))\n allocate(tmpline(1)%stable_phr(nstabphdim))\n ll=0\n tmpline(1)%nstabph=0\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n! write(*,*)'Stable phase: ',meqrec%nstph,kph,jj\n if(jj.eq.kph) cycle\n! if(meqrec%phr(jj)%iph.eq.kph .and.&\n! meqrec%phr(jj)%ics.eq.kcs) cycle\n! write(*,66)'smp3: upper bound: ',jph,jj,size(tmpline(1)%stableph),&\n! nstabphdim,meqrec%nstph\n66 format(a,10i4)\n ll=ll+1\n! write(*,*)'Store stable phase: ',jj,ll\n tmpline(1)%stableph(ll)%ixphase=meqrec%phr(jj)%iph\n tmpline(1)%stableph(ll)%compset=meqrec%phr(jj)%ics\n tmpline(1)%stablepham(ll)=meqrec%phr(jj)%curd%amfu\n tmpline(1)%stable_phr(ll)=jj\n tmpline(1)%nstabph=tmpline(1)%nstabph+1\n! why exit?\n! exit\n enddo\n! if(ocv()) write(*,300)axactive,kph,tmpline(1)%linefixph%phaseix,&\n! write(*,300)axactive,kph,tmpline(1)%linefixph%ixphase,&\n! tmpline(1)%linefixph%compset,tmpline(1)%nstabph,&\n! (tmpline(1)%stableph(jj)%ixphase,tmpline(1)%stableph(jj)%compset,&\n! jj=1,tmpline(1)%nstabph)\n300 format('exit map_startline: ',i2,i3,2x,2i3,2x,i2,10(2x,i3,i2))\n if(tmpline(1)%nstabph.eq.0) then\n write(*,*)'No stable phase !!'\n stop\n endif\n1000 continue\n return\n1010 continue\n gx%bmperr=4233\n goto 1000\n end subroutine map_startline\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_checkstep\n!\\begin{verbatim}\n subroutine map_checkstep(mapline,value,jj,axarr,nax,saveceq)\n! check if step too large\n! mapline is line record\n! axarr is array with axis records\n! nax is number of axis\n! saveceq is record for saved equilibria\n implicit none\n integer nax\n type(map_line), pointer :: mapline\n type(map_axis), dimension(nax) :: axarr\n type(map_ceqresults), pointer :: saveceq\n!\\end{verbatim}\n integer place,jph,jj\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), target :: axstv1\n type(gtp_state_variable), pointer :: axstv\n double precision value\n character ch1*1\n logical saveonfile\n! pointer to last calculated (can be zero) and last free\n! store last calulated axis values in axarr(iax)%lastaxval\n! write(*,*)'In map_checkstep',mapline%start%number_ofaxis,nax\n! do jj=1,nax\n! axstv1=axarr(jj)%axcond(1)\n! axstv=>axstv1\n! call state_variable_val(axstv,value,mapline%lineceq)\n! if(gx%bmperr.gt.0) goto 1000\n! if(nax.gt.1) then\n! when several axis check if any has a big change ...\n! if(mapline%number_of_equilibria.gt.3) then\n if(abs(axarr(jj)%lastaxval-value).gt.&\n 1.0D-1*(axarr(jj)%axmax-axarr(jj)%axmin)) then\n write(*,17)jj,mapline%axandir,mapline%number_of_equilibria,&\n axarr(jj)%lastaxval,value\n17 format(' *** Too large change in axis: ',2i3,' at ',i4,&\n 2(1pe14.6))\n gx%bmperr=4360; goto 1000\n endif\n1000 continue\n return\n end subroutine map_checkstep\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_store\n!\\begin{verbatim}\n subroutine map_store(mapline,axarr,nax,saveceq)\n! store a calculated equilibrium\n! mapline is line record\n! axarr is array with axis records\n! nax is number of axis\n! saveceq is record for saved equilibria\n implicit none\n integer nax\n type(map_line), pointer :: mapline\n type(map_axis), dimension(nax) :: axarr\n type(map_ceqresults), pointer :: saveceq\n!\\end{verbatim}\n integer place,jph,jj,lokcs\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), target :: axstv1\n type(gtp_state_variable), pointer :: axstv\n double precision value\n character ch1*1\n logical saveonfile,testforspinodal\n! pointer to last calculated (can be zero) and last free\n! store last calulated axis values in axarr(iax)%lastaxval ALLOCATE\n! write(*,*)'SMP in map_store',gx%bmperr,globaldata%sysparam(2)\n! insert a test for spinodal at every iii equilibriia\n testforspinodal=.FALSE.\n if(globaldata%sysparam(2).gt.0) then\n if(mod(mapline%number_of_equilibria,globaldata%sysparam(2)).eq.0) &\n testforspinodal=.TRUE.\n endif\n!\n do jj=1,nax\n axstv1=axarr(jj)%axcond(1)\n axstv=>axstv1\n call state_variable_val(axstv,value,mapline%lineceq)\n if(gx%bmperr.gt.0) goto 1000\n! write(*,*)'map_store: ',value\n! this check could be moved before store to take halfstep??\n if(nax.gt.1 .and. mapline%number_of_equilibria.gt.3) &\n call map_checkstep(mapline,value,jj,axarr,nax,saveceq)\n if(gx%bmperr.ne.0) goto 1000\n! if(nax.gt.1) then\n! when several axis check if any has a big change ...\n! if(mapline%number_of_equilibria.gt.3) then\n! if(abs(axarr(jj)%lastaxval-value).gt.&\n! 1.0D-1*(axarr(jj)%axmax-axarr(jj)%axmin)) then\n! 2.0D-2*(axarr(jj)%axmax-axarr(jj)%axmin)) then\n! write(*,17)' *** map_store large step in axis: ',&\n! mapline%number_of_equilibria,jj,&\n! mapline%axandir,axarr(jj)%lastaxval,value\n!17 format(a,3i3,2(1pe14.6))\n! gx%bmperr=4360; goto 1000\n! read(*,'(a)')ch1\n! endif\n! endif\n! endif\n axarr(jj)%lastaxval=value\n enddo\n if(repeatederr.ge.2) then\n! VERY STRANGE BEHAVIOUR HERE, repeatederr not reset ??\n! maybe not store if repeatederr nonzero \n jj=repeatederr; repeatederr=0\n! write(*,*)'SMP in map_store',jj,repeatederr,gx%bmperr\n! Finnaly I will store the calculated equilibrium but skip it for plotting\n! if lasterr nonzero.\n! gx%bmperr=4399\n! goto 1000\n endif\n repeatederr=0\n! write(*,18)'stored: ',mapline%number_of_equilibria,(axarr(jj)%lastaxval,&\n! jj=1,mapline%start%number_ofaxis)\n!18 format(a,i3,5(1pe14.6))\n!-----------------------\n saveonfile=.FALSE.\n! >>>> begin treadprotected\n! write(*,*)'map_store: ',saveonfile\n call reserve_saveceq(place,saveceq)\n if(gx%bmperr.eq.4219) then\n! the memory is full, save this equilibrium, clean up and empty all on file\n saveonfile=.TRUE.\n gx%bmperr=0\n elseif(gx%bmperr.ne.0) then\n! some other fatal error\n goto 1000\n endif\n if(repeatederr.gt.0) then\n! maybe not store if repeatederr nonzero\n! write(*,*)'SMP in map_store',repeatederr,gx%bmperr,place\n repeatederr=0\n endif\n! write(*,*)'map_store: ',place,allocated(mapline%meqrec%phr)\n! write(*,*)'map_store: ',place,assigned(mapline%meqrec)\n! >>>> end threadprotected\n!-----------------------\n! when step_tzero and some other step procedures MEQREC is not used\n if(.not.allocated(mapline%meqrec%phr)) goto 600\n! loop through all phases and if their status is entered set it as PHENTUNST\n! then loop through all stable to set status PHENTSTAB\n! That is important for extracting values later ...\n meqrec=>mapline%meqrec\n do jph=1,meqrec%nphase\n! write(*,*)'phase and status: ',jph,meqrec%phr(jph)%curd%phstate,&\n! PHENTSTAB\n! if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. &\n! meqrec%phr(jph)%curd%phstate.le.PHENTSTAB) then\n! meqrec%phr(jph)%curd%phstate=PHENTUNST\n if(meqrec%phr(jph)%curd%phstate.ge.PHENTUNST .and. &\n meqrec%phr(jph)%curd%phstate.le.PHENTERED) then\n meqrec%phr(jph)%curd%phstate=PHENTUNST\n! else\n! write(*,*)'map_store found a phase with status: ',&\n! meqrec%phr(jph)%curd%phstate\n endif\n enddo\n! write(*,*)'map_store, stable phases',meqrec%nstph,place\n do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(jj)%curd%phstate.lt.PHFIXED) then\n meqrec%phr(jj)%curd%phstate=PHENTSTAB\n! check if phase is inside miscibility gap\n if(testforspinodal) then\n lokcs=phasetuple(meqrec%phr(jj)%curd%phtupx)%compset\n call calc_qf(lokcs,value,mapline%lineceq)\n write(*,'(a,i3,F8.2,4(1pe12.4))')'SMP qf: ',lokcs,&\n mapline%lineceq%tpval(1),value\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP error chacking for instability',lokcs\n gx%bmperr=0\n elseif(value.lt.zero) then\n write(*,*)'SMP detected phase inside spinodal: ',lokcs\n gx%bmperr=4399; goto 1000\n endif\n endif\n! else\n! write(*,*)'Fix phase 1: ',jj,meqrec%phr(jj)%iph,meqrec%phr(jj)%ics\n endif\n enddo\n! write(*,201)' map store, stable phases: ',&\n! (meqrec%phr(meqrec%stphl(jj))%iph,&\n! meqrec%phr(meqrec%stphl(jj))%ics,jj=1,meqrec%nstph)\n201 format(a,10(2i3,2x))\n!-----------------------------------------\n600 continue\n! this copies the whole data structure !!!\n! LIKELY PLACE FOR SEGMENTATION FAULT !!!\n! write(*,*)'SMP storing equilibrium record: ',place\n! The = means copy the record, all internal structures copied\n! BUT conditions are NOT saved ... because they are a linked list.\n saveceq%savedceq(place)=mapline%lineceq\n! remove index of nexeq (free list?)\n saveceq%savedceq(place)%nexteq=0\n! MAYBE one should nullify the pointers lastcontition and lastexperinet\n! in saveceq%savedceq(place). They point to mapline%lineceq ...\n! IF I NULLIFY here I cannot plot CP which requires the conditions to be set!!\n! nullify(saveceq%savedceq(place)%lastcondition)\n! nullify(saveceq%savedceq(place)%lastexperiment)\n! I have to be careful using these conditions ....\n! The calculated results are saved in allocated arrays\n! All map examples tested OK\n!------------------------------------------------------ above added 20210707\n if(mapline%last.gt.0) then\n saveceq%savedceq(mapline%last)%nexteq=place\n endif\n mapline%last=place\n mapline%number_of_equilibria=mapline%number_of_equilibria+1\n if(mod(mapline%number_of_equilibria,20).eq.0) &\n write(kou,'(\"Equilibria calculated \",i5)')mapline%number_of_equilibria\n if(mapline%first.eq.0) mapline%first=place\n! this counter is zeroed when starting a new map/step unless old saved kept\n totalsavedceq=totalsavedceq+1\n if(totalsavedceq.gt.maxsavedceq) then\n write(kou,202)totalsavedceq\n202 format(78('*')/'SMP saved equilibria overflow ',i5,&\n ' and save on file is not implemented.'/&\n 'Use smaller increments or reinitiate before STEP or MAP'/78('*')/)\n gx%bmperr=4219\n endif\n if(saveonfile) then\n! We have to wind up all unfinished lines to continue step/map\n! but this is not yet implemented\n write(*,207)\n207 format(/' *** Buffer full and save on file not yet implemented,',&\n ' terminating step/map'/)\n gx%bmperr=4219\n endif\n1000 continue\n! nothing allocated?\n! write(*,*)'SMP exit map_store',place\n return\n end subroutine map_store\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_lineend\n!\\begin{verbatim}\n subroutine map_lineend(mapline,value,ceq)\n! terminates gracefully a line at an axis limit or an error.\n! mapline probably not needed except for testing\n! value is last calculated axis value\n! ceq is equilibrium record\n implicit none\n integer mode\n type(map_line), pointer :: mapline\n type(gtp_equilibrium_data), pointer :: ceq\n double precision value\n!\\end{verbatim}\n! type(meq_setup), pointer :: meqrec\n! this will be called when a line ends at an axis limit, nothing to do?\n if(gx%bmperr.ne.0) then\n write(kou,75)mapline%number_of_equilibria,value,gx%bmperr\n75 format('Terminating line with ',i4,' equilibria at ',1pe12.4,&\n ' due to error',i5)\n mapline%termerr=gx%bmperr\n gx%bmperr=0\n! maybe do some cleanup ??\n else\n write(kou,77)mapline%number_of_equilibria,value\n77 format('Terminating line with ',i4,' equilibria at axis limit ',1pe12.4)\n mapline%termerr=0\n endif\n! mark there is no node at the end\n nullify(mapline%end)\n1000 continue\n! This routine should clear any error code\n gx%bmperr=0\n return\n end subroutine map_lineend\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_changeaxis\n!\\begin{verbatim}\n subroutine map_changeaxis(mapline,nyax,oldax,nax,axarr,axval,bytax,ceq)\n! changes the axis with active condition to nyax\n! mapline is line record\n! nyax is index of new active axis\n! oldax is index of old active axis\n! nax is number of axis (always 2?)\n! axarr is array with axis records\n! axval the value to set as condition on new axis\n! bytax logical, if true ignore axval ?? also used to indicate change of fix ph\n! ceq is equilibrium record\n type(map_line), pointer :: mapline\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_axis), dimension(nax) :: axarr\n logical bytax\n integer nyax,nax,oldax\n double precision axval\n!\\end{verbatim} %+\n type(gtp_condition), pointer :: pcond,lastcond\n type(gtp_state_variable), pointer :: axcondrec\n integer jax,iadd,irem,ierr,mapx\n double precision value\n! turns off converge control for T\n integer, parameter :: inmap=1\n! look for the condition record for new axis\n! write(*,*)'In map_changeaxis: ',nyax,axval\n call locate_condition(axarr(nyax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!-----------\n120 continue\n! calculate the value of the inactive axis (nyax) condition. An inactive\n! condition is not updated automatically. Set prescribed value and\n! activate the condition. \n if(pcond%active.eq.0) then\n write(*,*)'In map_changeaxis, new axis condition is already acive!'\n goto 1000\n endif\n if(ocv()) write(*,*)'Axis condition: ',axarr(nyax)%axcond(1)%oldstv\n! svrrec=>pcond%statvar(1)\n axcondrec=>pcond%statvar(1)\n! axcondrec=>axarr(nyax)%axcond(1)\n127 format('Map_changeaxis: ',2i2,2x,i3,2x,4i3,2x,i5,2x,2i5)\n call state_variable_val(axcondrec,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv()) write(*,130)'New axis, current and prescribed: ',nyax,&\n value,axval,mapline%axvalx(nyax)\n130 format(a,i2,2(1pe12.4))\n! when called from bytaxis we should ignore current value ...\n if(bytax) then\n pcond%prescribed=axval\n else\n pcond%prescribed=value\n endif\n pcond%active=0\n! we must indicate if T or P are now fixed ...\n if(pcond%statev.eq.1) then\n mapline%meqrec%tpindep(1)=.FALSE.\n if(ocv()) write(*,*)'Marking that T is variable'\n elseif(pcond%statev.eq.2) then\n mapline%meqrec%tpindep(2)=.FALSE.\n endif\n!-------------------------------------------\n! this is the old axis with active condition, look for its condition\n call locate_condition(axarr(oldax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%active.ne.0) then\n if(ocv()) write(*,*)'Wow, old axis condition is still active'\n else\n! deactivate condition\n if(ocv())write(*,*)'Current value of old axis cond: ',pcond%prescribed\n pcond%active=1\n endif\n! we must indicate if T or P are not fixed ...\n if(pcond%statev.eq.1) then\n! in one case the value ceq%tpval was zero whereas the condition was positive\n! This was due to a failed calculation of a new invariant equilibrium.\n mapline%meqrec%tpindep(1)=.TRUE.\n if(ocv()) write(*,*)'Marking that T is variable',ceq%tpval(1)\n ceq%tpval(1)=pcond%prescribed\n elseif(pcond%statev.eq.2) then\n mapline%meqrec%tpindep(2)=.TRUE.\n endif\n!----------------------------------------------------------\n! now we calculate the same equilibrium but with different axis condition!\n irem=0\n iadd=0\n! add=-1 turn on verbose in meq_sameset\n! iadd=-1\n! if(bytax) then\n! write(*,*)'Calling meq_sameset in map_bytaxis:'\n! call list_conditions(kou,ceq)\n! iadd=-1\n! endif\n if(ocv()) write(*,*)'Map_changeaxis call meq_sameset, T=',ceq%tpval(1)\n! write(*,*)'SMP2A calling meq_sameset from map_changeaxis'\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,inmap,ceq)\n if(gx%bmperr.ne.0) then\n! write(*,*)'Error from meq_sameset when trying to change axis',gx%bmperr\n endif\n! ierr=gx%bmperr; gx%bmperr=0\n! write(*,*)'Error trying to change axis: ',ierr\n! call list_conditions(kou,ceq)\n! gx%bmperr=ierr\n! if(ocv()) write(*,*)'Something really wrong ...',gx%bmperr,ceq%tpval(1)\n! else\n! write(*,990)gx%bmperr,irem,iadd,ceq%tpval(1)\n!990 format(//' *** sucess *** ',3i5,1pe15.7//)\n! endif\n!\n1000 continue\n return\n end subroutine map_changeaxis\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_force_changeaxis\n!\\begin{verbatim} %-\n subroutine map_force_changeaxis(maptop,mapline,meqrec,nax,axarr,axvalok,ceq)\n! force change of axis with active condition. Works only with 2 axis.\n! (and for tie-line not in plane ??). Calls map_changeaxis ...\n! maptop is node record\n! mapline is line record\n! meqrec is equilibrium calculation record\n! nax is number of axis, also in maptop record\n! axarr is array with axis records\n! axvalok is last successfully calculated axis value\n! ceq is equilibrium record\n implicit none\n integer nax\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(meq_setup) :: meqrec\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_axis), dimension(*) :: axarr\n double precision axvalok\n!\\end{verbatim}\n double precision axfact,slope,xxx,value,axval,zzz\n integer nyax,seqz,jaxwc,oldax\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svrrec\n! copied from map_step\n if(ocv()) write(*,*)'Force change of axis with active condition: ',&\n mapline%axandir\n! We have to change the axis with active condition, assume 2 axis\n jaxwc=abs(mapline%axandir)\n nyax=3-jaxwc\n oldax=jaxwc\n if(ocv()) write(*,101)mapline%number_of_equilibria,jaxwc,&\n nyax,xxx,mapline%axvals(oldax),ceq%tpval(1)\n101 format('Bytaxis slope ',i3,2x,2i2,6(1pe12.4))\n axfact=1.0D-2\n!\n! Extract the current value of the (old) axis state variable items using pcond\n seqz=axarr(nyax)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n zzz=pcond%prescribed\n svrrec=>pcond%statvar(1)\n call state_variable_val(svrrec,axval,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! find the direction\n if(mapline%axvals(nyax)-mapline%axvalx(nyax).lt.0) then\n! set negative direction and a small step\n! write(*,*)'Force_changeaxis 1: ',mapline%axandir,-nyax\n mapline%axandir=-nyax\n! xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc\n else\n! set positive direction\n! write(*,*)'Force_changeaxis 2: ',mapline%axandir,nyax\n mapline%axandir=nyax\n! xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc\n endif\n xxx=zzz\n if(ocv()) write(*,62)'New axis direction: ',mapline%axandir,&\n mapline%axvals(nyax),mapline%axvalx(nyax)\n62 format(a,i3,2x,2(1pe14.6))\n! set new axis value as prescribed ... otherwise problems in map_changeaxis\n pcond%prescribed=xxx\n if(ocv()) write(*,63)'Call map_changeaxis',nyax,mapline%axchange,&\n mapline%number_of_equilibria,axval,zzz,xxx,ceq%tpval(1)\n63 format(a,i2,2i3,4(1pe12.4))\n! call list_conditions(kou,ceq)\n call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,.TRUE.,ceq)\n if(gx%bmperr.ne.0) then\n! seqz=gx%bmperr; gx%bmperr=0\n! write(*,*)'Error back from map_changeaxis: ',seqz\n! call list_conditions(kou,ceq)\n! gx%bmperr=seqz\n goto 1000\n endif\n! change pcond!!!\n seqz=axarr(nyax)%seqz\n call locate_condition(seqz,pcond,ceq)\n! write(*,*)'After map_change: ',nyax,pcond%seqz,pcond%statev\n jaxwc=nyax\n mapline%axchange=mapline%number_of_equilibria\n! value below is assumed to be most recently calculated value\n value=mapline%axvals(jaxwc)\n if(ocv()) write(*,16)'Axis, old and new condition: ',&\n mapline%axandir,value,xxx,ceq%tpval(1)\n16 format(a,i3,6(1pe12.4))\n! take a step in the axis variable. mapline%axandir is +/-jaxwc\n! mark axis changed\n mapline%axchange=mapline%number_of_equilibria\n if(mapline%axandir.gt.0) then\n value=value+axfact*axarr(jaxwc)%axinc\n else\n value=value-axfact*axarr(jaxwc)%axinc\n endif\n if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,&\n mapline%axandir,value,axfact*axarr(jaxwc)%axinc,ceq%tpval(1)\n202 format(a,2i3,3(1pe14.6))\n mapline%more=1\n! Make sure value is set for the active axis condition!!\n seqz=axarr(jaxwc)%seqz\n call locate_condition(seqz,pcond,ceq)\n! this call sets value as condition on the axis!\n if(ocv()) write(*,207)'Axis condition: ',jaxwc,pcond%statev,value\n207 format(a,i2,i4,1pe14.6)\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!\n1000 continue\n return\n end subroutine map_force_changeaxis\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_step\n!\\begin{verbatim}\n subroutine map_step(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq)\n! select old or new step method\n implicit none\n integer nax\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(meq_setup) :: meqrec\n type(meq_phase), dimension(*), target :: phr\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_axis), dimension(*) :: axarr\n double precision axvalok\n!\\end{verbatim}\n! User can set GSOLDMAP \n! When not tielines inplane select old map\n! if(btest(globaldata%status,GSOLDMAP) .or. maptop%tieline_inplane.lt.0) then\n if(btest(globaldata%status,GSOLDMAP)) then\n call map_step_old(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq)\n else\n call map_step2(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq)\n endif\n end subroutine map_step\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_step_old\n!\\begin{verbatim}\n subroutine map_step_old(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq)\n! This is the OLD map_step routine used until 2018.01.31\n! used also for map as mapping is stepping in one axis with fix phase condition\n! calculate the next equilibrium along a line. New phases can appear.\n! axis with active condition can change and the direction.\n! maptop is map node record\n! mapline is line record\n! phr is new array phase status (just for debugging)\n! axvalok is last successfully calculated axis value\n! nax number of axis, redundant as also in maptop record\n! axarr is array with axis records\n! ceq is equilibrium record\n implicit none\n integer nax\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(meq_setup) :: meqrec\n type(meq_phase), dimension(*), target :: phr\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_axis), dimension(*) :: axarr\n double precision axvalok\n!\\end{verbatim}\n type(gtp_condition), pointer :: pcond\n integer seqz,jaxwc,jax,cmode,cmix(10),nyax,oldax,maybecongruent\n integer istv,indices(4),iref,iunit,ip,i1,i2,i3\n double precision value,dax1(5),dax2(5),axval(5),axval2(5),axvalt(5)\n double precision laxfact,xxx,yyy,bigincfix\n double precision preval(5),curval(5),prefixval(5),curfixval(5)\n double precision, parameter :: endfact=1.0D-6\n character ch1*1,statevar*24,encoded*24 \n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n logical tnip\n!\n! write(*,*)'In map_step1: ',mapline%number_of_equilibria\n!================================================================== new step\n! tnip emergency to stop mapping outside limit for non-active axis\n tnip=.FALSE.\n laxfact=one\n maybecongruent=0\n axis: if(mapline%more.eq.0) then\n! this means the current equilibrium is the last, line is terminated\n mapline%more=-1\n goto 1000\n!================================================================== new step\n! this is for STEP with one axis\n elseif(nax.eq.1) then\n seqz=axarr(1)%seqz\n! write(*,*)'Condition index: ',seqx\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! save last sucessfully calculated value in axvalok and axarr(1)%lastaxval\n axvalok=value\n axarr(1)%lastaxval=value\n! good check point\n if(ocv()) write(*,16)'In map_step: ',mapline%number_of_equilibria,&\n mapline%axandir,value\n16 format(a,2i3,6(1pe14.6))\n if(mapline%evenvalue.ne.zero) then\n! If there is a value in mapline%evenvalue this is the first step in a new\n! region, take 3 very small steps before using that as next value on axis!\n if(mapline%number_of_equilibria.lt.3) then\n value=value+1.0D-3*(mapline%evenvalue-value)\n else\n value=mapline%evenvalue\n mapline%evenvalue=zero\n endif\n else\n! just take a step in axis variable. mapline%axandir is -1 or +1\n value=value+axarr(1)%axinc*mapline%axandir\n endif\n mapline%more=1\n if(value.le.axarr(1)%axmin) then\n value=axarr(1)%axmin\n! mapline%more=0 means this is the last calculation\n mapline%more=0\n elseif(value.ge.axarr(1)%axmax) then\n value=axarr(1)%axmax\n mapline%more=0\n endif\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! check conditions\n! call list_conditions(kou,ceq)\n! write(*,*)'New axis value: ',value,ceq%tpval(1)\n!=============================================================== new step\n! This is for MAP with 2 or more axis, both tie-line in plane and not\n else \n! at regular intervals check that phases with 2 or more composition sets have\n! not identical constitutions!!\n if(mod(mapline%number_of_equilibria,3).eq.0) then\n call separate_constitutions(ceq)\n endif\n! this is the current axis with acitive condition\n jaxwc=abs(mapline%axandir)\n bigincfix=one\n! write(*,*)'map_step: Number of fix phases: ',mapline%meqrec%nfixph\n! write(*,*)'map_step: Fix phase: ',mapline%meqrec%fixph(1,1),&\n! mapline%meqrec%fixph(2,1)\n! Here we must compare changes in all axis to determine the axis for\n! next step and how long step. Last axis values stored in mapline%axvals\n! Save previous currently in mapline%axvals in axval2\n nyax=0\n loopaxis: do jax=1,nax\n seqz=axarr(jax)%seqz\n! write(*,*)'Locating axis condition: ',seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Found axis condition'\n svrrec=>pcond%statvar(1)\n call state_variable_val(svrrec,axval(jax),ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,53)'Axis value: ',svrrec%oldstv,svrrec%argtyp,svrrec%phase,&\n! svrrec%compset,svrrec%component,axval(jax),mapline%axvals(jax)\n53 format(a,5i4,2(1pe12.4))\n if(mapline%number_of_equilibria.eq.1) then\n! for first equilibria just save the axis value\n mapline%axvals(jax)=axval(jax)\n laxfact=1.0D-2\n else\n! for later equilibria calculate the slope\n preval(jax)=mapline%axvals(jax)\n curval(jax)=axval(jax)\n dax1(jax)=(axval(jax)-mapline%axvals(jax))/axarr(jax)%axinc\n! write(*,*)'dax1: ',jax,dax1(jax)\n axval2(jax)=mapline%axvals(jax)\n mapline%axvalx(jax)=mapline%axvals(jax)\n mapline%axvals(jax)=axval(jax)\n endif\n!----------------------------- below tie-line in/not in plane separate new step\n tip1: if(maptop%tieline_inplane.gt.0) then\n! if we have tie-lines in plane we must find the value of the axis condition\n! for the fix phase or if it is a phase or component dependent state variable\n svrtarget=svrrec\n istv=svrrec%oldstv\n if(istv.ge.10) then\n! in svrrec we have the axis variable for an extensive phase variable. \n! The value in mapline%axvals is for the entered phase, extract the value\n! for the fix phase. \n! NOTE: If we change fix/entered phase we must change axvals/axvals2\n! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset\n svrtarget%argtyp=3\n svrtarget%phase=mapline%linefixph(1)%ixphase\n svrtarget%compset=mapline%linefixph(1)%compset\n endif\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(mapline%number_of_equilibria.eq.1) then\n! for first equilibria just save the axisvalue for the fix phase\n mapline%axvals2(jax)=xxx\n else\n! for later equilibria calculate the slope and check if close to limit\n dax2(jax)=(xxx-mapline%axvals2(jax))/axarr(jax)%axinc\n axvalt(jax)=mapline%axvals2(jax)\n if(jax.ne.jaxwc .and. istv.ge.10) then\n prefixval(jax)=xxx\n curfixval(jax)=mapline%axvals2(jax)\n if(abs(prefixval(jax)-curfixval(jax)).gt.&\n 0.5D0*axarr(jax)%axinc) then\n bigincfix=5.0D-1\n endif\n! for axis with inactive condition check if next step would pass min/max limit\n! If so reduce the step in the active axis but do not change active axis!!\n! xxx is last axis value, mapline%axvals2(jax) is previous\n if(mapline%number_of_equilibria-mapline%axchange.gt.3) then\n if(2*xxx-mapline%axvals2(jax).lt.axarr(jax)%axmin) then\n nyax=jax\n elseif(2*xxx-mapline%axvals2(jax).gt.axarr(jax)%axmax) then\n nyax=jax\n endif\n endif\n if(nyax.gt.0) then\n! write(*,12)'Change nyax: ',nyax,&\n! mapline%number_of_equilibria,curfixval(nyax),&\n! curval(nyax)\n12 format(a,2i3,6(1pe12.4))\n! This restriction needed to calculate two-phase regions with almost \n! verical lines (in T) and with one composition close to the axis limit\n! and the other quite far away (like U4O9-GAS in U-O system)\n! it should perhaps be refined to check that the lines are vertical ...\n if(abs(curfixval(jax)-curval(jax)).gt.&\n axarr(jax)%axinc) then\n! write(*,*)'Ignore axis chnage!! ',nyax\n nyax=0\n endif\n endif\n else\n prefixval(jax)=xxx\n curfixval(jax)=mapline%axvals2(jax)\n! This test is very sensitive and if maybecongruent is set nonzero\n! it is too much to reduce the step by 1.0D-2 below. If so the map5\n! fails at low T and I calculate too many points. I set the\n! reduction to 1.0D-1 which seems OK.\n if(istv.ge.10 .and. &\n abs(curval(jax)-curfixval(jax)).lt.&\n axarr(jax)%axinc) then\n! 0.1*axarr(jax)%axinc) then\n! if phase compositions are close decrease step!!\n! write(*,93)'Phase compositions close:',jax,&\n! mapline%number_of_equilibria,curval(jax),&\n! curfixval(jax)\n93 format(a,2i5,4(1pe12.4))\n maybecongruent=jax\n endif\n endif\n mapline%axvals2(jax)=xxx\n! check which change is the largest\n! if(ocv()) write(*,99)mapline%number_of_equilibria,jax,jaxwc,&\n write(*,99)mapline%number_of_equilibria,jax,jaxwc,&\n nyax,mapline%axvals(jax),dax1(jax),&\n mapline%axvals2(jax),dax2(jax)\n99 format('Slope: ',i3,2x,3i2,6(1pe12.4))\n endif\n if(nyax.gt.0) then\n! write(*,*)'axis change due to limits: ',nyax,jaxwc\n mapline%axchange=mapline%number_of_equilibria\n endif\n! here we can calculate the extrapolated values of both phases\n! last calculated value a\n if(istv.ge.10) then\n! write(*,32)'stp xextra: ',jax,jaxwc,nyax,mapline%axandir,&\n! curval(jax),preval(jax),curfixval(jax),prefixval(jax)\n32 format(a,3i2,i3,6(1pe12.4))\n endif\n else\n!------------------------------------------------------------\n! here we have not tie-lines in the plane, we may need to change active axis\n! and length of the step.\n! write(*,98)jax,axval(jax),mapline%axvals(jax),dax1(jax)\n98 format('Tie-line not in plane, slope: ',i3,2x,6(1pe12.4))\n! action to check if axis outside limit or slope requires axis change\n! is done at the tip2 statement below\n endif tip1\n enddo loopaxis\n!-------------------------------------------------------------\n! write(*,73)'Saved: ',(jax,mapline%axvalx(jax),&\n! mapline%axvals(jax),jax=1,nax)\n!73 format(a,2(i4,2(1pe14.6)))\n! dax1(jaxwc) is for active axis, if dax2(jaxw) is larger\n! we should decrease the step length accordingly\n value=axval(jaxwc)\n if(mapline%number_of_equilibria.eq.1) then\n! for the first step no slopes to check but take a very small step\n laxfact=1.0D-3\n else\n tip2: if(maptop%tieline_inplane.gt.0) then\n! We have tielines in plane\n! check if we should reduce axis step or change axis with active condition\n xxx=abs(dax2(jaxwc))\n if(nyax.eq.0) then\n nyax=jaxwc\n do jax=1,nax\n if(jax.ne.jaxwc) then\n! good check point\n if(ocv()) write(*,33)jax,jaxwc,nyax,0,dax2(jax),xxx\n! write(*,33)jax,jaxwc,nyax,0,dax2(jax),xxx\n if(mapline%number_of_equilibria-mapline%axchange.gt.3) then\n if(abs(dax2(jax)).gt.2*xxx) then\n! write(*,*)'Change active axis due to slope to/from: ',jax,jaxwc\n xxx=abs(dax2(jax)); nyax=jax\n endif\n endif\n endif\n enddo\n33 format('Checking slopes: ',4i2,6(1pe12.4))\n endif\n if(nyax.ne.jaxwc) then\n! We have to change the axis with active condition\n write(*,101)mapline%number_of_equilibria,jaxwc,&\n nyax,xxx,dax1(1),dax2(1),dax1(2),dax2(2)\n if(ocv()) write(*,101)mapline%number_of_equilibria,jaxwc,&\n nyax,xxx,mapline%axvals(1),dax1(1),&\n mapline%axvals2(2),dax2(2)\n101 format('Slope 3: ',i3,2x,2i2,6(1pe12.4))\n! decrease the axis step factor\n mapline%axfact=1.0D-3\n oldax=abs(mapline%axandir)\n if(dax1(nyax).lt.0) then\n! set negative direction and a small step\n mapline%axandir=-nyax\n xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc\n else\n! set positive direction and small step\n mapline%axandir=nyax\n xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc\n endif\n! write(*,*)'axandir: ',nyax,mapline%axandir,xxx\n if(ocv()) write(*,63)'Call map_changeaxis',nyax,&\n mapline%axchange,&\n mapline%number_of_equilibria,dax1(nyax),dax2(nyax),xxx\n63 format(a,i2,2i3,4(1pe12.4))\n call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,&\n .FALSE.,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! change pcond!!!\n seqz=axarr(nyax)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(ocv()) write(*,*)'After map_change: ',&\n nyax,pcond%seqz,pcond%statev\n jaxwc=nyax\n mapline%axchange=mapline%number_of_equilibria\n! value below is assumed to be most recently calculated value\n value=mapline%axvals(jaxwc)\n if(ocv()) write(*,16)'Axis, old and new condition: ',&\n mapline%axandir,value,xxx,ceq%tpval(1)\n endif\n! \n!-----------------------------------------------------------------\n elseif(maptop%tieline_inplane.lt.0) then\n! Tie-lines not in the plane\n do jax=1,nax\n if(jax.eq.jaxwc) cycle\n! check if outside axis limit of non-active condition\n if(axval(jax).le.axarr(jax)%axmin) then\n tnip=.TRUE.\n write(kou,310)'Below ',jax,axval(jax),axarr(jax)%axmin\n310 format(a,' limit',i3,2(1pe14.6),' of non-active axis')\n elseif(axval(jax).ge.axarr(jax)%axmax) then\n tnip=.TRUE.\n write(kou,310)'Above ',jax,axval(jax),axarr(jax)%axmax\n endif\n! check if bytaxis when tie-lines not in plane\n if(abs(dax1(jax)).gt.one) then\n write(*,*)'map_step_old: Change active axis: ',jax\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,&\n nax,axarr,axvalok,ceq)\n if(gx%bmperr.eq.0) goto 1000\n endif\n enddo\n endif tip2\n endif\n!----------------------------------------------------------------------\n! Here we decide the step to take in the axis variable. \n! mapline%axandir is +/-jaxwc\n! laxfact takes into account if the fix phase changes more rapidly\n! if maybecongruent is jaxwc then take small step\n i3=mapline%number_of_equilibria - mapline%axchange\n if(nax.gt.1) then\n if(i3.lt.3) then\n! take small steps when starting a line or after axis change\n laxfact=1.0D-2\n elseif(i3.lt.6) then\n laxfact=1.0D-1\n! else\n! laxfact= 0.02, 0.04, 0.08, 0.16, 0.32, 0.64, 1.0\n! laxfact=min(1.0,2.0D0*laxfact)\n endif\n! write(*,*)'stepcheck: ',nax,maybecongruent,i3\n if(maybecongruent.gt.0 .and. i3.ge.3) then\n! mapline%axfact=1.0D-2\n mapline%axfact=1.0D-1\n! write(*,*)'Decrease step due to close compositions',mapline%axfact\n endif\n endif\n axvalok=value\n! laxfact is not saved between calls\n! bigincfix 0.5 if fix phase changes more than 0.5*axinc\n bigincfix=one\n if(mapline%axandir.gt.0) then\n value=value+bigincfix*laxfact*axarr(jaxwc)%axinc*mapline%axfact\n else\n value=value-bigincfix*laxfact*axarr(jaxwc)%axinc*mapline%axfact\n endif\n! write(*,313)'laxfact: ',jaxwc,laxfact,value,&\n! axarr(jaxwc)%axinc,mapline%axfact,axvalok\n313 format(a,i3,6(1pe12.4))\n! good point for checking\n if(ocv()) write(*,65)'map_step: ',mapline%number_of_equilibria,&\n mapline%axandir,laxfact,mapline%axfact,ceq%tpval(1),axvalok,value\n65 format(a,2i3,2(1pe10.2),4(1pe14.6))\n if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,&\n mapline%axandir,value,laxfact*axarr(jaxwc)%axinc,ceq%tpval(1)\n202 format(a,2i3,3(1pe14.6))\n if(mapline%axfact.lt.one) then\n! calculation OK and no problems, make sure mapline%axfact approaches unity\n! write(*,*)'Incrementing mapline%axfact: ',mapline%axfact\n! mapline%axfact=min(one,1.2D0*mapline%axfact)\n! Trying to make axfact decrease less (like line above) makes map worse\n! mapline%axfact=min(one,2.0D0*mapline%axfact)\n! factor above works well but sometimes too big increase\n mapline%axfact=min(one,1.5D0*mapline%axfact)\n endif\n!======================================================================\n! if the new axis value exceeds the min or max limit calculate for the limit\n mapline%more=1\n if(value.le.axarr(jaxwc)%axmin) then\n value=axarr(jaxwc)%axmin\n! if a condition is an extensive variable like mole fraction avoid calculate\n! for x(a)=0 or x(a)=1\n call locate_condition(axarr(jaxwc)%seqz,pcond,ceq)\n if(pcond%statev.gt.10) then\n value=value+endfact*axarr(jaxwc)%axinc\n endif\n! mapline%more=0 means this is the last calculation ... At axis low limit\n write(kou,23)'low',value\n23 format('At axis ',a,' limit',1pe12.4)\n mapline%more=0\n elseif(value.ge.axarr(jaxwc)%axmax) then\n value=axarr(jaxwc)%axmax\n! if a condition is an extensive variable like mole fraction avoid calculate\n! for x(a)=0 or x(a)=1 ........ at axis high limit\n call locate_condition(axarr(jaxwc)%seqz,pcond,ceq)\n if(pcond%statev.gt.10) then\n value=value-endfact*axarr(jaxwc)%axinc\n endif\n write(*,23)'high',value\n mapline%more=0\n endif\n if(ocv()) write(*,205)'Axis limits: ',mapline%more,axarr(jaxwc)%axmin,&\n value,axarr(jaxwc)%axmax\n205 format(a,i2,3(1pe12.4))\n! Make sure value is set for the active axis condition!!\n seqz=axarr(jaxwc)%seqz\n call locate_condition(seqz,pcond,ceq)\n! this call sets value as condition on the axis!\n if(ocv()) write(*,207)'Axis condition: ',jaxwc,pcond%statev,value\n! write(*,207)'Axis condition: ',jaxwc,pcond%statev,value\n207 format(a,i2,i4,1pe14.6)\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif axis\n!------------------------------------------\n1000 continue\n! tnip set TRUE above if inactive axis outside limits and tie-line not in plane\n if(maptop%tieline_inplane.lt.0 .and. tnip) mapline%more=0\n! if error code set mapline%more<0\n if(gx%bmperr.ne.0) mapline%more=-1\n! if(associated(pcond)) then\n! write(*,*)'Exit map_step: ',nyax,pcond%seqz,ceq%tpval(1)\n! endif\n! To know which phase has nonzero amount\n! write(*,1001)'step_am: ',(mapline%meqrec%phr(ip)%curd%amfu,&\n! ip=1,mapline%meqrec%nphase),ceq%tpval(1)\n1001 format(a,6(1pe12.4))\n return\n end subroutine map_step_old\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_step2\n!\\begin{verbatim}\n subroutine map_step2(maptop,mapline,meqrec,phr,axvalok,nax,axarr,ceq)\n! used for map and step, mapping is to step with all but one axis replaced\n! by a fix phase condition. Map with tie-lines in plane special\n! For map check if we should change independent (active) step axis.\n! For tie-lines in plance check if we should change fix phase\n! Set condition for the next equilibrium along the axis. New phases can appear.\n! axis with active condition can change and the direction.\n! maptop is map node record\n! mapline is line record\n! phr is new array phase status (just for debugging)\n! axvalok is last successfully calculated axis value\n! nax number of axis, redundant as also in maptop record\n! axarr is array with axis records\n! ceq is equilibrium record\n implicit none\n integer nax\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n! WOW type(meq_setup) :: meqrec\n type(meq_setup) :: meqrec\n! Should maybe be type(meq_setup), pointer :: meqrec\n!\n type(meq_phase), dimension(*), target :: phr\n type(gtp_equilibrium_data), pointer :: ceq\n type(map_axis), dimension(*) :: axarr\n double precision axvalok\n!\\end{verbatim}\n type(gtp_condition), pointer :: pcond\n integer seqz,jaxwc,jax,cmode,cmix(10),nyax,oldax,maybecongruent,mapeqno\n integer istv,indices(4),iref,iunit,ip,i1,i2,i3,jxxx\n double precision value,dax1(5),dax2(5),axval(5),axval2(5)\n double precision laxfact,xxx,yyy,maxstep\n double precision preval(5),curval(5),prefixval(5),curfixval(5)\n double precision, parameter :: endfact=1.0D-6\n! trying to change step axis for mapping with tie-lines in plane\n integer fixbyte(2),twoextensiveaxis\n double precision isoent(2,2),isofix(2,2),isoe,isof,isofact\n double precision lastaxisvalue,stepfact\n character ch1*1,statevar*24,encoded*24\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n logical tnip,nyfixph,ignore,approach\n! new check for large step when tie-lines in the plane\n double precision ysave\n save maxstep,isofix,isoent,fixbyte,ignore,ysave,approach\n!\n mapeqno=mapline%number_of_equilibria\n! the dgm variables are for Al3N2 in the Al-Ni system which is not found stable\n! write(*,'(a,i4,F8.2)')'SMP2 In map_step2: ',mapeqno,ceq%tpval(1)\n! write(*,'(a,i5,3i3,5(F10.2))')'In map_step2: ',mapeqno,meqrec%nv,&\n! maptop%tieline_inplane,mapline%axandir,ceq%tpval(1),&\n! ceq%phase_varres(3)%dgm,ceq%phase_varres(4)%dgm,&\n! ceq%phase_varres(5)%dgm\n! call list_conditions(kou,ceq)\n if(mapline%more.eq.0) then\n! this means the current equilibrium is the last, line is terminated\n mapline%more=-1\n goto 1000\n endif\n! tnip emergency to stop mapping outside limit for non-active axis\n tnip=.FALSE.\n laxfact=one\n twoextensiveaxis=0\n maybecongruent=0\n! new global check for stable and metastable phases\n! if(maptop%globalcheckinterval.gt.0 .and. &\n! mod(mapeqno,maptop%globalcheckinterval).eq.0) then\n! this may set error code if equilibrium should be recalculated\n! and it may change constitutions of metastable phases\n! call check_all_phases(0,ceq)\n! if(gx%bmperr.ne.0) then\n! these errors mean a new stable phase detected, we should terminate line\n! if(gx%bmperr.eq.4364 .or. gx%bmperr.eq.4365) goto 1000\n! otherwise ignore any errors\n! gx%bmperr=0\n! endif\n! endif\n if(nax.eq.1) then\n!================================================================== new step\n! this is for STEP with one axis\n seqz=axarr(1)%seqz\n! write(*,*)'Condition index: ',seqx\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! save last sucessfully calculated value in axvalok and axarr(1)%lastaxval\n axvalok=value\n axarr(1)%lastaxval=value\n! good check point\n if(ocv()) write(*,16)'In map_step: ',mapeqno,mapline%axandir,value\n16 format(a,2i3,6(1pe14.6))\n if(mapline%evenvalue.ne.zero) then\n! If there is a value in mapline%evenvalue this is the first steps in a new\n! region, take 3 very small steps before using that as next value on axis!\n if(mapeqno.lt.3) then\n if(mapeqno.eq.1) then\n maxstep=mapline%evenvalue-value\n! write(*,*)'SMP maxstep: ',mapeqno,maxstep\n endif\n value=value+1.0D-3*(mapline%evenvalue-value)\n elseif(mapline%evenvalue.ne.zero .and. mapeqno.lt.6) then\n! take a few more small steps ...\n value=value+2.0D-1*maxstep\n else\n value=mapline%evenvalue\n mapline%evenvalue=zero\n endif\n else\n! just take a step in axis variable. mapline%axandir is -1 or +1\n value=value+axarr(1)%axinc*mapline%axandir\n endif\n! write(*,*)'Next axis value: ',value\n mapline%more=1\n if(value.le.axarr(1)%axmin) then\n value=axarr(1)%axmin\n! mapline%more=0 means this is the last calculation\n mapline%more=0\n elseif(value.ge.axarr(1)%axmax) then\n value=axarr(1)%axmax\n mapline%more=0\n endif\n call condition_value(0,pcond,value,ceq)\n goto 1000\n! if(gx%bmperr.ne.0) goto 1000\n endif\n!=============================================================== new map\n! This is for MAP with 2 or more axis, both tie-line in plane and not\n if(mod(mapeqno,3).eq.0) then\n! at regulaar intervals check that phases with 2 or more composition sets have\n! not identical constitutions!! Should fix Cr-Fe metastable extrapolation!!\n! It does not change anything for the stable phases\n call separate_constitutions(ceq)\n endif\n! this is the current axis with acitive condition\n jaxwc=abs(mapline%axandir)\n! bigincfix=one\n! write(*,*)'map_step: Number of fix phases: ',mapline%meqrec%nfixph\n! write(*,*)'map_step: Fix phase: ',mapline%meqrec%fixph(1,1),&\n! mapline%meqrec%fixph(2,1)\n! Here we must compare changes in all axis to determine the axis for\n! next step and how long step. Last axis values stored in mapline%axvals\n! Save previous currently in mapline%axvals in axval2\n nyax=0\n! isofact is to keep check of changes in fix phase when tie-lines in plane\n isofact=one\n loopaxis: do jax=1,nax\n seqz=axarr(jax)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n svrrec=>pcond%statvar(1)\n call state_variable_val(svrrec,axval(jax),ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,53)'Axis value 1: ',svrrec%oldstv,svrrec%argtyp,svrrec%phase,&\n! svrrec%compset,svrrec%component,axval(jax),mapline%axvals(jax)\n53 format(a,5i4,2(1pe12.4))\n if(mapeqno.eq.1) then\n! for first equilibria just save the axis value\n approach=.true.\n mapline%axvals(jax)=axval(jax)\n laxfact=1.0D-2\n! isoent(2,jax)=axval(jax)\n else\n! for later equilibria calculate the slope\n preval(jax)=mapline%axvals(jax)\n curval(jax)=axval(jax)\n! CHECK CHANGE OF AXIS AND FIX PHASE HERE FOR ENTERED PHASE 1 of 3\n if(ocv()) write(*,94)'New and old axis values: ',mapeqno,jax,jaxwc,&\n! write(*,94)'New and old axis values: ',mapeqno,jax,jaxwc,&\n curval(jax),preval(jax),curval(jax)-preval(jax),&\n (curval(jax)-preval(jax))/axarr(jax)%axinc\n94 format(a,i2,2x,2i2,2F10.4,2(1pe12.4))\n dax1(jax)=(axval(jax)-mapline%axvals(jax))/axarr(jax)%axinc\n axval2(jax)=mapline%axvals(jax)\n mapline%axvalx(jax)=mapline%axvals(jax)\n mapline%axvals(jax)=axval(jax)\n! isoent(1,jax)=isoent(2,jax)\n! isoent(2,jax)=axval(jax)\n endif\n!----------------------------- below tie-line in/not in plane separate new step\n tip1: if(maptop%tieline_inplane.gt.0) then\n! if we have tie-lines in plane we must find the value of the axis condition\n! for the fix phase or if it is a phase or component dependent state variable\n svrtarget=svrrec\n istv=svrrec%oldstv\n! istv>=10 means extensive condition (not potential)\n extvar: if(istv.ge.10) then\n! in svrrec we have the axis variable for an extensive phase variable. \n! The value in mapline%axvals is for the entered phase, extract the value\n! for the fix phase. \n! NOTE: If we change fix/entered phase we must change axvals/axvals2\n twoextensiveaxis=twoextensiveaxis+1\n ignore=.false.\n jxxx=jax\n svrtarget%argtyp=3\n svr2=>svrtarget\n! extract composition of entered phase\n svrtarget%phase=mapline%stableph(1)%ixphase\n svrtarget%compset=mapline%stableph(1)%compset\n! we must use a pointer in state_variable_val\n call state_variable_val(svr2,yyy,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! extract composition of fix phase\n svrtarget%phase=mapline%linefixph(1)%ixphase\n svrtarget%compset=mapline%linefixph(1)%compset\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,99)'Axis value 2: ',1,jax,jaxwc,0,xxx\n if(mapeqno.eq.1) then\n! for first equilibria just save the axisvalue for the fix phase\n mapline%axvals2(jax)=xxx\n isofix(1,jax)=zero\n isofix(2,jax)=xxx\n isoent(1,jax)=zero\n isoent(2,jax)=yyy\n fixbyte(1)=mapline%linefixph(1)%ixphase\n fixbyte(2)=mapline%linefixph(1)%compset\n else\n! for later equilibria calculate the slope and check if close to limit\n! dax2 is slope value for fix phase\n isofix(1,jax)=isofix(2,jax)\n isofix(2,jax)=xxx\n isoent(1,jax)=isoent(2,jax)\n isoent(2,jax)=yyy\n if(fixbyte(1).ne.mapline%linefixph(1)%ixphase .and.&\n fixbyte(2).ne.mapline%linefixph(1)%compset) then\n ignore=.true.\n fixbyte(1)=mapline%linefixph(1)%ixphase\n fixbyte(2)=mapline%linefixph(1)%compset\n endif\n dax2(jax)=(xxx-mapline%axvals2(jax))/axarr(jax)%axinc\n! CHECK CHANGE OF AXIS AND FIX PHASE HERE FOR FIX PHASE 2/3\n! if(ocv()) write(*,94)'Fix phase values: ',&\n! write(*,94)'Fix phase values: ',&\n! mapeqno,jax,jaxwc,&\n! xxx,mapline%axvals2(jax),xxx-mapline%axvals2(jax),&\n! (xxx-mapline%axvals2(jax))/axarr(jax)%axinc\n mapline%axvals2(jax)=xxx\n if(jax.ne.jaxwc .and. istv.ge.10) then\n prefixval(jax)=xxx\n curfixval(jax)=mapline%axvals2(jax)\n! for axis with inactive condition check if next step would pass min/max limit\n! If so reduce the step in the active axis but do not change active axis!!\n! xxx is last axis value, mapline%axvals2(jax) is previous\n if(mapeqno-mapline%axchange.gt.3) then\n if(2*xxx-mapline%axvals2(jax).lt.axarr(jax)%axmin) then\n nyax=jax\n elseif(2*xxx-mapline%axvals2(jax).gt.axarr(jax)%axmax) then\n nyax=jax\n endif\n! if(nyax.gt.0) write(*,*)'SMP: change axis 1',isofact\n endif\n! nothing happends here ...\n if(nyax.gt.0) then\n! This restriction needed to calculate two-phase regions with almost \n! verical lines (in T) and with one composition close to the axis limit\n! and the other quite far away (like U4O9-GAS in U-O system)\n! it should perhaps be refined to check that the lines are vertical ...\n if(abs(curfixval(jax)-curval(jax)).gt.&\n axarr(jax)%axinc) then\n! write(*,*)'Ignore axis change!! ',nyax\n nyax=0\n endif\n endif\n else\n prefixval(jax)=xxx\n curfixval(jax)=mapline%axvals2(jax)\n! This test is very sensitive and if maybecongruent is set nonzero\n! it is too much to reduce the step by 1.0D-2 below. If so the map5\n! fails at low T and I calculate too many points. I set the\n! reduction to 1.0D-1 which seems OK. istv>=10 means extensive variable\n if(istv.ge.10 .and. &\n abs(curval(jax)-curfixval(jax)).lt.&\n axarr(jax)%axinc) then\n! if phase compositions are close decrease step!!\n93 format(a,2i5,4(1pe12.4))\n maybecongruent=jax\n endif\n endif\n mapline%axvals2(jax)=xxx\n! check which change is the largest\n! if(ocv()) write(*,99)'Slope: ',mapeqno,jax,jaxwc,&\n! write(*,97)'Slope: ',mapeqno,jax,jaxwc,&\n! mapline%axvals(jax),dax1(jax),&\n! mapline%axvals2(jax),dax2(jax)\n!97 format(a,11x,i4,2i2,2(F10.4),2x,2(F10.4))\n! write(*,99)'Slope: ',mapeqno,jax,jaxwc,nyax,&\n! entph_dxy(1,jax),entph_dxy(2,jax),&\n! fixph_dxy(1,jax),fixph_dxy(2,jax)\n99 format(a,i3,3i2,4(F10.4),2x,2(F10.4))\n endif\n if(nyax.gt.0) then\n mapline%axchange=mapline%number_of_equilibria\n endif\n else\n! this axis is not extensive variable, same value as dax1(jax)\n dax2(jax)=dax1(jax)\n endif extvar\n! end special for tie-lines in plane\n endif tip1\n enddo loopaxis\n!-------------------------------------------------------------\n! trying to avoid too big steps when two extensive axis variables\n if(twoextensiveaxis.eq.2) then\n! UNFINISHED: this assumes both axis are compositions (fractions) !!!!!!!!!\n! what about a composition and an enthalpy axis ??\n isoe=sqrt((isoent(2,1)-isoent(1,1))**2+(isoent(2,2)-isoent(1,2))**2)\n isof=sqrt((isofix(2,1)-isofix(1,1))**2+(isofix(2,2)-isofix(1,2))**2)\n if(plottrace) write(*,888)'smp1: ',&\n mapeqno,isoent(2,1),isoent(1,1),isoent(2,2),&\n isoent(1,2),isofix(2,1),isofix(1,1),isofix(2,2),isofix(1,2)\n if(mapeqno.gt.1) then\n i3=abs(mapline%axandir)\n if(plottrace) write(*,888)'smp2: ',mapline%axandir,isoe,isof,&\n axarr(i3)%axinc\n888 format(a,i3,4F8.5,2x,4F8.5)\n! if(.not.ignore .and. isof.gt.3.0D0*isoe) then\n if(.not.ignore) then\n! isofact is set to unity above\n! THE TESTS HERE ARE QUITE CRAY BUT THEY WORK REASONABLY FOR\n! MAP-10, BEF-500Y, CRFEMO(1400K), BEF-1500 and BEF-2500\n if(isoe.gt.2.0D0*axarr(i3)%axinc) then\n! change in entered phase larger than max step\n isofact=axarr(i3)%axinc/isoe\n! elseif(isof.gt.3.0D0*axarr(i3)%axinc) then\n elseif(isof.gt.3.0D0*isoe) then\n! if(isof.gt.3.0D0*isoe) then\n! if(isof.gt.3.0D0*axarr(i3)%axinc) then\n isofact=isoe/isof\n! isofact=axarr(i3)%axinc/isof\n endif\n if(plottrace) write(*,'(a,3(1pe12.4))')'smp3: ',isoe,isof,isofact\n endif\n endif\n endif\n!-------------------------------------------------------------\n! for understanding what is happening ....\n! if(maptop%tieline_inplane.gt.0) then\n! write(*,59)'tieline: ',mapeqno,jaxwc,jxxx,nyax,&\n! mapline%stableph(1)%ixphase,mapline%linefixph(1)%ixphase,&\n! mapline%axvals(jxxx),mapline%axvals2(jxxx),&\n! mapline%axvals(3-jxxx),preval(jxxx),prefixval(jxxx)\n!59 format(a,i4,3i2,2i3,2F10.5,f10.2,2(f10.5))\n! endif\n! list last calculated tie-line\n! we should check for the step length accordingly\n value=axval(jaxwc)\n if(mapeqno.eq.1) then\n! for the first step no slopes to check but take a very small step\n laxfact=1.0D-3\n else\n tip2: if(maptop%tieline_inplane.gt.0) then\n! We have tielines in plane\n! check if we should reduce axis step or change axis with active condition\n! xxx=abs(dax2(jaxwc))\n! xxx is set to the slope for the current independent axis and fix phase\n xxx=abs(dax1(jaxwc))\n nyfixph=.false.\n! write(*,*)'Attention 1: ',mapeqno,nyax,jaxwc\n if(nyax.eq.0) then\n nyax=jaxwc\n do jax=1,nax\n if(jax.ne.jaxwc) then\n! good check point ?? YES\n! write(*,33)mapeqno,jaxwc,jax,nyax,mapline%axandir,&\n! meqrec%nv,&\n! dax2(jax),xxx,dax1(jax),ceq%tpval(1)\n33 format('Check 7: ',6i3,6(1pe12.4))\n! MISSING check for changing of fix/stable phase but keep same axis!!\n if(mapeqno.gt.3 .and. mapeqno-mapline%axchange.gt.3) then\n isotest1: if(isofact.eq.one) then\n! ignore changing axis if isofact not unity\n if(abs(dax2(jax)).gt.2*xxx) then\n! dependent axis changes more! change independent axis\n xxx=abs(dax2(jax))\n58 format(a,2i3,2(1pe12.4))\n nyfixph=.true.\n nyax=jax\n elseif(abs(dax1(jax)).gt.2*xxx) then\n xxx=abs(dax1(jax))\n nyax=jax\n endif\n endif isotest1\n endif\n else\n! if the independent axis is extensive check if we should change fix phase\n seqz=axarr(jax)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n svrrec=>pcond%statvar(1)\n! call state_variable_val(svrrec,axval(jax),ceq)\n! if(gx%bmperr.ne.0) goto 1000\n! If independent axis is an extensive variable check for fix phase change\n! This does not seem to change anything!!!\n if(svrrec%oldstv.ge.10) then\n if(mapeqno-mapline%axchange.gt.3 .and. &\n abs(dax2(jax)).gt.abs(dax1(jax))) then\n! dependent axis for fix phase changes more, change axis and fix phase!\n nyfixph=.true.\n ! write(*,101)'Change fix phase?',mapeqno,jaxwc,&\n ! nyax,mapline%linefixph(1)%ixphase,&\n ! mapline%stableph(1)%ixphase,nyfixph,&\n ! dax2(jax),dax1(jax)\n endif\n endif\n endif\n enddo\n endif\n! This is all for tie-lines in the plane!!\n! if(nyax.ne.jaxwc) write(*,*)'Attention 2: ',mapeqno,nyax,jaxwc\n! write(*,152)'Attention 2: ',mapeqno,nyax,jaxwc,.FALSE.,&\n! dax1(nyax),dax2(nyax),dax1(3-nyax),dax2(3-nyax),ceq%tpval(1)\n limits: if(nyax.eq.jaxwc .and. jaxwc.ne.jxxx .and. &\n mapeqno-mapline%axchange.gt.3 .and. .not.nyfixph) then\n! Problems in U-O system with gas and U3O8 when gas is almost pure O\n! If the entered (not fixed) phase cannot vary its composition \n! that is bad but do nothing here\n if(fixedcomposition(mapline%stableph(1)%ixphase)) then\n! write(*,*)'Continue as entered phase has fixed composition!'\n exit limits\n endif\n! check if phase compositions are close\n if(abs(mapline%axvals(jxxx)-mapline%axvals2(jxxx)).gt.&\n axarr(jxxx)%axinc) then\n! write(*,69)'Continue as phase compositions not close',&\n! mapline%axvals(jxxx),mapline%axvals2(jxxx)\n69 format(a,2F10.6)\n! They are not ... do nothing\n exit limits\n endif\n! No changes, check if we are close to the end of the extensive variable axis\n if(2*mapline%axvals(jxxx)-preval(jxxx).gt.&\n axarr(jxxx)%axmax) then\n! write(*,91)'high',jxxx,2*mapline%axvals(jxxx)-preval(jxxx)\n nyax=jxxx\n! write(*,*)'SMP nyax 4:',nyax\n91 format('At ',a,' limit, change axis to: ',i2,F10.6)\n elseif(2*mapline%axvals(jxxx)-preval(jxxx).lt.&\n axarr(jxxx)%axmin) then\n! write(*,91)'low',jxxx,2*mapline%axvals(jxxx)-preval(jxxx)\n nyax=jxxx\n! write(*,*)'SMP nyax 5:',nyax\n endif\n endif limits\n!\n! write(*,152)'Attention 3: ',mapeqno,nyax,jaxwc,nyfixph,&\n! dax1(nyax),dax2(nyax),dax1(3-nyax),dax2(3-nyax),ceq%tpval(1)\n newaxis: if(nyax.ne.jaxwc) then\n! We have to change the axis with active condition\n! write(*,101)'Slope 3: ',mapeqno,jaxwc,nyax,&\n! mapline%linefixph(1)%ixphase,&\n! mapline%stableph(1)%ixphase,nyfixph,&\n! mapline%axvals(nyax),mapline%axvals2(nyax),&\n! dax1(nyax),dax2(nyax)\n101 format(a,5i3,l2,6(1pe12.4))\n! decrease the axis step factor\n mapline%axfact=1.0D-3\n oldax=abs(mapline%axandir)\n! emergency fix: if dax1(nyax) is zero we must change fix phase!\n if(dax1(nyax).eq.zero .and. .not.nyfixph) nyfixph=.TRUE.\n! write(*,152)'SMP: change active axis: ',nyax,mapline%axandir,&\n! jaxwc,nyfixph,dax1(nyax),dax2(nyax),&\n! dax1(3-nyax),dax2(3-nyax),ceq%tpval(1)\n152 format(a,3i3,l2,5(1pe10.2))\n if(nyfixph) then\n! We must set new fix phase, take the direction from dax2\n if(dax2(nyax).lt.0) then\n! set negative direction and a small step\n mapline%axandir=-nyax\n xxx=mapline%axvals2(nyax)-1.0D-2*axarr(nyax)%axinc\n else\n! set positive direction and small step\n mapline%axandir=nyax\n xxx=mapline%axvals2(nyax)+1.0D-2*axarr(nyax)%axinc\n endif\n else\n if(dax1(nyax).lt.0) then\n! set negative direction and a small step\n mapline%axandir=-nyax\n xxx=mapline%axvals(nyax)-1.0D-2*axarr(nyax)%axinc\n else\n! set positive direction and small step\n mapline%axandir=nyax\n xxx=mapline%axvals(nyax)+1.0D-2*axarr(nyax)%axinc\n endif\n endif\n if(ocv()) write(*,63)'Call map_changeaxis',nyax,&\n mapline%axchange,&\n mapeqno,dax1(nyax),dax2(nyax),xxx\n63 format(a,i2,2i3,4(1pe12.4))\n! bytax is TRUE if axval is new axis condition\n! if(nyfixph) then\n! call list_conditions(kou,ceq)\n! endif\n if(nyfixph) then\n! This routine switches the fix and entered phases\n if(plottrace) write(*,*)'new fix phase: ',nyfixph\n call map_bytfixphase(mapline,oldax,meqrec,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n ignore=.TRUE.\n endif\n! write(*,*)'New independent axis and value: ',nyax,xxx,nyfixph\n call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,&\n nyfixph,ceq)\n! call map_changeaxis(mapline,nyax,oldax,nax,axarr,xxx,&\n! .FALSE.,ceq)\n! if(nyfixph) then\n! call list_conditions(kou,ceq)\n! write(*,*)'new fix phase ',mapline%axandir,ceq%tpval(1)\n! read(*,62)ch1\n!62 format(a)\n! endif\n if(gx%bmperr.ne.0) goto 1000\n! change pcond!!!\n seqz=axarr(nyax)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(ocv()) write(*,*)'After map_change: ',&\n nyax,pcond%seqz,pcond%statev\n jaxwc=nyax\n mapline%axchange=mapline%number_of_equilibria\n! value below is assumed to be most recently calculated value\n value=mapline%axvals(jaxwc)\n if(ocv()) write(*,16)'Axis, old and new condition: ',&\n mapline%axandir,value,xxx,ceq%tpval(1)\n endif newaxis\n! \n!-----------------------------------------------------------------\n elseif(maptop%tieline_inplane.lt.0) then\n! Tie-lines not in the plane\n do jax=1,nax\n if(jax.eq.jaxwc) cycle\n! check if outside axis limit of non-active condition\n if(axval(jax).le.axarr(jax)%axmin) then\n tnip=.TRUE.\n write(kou,310)'Below ',jax,axval(jax),axarr(jax)%axmin\n310 format(a,' limit',i3,2(1pe14.6),' of non-active axis')\n elseif(axval(jax).ge.axarr(jax)%axmax) then\n tnip=.TRUE.\n write(kou,310)'Above ',jax,axval(jax),axarr(jax)%axmax\n endif\n! check if bytaxis when tie-lines not in plane\n if(abs(dax1(jax)).gt.one) then\n! write(*,*)'map_step: Change active axis: ',jax\n call map_force_changeaxis(maptop,mapline,mapline%meqrec,&\n nax,axarr,axvalok,ceq)\n if(gx%bmperr.eq.0) goto 1000\n endif\n enddo\n! end check for tie-lines in plane\n endif tip2\n endif\n!----------------------------------------------------------------------\n! Here we decide the step to take in the axis variable. \n! mapline%axandir is +/-jaxwc\n! laxfact takes into account if the fix phase changes more rapidly\n! if maybecongruent is jaxwc then take small step\n i3=mapline%number_of_equilibria - mapline%axchange\n if(nax.gt.1) then\n if(i3.lt.3) then\n! take small steps when starting a line or after axis change\n laxfact=1.0D-2\n elseif(i3.lt.6) then\n laxfact=1.0D-1\n endif\n if(maybecongruent.gt.0 .and. i3.ge.3) then\n mapline%axfact=1.0D-1\n endif\n endif\n axvalok=value\n! laxfact is not saved between calls\n! bigincfix 0.5 if fix phase changes more than 0.5*axinc\n! bigincfix=one\n lastaxisvalue=value\n if(mapline%axandir.gt.0) then\n value=value+isofact*laxfact*axarr(jaxwc)%axinc*mapline%axfact\n else\n value=value-isofact*laxfact*axarr(jaxwc)%axinc*mapline%axfact\n endif\n! good point for checking\n if(ocv()) write(*,65)'map_step: ',mapeqno,&\n mapline%axandir,laxfact,mapline%axfact,ceq%tpval(1),axvalok,value\n65 format(a,2i3,2(1pe10.2),4(1pe14.6))\n if(ocv()) write(*,202)'In map_step new, step & T: ',jaxwc,&\n mapline%axandir,value,laxfact*axarr(jaxwc)%axinc,ceq%tpval(1)\n202 format(a,2i3,3(1pe14.6))\n if(mapline%axfact.lt.one) then\n! calculation OK and no problems, make sure mapline%axfact approaches unity\n! write(*,*)'Incrementing mapline%axfact: ',mapline%axfact\n! mapline%axfact=min(one,1.2D0*mapline%axfact)\n! Trying to make axfact decrease less (like line above) makes map worse\n mapline%axfact=min(one,2.0D0*mapline%axfact)\n endif\n!======================================================================\n! if the new axis value exceeds the min or max limit calculate for the limit\n mapline%more=1\n if(value.le.axarr(jaxwc)%axmin) then\n value=axarr(jaxwc)%axmin\n! if a condition is an extensive variable like mole fraction avoid calculate\n! for x(a)=0 or x(a)=1\n call locate_condition(axarr(jaxwc)%seqz,pcond,ceq)\n if(pcond%statev.gt.10) then\n value=value+endfact*axarr(jaxwc)%axinc\n endif\n! mapline%more=0 means this is the last calculation\n write(kou,23)'low',value\n23 format('At axis ',a,' limit',1pe12.4)\n mapline%more=0\n elseif(value.ge.axarr(jaxwc)%axmax) then\n value=axarr(jaxwc)%axmax\n! if a condition is an extensive variable like mole fraction avoid calculate\n! for x(a)=0 or x(a)=1\n call locate_condition(axarr(jaxwc)%seqz,pcond,ceq)\n if(pcond%statev.gt.10) then\n value=value-endfact*axarr(jaxwc)%axinc\n endif\n write(*,23)'high',value\n mapline%more=0\n endif\n!....... special for axis limits of isothermal sections DOES NOT WORK\n! check if we are close to an axis limit for isothermal sections\n if(mapeqno.gt.2 .and. twoextensiveaxis.eq.2) then\n! The fraction of the third component of entered phase (where we step):\n call locate_condition(axarr(jaxwc)%seqz,pcond,ceq)\n if(pcond%statev.gt.10) then\n xxx=pcond%prescribed\n endif\n yyy=one-isoent(2,jaxwc)-isoent(2,3-jaxwc)\n if(yyy.le.0.5D0*axarr(jaxwc)%axinc) then\n! changing the axis variable will make third fraction negative \n! we should decrease value ...\n! write(*,'(a,i3,F9.5,7F8.5)')'At boundary? ',mapeqno,yyy,&\n! isoent(2,jaxwc),isoent(2,3-jaxwc),&\n! isofix(2,jaxwc),isofix(2,3-jaxwc),xxx,value,value-xxx\n if(approach) then\n! I am not sure this is useful .... approach never used ....\n write(*,*)'SMP2A approaching limit of third component'\n approach=.false.\n endif\n! ysave is never initiated ....\n! if(yyy.gt.zero) then\n! if(yyy.lt.ysave) then\n! value=xxx+0.9D0*yyy\n! endif\n! ysave=yyy\n! else\n! yyy is negative\n! write(*,*)'SMP2A impossible!',yyy\n! endif\n endif\n endif\n!......\n if(ocv()) write(*,205)'Axis limits: ',mapline%more,axarr(jaxwc)%axmin,&\n value,axarr(jaxwc)%axmax\n205 format(a,i2,3(1pe12.4))\n! Make sure value is set for the active axis condition!!\n seqz=axarr(jaxwc)%seqz\n call locate_condition(seqz,pcond,ceq)\n! CHECK CHANGE OF AXIS AND FIX PHASE HERE 3/3\n if(ocv()) write(*,207)'New axis condition: ',jaxwc,pcond%statev,value,&\n value-lastaxisvalue\n207 format(a,i2,i4,2(1pe14.6))\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!------------------------------------------\n1000 continue\n! tnip set TRUE above if inactive axis outside limits and tie-line not in plane\n if(maptop%tieline_inplane.lt.0 .and. tnip) mapline%more=0\n! if error code set mapline%more<0\n if(gx%bmperr.ne.0) mapline%more=-1\n! if(associated(pcond)) then\n! write(*,*)'Exit map_step: ',nyax,pcond%seqz,ceq%tpval(1)\n! endif\n! To know which phase has nonzero amount\n! write(*,1001)'step_am: ',(mapline%meqrec%phr(ip)%curd%amfu,&\n! ip=1,mapline%meqrec%nphase),ceq%tpval(1)\n1001 format(a,6(1pe12.4))\n! write(*,*)'Leaving map_step2 '\n return\n! axis limit\n end subroutine map_step2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_bytfixphase\n!\\begin{verbatim}\n subroutine map_bytfixphase(mapline,axis,meqrec,xxx,ceq)\n! Try to change the fix phase for axis\n! the new axis value is in xxx (not needed??)\n! mapline is map line record\n! ceq is equilibrium record\n implicit none\n type(map_line), pointer :: mapline\n integer axis\n type(meq_setup) :: meqrec\n double precision xxx\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n! REMEMBER: %stableph(..) and %linefixph are arrays of phase tuples !!!\n! 5 integers: lokph,compset,ixphase,lokvares,nextcs, only ixphase/compset set\n! we need meqrec!!!\n type(gtp_phasetuple) :: phtup1\n integer lokcs,phrix\n double precision x1,x2\n! just as check\n x1=mapline%stablepham(1)\n! write(*,33)'Phase change 1:',meqrec%fixph(1,1),meqrec%fixph(2,1),&\n! meqrec%iphl(1),meqrec%icsl(1),meqrec%iphl(2),meqrec%icsl(2),&\n! meqrec%aphl(1),meqrec%aphl(2),xxx\n33 format(a,3(i3,i2,2x),3F8.3)\n! we must change in meqrec also!! This is for tie-lines in plane,\n! one fix phase, one stable phase\n phtup1=mapline%linefixph(1)\n phrix=mapline%linefix_phr(1)\n mapline%linefixph(1)=mapline%stableph(1)\n mapline%linefix_phr(1)=mapline%stable_phr(1)\n if(meqrec%nfixph.ne.1) then\n write(*,*)'MAP wants to change ONE fix phase: ',meqrec%nfixph\n gx%bmperr=4399; goto 1000\n endif\n meqrec%fixph(1,1)=mapline%linefixph(1)%ixphase\n meqrec%fixph(2,1)=mapline%linefixph(1)%compset\n meqrec%fixpham(1)=zero\n meqrec%iphl(1)=mapline%linefixph(1)%ixphase\n meqrec%icsl(1)=mapline%linefixph(1)%compset\n!------------- now the stable phase ?? value of stable_phr=??\n mapline%stableph(1)=phtup1\n mapline%stable_phr(1)=phrix\n! write(*,*)'SMP2A phrix switching fix/stable phase: ',phrix\n! nstabph is part of mapfix record ... saved in meqrec%nv\n! we are not changing the number of fix or stable phases ...\n if(meqrec%nv.ne.2) then\n write(*,*)'MAP wants to change ONE stable phase: ',meqrec%nv\n gx%bmperr=4399; goto 1000\n endif\n meqrec%iphl(2)=phtup1%ixphase\n meqrec%icsl(2)=phtup1%compset\n meqrec%aphl(2)=x1\n! we have changed the stable phase, set a positive amount\n mapline%stablepham(1)=x1\n! write(*,33)'Phase change 2:',meqrec%fixph(1,1),meqrec%fixph(2,1),&\n! meqrec%iphl(1),meqrec%icsl(1),meqrec%iphl(2),meqrec%icsl(2),&\n! meqrec%aphl(1),meqrec%aphl(2),xxx\n1000 continue\n return\n end subroutine map_bytfixphase\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_calcnode\n!\\begin{verbatim}\n subroutine map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq)\n! we have found a change in the set of stable phases. check if this node\n! already been found and if so eliminate a line record. Otherwise \n! create a new node record with line records and continue mapping one\n! of these.\n! irem and iadd are indices (in phr?) of phase that will disappear/appear\n! maptop is map node record\n! mapline is map line record\n! meqrec is equilibrium calculation record, ! Note changes in meqrec is local,\n! not copied to mapline%meqrec!!!\n! axarr is array with axis records\n! ceq is equilibrium record\n implicit none\n integer irem,iadd\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(meq_setup) :: meqrec\n type(map_axis), dimension(*) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_condition), pointer :: lastcond,pcond\n integer iremsave,iaddsave,iph,ics,jj,jph,kph,phfix,seqx,jax,haha\n integer what,type,cmix(10),maxstph,noplot,mode,addtupleindex,mapx,sameadd\n double precision, parameter :: addedphase_amount=1.0D-2\n double precision value,axval,axvalsave,tx,nodefixpham\n type(gtp_state_variable), pointer :: svrrec\n logical global\n double precision, allocatable, dimension(:) :: yfra\n type(gtp_equilibrium_data), target :: tceq\n type(gtp_equilibrium_data), pointer :: pceq\n character phname*32\n! turns off converge control for T\n integer, parameter :: inmap=1\n!\n! write(*,*)'In map_calcnode phase change add/remove: ',iadd,irem\n! we have already called same_composition(iadd...)\n iremsave=irem\n iaddsave=iadd\n if(irem.gt.0) then\n if(iadd.gt.0) then\n write(*,*)'Confusion, both add and remove phases?'\n! check if phase to be added is already stable\n if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then\n iadd=0\n phfix=-irem\n else\n! go back and calculate with half the step ... \n gx%bmperr=4220; goto 1000\n endif\n else\n phfix=-irem\n iadd=irem\n endif\n else\n phfix=iadd\n endif\n!--------------------------------------------\n! remove here the axis condition, abs(mapline%axandir) gives active axis\n! axandir is the axis with active condition. It can be negative\n jax=abs(mapline%axandir)\n! write(*,*)'Remove axis condition: ',jax,axarr(jax)%seqz\n lastcond=>ceq%lastcondition\n if(.not.associated(lastcond)) then\n write(*,*)'in map_calcnode, no conditions: ',jax\n gx%bmperr=4221; goto 1000\n endif\n pcond=>lastcond\n60 continue\n pcond=>pcond%next\n if(pcond%seqz.eq.axarr(jax)%seqz) goto 70\n if(.not.associated(pcond,lastcond)) goto 60\n write(*,*)'in map_calcnode the axis condition not found: ',jax\n gx%bmperr=4221; goto 1000\n!\n70 continue\n! this removes the condition, remember pcond as condition will be set again!!\n pcond%active=1\n axval=pcond%prescribed\n if(ocv()) write(*,77)pcond%seqz,pcond%prescribed,ceq%tpval(1),axval\n77 format('Removing condition: ',i3,6(1pe12.4))\n! if the condition is T or P this must be indicated specially\n! if a potential condition released we can have one more stable phse\n maxstph=0\n if(pcond%statev.eq.1) then\n meqrec%tpindep(1)=.TRUE.\n if(ocv()) write(*,*)'Marking that T is variable'\n maxstph=1\n elseif(pcond%statev.eq.2) then\n meqrec%tpindep(2)=.TRUE.\n maxstph=1\n endif\n!--------------------------------------------\n! independently if iadd or irem >0 set this phase, phfix, fix with zero amount\n! we may return here if there is problems calculate the node equilibrium\n100 continue\n! set phfix fix with amount nodefixpham\n nodefixpham=zero\n! NOTE it must be added so meqrec%stphl in ascending order\n if(phfix.gt.0 .and. meqrec%nstph.eq.meqrec%maxsph+maxstph) then\n! No more phases allowed, we must see if some other phase may be removed\n! write(*,*)'Too many stable phases at nodepoint',meqrec%maxsph\n! set back pcond as active, this saved top of miscibility gap in Cr-Mo !!!\n pcond%active=0\n! if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then\n! iadd=0; goto 201\n! endif\n! write(*,'(a,10i5)')'SMP node with too many stable phases: ',&\n! iremsave,iaddsave,phfix,meqrec%nstph,maxstph\n gx%bmperr=4223; goto 1000\n else\n if(ocv()) write(*,*)'Number of stable phases at nodepoint',&\n meqrec%nstph,maxstph\n endif\n if(phfix.gt.0) then\n! the phase must be added in sequential order of phase and composition set no\n findplace: do jph=1,meqrec%nstph\n jj=meqrec%stphl(jph)\n if(meqrec%phr(phfix)%iph.gt.meqrec%phr(jj)%iph) then\n cycle\n endif\n if(meqrec%phr(phfix)%iph.lt.meqrec%phr(jj)%iph) then\n exit\n endif\n! if same phase number compare composition set numbers\n if(meqrec%phr(phfix)%iph.eq.meqrec%phr(jj)%iph) then\n if(meqrec%phr(phfix)%ics.gt.meqrec%phr(jj)%ics) then\n cycle\n else\n exit\n endif\n endif\n enddo findplace\n! one should come here at exit, iadd should be inserted before \n! meqrec%stphl(jph), jph can be nstph+1 if added phase should be the last\n! otherwise shift previous phases one step up.\n do kph=meqrec%nstph,jph,-1\n meqrec%stphl(kph+1)=meqrec%stphl(kph)\n enddo\n! phase added at jph, (note jph may be equal to nstph+1)\n meqrec%stphl(jph)=phfix\n meqrec%nstph=meqrec%nstph+1\n meqrec%phr(phfix)%itadd=meqrec%noofits\n meqrec%phr(phfix)%curd%dgm=zero\n meqrec%phr(phfix)%curd%amfu=nodefixpham\n meqrec%phr(phfix)%stable=1\n! set that the phase has fixed amount\n meqrec%phr(phfix)%phasestatus=PHFIXED\n else\n! we are removing a phase, abs(phfix) already in meqrec%phr\n! meqrec%stphl(jph)=phfix\n! meqrec%nstph=meqrec%nstph+1\n! write(*,*)'Removing a phase: ',phfix\n if(phfix.ge.0) then\n gx%bmperr=4234\n goto 1000\n endif\n meqrec%phr(-phfix)%itadd=meqrec%noofits\n meqrec%phr(-phfix)%curd%dgm=zero\n meqrec%phr(-phfix)%curd%amfu=nodefixpham\n meqrec%phr(-phfix)%stable=1\n! set that the phase has fixed amount\n meqrec%phr(-phfix)%phasestatus=PHFIXED \n endif\n!--------------\n! mark that the phase is fix, we have to be careful not to exceed size\n! Sigh, the fixed phases must be in sequential order ??? ... not done here\n! ... maybe not needed ??\n! write(*,*)'added fix phase: ',phfix\n meqrec%nfixph=meqrec%nfixph+1\n if(meqrec%nfixph.gt.size(meqrec%fixpham)) then\n write(*,*)'Too many phases set fixed during mapping',&\n meqrec%nfixph,size(meqrec%fixpham)\n gx%bmperr=4235; goto 1000\n endif\n! meqrec%nfixph is used to reduce the number of variables in the system\n! matrix. Fix phases have no variable amount.\n meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(abs(phfix))%iph\n meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(abs(phfix))%ics\n meqrec%fixpham(meqrec%nfixph)=zero\n! write(*,*)'Set fixed phase: ',meqrec%nfixph,&\n! meqrec%phr(abs(phfix))%iph,meqrec%phr(abs(phfix))%ics,PHFIXED\n! I am not sure what this make but error allocating svar inside meq_sameset\n! meqrec%nv=meqrec%nv+1\n!---------------------------------------------------\n! call meq_sameset with new set of phases and axis condition removed\n! If there is a phase change (iadd or irem nonzero) or error it exits \n sameadd=0\n200 continue\n iadd=0; irem=0\n! write(*,'(a,3i5)')'In map_calcnode calling sameset for new node: ',&\n! meqrec%nstph,phfix\n!\n! write(*,*)'SMP2A Calling meq_sameset from map_calcnode'\n call meq_sameset(irem,iadd,mapx,meqrec,meqrec%phr,inmap,ceq)\n!\n! write(*,202)'Calculated node with fix phase: ',gx%bmperr,irem,iadd,ceq%tpval\n202 format(a,3i4,2(1pe12.4))\n201 continue\n!-------------------------------------------------\n! trouble if error or another phase wants to be stable/dissapear\n! We may have to calculate with the axis fix again, maybe even read up\n! the previous calculated equilibrium\n if(gx%bmperr.ne.0) then\n write(*,*)'Error trying to calculate a node point',gx%bmperr\n! Below is code to reset the fix phase to continue map/step unless error 4187\n if(gx%bmperr.eq.4187) goto 1000\n elseif(irem.gt.0) then\n write(*,207)gx%bmperr,irem\n207 format('Failed calculating a node when another phase',&\n ' wants to disappear',2i5)\n gx%bmperr=4222\n elseif(iadd.gt.0) then\n! another phase wants to be stable\n! write(*,*)'SMPNODE: Another phase wants to be stable ',iadd,sameadd,phfix\n if(same_composition(iadd,meqrec%phr,meqrec,ceq,zero)) then\n iadd=0; goto 201\n endif\n! write(*,'(a,3i5,F10.2)')'Error: new phase stable: ',&\n! iremsave,iaddsave,iadd,ceq%tpval(1)\n gx%bmperr=4223\n else\n! It worked to calculate with a new fix phase releasing all axis condition!!!\n! *************************************************************\n! check that the node point is global using grid minimizer\n! ceq is copied inside global_equil_check and not destroyed??.\n! mode=0 means do not recalculate if gridpoint below is found\n mode=0\n! write(*,*)'NOT Calling global check'\n! global=.TRUE.\n! write(*,*)'Check if nodepoint global'\n! make a copy of the whole equilibrium record and set a pointer to the copy\n! Does this really make a copy of the conditions etc inside ceq?\n! tceq=ceq\n! pceq=>tceq\n! write(*,*)'SMP value of T: ',pceq%tpval(1)\n! SEGMENTATION FAULT and other strange errors after this call\n! very difficult to find ... puhhhhh\n! --- BUT THERE is still a segmentation fault\n! global=global_equil_check1(mode,addtupleindex,yfra,pceq)\n global=global_equil_check1(mode,addtupleindex,yfra,ceq)\n if(.not.global) then\n write(*,*)'gridminimizer found node point not global'\n! set this line as INACTIVE and do not generate any start points\n mapline%status=ibset(mapline%status,EXCLUDEDLINE)\n gx%bmperr=4353\n goto 1000\n endif\n! *************************************************************\n goto 500\n endif\n! Problems, the simplest is to go back and try a smaller step\n! But we must first remove the fix phase and restore the axis condition\n! write(*,54)'Error calculating node point? ',gx%bmperr,mapline%lasterr,&\n! irem,iadd,phfix,pcond%statev,mapline%problems,axval\n54 format(a,2i5,5i3,1pe12.4)\n! if(maptop%tieline_inplane.gt.0) then\n! if <0 isopleth, 0 step, >0 tie-lines in plane\n! write(*,*)'Tie-lines in plane:'\n! if T axis maybe change to extensive axis ...\n! endif\n if(ocv()) write(*,*)'Error calculating node point, take shorter step'\n pcond%active=0\n pcond%prescribed=axval\n if(pcond%statev.eq.1) then\n meqrec%tpindep(1)=.FALSE.\n if(ocv()) write(*,55)'Marking that T is a condition again',&\n axval,ceq%tpval(1)\n55 format(a,6(1pe14.6))\n elseif(pcond%statev.eq.2) then\n meqrec%tpindep(2)=.FALSE.\n! ceq%tpval(2)=value\n endif\n! write(*,*)'error in map_calcnode, remove phfix: ',phfix\n if(phfix.gt.0) then\n! we must remove phfix from the list of stable phases and shift down\n meqrec%nstph=meqrec%nstph-1\n do iph=1,meqrec%nstph\n jj=meqrec%stphl(iph)\n if(jj.ge.phfix) then\n meqrec%stphl(iph)=meqrec%stphl(iph+1)\n endif\n enddo\n! we must zero the last stable phase !!\n meqrec%stphl(meqrec%nstph+1)=0\n meqrec%phr(phfix)%itrem=meqrec%noofits\n meqrec%phr(phfix)%prevam=zero\n meqrec%phr(phfix)%stable=0\n meqrec%phr(phfix)%curd%amfu=zero\n! we do not need to do anyting if -phfix should have been removed, then it\n! is should remain among the stable phases, just remove it as fixed\n endif\n meqrec%fixph(1,meqrec%nfixph)=meqrec%phr(abs(phfix))%iph\n meqrec%fixph(2,meqrec%nfixph)=meqrec%phr(abs(phfix))%ics\n meqrec%nfixph=meqrec%nfixph-1\n mapline%lasterr=gx%bmperr\n! write(*,*)'SMP lasterr: ',mapline%lasterr,&\n! gx%bmperr,phfix,meqrec%phr(phfix)%phasestatus\n! I had forgotten this!!\n meqrec%phr(abs(phfix))%phasestatus=0\n! exit as no node found\n goto 1000\n!------------------------------------------------------\n! When we are there we have successfully calculated an equilibrium with a\n! new phase set create a node with this equilibrium and a new line records\n500 continue\n! write(*,*)'SMP2 Successful calculation of a node point',phfix\n! phfix is set negative if phase should be removed\n! NOTE the phase set fix in the node may not be the same which\n! wanted to disappear/appear when calling the map_calcnode!!\n! If iremsave=phfix the fix phase is one to be removed.\n! write(*,*)'SM2A node with new fix phase: ',phfix,iremsave,iaddsave\n! I do not understand the next IF statement/BoS 200222\n if(iremsave.eq.-phfix) then\n! write(*,*)'In SMP2A with strange assignment ...',iremsave,-phfix\n phfix=-abs(phfix)\n endif\n! if the user wants to have global minimization during mapping this is\n! time to test if the current equilibrium is the global one. We can use\n! a temporary ceq record and chech the set of phases and chemical potentials\n!\n! NOTE that after a global equilibrium new composition set can have been\n! created ... that should not be allowed unless they are really stable ...\n! and one may have the same phases but different composition sets ... it\n! can be quite messy.\n! We have to set back the axis condition, before or after creating the node?\n! and the new value ...\n if(pcond%noofterms.gt.1) then\n write(*,*)'Cannot handle conditions with several terms'\n gx%bmperr=4236; goto 1000\n endif\n! this sets the condition as active\n pcond%active=0\n svrrec=>pcond%statvar(1)\n call state_variable_val(svrrec,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv()) write(*,510)'Checking condition value; ',lastcond%seqz,&\n value,pcond%prescribed,ceq%tpval(1)\n510 format(a,i3,6(1pe12.4))\n! set the new condition value on the axis\n pcond%prescribed=value\n if(pcond%statev.eq.1) then\n meqrec%tpindep(1)=.FALSE.\n ceq%tpval(1)=value\n if(ocv()) write(*,*)'Marking that T is a condition again',value\n elseif(pcond%statev.eq.2) then\n meqrec%tpindep(2)=.FALSE.\n ceq%tpval(2)=value\n endif\n! Save this as the last equilibrium of the line\n if(maptop%tieline_inplane.gt.0) then\n! remove phfix as fix, otherwise graphics will be strange!\n517 format(a,2i3,5x,5(2i3))\n! remove phfix as fix\n if(phfix.lt.0) then\n write(*,*)'SM2A negative phfix used as index?',phfix\n endif\n mapline%meqrec%phr(phfix)%curd%phstate=PHENTERED\n! this is necessary not to have data from this phase interfering with the line\n if(ocv()) write(*,519)phfix,mapline%meqrec%phr(phfix)%iph,&\n mapline%meqrec%phr(phfix)%ics,phentunst\n519 format('Removing ',i3,2x,2i3,' as stable as last line equil',i3)\n!?????????????????????????????????????????\n mapline%meqrec%nstph=mapline%meqrec%nstph-1\n endif\n! write(*,*)'Storing last point on line',phfix,maptop%tieline_inplane\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n! if(gx%bmperr.eq.4300) write(*,*)'Node point ignored'\n goto 1000\n endif\n! If we have an error here it may be that the node axis has big jumps\n! Do not save any node\n! here we have stored the last equilibrium that lead to th enode\n! now update all condition records related to axis\n!--------------------\n! now store all axis values as prescribed vaules in the condition records\n! A rather clumsy way and cannot handle expressions ...\n lastcond=>ceq%lastcondition\n pcond=>lastcond\n600 continue \n pcond=>pcond%next\n do jax=1,maptop%number_ofaxis\n if(pcond%seqz.eq.axarr(jax)%seqz) then\n! write(*,*)'At node set axis ',jax,axarr(jax)%lastaxval\n pcond%prescribed=axarr(jax)%lastaxval\n endif\n enddo\n if(.not.associated(pcond,lastcond)) goto 600\n!-------------------\n if(maptop%tieline_inplane.gt.0) then\n! Now set phfix back again for storing at the node record!!\n iph=1\n do jj=mapline%meqrec%nstph,1,-1\n if(mapline%meqrec%stphl(jj).gt.phfix) then\n mapline%meqrec%stphl(jj+1)=mapline%meqrec%stphl(jj)\n else\n iph=jj+1; exit\n endif\n enddo\n mapline%meqrec%stphl(iph)=phfix\n mapline%meqrec%phr(meqrec%stphl(iph))%curd%phstate=PHENTSTAB\n mapline%meqrec%nstph=mapline%meqrec%nstph+1\n if(ocv())write(*,517)'In map_calcnode: ',phfix,meqrec%nstph,&\n (meqrec%phr(meqrec%stphl(jj))%iph,meqrec%phr(meqrec%stphl(jj))%ics,&\n jj=1,meqrec%nstph)\n! meqrec%phr(meqrec%stphl(jj))%phstate,jj=1,meqrec%nstph)\n518 format(a,2i3,5x,5(2i3,i2,2x))\n endif\n!--------------------------------------------------------\n!\n if(mapline%evenvalue.ne.zero) then\n! if we have taken halfsteps then use the original even step\n if(ocv()) write(*,*)'Using original even step: ',mapline%evenvalue\n axval=mapline%evenvalue\n endif\n!\n! Finally create the new node and with new exit lines\n haha=0\n if(maptop%tieline_inplane.lt.0) then\n! test if invariant ...\n if(inveq(haha,ceq)) then\n! haha is set to number of stable phases at invariant.\n! the number of lines ending at an invariant isopleth is 2*haha\n! current number of stable phases is meqrec%nstph. \n! sign(1,phfix) is 1 if phfix>0; -1 if phfix<0\n! write(*,21)meqrec%nstph,haha,phfix,meqrec%nstph-haha+sign(1,phfix)\n21 format('SMP2A stable phases mm: ',3i5,i10)\n endif\n endif\n! write(*,*)'SMP2A Test for invariant equilibrium: ',haha\n call get_phase_name(meqrec%phr(abs(phfix))%iph,meqrec%phr(abs(phfix))%ics,&\n phname)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2A illegal phase name: ',phfix\n goto 1000\n endif\n if(phfix.gt.0) then\n write(*,501)ceq%tpval(1),trim(phname)\n501 format('Creating a node at ',F10.2,' where ',a,' appears')\n else\n write(*,502)ceq%tpval(1),trim(phname)\n502 format('Creating a node at ',F10.2,' where ',a,' disappear')\n endif\n! write(*,*)'calling map_newnode: ',mapline%meqrec%nfixph,meqrec%nfixph,haha\n! if(haha.gt.1) &\n! write(*,*)'SMP2A invariant!! we should greate several exits ',haha\n! inside map_newnode the approriate number of exits will be generated\n call map_newnode(mapline,meqrec,maptop,axval,jax,axarr,phfix,haha,ceq)\n if(gx%bmperr.ne.0) then\n!lookingforbug\n! write(*,*)'Error return from map_newnode: ',gx%bmperr\n if(ocv()) write(*,*)'Error return from map_newnode: ',gx%bmperr\n endif\n! write(*,*)'Back from map_newnode',phfix\n! all done??\n1000 continue\n return\n end subroutine map_calcnode\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_newnode\n!\\begin{verbatim}\n subroutine map_newnode(mapline,meqrec1,maptop,axval,lastax,axarr,&\n phfix,haha,ceq)\n! must be partially THREADPROTECTED\n! first check if a node with this equilibrium already exists\n! if not add a new node with appropriate lineheads and arrange all links\n! Take care if tie-lines in the plane all lines do not have to be calculated\n! NOTE: meqrec1 not the same as mapline%meqrec !! ??\n! mapline is line record for current line\n! meqrec1 has information about last calculated equilibrium\n! maptop is node record\n! axval is the axis value attemped to calculate when phase set wanted to change\n! lastax is index of last active axis\n! axarr are axis records\n! phfix is phase which is set fix at node point\n! haha is larger than 1 if the calculated equilibrium is invariant\n! ceq is equilibrium record\n implicit none\n type(map_node), pointer :: maptop\n type(meq_setup) :: meqrec1\n type(map_line), pointer :: mapline,nodexit\n type(map_axis), dimension(*) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n integer phfix,lastax,haha\n double precision axval\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: newceq,tmpceq\n type(map_node), pointer :: mapnode,newnode\n type(map_line), pointer :: linenode,tmpline\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec2\n type(gtp_state_variable), target :: svrtarget\n integer remph,addph,nel,iph,ics,jj,seqx,nrel,jphr,stabph,kph,kcs,kk,lfix\n integer zph,stepax,kpos,seqy,jp,nopotax,lokcs,lokph,haha2,linefphr\n! there should be 8 significant digits, first step factor\n! double precision, parameter :: vz=1.0D-9,axinc1=1.0D-3\n double precision, parameter :: vz=1.0D-8,axinc1=1.0D-3\n character eqname*24,phases*60\n double precision stepaxval,middle,testv,xxx\n! mark that line ended with two stoichometric phases and data for isopleth inv\n integer twostoichset,errall,jfix,jstab,jlast,kstab,zp,phrix,infix3,nexit\n integer onlyone,notone,jused,zz,tz,qy,savefix1,savefix2,nodein(2),nodeut(2)\n! lifexix, nodefix and prevfix are used to fix pair of phases that have zero\n! amount at the exit points of lines from an invariant equilibrium.\n integer linefix,nodefix,infix,infix2,doubline,twice,firstoutfix,outfix,qq\n integer, allocatable, dimension(:,:) :: invph,nodeout\n! double precision, allocatable, dimension(:) :: exitcomp,eqcopy\n logical stepinvariantnode\n!\n lfix=0\n! the phase kept fix with zero amount at the node is phfix It can be\n! negative at STEP if it is a phase that will dissapear.\n if(ocv()) write(*,87)'We are in map_newnode with a fix phase: ',&\n phfix,ceq%tpval(1)\n87 format(a,i4,2x,1pe12.4)\n! write(*,*)'We have access to phr: ',meqrec1%phr(abs(phfix))%iph,&\n! meqrec1%phr(abs(phfix))%ics\n! mapnode should be set to point at maptop\n twostoichset=0\n if(btest(mapline%status,TWOSTOICH)) then\n twostoichset=1\n write(*,'(a)')'SMP line ended with two stochiometric allotropes stable'\n endif\n mapnode=>maptop\n nrel=meqrec1%nrel\n100 continue\n!---------------------------------------------------------------------\n! loop all mapnodes to check if any has the same chemical potentials\n!---------------------------------------------------------------------\n! write(*,*)'Comparing with node: ',mapnode%seqx,nrel\n! write(*,105)'T diff: ',ceq%tpval(1),mapnode%tpval(1),&\n! abs(ceq%tpval(1)-mapnode%tpval(1)),abs(vz*mapnode%tpval(1))\n! write(*,105)'P diff: ',ceq%tpval(2),mapnode%tpval(2),&\n! abs(ceq%tpval(2)-mapnode%tpval(2)),abs(vz*mapnode%tpval(2))\n if(abs(ceq%tpval(1)-mapnode%tpval(1)).gt.abs(vz*mapnode%tpval(1)) .or.&\n abs(ceq%tpval(2)-mapnode%tpval(2)).gt.abs(vz*mapnode%tpval(2))) then\n! write(*,*)'Not same, compare with next'\n goto 110\n endif\n do nel=1,nrel\n! write(*,105)'Chempot: ',ceq%cmuval(nel),mapnode%chempots(nel),&\n! abs(ceq%cmuval(nel)-mapnode%chempots(nel)),&\n! abs(vz*mapnode%chempots(nel))\n105 format(a,5(1pe16.8))\n if(abs(ceq%cmuval(nel)-mapnode%chempots(nel)).gt.&\n abs(2.0D1*vz*mapnode%chempots(nel))) then\n! write(*,'(a,3(1pe12.4))')'SMP not same chempots, at this node',&\n! abs(ceq%cmuval(nel)-mapnode%chempots(nel)),&\n! abs(2.0D1*vz*mapnode%chempots(nel))\n goto 110\n endif\n enddo\n! We can come here with a STEP command without any fix phases\n if(maptop%tieline_inplane.eq.0) then\n write(*,*)'SMP2A map_calcnode: Step command'\n goto 800\n endif\n! T, P and all chemical potentials the same, one should maybe check phases??\n iph=mapline%linefixph(1)%ixphase\n ics=mapline%linefixph(1)%compset\n! if(ocv()) write(*,107)'Node exist: ',&\n! write(*,107)'Node already exist: ',&\n! mapnode%seqx,size(mapnode%linehead),iph,ics\n107 format(a,i5,i3,i5,i2)\n! do not remove exits from invariant nodes ...\n if(btest(mapnode%status,MAPINVARIANT)) goto 800\n removexit: do jj=1,size(mapnode%linehead)\n! loop for all exits\n nodexit=>mapnode%linehead(jj)\n if(ocv()) write(*,108)'Exit: ',jj,nodexit%done,&\n nodexit%linefixph(1)%ixphase,nodexit%linefixph(1)%compset\n! nodexit%linefixph(1)%phaseix,nodexit%linefixph(1)%compset\n108 format(a,i4,i7,i5,i2)\n if(nodexit%done.le.0) cycle\n if(nodexit%linefixph(1)%ixphase.eq.iph .and. &\n nodexit%linefixph(1)%compset.eq.ics) then\n! write(*,*)'Number of stable phases: ',&\n! nodexit%nstabph,mapline%nstabph\n if(nodexit%nstabph.eq.mapline%nstabph) then\n! if we have same number of stable phases they must be checked (invariant)\n! write(*,*)'Can be an invariant equilibrium!',mapline%nstabph\n endif\n mapnode%linehead(jj)%done=-1\n write(*,106)mapnode%linehead(jj)%lineid,jj,mapnode%seqx\n106 format('Removed line ',i2,', exit ',i3,' from node: ',i3)\n exit removexit\n endif\n enddo removexit\n goto 800\n! take next mapnode\n110 continue\n! difficult error to detect, I had written mapnode=mapnde%next !!!\n mapnode=>mapnode%next\n! the next links should form a circular list ...\n if(.not.associated(mapnode,maptop)) goto 100\n!==================================================================\n! \n120 continue\n mapnode=>maptop%next\n seqx=mapnode%seqx+1\n! if maptop%next is maptop do not nullify this pointer !!\n! Always add the new record as the next link to maptop\n if(associated(mapnode,maptop)) then\n! a single maptop record\n! write(*,*)'allocate mapnone%next 1'\n allocate(mapnode%next)\n mapnode%next%status=0\n else\n! there is more mapnode records ... allocation here means memory leak\n! I do not know how to fix ... it seems one can deallocate pointers!! no leak\n! write(*,*)'allocate mapnone%next 2'\n allocate(maptop%next)\n maptop%next%status=0\n endif\n newnode=>maptop%next\n newnode%first=>maptop\n newnode%next=>mapnode\n newnode%previous=>maptop\n mapnode%previous=>newnode\n newnode%seqx=seqx\n! write(*,*)'Maptop and next: ',maptop%seqx,maptop%next%seqx,newnode%seqx\n!\n eqname='_MAPNODE_'\n jj=10\n! write(*,*)'SMP2A map_newnode copy equilibrium: ',seqx,nrel\n call wriint(eqname,jj,seqx)\n! This copy is a record in the array \"eqlista\" of equilibrium record, thus\n! it will be updated if new composition sets are created in other threads.\n! write(*,*)'Check 1: ',mapline%meqrec%nfixph,meqrec%nfixph,mapline%lineid,&\n! mapnode%seqx\n call copy_equilibrium(newceq,eqname,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating equilibrium: ',eqname\n goto 1000\n endif\n newnode%nodeceq=>newceq\n! if twostoichset is set then add a comment in the new equilibrium\n newnode%artxe=0\n if(twostoichset.eq.1) then\n! write(*,*)'SMP2A setting artxe'\n newnode%artxe=1\n endif\n! save a copy of ceq also in result (reserve is threadprotected)\n if(ocv()) write(*,*)'Copies node ceq to saveceq'\n call reserve_saveceq(jj,maptop%saveceq)\n if(gx%bmperr.ne.0) goto 1000\n maptop%saveceq%savedceq(jj)=newceq\n newnode%savednodeceq=jj\n! write(*,*)'Copy successful'\n! write(*,*)'Before copying meqrec: ',mapline%meqrec%nfixph,meqrec%nfixph\n! maybe it is not necessary to save meqrec and chemical potentials??\n newnode%meqrec=meqrec1\n! write(*,*)'New node index: ',newnode%seqx\n allocate(newnode%chempots(nrel))\n newnode%chempots=ceq%cmuval\n newnode%tpval=ceq%tpval\n! newnode%type_of_node=0\n! correct value of lines will be set later\n newnode%lines=0\n newnode%tieline_inplane=maptop%tieline_inplane\n! this seems to be wrong, maptop%number_ofaxis is zero when step separate\n newnode%number_ofaxis=maptop%number_ofaxis\n! save index of the phase set fix at the node\n! write(*,*)'SMP Saving index of new fix phase: ',abs(phfix)\n if(phfix.lt.0) then\n newnode%nodefix%ixphase=-meqrec1%phr(abs(phfix))%iph\n else\n newnode%nodefix%ixphase=meqrec1%phr(abs(phfix))%iph\n endif\n newnode%nodefix%compset=meqrec1%phr(abs(phfix))%ics\n! write(*,*)'Saved node fix phase: ',newnode%nodefix%phase,&\n! newnode%nodefix%compset\n! the set of stable phases\n newnode%noofstph=meqrec1%nstph\n allocate(newnode%stable_phases(newnode%noofstph))\n do jj=1,newnode%noofstph\n! newnode%stable_phases(jj)%phaseix=meqrec1%iphl(jj)\n newnode%stable_phases(jj)%ixphase=meqrec1%iphl(jj)\n newnode%stable_phases(jj)%compset=meqrec1%icsl(jj)\n enddo\n!\n! >>>>>>>>>>>>>>>>>>> add code here to generate 2*haha-1 exuts \n! if(haha.gt.0) write(*,*)'SMP2A found invariant with exits: !!',2*haha-1\n! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n!\n! Thats all in the newnode ... except the lineheads ....\n! Hm, when taking the different exits we must know phase sets and axis\n! directions, with some efforts one could check which axis variable will\n! change most rapidly for each exit but that can wait. But I must know\n! which phase set to have stable in the different lines ... but not for step.\n! For invariant equilibra with tie-lines not in the plane that can be quite\n! messy if I remeber correctly\n!-----------------------------------------------------\n! create mapline records in newnode with different sets of stable phases\n if(ocv()) write(*,*)'now generate lineheads',maptop%tieline_inplane,&\n mapline%meqrec%nfixph,meqrec1%nfixph\n if(maptop%tieline_inplane.eq.0) then\n! this is a step, just one line and one exit with the new set of stable phases\n newnode%lines=1\n if(noel().eq.1) then\n! step with single phase: problems with phase change as old phase still stable\n call get_phase_compset(phfix,1,lokph,lokcs)\n! this change will reomve the previously stable phase in newnode and \n! below also in meqrec1\n jj=newnode%stable_phases(1)%ixphase\n newnode%stable_phases(1)=phasetuple(phfix)\n phfix=-jj\n newnode%nodeceq%phase_varres(lokcs)%PHSTATE=PHENTSTAB\n newnode%nodeceq%phase_varres(lokcs)%amfu=one\n newnode%noofstph=1\n! write(*,*)'SMP phases 1A: ',phfix,newnode%stable_phases(1)%ixphase,&\n! newnode%stable_phases(2)%ixphase\n! But I had to remove the previously stable phase also this way !!\n call get_phase_compset(-phfix,1,lokph,lokcs)\n newnode%nodeceq%phase_varres(lokcs)%PHSTATE=PHENTUNST\n newnode%nodeceq%phase_varres(lokcs)%amfu=zero\n endif\n elseif(maptop%tieline_inplane.gt.0) then\n! mapping with tie-lines in plane. Always 3 lines meet ... 2 new exits ??\n! the number of exits depends on number of axis,\n! for 2 axis 3 lines meet, for 3 axis (one of which is a potential) 4 lines\n newnode%lines=2\n elseif(haha.gt.0) then\n! for mapping without tie-lines in plane and haha is nonzero then we are at\n! an invariant equlibrium with haha stable phases and 2*haha-1 exiting lines\n! newnode%lines=2*jj-1\n if(inveq(haha2,ceq)) then\n! newnode%lines=2*haha-1\n! Only few of the exit lines will be in the plane f the diagram. Assume 8\n! i.e. there will be 7 exits \n newnode%lines=7\n else\n newnode%lines=3\n endif\n else\n! mapping without tie-lines in plane\n! at other node points 4 lines meets, 3 exits\n write(*,*)'Unknown type of node create exit lines: ',newnode%lines\n newnode%lines=3\n endif\n! set link to end node in mapline\n mapline%end=>newnode\n!=============================================================================\n! we must create sufficient linehead records and initiate their content\n! differently depening on STEP (case 1), MAP with tie-lines in plane (case 2)\n! and MAP without tie-lines in plane (case 3). In the latter case special\n! care must be taken for invariant nodes. (for case 2 all nodes are invariants)\n! check if we have a potential axis and select that as axandir\n stepax=mapline%axandir\n nopotax=0\n if(maptop%number_ofaxis.gt.1) then\n! write(*,*)'Seach for step axis'\n kk=0\n do jj=1,maptop%number_ofaxis\n if(axarr(jj)%axcond(1)%statevarid.lt.5) then\n! positive or negative direction is unknown\n stepax=jj\n nopotax=jj\n! the value of this condition is hopefully in the axarr(jj)%lastaxval ??\n! It was stored there after calculating the node\n! write(*,*)'Found axis and value: ',axarr(jj)%lastaxval\n stepaxval=axarr(jj)%lastaxval\n endif\n! save the axis with the value closest to the \"middle\" of the axis\n if(kk.eq.0) then\n kk=1\n middle=abs(5.0D-1-axarr(jj)%lastaxval/&\n (axarr(jj)%axmax-axarr(jj)%axmin))\n! write(*,*)'middle: ',kk,middle\n else\n testv=abs(5.0D-1-axarr(jj)%lastaxval/&\n (axarr(jj)%axmax-axarr(jj)%axmin))\n if(testv.lt.middle) then\n middle=testv\n kk=jj\n endif\n! write(*,*)'middle: ',kk,middle,testv\n endif\n enddo\n if(nopotax.eq.0) then\n stepax=kk\n stepaxval=axarr(kk)%lastaxval\n endif\n! write(*,*)'Set step axis to: ',stepax,&\n! axarr(stepax)%axcond(1)%statevarid\n endif\n!\n!\n! write(*,*)'SMP2A creating lineheads: ',haha,newnode%lines\n! if(newnode%lines.gt.3) write(*,*)'SMP: generate exit lines: ',newnode%lines\n allocate(newnode%linehead(newnode%lines),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2A Allocation error 1: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! newnode%type_of_node=0\n!\n do jp=1,newnode%lines\n!--------------------- code moved from map_findline\n! COPY of the equilibrium record from newnode to newnode%linehead(jp)%lineceq\n if(ocv()) write(*,*)'We found a line from node: ',mapnode%seqx\n newnode%linehead(jp)%meqrec%status=0\n eqname='_MAPLINE_'\n kpos=10\n seqy=maptop%seqy+1\n call wriint(eqname,kpos,seqy)\n call copy_equilibrium(newnode%linehead(jp)%lineceq,eqname,&\n newnode%nodeceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating equilibrium: ',eqname\n goto 1000\n endif\n! write(*,*)'SMP phases 2: ',seqy,phfix,newnode%stable_phases(1)%ixphase,&\n! newnode%nodeceq%phase_varres(lokcs)%phstate,newnode%noofstph\n maptop%seqy=seqy\n newnode%linehead(jp)%lineid=seqy\n newnode%linehead(jp)%nodfixph=0\n! mapline%more is positive for line to be calculated, 0 means end at axis limit\n newnode%linehead(jp)%more=1\n enddo\n!------------------------------ end code copied\n!\n! write(*,*)'*** Trying to create node with # exit lines: ',haha,newnode%lines\n! STEP has just 1 exit; \n! MAP tie-line in plane 2; isopleth non-invariant 3; isopleth invariant >3\n kpos=min(newnode%lines,4)\n! select case(newnode%lines)\n exits: select case(kpos)\n!==========================================================================\n case default\n write(*,*)'SMP2A node error: exit lines= ',newnode%lines\n gx%bmperr=4237; goto 1000\n!==========================================================================\n case(1)! step node with just one exit\n! If phfix negative the fix phase wants to dissapear\n if(inveq(jj,ceq)) write(*,'(a)')'This is an invariant node'\n changephaseset: if(phfix.lt.0) then\n! remove a phase ---------------------------\n remph=-phfix\n! write(kou,88)remph,' disappears,',meqrec1%nstph\n88 format('SMP a node created where phase ',i3,a,' stable phases:',i3)\n if(meqrec1%nstph.eq.1) then\n write(*,*)'Attempt to remove the only stable phase!!!'\n gx%bmperr=4238; goto 1000\n endif\n! shift phases after remph up?? in meqrec1%stphlnewnode%lines)\n! irem is index to meqrec1%phr(), meqrec1%stphl(jph) is index to meqrec1%phr\n meqrec1%nstph=meqrec1%nstph-1\n do iph=1,meqrec1%nstph\n jj=meqrec1%stphl(iph)\n if(jj.ge.remph) then\n meqrec1%stphl(iph)=meqrec1%stphl(iph+1)\n endif\n enddo\n! we must zero the last phase, hm itrem is not really relevant ...\n meqrec1%stphl(meqrec1%nstph+1)=0\n! occational error because \"remph\" has illegal index value for meqrec1%phr \n if(remph.le.0) then\n write(*,*)'Occational error around line 4487',remph\n remph=-remph\n endif\n if(remph.gt.size(meqrec1%phr)) then\n! error calculating Cp for pure Al in Al-Mo ....\n write(*,'(a,4i4)')'SMP Too large phase indes',&\n remph,phfix,meqrec1%nstph\n gx%bmperr=4399; goto 1000\n endif\n meqrec1%phr(remph)%itrem=meqrec1%noofits\n meqrec1%phr(remph)%prevam=zero\n meqrec1%phr(remph)%stable=0\n meqrec1%phr(remph)%curd%amfu=zero\n! write(*,*)'SMP lineeq 3: ',meqrec1%nstph,meqrec1%stphl(1)\n elseif(phfix.gt.0) then\n! we have to add phase phfix to the stable phase set, that is no problem\n! as it is already in all lists, just remove that it should be fix\n! write(kou,88)phfix,' appears, ',meqrec1%nstph\n! meqrec1%nfixph seems not to be used .... ??\n if(meqrec1%nfixph.gt.0) then\n meqrec1%fixph(1,meqrec1%nfixph)=0\n meqrec1%fixph(2,meqrec1%nfixph)=0\n meqrec1%phr(phfix)%phasestatus=PHENTSTAB\n meqrec1%nfixph=meqrec1%nfixph-1\n endif\n stepinvariantnode=.FALSE.\n if(inveq(jj,ceq)) then\n!\n! if node is invariant we must remove one phase, which? NOT phfix\n stepinvariantnode=.TRUE.\n newnode%status=ibset(newnode%status,STEPINVARIANT)\n! write(*,*)'SMP2A invariant node at step',phfix,newnode%status,&\n! meqrec1%nstph\n! set the invariant bit in the node and calculate en equilibrium at\n! a very small step above the invariant to find the new set of phases\n newnode%linehead(1)%meqrec=meqrec1\n tmpline=>newnode%linehead(1)\n! do kk=1,meqrec1%nstph\n! jj=meqrec1%stphl(kk)\n! write(*,294)'SMP initial set of phases: ',kk,jj,&\n! meqrec1%phr(jj)%iph,meqrec1%phr(jj)%curd%amfu\n! enddo\n meqrec2=>tmpline%meqrec\n! do kk=1,meqrec2%nstph\n! jj=meqrec2%stphl(kk)\n! write(*,294)'SMP same initial set of phases: ',kk,jj,&\n! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,&\n! meqrec2%phr(jj)%curd%amfu\n! enddo\n294 format(a,3i5,i2,1pe14.6)\n call locate_condition(axarr(1)%seqz,pcond,tmpline%lineceq)\n if(gx%bmperr.ne.0) goto 100\n! call list_conditions(kou,tmpline%lineceq)\n! call list_sorted_phases(kou,tmpline%lineceq)\n! if(gx%bmperr.ne.0) goto 100\n pcond%prescribed=pcond%prescribed+&\n 1.0D-3*stepax*axarr(1)%axinc\n! call list_conditions(kou,tmpline%lineceq)\n! write(*,*)'SMP small step invariant to find phase which disappear'\n call calceq3(0,.FALSE.,tmpline%lineceq)\n! first argument -1 to keep the datastructure in meqrec2\n! call calceq7(-1,meqrec2,mapfix,tmpline%lineceq)\n! write(*,*)'Back from calceqx',gx%bmperr,meqrec1%nstph\n! call list_sorted_phases(kou,tmpline%lineceq)\n! NOTE the content of meqrec2 has not been updated as calceq3 creates a new\n! independent meqrec structure. We must copy the values of phase amounts\n! using a pointer directly to the phase_varres record\n! list amount of phases after this small step. However, the layout of\n! the meqrec records are the same, we can use phase indices and other things\n do kk=1,meqrec2%nstph-1\n jj=meqrec2%stphl(kk)\n call get_phase_compset(meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,&\n lokph,lokcs)\n xxx=tmpline%lineceq%phase_varres(lokcs)%amfu\n! write(*,294)'SMP new set of phases: ',kk,jj,&\n! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,xxx\n if(xxx.gt.zero) then\n meqrec2%phr(jj)%curd%amfu=xxx\n else\n do zz=kk,meqrec2%nstph-1\n meqrec2%stphl(zz)=meqrec2%stphl(zz+1)\n enddo\n endif\n enddo\n meqrec2%nstph=meqrec2%nstph-1\n! do kk=1,meqrec2%nstph\n! jj=meqrec2%stphl(kk)\n! write(*,294)'SMP final initial set of phases: ',kk,jj,&\n! meqrec2%phr(jj)%iph,meqrec2%phr(jj)%ics,&\n! meqrec2%phr(jj)%curd%amfu\n! enddo\n! finally copy to meqrec1 ...\n meqrec1%nstph=meqrec2%nstph\n do kk=1,meqrec2%nstph\n meqrec1%stphl(kk)=meqrec2%stphl(kk)\n! I assume the amounts are not needed, they should already be in lineceq ...??\n enddo\n! rearrange the array of stable phases, one should be removed\n! stop 'all OK?'\n endif\n else\n write(*,*)'This is another never never error',phfix\n gx%bmperr=4239; goto 1000\n endif changephaseset\n! set values in linhead record\n if(ocv()) write(*,*)'Creating linehead node record in: ',newnode%seqx\n newnode%linehead(1)%number_of_equilibria=0\n newnode%linehead(1)%first=0\n newnode%linehead(1)%last=0\n! newnode%linehead(1)%lineid=0\n! newnode%linehead(1)%axchange=1\n newnode%linehead(1)%axchange=-1\n newnode%linehead(1)%done=1\n newnode%linehead(1)%status=0\n newnode%linehead(1)%more=1\n newnode%linehead(1)%termerr=0\n newnode%linehead(1)%axfact=1.0D-2\n newnode%linehead(1)%nfixphases=0\n! try to get a nice output of stable phases below\n! if(stepinvariantnode) then\n! allocate(newnode%linehead(1)%stableph(meqrec2%nstph))\n! allocate(newnode%linehead(1)%stable_phr(meqrec2%nstph))\n! newnode%linehead(1)%nstabph=0\n! do iph=1,meqrec2%nstph\n! newnode%linehead(1)%nstabph=newnode%linehead(1)%nstabph+1\n! jj=meqrec2%stphl(iph)\n! newnode%linehead(1)%stableph(iph)%ixphase=meqrec2%phr(jj)%iph\n! newnode%linehead(1)%stableph(iph)%compset=meqrec2%phr(jj)%ics\n! newnode%linehead(1)%stable_phr(iph)=jj\n! enddo\n! else\n allocate(newnode%linehead(1)%stableph(meqrec1%nstph))\n allocate(newnode%linehead(1)%stable_phr(meqrec1%nstph))\n newnode%linehead(1)%nstabph=0\n do iph=1,meqrec1%nstph\n newnode%linehead(1)%nstabph=newnode%linehead(1)%nstabph+1\n jj=meqrec1%stphl(iph)\n newnode%linehead(1)%stableph(iph)%ixphase=meqrec1%phr(jj)%iph\n newnode%linehead(1)%stableph(iph)%compset=meqrec1%phr(jj)%ics\n newnode%linehead(1)%stable_phr(iph)=jj\n enddo\n! endif\n! end attempt\n newnode%linehead(1)%firstinc=1.0D-2*axarr(1)%axinc*mapline%axandir\n! newnode%linehead(1)%firstinc=1.0D-3*axarr(1)%axinc*mapline%axandir\n newnode%linehead(1)%evenvalue=axval\n newnode%linehead(1)%start=>newnode\n nullify(newnode%linehead(1)%end)\n if(ocv()) write(*,333)mapline%axandir,newnode%linehead(1)%firstinc,&\n newnode%linehead(1)%evenvalue\n333 format('linehead: ',i3,2(1pe15.6))\n newnode%linehead(1)%axandir=mapline%axandir\n!============================================================================\n case(2) ! Step node with two exits: Tie-lines in plane node, 3 lines meet,\n! 2 new exits\n! write(*,*)'Trying to implement \"tie-lines in plane\" nodes'\n if(ocv()) write(*,*)'Creating linehead node record in: ',newnode%seqx\n! write(*,*)'Creating linehead node record in: ',newnode%seqx\n! this is probably redundant, fixph already reset\n if(meqrec1%nfixph.gt.0) then\n meqrec1%fixph(1,meqrec1%nfixph)=0\n meqrec1%fixph(2,meqrec1%nfixph)=0\n meqrec1%phr(phfix)%phasestatus=PHENTSTAB\n meqrec1%nfixph=meqrec1%nfixph-1\n endif\n!-------------- \n! no need for loop here I guess ... but I am oldfashioned\n! begin doublecheck\n if(newnode%lines.ne.size(newnode%linehead)) then\n write(*,*)'SMP2A Trouble ahead!!'\n stop\n endif\n! end doublecheck\n do jj=1,2\n! initiate data in map_line record\n newnode%linehead(jj)%number_of_equilibria=0\n newnode%linehead(jj)%first=0\n newnode%linehead(jj)%last=0\n! newnode%linehead(jj)%lineid=0\n! newnode%linehead(jj)%axchange=1\n newnode%linehead(jj)%axchange=-1\n newnode%linehead(jj)%done=1\n newnode%linehead(jj)%status=0\n newnode%linehead(jj)%more=1\n newnode%linehead(jj)%termerr=0\n newnode%linehead(jj)%axfact=1.0D-2\n! newnode%linehead(jj)%axandir=mapline%axandir\n! ??????????? can stepax be negative ???????????????\n newnode%linehead(jj)%axandir=stepax\n newnode%linehead(jj)%nfixphases=1\n! this dimensioning is OK for two axis, if 3 it should be 2 etc.\n allocate(newnode%linehead(jj)%linefixph(1))\n allocate(newnode%linehead(jj)%linefix_phr(1))\n! with tie-lines in the plane there is always just one stable phase\n allocate(newnode%linehead(jj)%stableph(1))\n allocate(newnode%linehead(jj)%stablepham(1))\n allocate(newnode%linehead(jj)%stable_phr(1))\n! a small first step in same axis as used to find the node \n! We may have to change direction, in particular if the nodephase reappears\n! newnode%linehead(jj)%firstinc=1.0D-2*axinc*mapline%axandir\n newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc\n newnode%linehead(jj)%evenvalue=zero\n! node records at start and end\n newnode%linehead(jj)%start=>newnode\n nullify(newnode%linehead(jj)%end)\n enddo\n! This node represent a point where 3 lines meet 4 if 3 axis), each with a \n! different phase fix with zero amount. One line is the one we followed\n! to find the node, no need to generate an exit for that.\n! It seems we do not have to bother so much with nfixph and fixph ...\n! In meqrec1%phr there are currently two fixed phases, one which was fixed\n! along the line (LFIX in mapline%linefixph), the other fixed for the node\n! point, given by PHFIX which is an index to meqrec1%phr. The third phase\n! was stable with positive amount along the line LENT)\n! The three lines are: FIX STABLE UNSTABLE\n! already done LFIX LENT PHFIX\n! exit 1 PHFIX LFIX LENT\n! exit 2 LENT PHFIX LFIX\n jphr=0\n if(allocated(mapline%linefixph)) then\n if(size(mapline%linefixph).gt.1) then\n! If there are 3 axis this would be OK\n write(*,*)'SMP2B too many fix phases ...',size(mapline%linefixph)\n gx%bmperr=4240; goto 290\n endif\n endif\n! write(*,888)mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset,&\n! phfix,meqrec1%nphase,abs(phfix)\n888 format('Old fix phase 2: ',i3,i2,', new fix phase: ',i3,&\n ', number of phases: ',i3,' abs(phfix): ',i3)\n do jj=1,mapline%meqrec%nphase\n! loop through whole phr array to be sure nothing is wrong\n if(mapline%meqrec%phr(jj)%stable.eq.1) then\n if(jj.eq.abs(phfix) .or.&\n (meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and.&\n meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset)) cycle\n if(jphr.gt.0) then\n write(*,*)'Problems, two entered phases: ',jj,jphr\n gx%bmperr=4241; goto 290\n else\n jphr=jj\n! write(*,*)'Found entered phase: ',jphr\n endif\n endif\n enddo\n! jphr is the phase that was stable along the line\n if(jphr.eq.0) then\n write(*,*)'Problems, not a single entered phase!'\n gx%bmperr=4242; goto 290\n endif\n zph=0\n do jj=1,meqrec1%nphase\n if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and. &\n meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset) then\n! this is the index in phr for the phase that was fix along the line\n zph=jj\n endif\n enddo\n if(zph.eq.0) then\n write(*,203)' *** warning: cannot find the fix phase: ',zph,&\n mapline%linefixph(1)%ixphase,mapline%linefixph(1)%compset\n203 format(a,10i4)\n endif\n! For isothermal sections with no potential axis we must change the axis\n! condition when following a new line\n! if(nopotax.eq.0) then\n! write(*,*)'Changing the axis variable for the new entered phase'\n! endif\n! In mapnode there is a nfixph and array linefixph\n! if(ocv()) write(*,207)mapline%linefixph(1)%phaseix,&\n! if(ocv()) write(*,207)mapline%linefixph(1)%ixphase,&\n! write(*,207)mapline%linefixph(1)%ixphase,&\n! mapline%linefixph(1)%compset,&\n! meqrec%phr(phfix)%iph,meqrec%phr(phfix)%ics,&\n! meqrec%phr(jphr)%iph,meqrec%phr(jphr)%ics\n207 format('LFIX: ',2i3,5x,' PHFIX: ',2i3,5x,' LENT: ',2i3)\n! The two exits are: FIX STABLE UNSTABLE\n! exit 1 PHFIX LFIX LENT\n! exit 2 LENT PHFIX LFIX\n! for alcrni \n iph=mapline%linefixph(1)%ixphase\n ics=mapline%linefixph(1)%compset\n linefphr=mapline%linefix_phr(1)\n phrix=mapline%linefix_phr(1)\n newnode%linehead(1)%linefixph%ixphase=meqrec1%phr(phfix)%iph\n newnode%linehead(1)%linefixph%compset=meqrec1%phr(phfix)%ics\n newnode%linehead(1)%linefix_phr=phfix\n newnode%linehead(1)%nstabph=1\n! the previously fix phase is set as entered with stablepham as initial amount\n newnode%linehead(1)%stableph(1)%ixphase=iph\n newnode%linehead(1)%stableph(1)%compset=ics\n! value of %stable_phr=??\n newnode%linehead(1)%stable_phr(1)=phrix\n newnode%linehead(1)%stablepham(1)=one\n! store the phase number that must not become stable in nodfixph\n newnode%linehead(1)%nodfixph=jphr\n! newnode%linehead(1)%nodfixtup=meqrec1%phr(jphr)%phtupix\n! write(*,*)'SM2A nodfix:',phasetuple(meqrec1%phr(jphr)%phtupix)%ixphase,&\n! meqrec1%phr(jphr)%ics\n!-----------\n newnode%linehead(2)%linefixph%ixphase=meqrec1%phr(jphr)%iph\n newnode%linehead(2)%linefixph%compset=meqrec1%phr(jphr)%ics\n newnode%linehead(2)%linefix_phr=jphr\n newnode%linehead(2)%nstabph=1\n newnode%linehead(2)%stableph(1)%ixphase=meqrec1%phr(phfix)%iph\n newnode%linehead(2)%stableph(1)%compset=meqrec1%phr(phfix)%ics\n newnode%linehead(2)%stable_phr(1)=phfix\n newnode%linehead(2)%stablepham(1)=one\n! store the phase number that must not become stable in nodfixph\n newnode%linehead(2)%nodfixph=zph\n! newnode%linehead(1)%nodfixtup=meqrec1%phr(zph)%phtupix\n if(nopotax.eq.0) then\n! If we have no potential axis we MUST change the axis condition\n! to represent the axis composition of the new stable phase\n write(*,712)stepax,axarr(abs(stepax))%axcond(1)%statevarid,stepaxval\n712 format('Creating nodepoint with no potential axis: ',2i4,1pe12.4)\n! we have to change the axis condition to be the current composition of the\n! new stable phase. \n! write(*,*)'Conditions at node point'\n! call list_conditions(kou,newnode%nodeceq)\n! change condition value for the lines exiting this node point\n tmpceq=>newnode%linehead(1)%lineceq\n call locate_condition(axarr(stepax)%seqz,pcond,tmpceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot locate condition: ',axarr(stepax)%seqz\n goto 1000\n endif\n svrrec=>pcond%statvar(1)\n! call state_variable_val(svrrec,xxx,tmpceq)\n! if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Condition/State variable value: ',xxx\n! NOTE: If we change fix/entered phase we must change axvals/axvals2\n! i1=svr2%argtyp; i2=svr2%phase; i3=svr2%compset\n svrtarget=svrrec\n svrtarget%argtyp=3\n svrtarget%phase=newnode%linehead(1)%stableph(1)%ixphase\n svrtarget%compset=newnode%linehead(1)%stableph(1)%compset\n! This extracts the composition of the entered phase for first new line\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xxx,tmpceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,xxx,tmpceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting new conditions in lineceq'\n goto 1000\n endif\n! write(*,*)'Setting condition for line 1 to ',xxx\n! write(*,211)'New conditions at line: ',newnode%linehead(1)%lineid,&\n! trim(newnode%linehead(1)%lineceq%eqname),&\n! svr2%phase,svr2%compset,xxx\n211 format(a,i3,a,2x,' phase/set: ',2i3,2x,1pe12.4)\n! call list_conditions(kou,newnode%linehead(1)%lineceq)\n!--------- second exit\n tmpceq=>newnode%linehead(2)%lineceq\n call locate_condition(axarr(stepax)%seqz,pcond,tmpceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot locate condition: ',axarr(stepax)%seqz\n goto 1000\n endif\n svrrec=>pcond%statvar(1)\n svrtarget=svrrec\n svrtarget%argtyp=3\n svrtarget%phase=newnode%linehead(2)%stableph(1)%ixphase\n svrtarget%compset=newnode%linehead(2)%stableph(1)%compset\n! This extracts the composition of the entered phase for second new line\n! ONLY CHANGE ... has no influence on the problem ...\n svr2=>svrtarget\n! the line above should be there I think but was missing ... xxx below wrong??\n call state_variable_val(svr2,xxx,tmpceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(0,pcond,xxx,tmpceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting new conditions in lineceq'\n goto 1000\n endif\n! write(*,*)'Setting condition for line 2 to ',xxx\n! write(*,211)'New conditions at line: ',newnode%linehead(2)%lineid,&\n! trim(newnode%linehead(2)%lineceq%eqname),&\n! svr2%phase,svr2%compset,xxx\n! call list_conditions(kou,newnode%linehead(2)%lineceq)\n endif\n! list the exits:\n if(ocv()) write(*,56)'Created linehead 1 for node: ',newnode%seqx,&\n! write(*,56)'Created linehead 1 for node: ',newnode%seqx,&\n newnode%linehead(1)%linefixph%ixphase,&\n newnode%linehead(1)%linefixph%compset,&\n newnode%linehead(1)%stableph(1)%ixphase,&\n newnode%linehead(1)%stableph(1)%compset,&\n newnode%linehead(1)%nodfixph\n if(ocv()) write(*,56)'Created linehead 2 for node: ',newnode%seqx,&\n! write(*,56)'Created linehead 2 for node: ',newnode%seqx,&\n newnode%linehead(2)%linefixph%ixphase,&\n newnode%linehead(2)%linefixph%compset,&\n newnode%linehead(2)%stableph(1)%ixphase,&\n newnode%linehead(2)%stableph(1)%compset,&\n newnode%linehead(2)%nodfixph\n56 format(a,i3,5x,2i3,5x,2i3,5x,2i3)\n if(newnode%lines.ne.2) then\n write(*,*)'SMP2A setting newnode%lines'\n newnode%lines=2\n endif\n! the fix and stable phases must be copied to meqrec1 when line is started\n! write(*,*)'Created node with 2 exits: ',newnode%seqx,ceq%tpval(1)\n! prevent the lines from being used as that makes the program crash\n290 continue\n!======================================================================\n case(3) ! Normal node in a phase diagram without tie-lines in plane\n! Two crossing lines, one in and 3 exits\n! THERE IS NO CASE WHEN FINDING AN INVARIANT\n! this is probably redundant, fixph already reset\n if(meqrec1%nfixph.gt.0) then\n! write(*,*)'Not redundant ...'\n meqrec1%fixph(1,meqrec1%nfixph)=0\n meqrec1%fixph(2,meqrec1%nfixph)=0\n meqrec1%phr(abs(phfix))%phasestatus=PHENTSTAB\n meqrec1%nfixph=meqrec1%nfixph-1\n endif\n!-------------- \n! no need for loop here I guess ... but I am oldfashioned\n do jj=1,3\n! initiate data in map_line record\n newnode%linehead(jj)%number_of_equilibria=0\n newnode%linehead(jj)%first=0\n newnode%linehead(jj)%last=0\n! newnode%linehead(jj)%lineid=0\n! newnode%linehead(jj)%axchange=1\n newnode%linehead(jj)%axchange=-1\n newnode%linehead(jj)%done=1\n newnode%linehead(jj)%status=0\n newnode%linehead(jj)%more=1\n newnode%linehead(jj)%termerr=0\n newnode%linehead(jj)%axfact=1.0D-2\n! newnode%linehead(jj)%axandir=mapline%axandir\n newnode%linehead(jj)%axandir=stepax\n newnode%linehead(jj)%nfixphases=1\n! this dimensioning is OK for two axis, if 3 axis it should be 2 etc.\n allocate(newnode%linehead(jj)%linefixph(1))\n allocate(newnode%linehead(jj)%linefix_phr(1))\n! There will be different number of stable phases in the lines \n! if new phase appear, 2 lines with jphr+1, one with jphr\n! if old phase dissapear, 2 lines with jphr-1, one with jphr\n jphr=mapline%nstabph\n if(jphr.eq.1 .and. phfix.lt.0) then\n write(*,*)'Trying to remove the only entered phase !'\n gx%bmperr=4238; goto 1000\n endif\n if(jj.eq.3) then\n! write(*,*)'Allocating stableph: ',jj,jphr\n allocate(newnode%linehead(jj)%stableph(jphr))\n allocate(newnode%linehead(jj)%stablepham(jphr))\n allocate(newnode%linehead(jj)%stable_phr(jphr))\n else\n if(phfix.lt.0) then\n! write(*,*)'Allocating stableph: ',jj,jphr-1\n allocate(newnode%linehead(jj)%stableph(jphr-1))\n allocate(newnode%linehead(jj)%stablepham(jphr-1))\n allocate(newnode%linehead(jj)%stable_phr(jphr-1))\n else\n! write(*,*)'Allocating stableph: ',jj,jphr+1\n allocate(newnode%linehead(jj)%stableph(jphr+1))\n allocate(newnode%linehead(jj)%stablepham(jphr+1))\n allocate(newnode%linehead(jj)%stable_phr(jphr+1))\n endif\n endif\n! a small first step in same axis as used to find the node \n! We may have to change direction, in particular if the nodephase reappears\n! evenvalue important only for STEP with one axis\n! newnode%linehead(jj)%firstinc=1.0D-2*axinc*mapline%axandir\n! newnode%linehead(jj)%firstinc=axinc1*axinc*mapline%axandir\n newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc\n newnode%linehead(jj)%evenvalue=zero\n! links to node records at start and end of line\n newnode%linehead(jj)%start=>newnode\n nullify(newnode%linehead(jj)%end)\n enddo\n!\n if(allocated(mapline%linefixph)) then\n if(size(mapline%linefixph).gt.1) then\n! error if 2 axis but would be OK if 3 axis\n write(*,*)'Problem, many fix phases!',size(mapline%linefixph)\n gx%bmperr=4240; goto 390\n endif\n endif\n stabph=0\n do jj=1,meqrec1%nphase\n! loop through whole phr array to be sure nothing is wrong\n if(meqrec1%phr(jj)%stable.eq.1) then\n! there should be 2 fixed phases, one along the line and one at the node\n! If 3 or more axis there will be more fixed phases, phfix can be negative\n! if(jj.eq.abs(phfix) .or.&\n! (meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%phase .and.&\n! meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset)) cycle\n! we should include phfix in stabph!!\n! if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%phaseix .and.&\n if(meqrec1%phr(jj)%iph.eq.mapline%linefixph(1)%ixphase .and.&\n meqrec1%phr(jj)%ics.eq.mapline%linefixph(1)%compset) cycle\n stabph=stabph+1\n endif\n enddo\n! Hm, stabph calculated this way is wrong, use mapline%nstabph\n! write(*,312)meqrec1%nphase,stabph,mapline%nstabph,phfix,&\n! mapline%linefixph(1)%phase,mapline%linefixph(1)%compset\n312 format('In map_newnode 312: ',i3,i5,i3,i5,i3,i2,10i5)\n stabph=mapline%nstabph\n if(stabph.eq.0) then\n write(*,*)'Problems, no entered phase!'\n gx%bmperr=4242; goto 390\n endif\n! 4 lines meet in all nodes except invariants\n! We have 1 fix phase and f=stabph enterend phases and 1 new/old (+/-PHFIX)\n! LFIX is phase fix along line up to node\n! +PHFIX is a new phase becommong stable, -PHFIX is stable phase dissapearing\n! if not invariant generate 3 exits, with PHFIX>0 these are\n! The three exits are: FIX STABLE phases nodfixph\n! exit 1 LFIX f+1 (+PHFIX) PHFIX\n! exit 2 PHFIX f+1 (+LFIX) LFIX\n! exit 3 PHFIX f (-PHFIX and add LFIX) LFIX\n! If PHFIX<0 is an old phase becommong unstable\n! The three exits are: FIX STABLE not allwed appear/disappear\n! exit 1 LFIX f-1 (-PHFIX) PHFIX\n! exit 2 PHFIX f-1 (-PHFIX not LFIX) LFIX\n! exit 3 PHFIX f (-PHFIX and add LFIX) LFIX\n iph=mapline%linefixph(1)%ixphase\n ics=mapline%linefixph(1)%compset\n linefphr=mapline%linefix_phr(1)\n! for use below I need to know the position of iph+ics in meqrec1%phr ...\n flfix: do jj=1,meqrec1%nstph\n if(meqrec1%phr(jj)%iph.eq.iph .and. meqrec1%phr(jj)%ics.eq.ics) then\n lfix=jj; exit flfix\n endif\n enddo flfix\n kph=mapline%meqrec%phr(abs(phfix))%iph\n kcs=mapline%meqrec%phr(abs(phfix))%ics\n! exit 1 has same linefix as incomming line ------------------------\n newnode%linehead(1)%linefixph%ixphase=iph\n newnode%linehead(1)%linefixph%compset=ics\n newnode%linehead(1)%linefix_phr=linefphr\n if(phfix.gt.0) then\n! write(*,*)'allocated size of stableph 2: ',size(mapline%stableph)\n do jj=1,stabph\n newnode%linehead(1)%stableph(jj)%ixphase=&\n mapline%stableph(jj)%ixphase\n newnode%linehead(1)%stableph(jj)%compset=&\n mapline%stableph(jj)%compset\n newnode%linehead(1)%stablepham(jj)=mapline%stablepham(jj)\n newnode%linehead(1)%stable_phr(jj)=mapline%stable_phr(jj)\n enddo\n! add phfix as stable phase\n jj=stabph+1\n newnode%linehead(1)%stableph(jj)%ixphase=kph\n newnode%linehead(1)%stableph(jj)%compset=kcs\n newnode%linehead(1)%stablepham(jj)=zero\n newnode%linehead(1)%stable_phr(jj)=abs(phfix)\n! UNFINISHED check why stable_phr and nodefxph same??\n newnode%linehead(1)%nodfixph=abs(phfix)\n! newnode%linehead(1)%nodfixtup=meqrec1%phr(abs(phfix))%phtupix\n newnode%linehead(1)%nstabph=jj\n else\n! phfix is negative, a phase disappear\n kk=0\n do jj=1,stabph-1\n! remove -phfix as stable phase\n if(mapline%stableph(jj)%ixphase.eq.kph .and.&\n mapline%stableph(jj)%compset.eq.kcs) then\n kk=jj+1\n else\n kk=kk+1\n endif\n newnode%linehead(1)%stableph(jj)%ixphase=&\n mapline%stableph(kk)%ixphase\n newnode%linehead(1)%stableph(jj)%compset=&\n mapline%stableph(kk)%compset\n newnode%linehead(1)%stablepham(jj)=mapline%stablepham(kk)\n newnode%linehead(1)%stable_phr(jj)=mapline%stable_phr(kk)\n enddo\n newnode%linehead(1)%nodfixph=abs(phfix)\n newnode%linehead(1)%nstabph=stabph-1\n endif\n!\n! exit 2 has PHFIX as linefix ----------------------------------\n newnode%linehead(2)%linefixph%ixphase=kph\n newnode%linehead(2)%linefixph%compset=kcs\n newnode%linehead(2)%linefix_phr=abs(phfix)\n if(phfix.gt.0) then\n do jj=1,stabph\n newnode%linehead(2)%stableph(jj)%ixphase=&\n mapline%stableph(jj)%ixphase\n newnode%linehead(2)%stableph(jj)%compset=&\n mapline%stableph(jj)%compset\n newnode%linehead(2)%stablepham(jj)=mapline%stablepham(jj)\n newnode%linehead(2)%stable_phr(jj)=mapline%stable_phr(jj)\n enddo\n! add LFIX as stable phase\n jj=stabph+1\n newnode%linehead(2)%stableph(jj)%ixphase=iph\n newnode%linehead(2)%stableph(jj)%compset=ics\n newnode%linehead(2)%stablepham(jj)=zero\n newnode%linehead(2)%stable_phr(jj)=lfix\n newnode%linehead(2)%nodfixph=lfix\n newnode%linehead(2)%nstabph=jj\n else\n kk=0\n do jj=1,stabph-1\n! remove -phfix as stable phase\n if(mapline%stableph(jj)%ixphase.eq.kph .and.&\n mapline%stableph(jj)%compset.eq.kcs) then\n kk=jj+1\n else\n kk=kk+1\n endif\n newnode%linehead(2)%stableph(jj)%ixphase=&\n mapline%stableph(kk)%ixphase\n newnode%linehead(2)%stableph(jj)%compset=&\n mapline%stableph(kk)%compset\n newnode%linehead(2)%stable_phr(jj)=mapline%stable_phr(kk)\n enddo\n newnode%linehead(2)%nodfixph=lfix\n! newnode%linehead(1)%nodfixtup=meqrec1%phr(lfix)%phtupix\n newnode%linehead(2)%nstabph=stabph-1\n endif\n!\n! exit 3 has PHFIX as linefix ----------------------------------\n newnode%linehead(3)%linefixph%ixphase=kph\n newnode%linehead(3)%linefixph%compset=kcs\n newnode%linehead(3)%linefix_phr=abs(phfix)\n do jj=1,stabph\n if(mapline%stableph(jj)%ixphase.eq.kph .and. &\n mapline%stableph(jj)%compset.eq.kcs) then\n! exchange PHFIX for LFIX as stable phase\n newnode%linehead(3)%stableph(jj)%ixphase=iph\n newnode%linehead(3)%stableph(jj)%compset=ics\n newnode%linehead(3)%stablepham(jj)=zero\n newnode%linehead(3)%stable_phr(jj)=abs(phfix)\n else\n newnode%linehead(3)%stableph(jj)%ixphase=&\n mapline%stableph(jj)%ixphase\n newnode%linehead(3)%stableph(jj)%compset=&\n mapline%stableph(jj)%compset\n newnode%linehead(3)%stablepham(jj)=mapline%stablepham(jj)\n newnode%linehead(3)%stable_phr(jj)=mapline%stable_phr(jj)\n endif\n enddo\n newnode%linehead(3)%nodfixph=lfix\n newnode%linehead(3)%nstabph=stabph\n!\n if(ocv()) then\n do jj=1,3\n write(*,356)jj,newnode%seqx,&\n! newnode%linehead(jj)%linefixph%phaseix,&\n newnode%linehead(jj)%linefixph%ixphase,&\n newnode%linehead(jj)%linefixph%compset,&\n newnode%linehead(jj)%nodfixph,&\n newnode%linehead(jj)%nstabph,&\n (newnode%linehead(jj)%stableph(kk)%ixphase,&\n newnode%linehead(jj)%stableph(kk)%compset,&\n kk=1,newnode%linehead(jj)%nstabph)\n enddo\n356 format('Tie-line NOT in plane node exits: ',&\n i2,i3,i4,i2,i5,i3,10(i4,i2))\n endif\n! the fix and stable phases must be copied to meqrec1 when line is started\n! write(*,*)'Created node with 2 exits: ',newnode%seqx,ceq%tpval(1)\n390 continue\n!---------------------------------------------------------------\n! invariant isopleth, more than 3 exits\n case(4) ! isopleth invariants for isopleths, inveq\n! number of stable phases equal to components+1\n! number of adjacent regions with \"components\" stable phases is \"components+1\"\n! number of exit lines are 2*(components+1) ?? limit to 8 (minus 1 for entry)\n! each line has a fix phase and one of the phases is stable at the invariant\n! (set as not \"nodefix\"). The remaining phases are entered.\n! Each phase is fix for two lines and \"nodefix\" for two others\n! This is the way to generate the exit lines:\n! - loop for all phases to set a phase fix (for two lines)\n! - loop for the next two phases to set one phase not stable\n! the remaining phases are set entered (amount?) generate a line startpoint\n! take care of remobing line into the invariant\n!\n! How to know if the node is invariant? Gibbs phase rule, Degrees of freedom\n! f = n + 2 - p\n! where n is number of components, 2 if T and P variable, 1 if T or P variable,\n! 0 if both T and P fixed, p is number of stable phases.\n! write(*,*)'SMP2A Generating exits from isopleth invariant',newnode%lines\n! Two crossing lines, one in and 3 exits\n! this is probably redundant, fixph already reset\n! phfix is the new stable phase! Must be positive\n! mapline is the just finished line\n if(meqrec1%nfixph.gt.0) then\n! write(*,*)'Invariant isopleth:',meqrec1%nfixph,phfix,mapline%nstabph\n meqrec1%fixph(1,meqrec1%nfixph)=0\n meqrec1%fixph(2,meqrec1%nfixph)=0\n meqrec1%phr(abs(phfix))%phasestatus=PHENTUNST\n meqrec1%nfixph=meqrec1%nfixph-1\n endif\n! determine LFIX, the phase which was fix along incomming line\n iph=mapline%linefixph(1)%ixphase\n ics=mapline%linefixph(1)%compset\n! for use below I need to know the position of iph+ics in meqrec1%phr ...\n lfix=mapline%linefix_phr(1)\n flfix2: do jj=1,meqrec1%nstph\n! this loop is only for stable phase it does not include the fix\n if(meqrec1%phr(jj)%iph.eq.iph .and. meqrec1%phr(jj)%ics.eq.ics) then\n lfix=jj\n meqrec1%phr(lfix)%phasestatus=PHENTUNST\n exit flfix2\n endif\n enddo flfix2\n if(lfix.eq.0) stop 'ERROR'\n! this is total number of phases at each the invariant\n! 1 fix and stabph-2 should be stable at each exit\n stabph=mapline%nstabph\n if(stabph.eq.0) then\n write(*,*)'Problems, no entered phase!'\n gx%bmperr=4242; goto 490\n endif\n! Collect all stable phases to be used as different exits.\n! invph(1,jj) is iph,, invph(2,jj) is ics; invph(3,jj) is index in meqrec1%phr\n! invph(4,jj) is to count number of times jj has been linefix\n! invph(5,jj) is to count number of times jj has been nodefix\n! invph(6,jj) is index to phase_varres\n allocate(invph(6,stabph+2))\n invph=0\n do jj=1,stabph\n! stableph is a phase_tuple\n invph(1,jj)=mapline%stableph(jj)%ixphase\n invph(2,jj)=mapline%stableph(jj)%compset\n invph(3,jj)=mapline%stable_phr(jj)\n! stable_phr is used to find the index in phr and index to phase_varres\n! I DO NOT TRUST THE VALUE, \"stable_phr\"\n! I SHOULD REORGANIZE PHE TO BE IN PHASE TUPLE ORDER.\n! THERE ARE ALWAYS PROBLEM IS IF NEW COMPOSIION SETS ARE CREATED DURING MAPPING\n do zz=1,meqrec1%nphase\n if(meqrec1%phr(zz)%iph.eq.invph(1,jj) .and.&\n meqrec1%phr(zz)%ics.eq.invph(2,jj)) then\n invph(3,jj)=zz\n! if(zz.ne.mapline%stable_phr(jj)) &\n! write(*,*)'SMP correction: ',jj,zz,mapline%stable_phr(jj)\n endif\n enddo\n call get_phase_compset(invph(1,jj),invph(2,jj),lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n invph(6,jj)=lokcs\n enddo\n! at the end of loop jj=stabph+1; store phfix, the new fix phase, \n invph(1,jj)=meqrec1%phr(phfix)%iph\n invph(2,jj)=meqrec1%phr(phfix)%ics\n invph(3,jj)=phfix\n call get_phase_compset(invph(1,jj),invph(2,jj),lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n invph(6,jj)=lokcs\n! this is the phase fix at incomming line, only one exit line with this fix\n invph(1,jj+1)=iph\n invph(2,jj+1)=ics\n invph(3,jj+1)=lfix\n call get_phase_compset(invph(1,jj+1),invph(2,jj+1),lokph,lokcs)\n if(gx%bmperr.ne.0) goto 1000\n invph(6,jj+1)=lokcs\n jlast=stabph+2\n! STABLE PHASES HAS TO BE IN PHR ORDER!! SORT invph\n! do kk=1,stabph+2\n! write(*,'(a,i3,2x,i3,i2,4i4)')'SMP invph:',kk,(invph(zz,kk),zz=1,6)\n! enddo\n! second argument is first dimenstion of invph!!\n call sort_invph(jlast,6,invph)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'SMP sorted invph: '\n! do kk=1,stabph+2\n! write(*,'(a,i3,2x,i3,i2,4i4)')'SMP invph:',kk,(invph(zz,kk),zz=1,6)\n! enddo\n do jj=1,jlast\n phases=' '\n call get_phase_name(invph(1,jj),invph(2,jj),phases)\n! keep track of the phase found at the invariant and the linefix phase\n! nodein(1) is linefix\n if(invph(3,jj).eq.lfix) then\n nodein(1)=jj\n linefix=jj\n invph(4,nodein(1))=1\n! nodein(2) is nodefix\n elseif(invph(3,jj).eq.phfix) then\n nodein(2)=jj\n nodefix=jj\n invph(5,nodein(2))=1\n endif\n enddo\n! the entering line found at node, nodefix, mark it is used\n! the entering line had this phase fix with zero amount\n! write(*,'(a,5i4)')'SMP2: linefix and nodefix: ',&\n! onlyone,lfix,notone,phfix\n! all the others should be fixed one two exits\n!-------------- \n tmpceq=>newnode%nodeceq\n! max 20 exit lines ....\n allocate(nodeout(2,10))\n! write(*,*)'SMP call to find all exits',tmpceq%tpval(1)\n call find_inv_exits(nexit,nodeout,nodein,stabph,invph,6,axarr,tmpceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,i3,5(i5,i3))')'SMP back from find_inv_exit: ',nexit,&\n! nodein(1),nodein(2),(nodeout(1,jj),nodeout(2,jj),jj=1,nexit)\n! stop 'SMP does it work? YES!'\n if(nexit.gt.2*mapline%nstabph) then\n write(*,*)'SMP too many exit lines: ',nexit,newnode%lines\n elseif(nexit.le.0) then\n write(*,*)'SMP no exits found?, just continue with one line'\n newnode%lines=1\n else\n newnode%lines=2*nexit+1\n endif\n! There are nexit pairs of phases in nodeout for all exits, total number\n! of exits are 2*nexit+1 (one exit eliminated because that was entering)\n!\n!-------------- \n! We have to generate newnode%lines exits!!\n jphr=mapline%nstabph\n jfix=1\n! set bit in mapnode!\n if(newnode%status.ne.0) write(*,*)'SMP2 nodestatus: ',newnode%status\n newnode%status=ibset(newnode%status,MAPINVARIANT)\n! write(*,*)'SMP2 number of exit lines: ',newnode%lines,jphr\n allexit: do jj=1,newnode%lines\n! initiate common data in map_line record in all exit lines\n newnode%linehead(jj)%number_of_equilibria=0\n newnode%linehead(jj)%first=0\n newnode%linehead(jj)%last=0\n newnode%linehead(jj)%axchange=-1\n newnode%linehead(jj)%done=1\n newnode%linehead(jj)%status=0\n newnode%linehead(jj)%more=1\n newnode%linehead(jj)%termerr=0\n newnode%linehead(jj)%axfact=1.0D-2\n newnode%linehead(jj)%axandir=stepax\n! this dimensioning is OK for two axis, if 3 axis it should be 2 etc.\n newnode%linehead(jj)%nfixphases=1\n if(allocated(newnode%linehead(jj)%linefixph)) then\n write(*,*)'SMP2A line 5537: Strange allocated error in map17',&\n jj,jphr\n deallocate(newnode%linehead(jj)%linefixph)\n deallocate(newnode%linehead(jj)%linefix_phr)\n if(allocated(newnode%linehead(jj)%stableph)) then\n write(*,*)'SMP2A line 5537: skipping!'\n endif\n endif\n allocate(newnode%linehead(jj)%linefixph(1))\n allocate(newnode%linehead(jj)%linefix_phr(1))\n! There will be the same number of stable phases in all lines \n allocate(newnode%linehead(jj)%stableph(jphr))\n allocate(newnode%linehead(jj)%stablepham(jphr))\n allocate(newnode%linehead(jj)%stable_phr(jphr))\n! a small first step in same axis as used to find the node \n! We may have to change direction, in particular if the nodephase reappears\n! evenvalue important only for STEP with one axis\n newnode%linehead(jj)%firstinc=axinc1*axarr(abs(stepax))%axinc\n newnode%linehead(jj)%evenvalue=zero\n! links to node records at start and end of line\n newnode%linehead(jj)%start=>newnode\n nullify(newnode%linehead(jj)%end)\n! number of stable phases along all lines. Additionally a fix and a forbidden\n newnode%linehead(jj)%nstabph=stabph\n! possible problem with meqrec%status\n if(newnode%linehead(jj)%meqrec%status.ne.0) then\n write(*,*)'SMP zero meqrec%status for newnode%linehead',&\n newnode%linehead(jj)%meqrec%status\n newnode%linehead(jj)%meqrec%status=0\n endif\n enddo allexit\n!\n! ------------------------ ISOPLETHAL INVARIANTS EXITS -----------\n! we have set LINEFIX and NODEFIX phases for each line\n! We know the LINEFIX and NODEFIX phases for the line INTO THE INVARIAT\n! For the first exit line we just swich these as they are at the same point\n! with zero amount of both phases\n!\n! (C is ?) Cfix Afix Dfix Bfix (B is ?)\n! \\ ABCE.. \\BCE./ BCDE.. /\n! \\ \\ / /\n! \\____________\\/_________/ \n! ABDE.. !_________ ABCDE..______! CDE...\n! / /\\ \\\n! / ABDE.. / \\ ACDE.. \\\n! / /ADE.\\ \\\n! Dfix Bfix Cfix Afix\n!\n! For the other exits FIND_INV_EXITS above have found all points along\n! the invariant line that have two phases with zero amount.\n! If next<0 just one exit will be generated with linefix/nodefix changed\n!\n jj=1\n phases=' '\n! write(*,717)newnode%nodeceq%tpval(1)\n717 format(/' *************** invariant node at ',F10.2)\n! now code to create correct combination of linefix and nodefix\n! first a line with nodefix as linefix and vice versa\n! and old linefix as nodefix phase (sorry very confusing for me too)\n newnode%linehead(jj)%linefixph%ixphase=invph(1,nodefix)\n newnode%linehead(jj)%linefixph%compset=invph(2,nodefix)\n newnode%linehead(jj)%linefix_phr=invph(3,nodefix)\n! this is just to understand what is happening\n call get_phase_name(invph(1,nodefix),invph(2,nodefix),phases)\n zp=len_trim(phases)+3\n phases(zp-1:zp-1)='('\n! write(*,*)'smp2: fix: ',trim(phases),onlyone,invph(3,onlyone)\n! set linefix=LFIX as phase forbidden to become stable when line starts\n! enclose the nodefix phase with ( .... )\n newnode%linehead(jj)%nodfixph=invph(3,linefix)\n call get_phase_name(invph(1,linefix),invph(2,linefix),phases(zp:))\n zp=len_trim(phases)+3\n phases(zp-2:zp-2)=')'\n! at this line we have switched nodefix/linefix; nodefix is fix along the line\n! the incomming line had the same fix phases so set both 4 and 5 to 1\n invph(4,nodefix)=1; invph(5,nodefix)=1\n invph(4,linefix)=1; invph(5,linefix)=1\n! NOW add the stable phases excluding linefix and nodefix\n kk=0\n names: do zz=1,stabph+2\n if(zz.eq.linefix .or. zz.eq.nodefix) cycle names\n kk=kk+1\n newnode%linehead(jj)%stableph(kk)%ixphase=invph(1,zz)\n newnode%linehead(jj)%stableph(kk)%compset=invph(2,zz)\n newnode%linehead(jj)%stablepham(kk)=1.0D-2\n newnode%linehead(jj)%stable_phr(kk)=invph(3,zz)\n call get_phase_name(invph(1,zz),invph(2,zz),phases(zp:))\n zp=len_trim(phases)+2\n enddo names\n! note again: nodefix here is fix along the line, linefix is stable at invarant\n! write(*,430)jj,nodefix,linefix,trim(phases)\n write(*,430)jj,trim(phases)\n430 format('SMP2A invexit ',i3,' >>> ',a)\n! The code above is for the FIRST exit line\n! Here we will create 2 exit lines using nodeout(1,jj) and nodeout(2,jj)\n! with jj=1..nexit, repeat with switched linefix/nodefix\n do qq=1,nexit\n linefix=nodeout(1,qq)\n nodefix=nodeout(2,qq)\n doubline=0\n392 continue\n jj=jj+1\n newnode%linehead(jj)%linefixph%ixphase=invph(1,linefix)\n newnode%linehead(jj)%linefixph%compset=invph(2,linefix)\n newnode%linehead(jj)%linefix_phr=invph(3,linefix)\n invph(4,linefix)=invph(4,linefix)+1\n call get_phase_name(invph(1,linefix),invph(2,linefix),phases)\n zp=len_trim(phases)+3\n phases(zp-1:zp-1)='('\n! nodefix not always set correctly here, error in map16 running all macros\n newnode%linehead(jj)%nodfixph=invph(3,nodefix)\n invph(5,nodefix)=invph(5,nodefix)+1\n call get_phase_name(invph(1,nodefix),invph(2,nodefix),phases(zp:))\n zp=len_trim(phases)+3\n phases(zp-2:zp-2)=')'\n kk=0\n names2: do zz=1,stabph+2\n if(zz.eq.linefix .or. zz.eq.nodefix) cycle names2\n kk=kk+1\n if(kk.le.stabph) then\n newnode%linehead(jj)%stableph(kk)%ixphase=invph(1,zz)\n newnode%linehead(jj)%stableph(kk)%compset=invph(2,zz)\n newnode%linehead(jj)%stablepham(kk)=1.0D-2\n newnode%linehead(jj)%stable_phr(kk)=invph(3,zz)\n else\n write(*,'(a,10i5)')'SMP2 too many stable phases: ',jj,kk,zz,&\n invph(1,zz),invph(2,zz),linefix,nodefix\n endif\n call get_phase_name(invph(1,zz),invph(2,zz),phases(zp:))\n zp=len_trim(phases)+2\n enddo names2\n write(*,430)jj,trim(phases)\n if(doubline.eq.0) then\n! we have switch linefix and nodefis to create one more exit line\n doubline=linefix\n linefix=nodefix; nodefix=doubline\n phases=' '\n goto 392\n endif\n enddo\n490 continue\n! stop ' *** Unfinished invariant isopleth node exits *** '\n end select exits\n!=========================================================================\n goto 1000\n!------------------------------------------- \n! we have found a node with same chemical potentials\n! we should perhaps also check the set of phases ... ???\n800 continue\n if(ocv()) write(*,*)'This node already found',mapnode%seqx\n! we set a link in the mapline record to this node and has finished!\n mapline%end=>mapnode\n if(ocv()) write(*,*)'Line: ',mapline%lineid,' ends in node: ',mapnode%seqx\n! >>> We must also mark the \"%done=-1\" in the linehead record corresponding to\n! the line we just followed. \n! \n1000 continue\n return\n end subroutine map_newnode ! redefined argument mecreq to mecreq1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine sort_invph\n!\\begin{verbatim}\n subroutine sort_invph(nitems,ndim,array)\n! primitive sorting of array\n implicit none\n integer nitems,ndim,array(ndim,*)\n!\\end{verbatim}\n! sort array in acending order of value in array(3,*) \n integer ia,ib,ic,more\n more=nitems\n ia=1\n do while(more.gt.0)\n more=0\n do ia=2,nitems\n if(array(3,ia-1).gt.array(3,ia)) then\n more=more+1\n do ic=1,ndim\n ib=array(ic,ia-1); array(ic,ia-1)=array(ic,ia); array(ic,ia)=ib\n enddo\n endif\n enddo\n enddo\n1000 continue\n end subroutine sort_invph\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_inv_exits\n!\\begin{verbatim}\n subroutine find_inv_exits(nexit,phut,phin,stabph,invph,dim1,axarr,thisceq)\n! Find the phases to be linefix when nodefix with zero amount at the invariant\n! NEW IDEA (N is numbe of elements)\n! 1. extract the composition of all stable phases at invariant (N+1)\n! 2. set up a system of linear equations M_j x_ij = c_i\n! where x_ij is composition of component i in phase j, c_i is the condition\n! for component i, (N-1 conditions) and M_j amount of phase j\n! 3. The cases when his system has a solution represent exits!\n! This also solves the problem with the number of exits!\n! The conditions must be simple, such as x(cr)=0.05 ...\n! Normal conditions are T, P, N and x, with N-1 x conditions.\n! For 5 components, 6 phases at invariant, 4 mass balance conditions\n! input/output:\n! nexit is number of pairs that form two exit lines\n! phut(1,*) and (2,*) are two phases with zero amount at the invariant\n! phin is on enter the two phase with zero amount when the invariant is found\n! stabph is number of stable phases along the lines, at node point 2 more stable\n! invph is matrix with all phases at the node, dim1 is its first dim\n! dim1 is first dimension of invph\n! axarr has axis information (needed to maniplulate conditions)\n! eqcopy1 is array with phase anounts and constitutions at new point (not used)\n! linerec is a line record with all necessary data to calculate en equil\n implicit none\n integer nexit,phut(2,*),phin(2),stabph,dim1,invph(dim1,*),par(2)\n type(map_axis), dimension(*) :: axarr\n double precision, dimension(:), allocatable :: eqcopy1\n type(gtp_equilibrium_data), pointer :: thisceq\n! type(map_line), pointer :: linerec\n!\\end{verbatim}\n double precision, allocatable, dimension(:) :: condval,rhs\n double precision, allocatable, dimension(:,:) :: phaseval,test\n type(gtp_condition), pointer :: lastcond,pcond,axcond\n type(gtp_state_variable), pointer :: statevar\n! assume less than 20 components ...\n integer, parameter :: mcomp=20\n character text*32,ch1*1\n integer, allocatable, dimension(:) :: ipiv,jphase\n type(gtp_state_variable), dimension(mcomp), target :: stvarray\n!\n integer ii,jj,kk,mm,ip,seqz,ncomp,ncomp1,info,ldb,zz\n! dim is number of phases at the invariant, dim-1 is number of components\n! For 5 components, 6 phases at invariant, select 4 phases to find exit\n! x_ij is fraction of j in phase i\n! x_11 + x_21 + x_31 N_1 C_1 \n! ( x_12 + x_22 + x_32 ) ( N_2 ) = ( C_2 ) \n! x_13 + x_23 + x_33 N_3 C_3 \n! 1 1 1 N_4 1\n! to find N_i (which must be >0). The two excluded phases represet the exit\n!\n! 1. extract all condition values, skip the axis condition\n allocate(condval(stabph-1))\n lastcond=>thisceq%lastcondition\n pcond=>lastcond%next\n ncomp=0\n cloop: do while(.true.)\n cskip: if(pcond%active.eq.0) then\n! this is an active condition, extract the state variable record\n statevar=>pcond%statvar(1)\n if(statevar%statevarid.ge.10 .and. statevar%argtyp.eq.1) then\n! statevarid>=10 is extensive condition on a component\n seqz=pcond%seqz\n! skip axis conditions\n if(seqz.eq.axarr(1)%seqz .or. seqz.eq.axarr(1)%seqz) exit cskip\n! There must not be any terms\n if(pcond%noofterms.gt.1) cycle cloop\n ip=1\n ncomp=ncomp+1\n! remember the state variable to be used extracting values from phases\n stvarray(ncomp)=statevar\n if(ncomp.gt.mcomp) stop 'SMP Too many components'\n condval(ncomp)=pcond%prescribed\n! call get_one_condition(ip,text,seqz,thisceq)\n! write(*,*)'SMP condition: ',trim(text),ncomp,condval(ncomp)\n endif\n endif cskip\n if(associated(pcond,lastcond)) exit cloop\n pcond=>pcond%next\n enddo cloop\n! we must have extracted stabph-1 extensive conditions ...\n if(ncomp.ne.stabph-1) then\n write(*,*)'SMP too few conditions for invariants',ncomp,stabph-2\n gx%bmperr=4399; goto 1000\n endif\n! 2. extract all phase compositions, for stabph+2 phases and ncomp compositions\n allocate(phaseval(ncomp,stabph+2))\n do ii=1,stabph+2\n do jj=1,ncomp\n! insert phase index to get phase composition\n stvarray(jj)%argtyp=3\n stvarray(jj)%phase=invph(1,ii)\n stvarray(jj)%compset=invph(2,ii)\n! this subroutine uses character as argument\n! call get_state_var_value(stvarray(jj),phaseval(jj,ii),text,thisceq)\n! this subroutine uses state variable as argument\n statevar=>stvarray(jj)\n call state_variable_val(statevar,phaseval(jj,ii),thisceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP error extracting phase value',trim(text),ii,jj\n goto 1000\n endif\n enddo\n enddo\n!----------------------------------\n! This is the invariant used to debug this \n!Output for equilibrium: 1, DEFAULT_EQUILIBRIUM 2020.04.28\n!Conditions .................................................:\n! 1:P=100000, 2:N=1, 3:W%(CR)=5, 4:W%(MO)=8, 5:W%(V)=1, 6:=0,\n! 7:=0\n! Degrees of freedom are 0\n!\n!Some global data, reference state SER ......................:\n!T= 1232.69 K ( 959.54 C), P= 1.0000E+05 Pa, V= 6.4311E-06 m3\n!N= 1.0000E+00 moles, B= 5.4289E+01 g, RT= 1.0249E+04 J/mol\n!G= -6.09563E+04 J, G/N=-6.0956E+04 J/mol, H= 3.4334E+04 J, S= 7.730E+01 J/K\n!\n!Some data for components ...................................:\n!Component name Moles Mass-fr Chem.pot/RT Activities Ref.state\n!C 7.1177E-02 0.01575 -3.2298E+00 3.9566E-02 SER (default)\n!CR 5.2205E-02 0.05000 -7.7539E+00 4.2908E-04 SER (default)\n!FE 8.2069E-01 0.84425 -5.8469E+00 2.8888E-03 SER (default)\n!MO 4.5269E-02 0.08000 -8.0031E+00 3.3442E-04 SER (default)\n!V 1.0657E-02 0.01000 -1.4256E+01 6.4376E-07 SER (default)\n!\n!Some data for phases .......................................:\n!Name Status Mass Volume Form.Units Cmp/FU dGm/RT Comp:\n!FCC_A1#1................ E 4.802E-02 6.36E-06 8.48E-01 1.03 0.00E+00 W:\n! FE 9.34742E-01 MO 2.09038E-02 C 7.38762E-03 V 1.04403E-03\n! CR 3.59223E-02\n!\n!MC_FCC_A1#2............. E 7.219E-04 6.12E-09 9.35E-03 1.86 0.00E+00 W:\n! MO 4.38724E-01 C 1.33163E-01 CR 4.68908E-02 FE 6.00860E-03\n! V 3.75214E-01\n!\n!HCP_A3.................. E 3.954E-03 6.74E-08 4.54E-02 1.50 0.00E+00 W:\n! MO 7.20128E-01 FE 7.62966E-02 C 6.87569E-02 V 4.49350E-02\n! CR 8.98830E-02\n!\n!KSI_CARBIDE............. F 0.000E+00 0.00E+00 0.00E+00 4.00 0.00E+00 W:\n! FE 4.58671E-01 CR 9.59266E-02 C 5.64977E-02 V 0.00000E+00\n! MO 3.88905E-01\n!\n!M23C6................... F 0.000E+00 0.00E+00 0.00E+00 29.00 0.00E+00 W:\n! FE 5.94954E-01 MO 1.04967E-01 C 5.17714E-02 V 1.20517E-04\n! CR 2.48187E-01\n!\n!M7C3.................... E 1.590E-03 0.00E+00 3.67E-03 10.00 0.00E+00 W:\n! FE 4.01696E-01 MO 1.09953E-01 C 8.31013E-02 V 2.77992E-02\n! CR 3.77451E-01\n!\n! In alphabetical order of phases and components (mass percent)\n! Phase Cr Mo V Mass of phase ??\n! FCC 3.59223 2.09038 0.1044 0.04802\n! MC_FCC 4.68908 43.8724 37.5214 0.0007219\n! HCP 8.98830 72.0128 4.4925 0.003954\n! KSI 9.59266 38.8905 0 0\n! M23 24.8187 10.4967 0.00012 0\n! M7 37.7451 10.9953 2.77992 0.001590 \n!-----------------------------------\n! debug:\n! do ii=1,stabph+2\n! write(*,88)'SMP all: ',ii,(phaseval(jj,ii),jj=1,ncomp)\n! enddo\n88 format(a,i3,6(1pe12.4))\n! The code gives: (in mass percent) \n! 3.5822 2.0904 0.1044 etc ...\n! ALL CORRECT!! WOW\n! (missing in list result is mass %! I have only mass fraction)\n!\n! 3. select submatrix with dim-2 phases and solve for phase fractions.\n! For solutions with phase phase fractions >0 the 2 excluded phases\n! are exits.\n nexit=0\n ncomp1=ncomp+1\n allocate(test(ncomp1,ncomp1))\n allocate(rhs(ncomp1))\n allocate(ipiv(ncomp1))\n! I am not certain of this dimensioning ...\n allocate(jphase(ncomp1*(ncomp1+1)))\n! allocate(lukas(ncomp1+1,ncomp1))\n! All possible ncomp x ncomp marices from phaseval are solved for phase amounts\n! for the correct content of the components. One should find phin!\n! This means we actually have 3 phases with zero amount at the lines??\n! The matrix phaseval has stabph+2 rows and columns\n! We must copy this to test eliminating 3 rows\n! THIS WAY OF GENERATING ALL COMBINATIONS OF ncomp x nacomp MATRICES IS\n! involved but seems to work .... WoW\n do ii=1,ncomp1\n jphase(ii)=ii\n enddo\n zz=0\n kloop: do while(.true.)\n zz=zz+1\n! write(*,'(a,10i3)')'SMP subset ----------- ',zz,jphase\n! test is destroyed when solving the system of linear equations\n! and must be regenerated totally each time\n test=zero\n! copy fractions from phaseval(P,*) represent fractions in phase P\n! test(*,K) is fractions in all phases for component K\n do jj=1,ncomp1\n do kk=1,ncomp\n test(kk,jj)=phaseval(kk,jphase(jj))\n enddo\n enddo\n! last line should be a row of 1.0\n do kk=1,ncomp1\n test(ncomp1,kk)=one\n enddo\n! do jj=1,ncomp1\n! write(*,88)'SMP sub: ',zz,(test(jj,kk),kk=1,ncomp1)\n! enddo\n!------------------------\n! this should be the solving ...\n! LAPACK routine to L*U factorize A, the original A is destroyed\n! call dgetrf(trans,n,nrhs,a,lda,ipiv,b,ldb,info)\n! ipiv is array with N pivot \n ldb=ncomp1\n call dgetrf(ncomp1,ncomp1,test,ldb,ipiv,info)\n if(info.ne.0) then\n write(*,*)'SMP error from dgetrf',info\n! some combination of phases may not work, just skip\n goto 100\n! gx%bmperr=4399; goto 1000\n endif\n! solve the system of linear equations, X is overwritten by solution\n! call dgetrs(trans,n,nrhs,a,lda,ipiv,b,ldb,info)\n do kk=1,ncomp\n rhs(kk)=condval(kk)\n enddo\n rhs(ncomp1)=one\n! write(*,'(a,10(1pe10.2))')'SMP rhs: ',rhs\n call dgetrs('N',ncomp1,1,test,ldb,ipiv,rhs,ldb,info)\n if(info.ne.0) then\n! some combination of phases may not work, just skip\n goto 100\n! write(*,*)'SMP error from dgetrs',info\n! gx%bmperr=4399; goto 1000\n endif\n600 continue\n! write(*,'(a,10(1pe10.2))')'SMP phase amounts: ',rhs\n! check if all amounts greater than zero\n do kk=1,ncomp1\n if(rhs(kk).le.zero) goto 100\n enddo\n! write(*,'(a,10(1pe11.3))')'SMP phase amounts: ',rhs\n! Wow, now it works, but I must find which phases are excluded\n! A very clumsy set to find which two phases that are excluded ...\n zz=0\n ex1: do jj=1,stabph+2\n do kk=1,stabph+2\n if(jphase(kk).eq.jj) cycle ex1\n enddo\n zz=zz+1; par(zz)=jj\n enddo ex1\n! write(*,'(a,20i3)')'SMP solution ',zz,jphase,0,phin,par\n! write(*,'(a,20i3)')'SMP solution ',zz,phin,par\n! we must have found 2 phases ... bug using map15\n if(zz.ne.2) goto 100\n! check if solution equal to phin\n if((par(1).eq.phin(1) .or. par(1).eq.phin(2)) .and. &\n (par(2).eq.phin(1) .or. par(2).eq.phin(2))) then\n continue\n! write(*,'(a,2i3,3x,2i2)')'SMP same as phin: ',par,phin\n else\n nexit=nexit+1\n phut(1,nexit)=par(1)\n phut(2,nexit)=par(2)\n endif\n! read(*,'(a)')ch1\n! here we have solved the system of linear equations\n!------------------------\n100 continue\n! exclude a different phase in jphase ...\n jj=ncomp1\n kk=0\n jloop: do while(.true.)\n jphase(jj)=jphase(jj)+1\n if(jphase(jj).gt.stabph+2-kk) then\n jj=jj-1\n kk=kk+1\n if(jj.ge.1) cycle jloop\n exit kloop\n else\n exit jloop\n endif\n! increment all values in jphase after jj\n enddo jloop\n do kk=jj+1,ncomp1\n jphase(kk)=jphase(kk-1)+1\n enddo\n enddo kloop\n! now we have found the all exits ...\n! write(*,'(a,i3,5(i5,i3))')'SMP exits: ',nexit,&\n! (phut(1,jj),phut(2,jj),jj=1,nexit)\n!\n1000 continue\n return\n end subroutine find_inv_exits\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_inv_nodephase\n!\\begin{verbatim}\n subroutine find_inv_nodephase(phut,phin,stabph,invph,dim1,axarr,&\n eqcopy1,linerec)\n! Find the phase to set as linefix when nodefix has zero amount\n! phut will on exit be two phases with zero amount at the invariant\n! phin is on enter the two phase with zero amount when the invariant is found\n! stabph is number of stable phases along the lines, at node point 2 more stable\n! invph is matrix with all phases at the node, dim1 is its first dim\n! axarr has axis information (needed to manipulate conditions)\n! eqcopy1 is array with phase anounts and constitutions at new point (not used)\n! linerec is a line record with all necessary data to calculate en equil\n implicit none\n integer phut(2),phin(2),stabph,dim1,invph(dim1,*)\n type(map_axis), dimension(*) :: axarr\n double precision, dimension(:), allocatable :: eqcopy1\n type(map_line), pointer :: linerec\n!\\end{verbatim}\n! linefix and nodefix is 2nd index in invph(5,*)\n type(gtp_condition), pointer :: lastcond,pcond,pcondx,pcondt\n! type(gtp_equilibrium_data), target :: thisceq1\n type(gtp_equilibrium_data), pointer :: thisceq\n integer linefix,nodefix,reset,ph1,ph2,lokcs1,lokcs2,onemoretry\n integer ii,jj,kk,nodeph,mapx,iadd,irem,iz,jax,mode,okcond,lokph,zeroam\n character*24 phname1,phname2,phname3,phname4\n double precision, parameter :: mamfu=1.0D-6,mdgm=1.0D-4\n double precision, dimension(:), allocatable :: eqcopy\n!\n! we must set the axis condition on T and\n! remove the axis condition on the composition on the other axis\n!-------------------- copied from somewhere ...................\n! write(*,10)phin,stabph,linerec%lineceq%tpval(1)\n10 format(/'SMP find_inv exits from isopleth invariant: ',2i4,2x,i2,F10.2)\n reset=globaldata%status\n! supress messages from calceq3 done inside find_inv\n globaldata%status=ibset(globaldata%status,GSSILENT)\n globaldata%status=ibclr(globaldata%status,GSSILENT)\n! I wonder how much is copied when I use = ...?\n! lineceq is an equilibrium record in eqlista ...\n thisceq=>linerec%lineceq\n write(*,*)'SMP exit equilibrum: ',thisceq%eqname\n! constitution is OK here\n! call list_conditions(kou,linerec%lineceq)\n! call list_sorted_phases(kou,thisceq)\n! write(*,*)'SMP constitution entering find_inv'\n! suspend all phases not involved in the invariant, 1 means suspend\n call suspend_somephases(1,invph,6,stabph+2,thisceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP error calling suspend_somephases'; goto 1000\n endif\n if(allocated(eqcopy)) deallocate(eqcopy)\n call save_phase_constitutions(0,thisceq,eqcopy)\n if(gx%bmperr.ne.0) goto 1000\n! loop both axis to extract condition pointer\n okcond=0\n do jax=1,2\n! Set the condition on T and remember the condition on composition\n lastcond=>thisceq%lastcondition\n if(.not.associated(lastcond)) then\n write(*,*)'in find_inv, no conditions: ',jax\n gx%bmperr=4221; goto 1000\n endif\n pcond=>lastcond\n60 continue\n pcond=>pcond%next\n if(pcond%seqz.eq.axarr(jax)%seqz) goto 70\n if(.not.associated(pcond,lastcond)) goto 60\n write(*,*)'in find_inv the axis condition not found: ',jax\n gx%bmperr=4221; goto 1000\n!\n70 continue\n if(pcond%statev.ge.10) then\n! save pointer to extensive condition and remove it\n pcond%active=1\n okcond=okcond+1\n pcondx=>pcond\n elseif(pcond%statev.eq.1) then\n! set condition on T as active\n okcond=okcond+1\n pcondt=>pcond\n! try setting two fix phases .... remove condition on T\n! pcond%active=1\n endif\n enddo\n if(okcond.ne.2) then\n write(*,*)'Conditions not T and X, quitting'\n gx%bmperr=4399\n goto 1000\n endif\n!----------------- end copy from somewhere.................\n! most of these variables are just for debugging\n ph1=phin(1)\n ph2=phin(2)\n! extract the name of the linefix and nodefix phases\n call get_phase_name(invph(1,ph1),invph(2,ph1),phname1)\n call get_phase_name(invph(1,ph2),invph(2,ph2),phname2)\n! set small amounts of ph1 ??\n! call change_many_phase_status(phname1,PHENTSTAB,mamfu,thisceq)\n! call change_many_phase_status(phname1,PHENTSTAB,zero,thisceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'SMP error setting zero of line/nodefix'\n! goto 1000\n! endif\n! below we check the amounts and driving forces of both linefix and nodefix\n! Note the phase_varres indices are the same in all equilibria!\n call get_phase_compset(invph(1,ph1),invph(2,ph1),lokph,lokcs1)\n call get_phase_compset(invph(1,ph2),invph(2,ph2),lokph,lokcs2)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP find_inv failed get phase_varres index'\n goto 1000\n endif\n! remove the condition on compostion and set fix T\n pcondx%active=1\n pcondt%active=0\n!-------------------------------------------------------\n!\n! the loop below tries set fix one phase at a time to discover an exit\n! where one other phase is stable with zero amount\n! Initial amounts of phases and constitutions are in eqcopy\n! all calculations below are made at fixed T with different fix phases\n! afterwards we check that the amount of nodefix is still zero (or very small)\n! total number of phases at nodepoint is stabph+2\n call list_sorted_phases(kou,0,thisceq)\n write(*,*)'SMP above listing for initial set of stable phases',gx%bmperr\n loop: do ii=1,stabph+2\n unused: if(invph(4,ii).eq.0 .and. invph(5,ii).eq.0) then\n! only test phases which has not already been used, extract its name\n call get_phase_name(invph(1,ii),invph(2,ii),phname3)\n onemoretry=0\n! jump back here to try with a small amount of phname1 or phname2 (no good)\n50 continue\n! restore inital amounts and constitutions 1 copies from eqcopy to thisceq\n call save_phase_constitutions(1,thisceq,eqcopy)\n call list_sorted_phases(kou,0,thisceq)\n write(*,76)trim(phname3),ii,thisceq%tpval(1),gx%bmperr\n76 format(/'SMP find_inv ******** testing as fixed: ',a,i4,F10.2,i7)\n! set ii fix with zero amount\n call change_many_phase_status(phname3,PHFIXED,zero,thisceq)\n! debug listing\n call list_conditions(kou,thisceq)\n write(*,*)'SMP find_inv call calceq3:',gx%bmperr,onemoretry\n mode=0\n call calceq3(mode,.FALSE.,thisceq)\n if(gx%bmperr.ne.0) then\n! calculation error, remove phase ii as fix and try another\n write(*,*)'SMP find_inv error finding exit with fix: ',&\n trim(phname3),gx%bmperr\n gx%bmperr=0\n call list_conditions(kou,thisceq)\n call list_sorted_phases(kou,0,thisceq)\n! remove this phase as fix and continue loop\n goto 120\n endif\n! debug listing\n call list_conditions(kou,thisceq)\n call list_sorted_phases(kou,0,thisceq)\n write(*,*)'SMP find_inv: phases AFTER calculations',gx%bmperr\n jj=0\n zeroam=0\n zeroloop: do kk=1,stabph+2\n! At any exit all phases invph should have almost zero dgm\n if(abs(thisceq%phase_varres(invph(6,kk))%dgm).gt.mdgm) then\n write(*,*)'SMP too negative dgm: ',kk,&\n thisceq%phase_varres(invph(6,kk))%dgm\n! exit unused\n endif\n if(thisceq%phase_varres(invph(6,kk))%amfu.lt.mamfu) then\n! we have a phase with zero amount\n if(kk.ne.ii) then\n if(zeroam.eq.0) then\n zeroam=kk\n else\n write(*,*)'SMP two or more zero amount phases'\n endif\n endif\n else\n jj=jj+1\n endif\n enddo zeroloop\n! write(*,*)'SMP number of stable phases',jj,stabph\n! call list_sorted_phases(kou,thisceq)\n if(jj.ne.stabph) then\n write(*,'(a,2i3,F10.2)')'SMP Skip wrong number of stable phases',&\n jj,stabph+2,thisceq%tpval(1)\n goto 120\n endif\n write(*,'(a,3(i5,i3))')'SMP phin: ',jj,stabph,invph(4,phin(1)),&\n invph(5,phin(1)),invph(4,phin(2)),invph(5,phin(2))\n! select either phin(1) or phin(2) if free and zero amount with this phase\n if(invph(4,phin(1)).eq.1 .and.&\n thisceq%phase_varres(lokcs1)%amfu.lt.mamfu) then\n! phase invph(*,ii) and invph(*,phin(1)) have zero amount, use as exit?\n! ADD CHECK IF amfu for BOTH phin(1) and ph(2) are zero we must check dgm ...\n phut(1)=ii; phut(2)=phin(1)\n write(*,112)trim(phname3)//'+'//trim(phname1),phut(1),phut(2),&\n thisceq%tpval(1)\n112 format('SMP find_inv **** success: ',a,2i4,F10.2)\n goto 200\n elseif(invph(4,phin(2)).eq.1 .and. &\n thisceq%phase_varres(lokcs2)%amfu.lt.mamfu) then\n! phase invph(*,ii) and invph(*,phin(1)) have zero amount, use this as exit\n phut(1)=ii; phut(2)=phin(2)\n write(*,112)trim(phname3)//'+'//trim(phname2),phut(1),phut(2),&\n thisceq%tpval(1)\n goto 200\n elseif(invph(4,phin(1)).eq.1 .and. invph(4,phin(2)).eq.1) then\n! This is first call to find_inv and we have found two new phases with\n! zero amount. We do not need to find any more!\n call get_phase_name(invph(1,zeroam),invph(2,zeroam),phname4)\n! Indicae this by setting it negative!\n phut(1)=ii; phut(2)=-zeroam\n write(*,114)trim(phname3)//'+'//trim(phname4),phut(1),-phut(2),&\n thisceq%tpval(1)\n114 format('SMP find_inv **** success BUT IGNORED: ',a,2i4,F10.2)\n else\n call list_sorted_phases(kou,0,thisceq)\n write(*,113)trim(phname3),trim(phname1)//' nor '//trim(phname2)\n113 format('SMP Skipping ',a,' as neither ',a,' has zero amount')\n endif\n120 continue\n! Failed but make two more tries. Constitutions restored above\n! if(onemoretry.eq.0) then\n! try once more ...\n! write(*,*)'SMP try one more time with fix ',trim(phname3)\n! call change_many_phase_status(phname1,PHENTSTAB,1.0D-2,thisceq)\n! onemoretry=1\n! goto 50\n! elseif(onemoretry.eq.1) then\n! try once more ...\n! onemoretry=2\n! write(*,*)'SMP try one more time with fix ',trim(phname3)\n! call change_many_phase_status(phname2,PHENTSTAB,1.0D-2,thisceq)\n! goto 50\n! endif\n! giv up on this fix phase\n endif unused\n! try another fix phase ...\n call change_many_phase_status(phname3,PHENTERED,zero,thisceq)\n if(gx%bmperr.ne.0) goto 1000\n enddo loop\n! we have not found any set of phases for an exit line\n! if we arrive here we should maybe try 2 fix phases and release T?\n write(*,*)'SMP find_inv failed to find two phases with zero amount'\n gx%bmperr=4399; goto 1000\n200 continue\n! we have a pair of phases in phut, reset phname3 as entered\n call change_many_phase_status(phname3,PHENTERED,zero,thisceq)\n! copy constitution from thisceq to eqcopy, then copy to linerec%lineceq\n! call save_phase_constitutions(1,thisceq,eqcopy)\n if(allocated(eqcopy)) deallocate(eqcopy)\n call save_phase_constitutions(0,thisceq,eqcopy)\n call save_phase_constitutions(1,linerec%lineceq,eqcopy)\n if(gx%bmperr.ne.0) write(*,*)'Problem to copy constitutions'\n!----------------------------- exit\n1000 continue\n ii=gx%bmperr; gx%bmperr=0\n! restore axis conditions, set x condition and remove T condition\n pcondx%active=0\n pcondt%active=1\n! If we have found an exit the phase set and constitution are in thisceq\n! Restore phases earlier suspended, 0 menas restore\n call suspend_somephases(0,invph,6,stabph+2,thisceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP error calling suspend_somephases'; goto 1000\n endif\n if(allocated(eqcopy)) deallocate(eqcopy)\n gx%bmperr=ii\n! reset globaldata%status\n globaldata%status=reset\n return\n end subroutine find_inv_nodephase\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine reserve_saveceq\n!\\begin{verbatim}\n subroutine reserve_saveceq(location,saveceq)\n! must be THREADPROTECTED\n! location index of reserved ceq record in saveceq\n implicit none\n integer location\n type(map_ceqresults), pointer :: saveceq\n!\\end{verbatim}\n location=saveceq%free\n! write(*,*)'SMP reserve record: ',location,saveceq%size\n! write(*,*)'Reserve place for equilibrium: ',location,saveceq%size\n if(location.eq.saveceq%size-10) then\n! indicate overflow with 5 places left if some emergency saving needed\n write(*,*)'Close to overflow in saveceq: ',saveceq%free\n gx%bmperr=4219; goto 1000\n endif\n saveceq%free=location+1\n! end THREADPROTECT\n1000 continue\n return\n end subroutine reserve_saveceq\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_findline\n!\\begin{verbatim}\n subroutine map_findline(maptop,axarr,mapfix,mapline)\n! must be THREADPROTECTED\n! Searches all node records from maptop for a map_line record to be calculated\n! ?? already been found and if so eliminate a line record ??\n! maptop map node record\n! axarr array with axis records\n! mapfix returned fixph record with phases to be ste as fixed for this line\n! mapline returned mapline record for line to be calculated\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(map_axis), dimension(*) :: axarr\n type(map_fixph), allocatable :: mapfix\n! memory leak as mapfix is allocated below ...\n! type(map_fixph), pointer :: mapfix\n!\\end{verbatim}\n type(map_node), pointer :: mapnode\n type(gtp_condition), pointer :: pcond\n type(meq_setup), pointer :: meqrec\n type(gtp_equilibrium_data), pointer :: ceq2\n type(gtp_state_variable), pointer :: svrrec,svr2\n type(gtp_state_variable), target :: svrtarget\n integer nyline,jp,seqy,iph,ics,lokph,lokcs,ip,mapx\n integer mode,nofecond,jax,activax,irem1,iadd1,irem,iadd\n integer, parameter :: inmap=1\n double precision finc,fixpham,xstab,xfix,xcorr,natpermol\n character eqname*24\n! sometimes there are many phases with long names ...\n character phaseset*512\n logical hullerombuller\n!\n mapnode=>maptop\n! for the moment skip this for tie-lines not in the plane\n! write(*,*)'In map_findline: ',mapnode%tieline_inplane\n100 continue\n! write(*,*)'Looking a lines exiting from all nodes:'\n! write(*,*)'mapnode index: ',mapnode%seqx\n if(.not.allocated(mapnode%linehead)) then\n write(*,*)'ERROR found mapnode without exits'\n nullify(mapline)\n goto 1000\n endif\n! write(*,*)'map_findline: ',mapnode%lines\n do nyline=1,mapnode%lines\n! if done is >=0 then this is a line to be calculated\n if(mapnode%linehead(nyline)%done.ge.0) then\n mapline=>mapnode%linehead(nyline)\n mapline%done=-1\n goto 500\n endif\n enddo\n! write(*,*)'findline 1: ',mapnode%seqx\n mapnode=>mapnode%next\n! write(*,*)'findline 2: ',mapnode%seqx\n if(.not.associated(mapnode,maptop)) goto 100\n! no more lines to calculate\n if(ocv()) write(*,*)'nullifying mapline as no more lines to calculate'\n nullify(mapline); goto 1000\n! jump here if we found a nyline\n!--------------------------------------------------------------------\n500 continue\n! we must copy the equilibrium record ceq to the line record\n goto 503\n!----------------------------------------------------------------------\n! code deleted\n!---------------------------------------------------------------------\n503 continue\n! write(*,*)'At label 503',mapline%firstinc\n if(mapline%firstinc.ne.zero) then\n! update the axis condition if mapline%firstinc is nonzero\n jp=abs(mapline%axandir) \n call locate_condition(axarr(jp)%seqz,pcond,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n! Wow, here is the problem !!!\n pcond%prescribed=pcond%prescribed+mapline%firstinc\n finc=mapline%firstinc\n if(ocv()) write(*,501)'Selecting line and condition: ',&\n seqy,pcond%prescribed,finc\n501 format(a,i3,2(1pe14.6))\n! if(pcond%active.ne.0) then\n! write(*,*)'Error: axis condition not active!'\n! pcond%active=0\n! endif\n endif\n! check that correct axis condition is active, maybe I have not made sure\n! that the map_line records are independent ...\n! write(*,*)'axies ',maptop%number_ofaxis\n do jp=1,maptop%number_ofaxis\n call locate_condition(axarr(jp)%seqz,pcond,mapline%lineceq)\n! write(*,*)'condition located',jp,axarr(jp)%seqz\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%active.ne.0) then\n if(jp.eq.abs(mapline%axandir)) then\n! write(*,*)'Setting axis condition active!',jp,mapline%axandir\n pcond%active=0\n! write(*,*)'map_findline: ',jp,pcond%prescribed\n endif\n else\n if(jp.ne.abs(mapline%axandir)) then\n! write(*,*)'Setting axis condition NOT active!',jp,mapline%axandir\n pcond%active=1\n endif\n endif\n enddo\n! we may have a set of stable phases in mapnode%stable_phases, maybe they\n! should be set, at least when mapping. \n! a meqrec record will be created by calceq7 at the first calculation\n! for mapping set values in mapfix about which phases that should be fix\n! or stable when calling calceq7, at present ingnore that\n!-------------------------------------------------------------\n! write(*,*)'tielines: ',maptop%tieline_inplane\n if(maptop%tieline_inplane.lt.0) then\n! ISOPLETH\n if(allocated(mapfix)) then\n deallocate(mapfix)\n endif\n allocate(mapfix)\n! with only 2 axis we have just 1 fix phase for mapping, fixph is a tuple\n allocate(mapfix%fixph(1))\n mapfix%status=0\n mapfix%nfixph=1\n mapfix%fixph=mapline%linefixph(1)\n! we can have several stable phases when no tie-lines in plane\n ip=mapline%nstabph\n allocate(mapfix%stableph(ip))\n allocate(mapfix%stablepham(ip))\n allocate(mapfix%stable_phr(ip))\n! write(*,*)'Findline: Tie-lines not in plane: ',nyline,ip\n! create a heading text for the line\n phaseset=' '\n call get_phasetuple_name(mapfix%fixph(1),phaseset)\n if(gx%bmperr.ne.0) goto 1000\n ip=len_trim(phaseset)\n phaseset(ip+1:ip+10)=', stable: '\n ip=len_trim(phaseset)+2\n if(mapnode%linehead(nyline)%nstabph.le.0) then\n write(*,*)'No stable phases for a line'\n write(*,*)'Error 14: ',nyline,mapnode%linehead(nyline)%nstabph,&\n mapnode%linehead(nyline)%stableph(1)%ixphase,&\n mapnode%linehead(nyline)%stableph(1)%compset\n mapfix%nstabph=0\n gx%bmperr=4242; goto 1000\n endif\n mapfix%nstabph=mapnode%linehead(nyline)%nstabph\n! write(*,*)'Findline: stable phases: ',mapfix%nstabph\n do jp=1,mapfix%nstabph\n! this is stored only for \"real\" nodes\n mapfix%stableph(jp)=mapnode%linehead(nyline)%stableph(jp)\n mapfix%stable_phr(jp)=mapnode%linehead(nyline)%stable_phr(jp)\n call get_phasetuple_name(mapfix%stableph(jp),phaseset(ip:))\n if(gx%bmperr.ne.0) goto 1000\n! this values hould perhaps be in linehead??\n! mapfix%stablepham(jp)=mapnode%linehead(nyline)%stablepham(jp)\n mapfix%stablepham(jp)=one\n! call get_phase_compset(mapfix%stableph(1)%phase,&\n! mapfix%stableph(1)%compset,lokph,lokcs)\n! mapline%lineceq%phase_varres(lokcs)%amfu=one\n ip=len_trim(phaseset)+2\n enddo\n write(kou,520)mapline%lineid,mapline%lineceq%tpval(1),phaseset(1:ip)\n520 format(/'Line ',i3,' T=',F8.2,' fix: ',a)\n!-------------------------------------------------------------\n elseif(maptop%tieline_inplane.gt.0) then\n! TIE-LINES IN PLANE, NOTE: meqrec not allocated!!\n! if(mapnode%nodefix%phase.gt.0) then\n! write(*,*)'We have to set the fix phase along the line: ',&\n! mapnode%nodefix%phase,mapnode%nodefix%compset\n! phr no longer allocated ...\n! iph=mapnode%meqrec%phr(mapnode%fixph)%iph\n! ics=mapnode%meqrec%phr(mapnode%fixph)%ics\n! call get_phase_compset(iph,ics,lokph,lokcs)\n! write(*,*)'Setting phase status as fixed, phase_varres: ',lokcs\n! mapline%lineceq%phase_varres(lokcs)%status2=&\n! ibset(mapline%lineceq%phase_varres(lokcs)%status2,PHFIXED)\n! endif\n! mapline here should be identical to mapnode%linehead(nyline)\n! if(ocv()) write(*,505)'In findline: add phase set for',&\n! write(*,505)'In findline: add phase set for',&\n! ' tie-lines in plane, node:',&\n! mapnode%seqx,nyline,mapnode%linehead(nyline)%nstabph,nofecond\n!505 format(/a,a,10i4)\n if(allocated(mapfix)) then\n! write(*,*)'Deallocating mapfix'\n deallocate(mapfix)\n endif\n allocate(mapfix)\n allocate(mapfix%fixph(1))\n allocate(mapfix%stableph(1))\n allocate(mapfix%stablepham(1))\n allocate(mapfix%stable_phr(1))\n mapfix%nfixph=1\n mapfix%status=0\n!.........................................................\n! trying to impove mapping with two extensive axis variables\n nofecond=0\n do jax=1,maptop%number_ofaxis\n call locate_condition(axarr(jax)%seqz,pcond,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n! active condition means pcond%active=0 !!\n if(pcond%active.eq.0) activax=jax\n if(pcond%statev.gt.10) nofecond=nofecond+1\n enddo\n! default value\n fixpham=zero\n! fix nonzero phase select!!\n! if(nofecond.eq.2) then ! trying to have nonzero fix phase ...\n if(nofecond.eq.17) then ! skip trying to have nonzero fix phase\n! ISOTHERMAL, two extensive axis variables\n! test if we can have non-zero fix phase amount. Calculate the equilibrium\n! set positive amount both in mapfix and in phase_varres ...??\n write(*,47)activax,mapline%linefixph(1)%ixphase\n47 format(/'*** Find_line nonzero fix phase',2i3,2(1pe12.4))\n mapfix%fixph=mapline%linefixph(1)\n mapfix%stablepham(1)=one\n mapfix%stableph(1)=mapnode%linehead(nyline)%stableph(1)\n mapfix%stable_phr(1)=mapnode%linehead(nyline)%stable_phr(1)\n! ceq2=>mapline%lineceq\n meqrec=>mapline%meqrec\n mapfix%nstabph=1\n write(*,54)mapfix%fixph%ixphase,mapfix%fixph%compset\n54 format('SMP fix phase: ',2i5,1pe12.4)\n write(*,55)mapfix%nstabph,mapfix%stableph%ixphase,&\n mapfix%stableph%compset,mapfix%stablepham\n55 format('SMP stable phase: ',i2,2i5,1pe12.4)\n! meqrec is allocated inside calceq7. mode=1 use gridminimizer\n! mode=0 no gridminimizer; mode=-1 no grid and no deallocation of phr\n mode=-1\n call calceq7(mode,meqrec,mapfix,mapline%lineceq)\n write(*,7)gx%bmperr,iadd,irem\n7 format('Calculated equilibrium in map_findline',3i5)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP Failed calculate equilibrium try to adjust amounts'\n gx%bmperr=0\n iadd1=0; irem1=0\n! write(*,*)'SMP2A calling meq_sameset from map_findline 1'\n call meq_sameset(irem1,iadd1,mapx,mapline%meqrec,&\n mapline%meqrec%phr,inmap,mapline%lineceq)\n write(*,*)'Check with meq_sameset: ',gx%bmperr,irem1,iadd1\n if(gx%bmperr.ne.0) then\n goto 1000\n elseif(iadd1.ne. 0 .or. irem1.ne.0) then\n write(*,*)'ignore nozero iadd or irem'\n endif\n endif\n! try to change the amount of the fix phase by selecting a composition\n! along the tieline with 30% of the fix phase\n! Now we must change a condition ...\n call locate_condition(axarr(activax)%seqz,pcond,mapline%lineceq)\n! write(*,*)'SMP2A Located condition',activax\n svrrec=>pcond%statvar(1)\n! NOTE: If we change fix/entered phase we must change axvals/axvals2\n svrtarget=svrrec\n svrtarget%argtyp=3\n! calculate composition of entered phase\n! svrtarget%phase=meqrec%phr(sj)%iph\n! svrtarget%compset=meqrec%phr(sj)%ics\n svrtarget%phase=mapfix%stableph(1)%ixphase\n svrtarget%compset=mapfix%stableph(1)%compset\n! This extracts the composition of the entered phase for first new line\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xstab,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n svrtarget%phase=mapfix%fixph(1)%ixphase\n svrtarget%compset=mapfix%fixph(1)%compset\n! This extracts the composition of the entered phase for first new line\n! we must use a pointer in state_variable_val\n svr2=>svrtarget\n call state_variable_val(svr2,xfix,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n! set fix phase amount to 0.3 as we may find a third phase along the line ..\n! but we must take into account how many moles of atoms in fix phase\n! natpermol=meqrec%phr(??fixphase)%curd%abnorm(1)\n iadd=mapfix%fixph(1)%ixphase\n write(*,*)'SMP Natpermol: ',iadd,meqrec%phr(iadd)%curd%abnorm(1)\n natpermol=one\n fixpham=0.3D0/natpermol\n xcorr=(one-fixpham)*xstab+fixpham*xfix\n write(*,71)fixpham,xstab,xfix,xcorr\n71 format('Change: ',4(1pe16.8))\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,xcorr,mapline%lineceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Cannot set axis condition'\n gx%bmperr=4399; goto 1000\n endif\n! Then call meq_sameset ignoring any new phases that tries to be stable\n iadd=0; irem=0\n! write(*,*)'SMP2A Calling meq_sameset from map_findline 2'\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,&\n mapline%meqrec%phr,inmap,mapline%lineceq)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0; goto 1000\n elseif(irem.gt.0 .or. irem.gt.0) then\n write(*,*)'ignoring new phases: ',irem,iadd\n endif\n! change the amount of the fix phase\n allocate(mapfix%fixphamap(1))\n mapfix%fixphamap(1)=fixpham\n! if hullerombuller true below then it will change fix and stable phase\n hullerombuller=.FALSE.\n mapfix%stablepham(1)=one-fixpham\n write(*,*)'find mapline conditions: '\n call list_conditions(kou,mapline%lineceq)\n! goto 1000\n!..................................\n else\n!-----------------------------------------------------------------------\n! with a potential axis ?\n! we should check that the not-fixed phase can vary composition ...\n! write(*,*)'SMP2A using code with nofecond.ne.17 !!'\n ip=mapnode%linehead(nyline)%stableph(1)%ixphase\n! fixedcomposition is a logical funtion in gtp3F.F90\n if(fixedcomposition(ip)) then\n mapfix%fixph=mapnode%linehead(nyline)%stableph(1)\n hullerombuller=.TRUE.\n! write(*,*)'Selecting other phase as fix',mapfix%fixph%ixphase,&\n! mapfix%fixph%compset\n else\n! write(*,*)'Changing fix phase: ',mapline%linefixph(1)%ixphase,&\n! mapline%linefixph(1)%compset\n mapfix%fixph=mapline%linefixph(1)\n hullerombuller=.FALSE.\n endif\n endif\n! create a heading text for the line\n phaseset=' '\n call get_phasetuple_name(mapfix%fixph(1),phaseset)\n if(gx%bmperr.ne.0) goto 1000\n ip=len_trim(phaseset)+4\n phaseset(ip-2:ip-2)='+'\n! It seems to be diffcult to reset tjis variable ....\n repeatederr=0\n! write(*,*)'Fixed phase: ',mapfix%nfixph,&\n! mapfix%fixph%ixphase,mapfix%fixph%compset\n if(mapnode%linehead(nyline)%nstabph.gt.0) then\n! this is stored only for \"real\" nodes\n mapfix%nstabph=1\n if(hullerombuller) then\n mapfix%stableph(1)=mapline%linefixph(1)\n mapfix%stable_phr(1)=mapline%linefix_phr(1)\n else\n mapfix%stableph(1)=mapnode%linehead(nyline)%stableph(1)\n mapfix%stable_phr(1)=mapnode%linehead(nyline)%stable_phr(1)\n endif\n call get_phasetuple_name(mapfix%stableph(1),phaseset(ip:))\n if(gx%bmperr.ne.0) goto 1000\n! set positive amount both in mapfix and in phase_varres ...??\n mapfix%stablepham(1)=one-fixpham\n ip=len_trim(phaseset)\n if(ip.gt.1) then\n write(kou,516)mapline%lineid,&\n mapline%lineceq%tpval(1),phaseset(1:ip)\n516 format(/'New line: ',i3,' T=',F8.2,' with: ',a)\n! write(*,507)' *** Phase fix: ',mapfix%fixph(1)%ixphase,&\n! mapfix%fixph(1)%compset,', entered: ',&\n! mapfix%stableph(1)%ixphase,&\n! mapfix%stableph(1)%compset,', old node: ',mapline%nodfixph\n507 format(a,2i3,a,2i3,a,2i3)\n else\n write(kou,521)\n521 format(/'Line with unknown phases, wow')\n endif\n else\n write(*,*)'No stable phase!! why??'\n write(*,*)'stable 4: ',nyline,mapnode%linehead(nyline)%nstabph,&\n mapnode%linehead(nyline)%stableph(1)%ixphase,&\n mapnode%linehead(nyline)%stableph(1)%compset\n mapfix%nstabph=0\n endif\n! write(*,*)'SMP looking for segmentation fault'\n!-------------------------------------------------------------\n else\n! For STEP we should set a small positive amount of a new stable phase\n! if(mapnode%nodefix%phaseix.gt.0) then\n if(mapnode%nodefix%ixphase.gt.0) then\n! If the fix phase at the node was disappearing the phase index is negative\n! write(*,*)'Add a small amount to the new stable phase: ',&\n! mapnode%nodefix%phase,mapnode%nodefix%compset\n! call get_phase_compset(abs(mapnode%nodefix%phaseix),&\n call get_phase_compset(abs(mapnode%nodefix%ixphase),&\n mapnode%nodefix%compset,lokph,lokcs)\n mapline%lineceq%phase_varres(lokcs)%amfu=1.0D-2\n endif\n!\n phaseset=' '\n ip=1\n do jp=1,mapnode%linehead(1)%nstabph\n call get_phasetuple_name(mapnode%linehead(1)%stableph(jp),&\n phaseset(ip:))\n if(gx%bmperr.ne.0) goto 1000\n ip=len_trim(phaseset)+2\n enddo\n if(ip.gt.1) then\n! just to get current value of axis condition\n call locate_condition(axarr(1)%seqz,pcond,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(1,pcond,finc,mapline%lineceq)\n if(gx%bmperr.ne.0) goto 1000\n write(kou,522)mapline%lineid,finc,phaseset(1:ip)\n522 format(/'Line ',i3,' from ',1pe14.6,' with: ',a)\n else\n write(*,*)'Line with unkonwn stable phases: ',&\n mapnode%linehead(1)%nstabph\n endif\n! write(*,*)'SMP is mapfix allocated? ',allocated(mapfix)\n! if(.not.allocated(mapfix)) then\n! for STEP calculations mapfix was normally not allocated but I need the status\n! but instead of adding this set a bit in the meqrec record after first\n! call to calceq7\n! allocate(mapfix)\n! mapfix%nfixph=0\n! mapfix%status=0\n! if(btest(mapnode%status,STEPINVARIANT)) then\n! write(*,*)'SMP invarant step node',mapnode%status\n! mapfix%status=ibset(mapfix%status,STEPINVARIANT)\n! endif\n! endif\n endif\n1000 continue\n return\n end subroutine map_findline\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine create_saveceq\n!\\begin{verbatim}\n subroutine create_saveceq(ceqres,size)\n! creates an array of equilibrium records to save calculated lines for step\n! and map. This can be very big\n type(map_ceqresults), pointer :: ceqres\n integer size\n!\\end{verbatim}\n! write(*,*)'In create saveceq',size\n integer errall\n allocate(ceqres)\n ceqres%size=size\n ceqres%free=1\n allocate(ceqres%savedceq(size),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2A Allocation error 1: ',errall\n gx%bmperr=4370; goto 1000\n endif\n1000 continue\n return\n end subroutine create_saveceq\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine delete_mapresults\n!\\begin{verbatim}\n subroutine delete_mapresults(maptop)\n! delete all saved results created by step or map\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n type(map_ceqresults), pointer :: saveceq\n TYPE(map_node), pointer :: current,nexttop,mapnode,delnode\n TYPE(map_line), pointer :: linehead\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer ieq,jj\n! integer place,lastused\n!\n if(.not.associated(maptop)) then\n write(*,*)'No step or map results to delete'\n goto 1000\n endif\n! write(*,*)'smp2A in delete_mapresults'\n current=>maptop\n! deloop: do while(associated(current))\n! write(*,*)'smp2A maybe no saveceq?',associated(current%saveceq)\n! if(associated(current%saveceq)) &\n! write(*,*)'Saved equilibria:',current%saveceq%free-1\n! current=>current%plotlink\n! enddo deloop\n! write(*,*)'All equilibria saved in mapnodes listed'\n! all mapnodes has a pointer to first where the saveceq is allocated\n current=>maptop\n do while(associated(current))\n! write(*,*)'smp2a current associated'\n if(associated(current%saveceq)) then\n if(allocated(current%saveceq%savedceq)) then\n write(*,*)'SMP: deleting saved step/map line equilibria: ',&\n current%saveceq%free-1\n deallocate(current%saveceq%savedceq)\n endif\n endif\n! adding this write avoided a segmentation fault ... no longer ...\n! write(*,*)'SMP: are there more mapnode records?',&\n! associated(current%plotlink),associated(current%next)\n nexttop=>current%plotlink\n mapnode=>current%next\n do while(.not.associated(mapnode,current))\n! write(*,*)'SMP: cleaning up more',mapnode%lines\n if(allocated(mapnode%linehead)) then\n! write(*,*)'SMP: cleaning maplines: ',size(mapnode%linehead)\n do jj=1,mapnode%lines\n! should these be deallocated explicitly??\n linehead=>mapnode%linehead(jj)\n if(allocated(linehead%axvals)) deallocate(linehead%axvals)\n if(allocated(linehead%axvals2)) deallocate(linehead%axvals2)\n if(allocated(linehead%axvalx)) deallocate(linehead%axvalx)\n enddo\n deallocate(mapnode%linehead)\n endif\n delnode=>mapnode\n mapnode=>mapnode%next\n deallocate(delnode)\n enddo\n delnode=>current\n current=>nexttop\n! deallocate the last mapnode\n if(associated(current)) deallocate(delnode)\n enddo\n write(*,*)'Deleting _MAPx equilibria'\n ceq=>firsteq\n call delete_equilibria('_MAP*',ceq)\n1000 continue\n return\n end subroutine delete_mapresults\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function tieline_inplane\n!\\begin{verbatim}\n integer function tieline_inplane(nax,axarr,ceq)\n! returns -1 if tielines are not in the plane (isopleth)\n! 0 for step calculations (nax=1)\n! 1 if tielines in the plane (binary T-X, ternary isopleths\n! set if more than one extensive variable is not axis variables\n! nax number of axis\n! axarr array with axis records\n integer nax\n type(map_axis), dimension(nax) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n type(gtp_condition), pointer :: lastcond,pcond\n integer noc,inplane,nexv,iax\n!\n inplane=0\n if(nax.eq.1) goto 1000\n lastcond=>ceq%lastcondition\n if(.not.associated(lastcond)) then\n write(*,*)'Whops, mapping with no conditions?'\n gx%bmperr=4243; goto 1000\n endif\n nexv=0\n pcond=>lastcond\n100 continue\n pcond=>pcond%next\n if(pcond%statev.gt.9) then\n! statev>10 means extensive variable, maximum one not axis variable \n! For example binary T-X has extra conditions, P,N; ternary X-X isoterm T,P,N\n! A fix chemical potential OK, a fix phase is the same as activity condition\n if(pcond%active.eq.0) then\n! active=0 means it is an active condition\n do iax=1,nax\n if(axarr(iax)%seqz.eq.pcond%seqz) goto 200\n enddo\n! we have a condition on an extensive variable that is not an axis\n nexv=nexv+1\n200 continue\n endif\n endif\n if(.not.associated(pcond,lastcond)) goto 100\n inplane=-1\n if(nexv.le.1) inplane=1\n1000 continue\n tieline_inplane=inplane\n! if(ocv()) write(*,*)'tie-line in plane return: ',inplane\n return\n end function tieline_inplane\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_map_equilibrium\n!\\begin{verbatim}\n subroutine list_map_equilibrium(maptop,mapline,axarr,xxx,typ)\n! output of all relevant infor for a failed equilibrium calculation\n! maptop map node record\n! mapline current line record\n! axarr array with axis records\n! xxx current active axis value that caused problems to calculate\n! typ indicates the type of problem\n integer typ\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(map_axis), dimension(*) :: axarr\n double precision xxx\n!\\end{verbatim}\n type(gtp_equilibrium_data), pointer :: ceq\n integer jj,nph,lokph,lokcs,fixph,fixcs\n character name*24\n double precision yyy\n! list current conditions (indicate active axis variable)\n! list stable phases\n! write(*,*)'SMP map problems: ',typ,gx%bmperr,mapline%nodfixph\n ceq=>mapline%lineceq\n call list_conditions(kou,ceq)\n! There is only one fix phase at all mapping at present !!\n jj=1\n fixph=mapline%meqrec%fixph(1,jj) \n fixcs=mapline%meqrec%fixph(2,jj)\n!\n! nph=noofphasetuples()\n nph=nooftup()\n write(*,66,advance='no')\n66 format('Phases: ')\n do jj=1,nph\n lokcs=phasetuple(jj)%lokvares\n if(ceq%phase_varres(lokcs)%phstate.eq.PHENTSTAB) then\n yyy=ceq%phase_varres(lokcs)%amfu\n call get_phase_name(phasetuple(jj)%ixphase,phasetuple(jj)%compset,&\n name)\n if(phasetuple(jj)%ixphase.eq.fixph .and. &\n phasetuple(jj)%compset.eq.fixcs) then\n write(*,67,advance='no')'*'//trim(name)//'=',yyy\n else\n write(*,67,advance='no')trim(name)//'=',yyy\n endif\n67 format(a,F4.1,1x)\n elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then\n! Ahhh, the fix phase is not set as condition in ceq!!\n call get_phase_name(phasetuple(jj)%ixphase,phasetuple(jj)%compset,&\n name)\n write(*,67,advance='no')'*'//trim(name)//' '\n endif\n enddo\n write(*,77)'SMP: ',fixph,fixcs,mapline%axandir,xxx\n77 format(/,a,3i3,1pe14.6)\n! try for the AL-Cr-Ni case ... tuple 16, FCC_L12#2, should not be stable ...\n! lokcs=phasetuple(16)%lokvares\n! ceq%phase_varres(lokcs)%phstate=PHENTERED\n! 15 is FCC_L12 is fix with 1 mole! try changing amounts\n! ceq%phase_varres(14)%amfu=one\n! ceq%phase_varres(15)%amfu=zero\n! 15 is FCC_L12 is fix with 1 mole! try changing fix phase to 14 BCC\n! I think meqrec is deallocated after this we have to change somewhere else\n! jj=1\n! mapline%meqrec%fixph(1,jj)=14\n! mapline%meqrec%fixph(2,jj)=1\n!\n1000 continue\n return\n end subroutine list_map_equilibrium\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_problems\n!\\begin{verbatim}\n subroutine map_problems(maptop,mapline,axarr,xxx,typ)\n! jump here for different problems\n! maptop map node record\n! mapline current line record\n! axarr array with axis records\n! xxx current active axis value that caused problems to calculate\n! typ indicates the type of problem\n integer typ\n type(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n type(map_axis), dimension(*) :: axarr\n double precision xxx\n!\\end{verbatim}\n character ch1*1\n integer oldaxis\n double precision yyy\n! skip debug output\n! write(*,7)'In map_problem: ',typ,mapline%problems,mapline%lasterr,&\n! mapline%axandir,mapline%nodfixph,maptop%number_ofaxis,xxx\n7 format(a,6i4,6(1pe14.6))\n! we can list the current conditions here, \n! note fix phases for mapping not included as condition here!!\n! write(*,*)'Map problems 1'\n! call list_conditions(kou,mapline%lineceq)\n! call list_short_results(kou,mapline%lineceq)\n! read(*,10)ch1\n10 format(a)\n! for debugging:\n! call list_map_equilibrium(maptop,mapline,axarr,xxx,typ)\n! if(mapline%problems.gt.5) then\n if(mapline%problems.gt.2) then\n if(mapline%nodfixph.gt.0) then\n! call list_conditions(kou,mapline%lineceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error listing conditions'\n! gx%bmperr=0\n! endif\n write(*,11)mapline%lineid,trim(mapline%lineceq%eqname)\n11 format('SMP2A giving up on this line',i3,': ',a)\n! write(*,11)mapline%lineid,trim(mapline%lineceq%eqname),&\n! mapline%meqrec%phr(mapline%nodfixph)%iph,&\n! mapline%meqrec%phr(mapline%nodfixph)%ics\n!11 format('I give up on this line',i3,2x,a,' with fix phase ',2i4)\n! else\n! write(*,11)mapline%nodfixph,mapline%lineceq%eqname,0,0\n endif\n gx%bmperr=4244; goto 1000\n endif\n! write(*,*)'Map problems 2'\n!---------------------------------------------\n! list current conditions\n! call list_conditions(kou,mapline%lineceq)\n if(maptop%number_ofaxis.eq.1) then\n! for step only take smaller steps or calculate with grid minimizer\n if(typ.eq.1) then\n! take a smaller step\n! current axis condition value is xxx, mapline%firstinc is the step taken\n xxx=xxx-0.999*mapline%firstinc\n else\n write(*,*)'Unknown problem ',typ\n gx%bmperr=4245\n endif\n goto 1000\n endif\n!=======================================================\n! two or more axis\n select case(typ)\n case default\n write(*,*)'Unknown problem ',typ\n gx%bmperr=4245\n!------------------------------------------------------\n case(1) ! error at first step, for map opposite direction\n! current axis condition value is xxx, mapline%firstinc is the step taken\n yyy=xxx\n! write(*,*)'First increment: ',mapline%axandir,mapline%firstinc\n if(mapline%problems.eq.1) then\n! first time here take the step in opposite direction\n! xxx=yyy-0.99D0*mapline%firstinc\n!>> xxx=yyy-1.01D0*mapline%firstinc best tested value\n xxx=yyy-1.01D0*mapline%firstinc\n mapline%axandir=-mapline%axandir\n elseif(mapline%problems.eq.2) then\n! second time take a small step in previous direction\n! xxx=yyy-0.02D0*mapline%firstinc\n!>> xxx=yyy+0.02D0*mapline%firstinc best tested value\n xxx=yyy+0.02D0*mapline%firstinc\n mapline%axandir=-mapline%axandir\n elseif(mapline%problems.eq.3) then\n! third time take small step in other axis\n! write(*,*)'Changing active axis'\n! we must extract axis value, change condition etc. assume only 2 axis\n! oldaxis=mapline%axandir\n! mapline%axandir=3-mapline%axandir\n! call list_conditions(kou,mapline%lineceq)\n elseif(mapline%problems.eq.4) then\n! fourth time take small step in opposite direction (of axis set with 3)\n! xxx=yyy-0.02D0*mapline%firstinc\n! mapline%axandir=-mapline%axandir\n endif\n mapline%axfact=1.0D-2\n! the returned value xxx will be set as condition\n! call condition_value(0,pcond,xxx,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n!------------------------------------------------------\n end select\n1000 continue\n return\n end subroutine map_problems\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_halfstep_bad\n!\\begin{verbatim}\n subroutine map_halfstep_bad(halfstep,type,axvalok,mapline,axarr,ceq)\n! THIS MADE MANY MAP macro FAIL: 3,6,7,8,12,13 and finally crash ...\n! Used when an error calculating a normal step or a node point\n! take back the last sucessfully calculated axis value and take smaller step\n! possibly one should also restore the ceq record.\n! halfstep number of times halfstep has been called for this problem\n! axvalok last cucessfully calculated value of active axis\n! mapline line record\n! axarr array with axis records\n! ceq equilibrium record\n implicit none\n integer halfstep,type\n double precision axvalok\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(map_line), pointer :: mapline\n type(map_axis), dimension(*) :: axarr\n!\\end{verbatim}\n type(gtp_condition), pointer :: pcond\n double precision value\n double precision :: sfact=1.0D-2\n integer jax\n! write(*,*)'In map_halfstep_bad',halfstep\n if(halfstep.eq.1) then\n sfact=0.5D0\n else\n sfact=sfact*sfact\n endif\n halfstep=halfstep+1\n if(type.eq.1 .and. (axvalok.eq.zero .or. halfstep.ge.3)) then\n! write(*,*)'Two phases competing to appear/disappear',axvalok,halfstep\n gx%bmperr=4246\n else\n! Previous axis value should be axvalok, find current\n jax=abs(mapline%axandir)\n call locate_condition(axarr(jax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Current active axis value: ',value\n! at first call remember the original axis value\n if(halfstep.eq.1) then\n if(ocv()) write(*,67)'First call to map_half, value:',value,axvalok\n67 format(a,2(1pe14.6))\n mapline%evenvalue=value\n elseif(halfstep.gt.3) then\n! write(*,*)'SMP2A Tried halfstep 3 times, giving up'\n gx%bmperr=4368\n endif\n if(mapline%axfact.le.1.0D-6) then\n! error initiallizing axfact ???\n write(*,*)'Too small value of mapline%axfact: ',mapline%axfact\n mapline%axfact=1.0D-3\n endif\n! take a small step\n if(mapline%axandir.gt.0) then\n value=axvalok+sfact*mapline%axfact*axarr(jax)%axinc\n else\n value=axvalok-sfact*mapline%axfact*axarr(jax)%axinc\n endif\n write(*,97)'Halfstep axis value: ',mapline%axandir,value,axvalok,&\n mapline%axfact,axarr(jax)%axinc\n97 format(a,i2,5(1pe14.6))\n! first argument 0 means to set the value\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv()) write(*,*)'Taking a small step, new axis value: ',jax,value\n endif\n1000 continue\n return\n end subroutine map_halfstep_bad\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine map_halfstep\n!\\begin{verbatim}\n subroutine map_halfstep(halfstep,type,axvalok,mapline,axarr,ceq)\n! Used when an error calculating a normal step or a node point\n! take back the last sucessfully calculated axis value and take smaller step\n! possibly one should also restore the ceq record.\n! halfstep number of times halfstep has been called for this problem\n! axvalok last cucessfully calculated value of active axis\n! mapline line record\n! axarr array with axis records\n! ceq equilibrium record\n implicit none\n integer halfstep,type\n double precision axvalok\n TYPE(gtp_equilibrium_data), pointer :: ceq\n TYPE(map_line), pointer :: mapline\n type(map_axis), dimension(*) :: axarr\n!\\end{verbatim}\n type(gtp_condition), pointer :: pcond\n double precision value\n double precision, parameter :: sfact=1.0D-2\n integer jax\n repeatederr=repeatederr+1\n! write(*,*)'In map_halfstep',halfstep,repeatederr\n halfstep=halfstep+1\n if(type.eq.1 .and. (axvalok.eq.zero .or. halfstep.ge.3)) then\n! write(*,*)'Two phases competing to appear/disappear',axvalok,halfstep\n gx%bmperr=4246\n else\n! Previous axis value should be axvalok, find current\n jax=abs(mapline%axandir)\n call locate_condition(axarr(jax)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Current active axis value: ',value\n! at first call remember the original axis value\n if(halfstep.eq.1) then\n if(ocv()) write(*,67)'First call to map_half, value:',value,axvalok\n67 format(a,2(1pe14.6))\n mapline%evenvalue=value\n elseif(halfstep.gt.3) then\n! write(*,*)'SMP2A Tried halfstep 3 times, giving up'\n gx%bmperr=4368\n endif\n if(mapline%axfact.le.1.0D-6) then\n! error initiallizing axfact ???\n write(*,*)'Too small value of mapline%axfact: ',mapline%axfact\n mapline%axfact=1.0D-3\n endif\n! take a small step\n if(mapline%axandir.gt.0) then\n value=axvalok+1.0D-1*mapline%axfact*axarr(jax)%axinc\n else\n value=axvalok-1.0D-1*mapline%axfact*axarr(jax)%axinc\n endif\n! write(*,97)'Halfstep axis value: ',mapline%axandir,value,axvalok,&\n! mapline%axfact,axarr(jax)%axinc\n97 format(a,i2,5(1pe14.6))\n! first argument 0 means to set the value\n call condition_value(0,pcond,value,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ocv()) write(*,*)'Taking a small step, new axis value: ',jax,value\n endif\n1000 continue\n return\n end subroutine map_halfstep\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_separate\n!\\begin{verbatim}\n subroutine step_separate(maptop,noofaxis,axarr,seqxyz,starteq)\n! calculates for each phase separately along an axis (like G curves)\n! There can not be any changes of the stable phase ...\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! starteq equilibrium record for starting\n implicit none\n integer noofaxis,seqxyz(*)\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq\n integer ntup,itup,iph,ics,nystat,inactive(4),notop,seqy,mode,jk\n integer jj,seqz,iadd,irem,nv,saveq,lokcs,mapx\n type(gtp_phasetuple), dimension(:), allocatable :: entphcs\n integer, dimension(:), allocatable :: stsphcs\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n! type(map_fixph), pointer :: mapfix\n! TYPE(map_node), pointer :: curtop\n type(meq_setup), pointer :: meqrec\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n double precision val,xxx,yyy,axvalok\n logical firstline\n! integer, parameter :: maxsavedceq=2000\n! decreased to 1800 as I sometimes run out of memeory\n integer, parameter :: maxsavedceq=1800\n character name*24\n! turns off convergence control for T\n integer, parameter :: inmap=1\n!\n! write(*,*)'In step_separate'\n if(noofaxis.ne.1) then\n write(kou,*)'Step separate only with one axis variable'\n goto 1000\n endif\n! this subroutine returnes the total number of phase and composition sets\n! call sumofphcs(ntup,ceq)\n! ntup=totalphcs(starteq)\n! ntup=nonsusphcs(starteq)\n ntup=nooftup()\n allocate(entphcs(ntup))\n allocate(stsphcs(ntup))\n itup=0\n ceq=>starteq\n! collect all current phase status and set all phases suspended\n nystat=-3\n val=zero\n do iph=1,noph()\n do ics=1,noofcs(iph)\n itup=itup+1\n! entphcs(itup)%phaseix=iph\n entphcs(itup)%ixphase=iph\n entphcs(itup)%compset=ics\n stsphcs(itup)=test_phase_status(iph,ics,val,ceq)\n! write(*,*)'step-sep ',iph,noofcs(iph),ics,itup,stsphcs(itup)\n if(gx%bmperr.ne.0) goto 1000\n! phase status -1, 0 and 1 are all saved as 0\n if(stsphcs(itup).ge.-1 .and. stsphcs(itup).le.1) stsphcs(itup)=0\n! do not change status of dormant phases ...\n if(stsphcs(itup).ne.-2) then\n call change_phase_status(iph,ics,nystat,val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n endif\n enddo\n enddo\n! write(*,'(a,10i3)')'Suspended all phases',stsphcs\n! indicator if maptop allocated\n! nullify(curtop)\n notop=0\n! loop through all phases with stsphcs less than 3\n! nystat=0\n!============================================================\n phaseloop: do itup=1,ntup\n! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix\n! write(*,*)'SS Phase ',itup,' status ',stsphcs(itup),ntup\n if(stsphcs(itup).gt.-2) then\n! set default constitution, if none specified in the middle\n! write(*,*)'loop for phase phase ',itup,' stable'\n iph=entphcs(itup)%ixphase\n call set_default_constitution(entphcs(itup)%ixphase,&\n entphcs(itup)%compset,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed setting default constitution'\n goto 500\n endif\n! set phase as entered\n! write(*,*)'Trying to calculate line for phasetuple: ',itup\n call change_phase_status(entphcs(itup)%ixphase,&\n entphcs(itup)%compset,1,one,ceq)\n! entphcs(itup)%compset,0,one,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed setting phase entered',gx%bmperr\n goto 500\n endif\n! debug listing of phase constitution to check\n! call list_phase_model(entphcs(itup)%ixphase,entphcs(itup)%compset,&\n! kou,ceq)\n! here we should set the condition for overall composition to that of the phase\n! Extract the current value of the axis state variable items using pcond\n! write(*,*)'Extracting axis condition value '\n seqz=axarr(1)%seqz\n! write(*,*)'Locating condition ',seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 500\n! if condition is a composition set it to be the current value with the\n! default composition of the phase, 17 is mole fraction\n svr=>pcond%statvar(1)\n call get_phase_variance(entphcs(itup)%ixphase,nv)\n call get_phasetuple_name(entphcs(itup),name)\n! write(*,*)'SMP2A axis condition type: ',svr%statevarid,nv\n! skip phases with no variation of axis is not a potential\n if(nv.eq.0 .and. svr%statevarid.gt.5) then\n write(*,71)trim(name)\n71 format('SMP2A ignoring phase ',a,' with fixed composition: ')\n goto 500\n endif\n call state_variable_val(svr,val,ceq)\n if(gx%bmperr.ne.0) goto 500\n! 16=N, 17=X, 18=B, 19=W, 20=Y\n! if(svr%statevarid.eq.17) then\n! this call calculates the value of the axis condition with default composition\n! call state_variable_val(svr,val,ceq)\n! if(gx%bmperr.ne.0) goto 500\n! call get_phasetuple_name(entphcs(itup),name)\n! axis variable is composition, skip phases with no variance\n! call get_phase_variance(entphcs(itup)%ixphase,nv)\n! if(nv.eq.0) then\n! write(*,71)name(1:len_trim(name)),val\n!71 format(/'Ignoring phase with fixed composition: ',a,F10.6)\n!----------------\n! lokcs=phasetuple(iph)%lokvares\n! write(*,*)'indices: ',iph,phasetuple(iph)%ixphase,lokcs\n! goto 500\n! handle stoichiometric phases in step_separate ....\n! we need to initiate a line with just one point\n! special call to map_startpoint/map_findline for just one point\n! inactive=0\n! call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq)\n! if(gx%bmperr.ne.0) goto 500\n! call map_findline(maptop,axarr,mapfix,mapline)\n! if(gx%bmperr.ne.0) goto 500\n! ceq=>mapline%lineceq\n! meqrec=>mapline%meqrec\n! this call gives error meqrec allready allocated\n! ceq=>??\n! call calceq7(mode,meqrec,mapfix,ceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error calculating stoichiometric phase',gx%bmperr\n! endif\n! store the value of G\n! call map_store(mapline,axarr,maptop%number_ofaxis,&\n! maptop%saveceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error storing equilibrium',gx%bmperr\n! goto 900\n! endif\n! change the calculated value of G by adding 1.0D4 and store\n! mapline%lineceq%phase_varres(lokcs)%gval(1,1)=&\n! mapline%lineceq%phase_varres(lokcs)%gval(1,1)+1.0D3\n! call map_lineend(mapline,val,ceq)\n! goto 500\n!----------------\n! endif\n! if(ocv()) write(*,73)name(1:len_trim(name)),val\n! check if val is within axis limits\n if(val.lt.axarr(1)%axmin .or. val.gt.axarr(1)%axmax) then\n! write adjusting startpoint to be inside limits\n val=axarr(1)%axmin+0.1D0*(axarr(1)%axmax-axarr(1)%axmin)\n endif\n write(*,73)trim(name),val\n73 format(/'Setting start condition for ',a,f10.5)\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,val,ceq)\n if(gx%bmperr.ne.0) goto 500\n mode=-1\n!\n if(notop.eq.0) then\n! notop=-1\n! create maptop and things for storing results\n! map_startpoint calculates the equilibrium and generates two start points\n! write(*,*)'Creating start point',itup,notop\n inactive=0\n call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq)\n if(gx%bmperr.ne.0) goto 500\n! write(*,*)'Start point created'\n! create array of equilibrium records for saving results\n! if larger than 500 I get segmentation fault ,,,,\n saveq=maxsavedceq\n call create_saveceq(maptop%saveceq,saveq)\n if(gx%bmperr.ne.0) goto 900\n notop=-1\n! initiate line counter (redundant) ... maybe if several step separate?\n! if(seqxyz(2).ne.0) then\n! write(*,*)'step_separate seqy: ',seqxyz(2)\n! endif\n else\n! we generate a second or later startpoint for another phase\n! note that maptop is allocated a new map_node linked from this\n! write(*,*)'Creating next start point',itup,notop\n inactive=0\n call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,ceq)\n if(gx%bmperr.ne.0) then\n goto 500\n endif\n endif\n firstline=.TRUE.\n! find a stored line to calculate\n! in this subroutine we have only one axis variable\n200 continue\n! write(*,*)'Calling findline:'\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 500\n!lookingforbug ... never here\n write(*,*)'Back from map_findline in STEP',associated(mapline)\n ceq=>mapline%lineceq\n meqrec=>mapline%meqrec\n! this is the first equilibrium along the line, create meqrec in step_separate\n305 continue\n! do jk=1,ntup\n! if(stsphcs(jk).eq.-2) write(*,*)'SS phase ',jk,' dormant B'\n! if(stsphcs(jk).ge.0) write(*,*)'SS phase ',jk,' stable B'\n! enddo\n! write(*,*)'smp2A calling calceq7 for first point'\n!lookingforbug ... never here\n call calceq7(mode,meqrec,mapfix,ceq)\n! write(*,*)'smp2A back from calceq7',gx%bmperr\n if(gx%bmperr.ne.0) then\n! error 4187 is to set T or P less than 0.1\n if(gx%bmperr.eq.4187) then\n write(*,*)'We jump to 333'\n goto 333\n endif\n if(mapline%number_of_equilibria.eq.0) then\n! We can add/subtract a small amount of axis condition if error at first step\n write(*,*)'Error at first equilibrium: ',gx%bmperr,&\n mapline%axandir\n endif\n! write(*,*)'SMP error: ',gx%bmperr\n! if step turn on grid minimizer\n write(*,*)'Turn on grid minimizer'\n if(maptop%number_ofaxis.eq.1) then\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n write(kou,*)'Failed calling grid minimizer',gx%bmperr\n gx%bmperr=0\n endif\n endif\n! reset error code and take another line\n! write(*,*)'SMP2 Generating mapline%meqrec failed 1: ',gx%bmperr\n gx%bmperr=0; goto 333\n else\n! calculation OK, do it again (why?) without creating meqrec, save and\n! return here after taking a step using the same meqrec\n380 continue\n iadd=0\n irem=0\n! write(*,*)'SMP2A calling meq_sameset from step_separate'\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,&\n mapline%meqrec%phr,inmap,ceq)\n if(gx%bmperr.ne.0) then\n! write(*,*)'SMP2A Error calling meq_sameset',gx%bmperr\n goto 333\n elseif(iadd.ne.0 .or. irem.ne.0) then\n write(*,*)'Change of phases not allowed! ',iadd,irem\n goto 333\n endif\n! store the result\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibrium',gx%bmperr\n goto 900\n endif\n! do jk=1,ntup\n! if(stsphcs(jk).eq.-2) write(*,*)'SS phase ',jk,' dormant C'\n! if(stsphcs(jk).ge.0) write(*,*)'SS phase ',jk,' stable C'\n! enddo\n call map_step(maptop,mapline,mapline%meqrec,mapline%meqrec%phr,&\n axvalok,noofaxis,axarr,ceq)\n! write(*,*)'Back from map_step 2 ',mapline%more,&\n! mapline%number_of_equilibria\n if(gx%bmperr.ne.0) then\n! if error just terminate line\n write(*,*)'Error return from map_step 2: ',gx%bmperr\n mapline%more=-1\n gx%bmperr=0; goto 333\n endif\n if(mapline%more.ge.0) goto 380\n endif\n333 continue\n! write(*,*)'Calling map_linend 2'\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n if(firstline) then\n! follow the axis in the other direction\n if(gx%bmperr.ne.0) then\n write(*,*)'Reset error code',gx%bmperr\n endif\n firstline=.FALSE.\n goto 200\n endif\n! finished step in both directions\n500 continue\n! remove any error before calculating next phase\n if(gx%bmperr.ne.0) then\n write(*,*)'Reset error code to calculate next phase',gx%bmperr\n gx%bmperr=0\n endif\n endif\n! set current phase as suspended and calculate for next phase\n! call change_phase_status(entphcs(itup)%phaseix,entphcs(itup)%compset,&\n call change_phase_status(entphcs(itup)%ixphase,entphcs(itup)%compset,&\n -3,zero,ceq)\n! write(*,*)'At end of phase loop itup=',itup\n enddo phaseloop\n!============================================================\n! Terminate but restore all phase status, even if error above\n900 continue\n val=zero\n! write(*,*)'SMP Trying to restoring original phase status',ntup\n! reset ceq to be starteq !! otherwise nothing is changed\n ceq=>starteq\n do itup=1,ntup\n! write(*,910)itup,entphcs(itup)%ixphase,entphcs(itup)%compset,&\n! stsphcs(itup)\n910 format('Restoring all phase status: ',4i5)\n! call change_phtup_status(itup,stsphcs(itup),val,ceq)\n call change_phase_status(entphcs(itup)%ixphase,&\n entphcs(itup)%compset,stsphcs(itup),val,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! trying to set status entered ...\n! write(*,911)'step_sep: restored? ',itup,entphcs(itup)%ixphase,&\n! entphcs(itup)%compset,stsphcs(itup),val\n911 format(a,3i4,i6,1pe12.4)\n enddo\n1000 continue\n return\n end subroutine step_separate\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_special_setup\n!\\begin{verbatim}\n subroutine step_special_setup(maptop,seqxyz,exits,starteq)\n! create mapnode and tzero line and other special step commands\n! maptop map node record\n! seqxyz indices for map and line records\n! exits is 1 or more depending on type of step\n implicit none\n integer seqxyz(*),exits\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond\n double precision xxx,yyy,zzz,fact\n! logical firstline\n character eqname*24\n integer, parameter :: maxsavedceq=1800\n!\n! write(*,*)'In step_special_setup',exits\n!======================================================\n! create maptop, maplines and things for storing results\n! we cannot use map_startpoint as we are not calculating equilibria ...\n! we must allocate a maptop and its next and previous to point at itself\n allocate(maptop)\n mapnode=>maptop\n! inititate status and links, maybe some of these change for other applications\n mapnode%status=0\n mapnode%noofstph=2\n mapnode%savednodeceq=-1\n mapnode%next=>mapnode\n mapnode%previous=>mapnode\n mapnode%first=>mapnode\n mapnode%number_ofaxis=1\n mapnode%nodefix%ixphase=0\n mapnode%status=0\n! mapnone%lines incremented when created ??\n mapnode%lines=0\n! %artxe nonzero if node with two stoichiometric phases with same composition\n mapnode%artxe=0\n mapnode%globalcheckinterval=0\n mapnode%seqx=seqxyz(1)\n mapnode%seqy=seqxyz(2)\n!\n! skip saving chemical potentials?\n mapnode%tpval=starteq%tpval\n mapnode%nodeceq=>starteq\n eqname='_MAPNODE_'\n jp=10\n! maptop%next is the the same mapnode !!!\n seqx=maptop%next%seqx+1\n! seqy=maptop%next%seq+1\n! seqy commented away but used later (some 50 lines below)\n! I think it should probably be set here .../BoS 220220\n seqy=maptop%next%seqy+1\n maptop%next%seqx=seqx\n call wriint(eqname,jp,seqx)\n! make a copy of ceq in a new equilibrium record with the pointer neweq\n! This copy is a record in the array \"eqlista\" of equilibrium record, thus\n! it will be updated if new composition sets are created in other threads.\n call copy_equilibrium(neweq,eqname,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Created MAPNODE ',seqx\n! set the tieline_inplane or not\n! For step calculation, tieline_inplane=0\n! if there are more than one condition on an extensive_variable\n! that is not an axis variable then no tielines in plane, tieline_inplane=-1\n! If there are tie_lines in plane then tieline_inplane=1\n mapnode%tieline_inplane=0\n! forgetting to do this created a crash when plotting ...\n nullify(maptop%plotlink)\n! we must store 1 or 2 (=exits) lineceq using starteq\n mapnode%lines=exits\n allocate(mapnode%linehead(mapnode%lines))\n! write(*,*)'step_special_setup',maptop%seqx,exits\n! mapnode%type_of_node=0\n idir=1\n do jp=1,exits\n mapnode%linehead(jp)%axandir=idir\n idir=-1\n mapnode%linehead(jp)%number_of_equilibria=0\n mapnode%linehead(jp)%first=0\n mapnode%linehead(jp)%last=0\n mapnode%linehead(jp)%axchange=-1\n mapnode%linehead(jp)%done=0\n mapnode%linehead(jp)%status=0\n mapnode%linehead(jp)%more=1\n mapnode%linehead(jp)%termerr=0\n mapnode%linehead(jp)%firstinc=zero\n! saving equilibrium pointer in lineceq\n mapnode%linehead(jp)%lineceq=>starteq\n mapnode%linehead(jp)%start=>mapnode\n mapnode%linehead(jp)%axfact=1.0D-2\n! this is set to zero indicating the stable phases are saved in lineceq record\n mapnode%linehead(jp)%nstabph=0\n mapnode%linehead(jp)%lineid=seqy\n mapnode%seqy=seqy+1\n mapnode%linehead(jp)%nodfixph=0\n! %more is 1 while line is calculated, 0 means terminated at axis limit\n! > 0 means error code <0 means exit removed ?? or is it %done ??\n mapnode%linehead(jp)%more=1\n mapnode%lines=exits\n nullify(mapnode%linehead(jp)%end)\n enddo\n!\n! create array of equilibrium records for saving results\n! write(*,*)'step_special_setup create saveceq:',maxsavedceq\n saveq=maxsavedceq\n call create_saveceq(maptop%saveceq,saveq)\n if(gx%bmperr.ne.0) goto 1000\n! in this subroutine we have only one axis variable\n1000 continue\n return\n end subroutine step_special_setup\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_tzero\n!\\begin{verbatim}\n subroutine step_tzero(maptop,noofaxis,axarr,seqxyz,iph1,iph2,tzcond,starteq)\n! calculates t for two phases where they have same Gibbs energy\n! second version using step_special_setup\n! There can not be any other phases\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! iph1 and iph2 should be phase index (compset 1 in both)\n! tzcond should be condition number for T\n implicit none\n integer noofaxis,seqxyz(*),iph1,iph2,tzcond\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond\n double precision xxx,yyy,zzz,fact\n! logical firstline\n character eqname*24\n integer, parameter :: maxsavedceq=1800\n! turns off convergence control for T\n integer, parameter :: inmap=1\n!\n! write(*,*)'In step_tzero',iph1,iph2\n if(noofaxis.ne.1) then\n write(kou,*)'Step tzero only with one axis variable'\n goto 1000\n endif\n! check that we have a tzero point\n ceq=>starteq\n!\n call tzero(iph1,iph2,tzcond,yyy,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Start point is not on a tzero line'\n gx%bmperr=4399; goto 1000\n endif\n! extract axis condition value\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,88)xxx,yyy\n88 format('At x=',F10.6,' Tzero=',F10.2,10x,1pe12.4)\n!======================================================\n call step_special_setup(maptop,seqxyz,2,starteq)\n if(gx%bmperr.ne.0) goto 1000\n!\n mapnode=>maptop\n! write(*,*)'step_tzero creating maplines'\n tzstep: do jp=1,2\n mapline=>mapnode%linehead(jp)\n eqname='_MAPLINE_'\n kpos=10\n seqy=maptop%seqy+1\n call wriint(eqname,kpos,seqy)\n call copy_equilibrium(mapnode%linehead(jp)%lineceq,eqname,&\n mapnode%nodeceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating equilibrium: ',eqname\n goto 1000\n endif\n! write(*,*)'step_tzero created mapline ',seqy\n maptop%seqy=seqy\n mapnode%linehead(jp)%lineid=seqy\n mapnode%linehead(jp)%nodfixph=0\n! mapline%more is positive for line to be calculated, 0 means end at axis limit\n mapnode%linehead(jp)%more=1\n ceq=>mapline%lineceq\n! A very small first axis increment, extract axis condition value\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n fact=1.0D-2\n idir=mapline%axandir\n! write(*,*)'axis direction: ',idir,xxx\n tzlimits: do while(.TRUE.)\n xxx=xxx+fact*idir*axarr(1)%axinc\n if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) exit tzlimits\n call condition_value(0,pcond,xxx,ceq)\n call tzero(iph1,iph2,tzcond,yyy,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'TZERO step ',jp,' ended with error ',gx%bmperr\n gx%bmperr=0; cycle tzstep\n! else\n! write(*,88)xxx,yyy,fact\n endif\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibrium',gx%bmperr\n gx%bmperr=0; cycle tzstep\n endif\n! save missing .........\n fact=min(2.0d0*fact,1.0d0)\n enddo tzlimits\n if(xxx.lt.axarr(1)%axmin) then\n xxx=max(axarr(1)%axmin,1.0D-6)\n call condition_value(0,pcond,xxx,ceq)\n call tzero(iph1,iph2,tzcond,yyy,ceq)\n elseif(xxx.gt.axarr(1)%axmax) then\n xxx=min(axarr(1)%axmax,0.999999D0)\n call condition_value(0,pcond,xxx,ceq)\n call tzero(iph1,iph2,tzcond,yyy,ceq)\n endif\n! write(*,88)xxx,yyy\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibrium',gx%bmperr\n gx%bmperr=0; cycle tzstep\n endif\n enddo tzstep\n!\n1000 continue\n return\n end subroutine step_tzero\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_eet\n!\\begin{verbatim}\n subroutine step_eet(maptop,noofaxis,axarr,seqxyz,iph1,iph2,eetcond,starteq)\n! COPY of step_tzero modified for STEP LIQUID_EET\n! calculates t for two phases where they have same Gibbs energy\n! second version using step_special_setup\n! There can not be any other phases\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! iph1 and iph2 should be phase index (compset 1 in both)\n! eetcond should be condition number for T\n implicit none\n integer noofaxis,seqxyz(*),iph1,iph2,eetcond\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond\n double precision xxx,yyy,zzz,fact\n! logical firstline\n character eqname*24\n integer, parameter :: maxsavedceq=1800\n! turns off convergence control for T\n integer, parameter :: inmap=1\n!\n write(*,*)'step_eet not finished',iph1,iph2\n goto 1000\n if(noofaxis.ne.1) then\n write(kou,*)'Step tzero only with one axis variable'\n goto 1000\n endif\n! check that we have an eet point\n ceq=>starteq\n!\n call liquid_eet(iph1,iph2,eetcond,yyy,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Start point is not on an EET line'\n gx%bmperr=4399; goto 1000\n endif\n! extract axis condition value\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,88)xxx,yyy\n88 format('At x=',F10.6,' Tzero=',F10.2,10x,1pe12.4)\n!======================================================\n! the penultima argument is number of exits from first eqquilibrium\n call step_special_setup(maptop,seqxyz,2,starteq)\n if(gx%bmperr.ne.0) goto 1000\n!\n mapnode=>maptop\n! write(*,*)'step liquid_eet creating maplines'\n eetstep: do jp=1,2\n mapline=>mapnode%linehead(jp)\n eqname='_MAPLINE_'\n kpos=10\n seqy=maptop%seqy+1\n call wriint(eqname,kpos,seqy)\n call copy_equilibrium(mapnode%linehead(jp)%lineceq,eqname,&\n mapnode%nodeceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error creating equilibrium: ',eqname\n goto 1000\n endif\n! write(*,*)'step_tzero created mapline ',seqy\n maptop%seqy=seqy\n mapnode%linehead(jp)%lineid=seqy\n mapnode%linehead(jp)%nodfixph=0\n! mapline%more is positive for line to be calculated, 0 means end at axis limit\n mapnode%linehead(jp)%more=1\n ceq=>mapline%lineceq\n! A very small first axis increment, extract axis condition value\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to get the value\n call condition_value(1,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n fact=1.0D-2\n idir=mapline%axandir\n! write(*,*)'axis direction: ',idir,xxx\n eetlimits: do while(.TRUE.)\n xxx=xxx+fact*idir*axarr(1)%axinc\n if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) exit eetlimits\n call condition_value(0,pcond,xxx,ceq)\n! call tzero(iph1,iph2,eetcond,yyy,ceq)\n call liquid_eet(iph1,iph2,eetcond,yyy,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'TZERO step ',jp,' ended with error ',gx%bmperr\n gx%bmperr=0; cycle eetstep\n! else\n! write(*,88)xxx,yyy,fact\n endif\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibrium',gx%bmperr\n gx%bmperr=0; cycle eetstep\n endif\n! save missing .........\n fact=min(2.0d0*fact,1.0d0)\n enddo eetlimits\n if(xxx.lt.axarr(1)%axmin) then\n xxx=max(axarr(1)%axmin,1.0D-6)\n call condition_value(0,pcond,xxx,ceq)\n call liquid_eet(iph1,iph2,eetcond,yyy,ceq)\n elseif(xxx.gt.axarr(1)%axmax) then\n xxx=min(axarr(1)%axmax,0.999999D0)\n call condition_value(0,pcond,xxx,ceq)\n call liquid_eet(iph1,iph2,eetcond,yyy,ceq)\n endif\n! write(*,88)xxx,yyy\n call map_store(mapline,axarr,maptop%number_ofaxis,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibrium',gx%bmperr\n gx%bmperr=0; cycle eetstep\n endif\n enddo eetstep\n!\n1000 continue\n return\n end subroutine step_eet\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_scheil\n!\\begin{verbatim}\n subroutine step_scheil(maptop,noofaxis,axarr,seqxyz,starteq)\n! calculates a Scheil-Gulliver solidification simulation\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! starteq is an equilibrium with just liquid stable\n implicit none\n integer noofaxis,seqxyz(*)\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n integer inactive(4),mode,nc,nsch,liquid\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond,firstcond,axcond\n double precision xxx,yyy,zzz,fact,fact1,axvalok,npliqval,liqfrac(20)\n character eqname*24,phname*24,npliq*24,encoded*72\n integer, parameter :: maxsavedceq=1800\n! turns off convergence control for T\n integer, parameter :: inmap=1\n logical solids\n! needed to store links to condition values\n TYPE smp_scheil_condval\n! these pointers must be updated for each new line (equilibrium)\n type(gtp_condition), pointer :: p1\n end type smp_scheil_condval\n! These two arrays keep track of conditions and liquid compositis\n! the first is pointers to the condition record, the second is statevariable id\n type(smp_scheil_condval), dimension(20) :: scheilval\n TYPE(gtp_state_variable), target, dimension(20) :: scheilsvr\n!\n write(*,*)'In step_scheil'\n if(noofaxis.ne.1) then\n write(kou,*)'Scheil simulations use one axis variable'\n goto 1000\n endif\n! axis condition must be T, extract its value\n call locate_condition(axarr(1)%seqz,pcond,starteq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%statev.ne.1) then\n! pcond%statev=1 means T\n write(*,*)'Axis condition must be T'\n gx%bmperr=4399; goto 1000\n endif\n! first argument 1 means to get the value\n axcond=>pcond\n call condition_value(1,pcond,xxx,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,F10.2)')'Scheil start T=',xxx\n!\n inactive=0\n! inactive(1)=-1 means only one exit point with direcition -1\n inactive(1)=-1\n! generate step/map datastructure needed for plotting and phase set changes.\n call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! There should be two maplines generated, the stable phase should be the liquid\n! but do not be fuzzy, one may quech a two-phase mixture\n! write(*,*)'Scheil step 1',allocated(maptop%linehead)\n! write(*,*)'Scheil lineheads: ',size(maptop%linehead),&\n! maptop%linehead(1)%axandir\n! create array of equilibrium records for saving results\n seqy=maxsavedceq\n call create_saveceq(maptop%saveceq,seqy)\n if(gx%bmperr.ne.0) goto 1000\n! Mark this as a Scheil step\n maptop%type_of_node=3\n! ensure plotlink is nullified!!\n nullify(maptop%plotlink)\n! initiate node counter done, line counter will be incremented\n if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1\n85 format('Previous step/map results saved'/&\n 'New mapnode/line equilibria indices will start from: ',i3,i5)\n! take the first (only) line created by map_startpoint\n! write(*,*)'Calling map_findline'\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Back from map_findline in Scheil'\n ceq=>mapline%lineceq\n meqrec=>mapline%meqrec\n mode=-1\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) goto 1000\n xxx=ceq%tpval(1)\n if(meqrec%nstph.gt.1) then\n write(*,*)'More than one phase stable at startpoint'\n gx%bmperr=4399; goto 1000\n endif\n! check stable phase is liquid\n call get_phasetup_name(meqrec%phr(meqrec%stphl(1))%phtupix,phname)\n if(gx%bmperr.ne.0) goto 1000\n liquid=meqrec%phr(meqrec%stphl(1))%iph\n write(*,*)'Stable phase at start: ',trim(phname),liquid\n npliq='NP('//trim(phname)//') '\n!=======================================================\n! create special result array to save current fraction of liquid\n! allocate(mapline%stepresultid(1))\n! mapline%stepresultid(1)=npliq\n! extract relevant conditions and store in scheilval and scheilsvr\n firstcond=>ceq%lastcondition%next\n pcond=>firstcond\n nc=0\n nsch=0\n ploop: do while(.TRUE.)\n! if %active nonzero the condition is not active\n if(pcond%active.ne.0) cycle ploop\n nc=nc+1\n! to prevent eternal loop\n if(nc.gt.20) exit ploop\n! write(*,'(a,i3,a,i5)')'Condition ',nc,' type ',pcond%statev\n if(pcond%statev.lt.0) then\n write(*,*)'Fix phases not allowed as conditions'\n gx%bmperr=4399; goto 1000\n endif\n svr=>pcond%statvar(1)\n! write(*,*)'State variable id: ',svr%statevarid,svr%argtyp\n! statvarid<10 means potential, allow and ignore\n if(svr%statevarid.le.10) goto 100\n! 11 <= statvarid <=15 are G, H etc, not allowed. Neither is Y\n if(svr%statevarid.le.15 .or. svr%statevarid.ge.20) then\n write(*,*)'Illegal condition for Scheil simulation',svr%statevarid\n gx%bmperr=4399; goto 1000\n endif\n! Allowed state variables are N, X, B and W without phase specification\n! argtyp=0 means total such as N=1\n if(svr%argtyp.eq.0) goto 100\n! argtyp=1 means component, >1 other means phase or compset specification\n if(svr%argtyp.gt.1) then\n write(*,*)'Condition has wrong type of arguments: ',svr%argtyp\n gx%bmperr=4399; goto 1000\n endif\n if(pcond%symlink1.gt.0) then\n! value must not be a symbol\n write(*,*)'Condition value must not be a symbol'\n gx%bmperr=4399; goto 1000\n endif\n nsch=nsch+1\n scheilval(nsch)%p1=>pcond\n! save state variable but change it to include liquid phase index\n scheilsvr(nsch)=svr\n! replace argtyp and add phase and compset\n scheilsvr(nsch)%argtyp=3\n scheilsvr(nsch)%phase=liquid\n scheilsvr(nsch)%compset=1\n! write(*,'(a,i3,F10.6)')'Condition value: ',nsch,pcond%prescribed\n! Puuuuuh, condition allowed, link to its current value\n100 continue\n pcond=>pcond%next\n! current value\n if(associated(pcond,firstcond)) exit ploop\n enddo ploop\n! write(*,'(a,i3,a,i3)')'Found ',nc,' active conditions and saved ',nsch\n! test that we can extract (and set) liquid conditions and state variable\n do nc=1,nsch\n svr=>scheilsvr(nc)\n call state_variable_val(svr,xxx,ceq)\n! write(*,'(a,i3,2F10.6)')'Liquid initial conditions: ',&\n! nc,scheilval(nc)%p1%prescribed,xxx\n enddo\n! initial\n npliqval=one\n solids=.FALSE.\n! Now find T when first solid phase will appear\n! mapx does not seem to be used, inmap=1 turn off T convergence test(?)\n! all data in meqrec was set calling calceq7 above\n! axis conditio\n! first argument 1 means to get the value\n call condition_value(1,axcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n irem=0; iadd=0; nc=0\n! iadd=-1 turn on verbose in meq_sameset\n! iadd=-1\n! large step before first solid appears\n fact1=1.0D1\n axarr(1)%axinc=fact1*axarr(1)%axinc\n axvalok=xxx\n!==================================================== big loop\n node: do while(.TRUE.)\n! follow axis including nodepoints with phase changes\n! start with small steps\n! fact=1.0D-2\n line: do while(iadd.le.0 .and. irem.eq.0)\n! follow line until a nodepoint\n! axarr(1)%axval=axarr(1)%axval-axarr(1)%axinc\n if(solids) then\n! update the liquid composition\n! We have located the pcond records for each new line below\n! write(*,*)'Update liquid composition at T=',ceq%tpval(1)\n do nc=1,nsch\n! this call extract the liquid composition\n svr=>scheilsvr(nc)\n call state_variable_val(svr,liqfrac(nc),ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error extracting liquid composition'\n goto 1000\n endif\n! and this sets it as the overall composition\n call condition_value(0,scheilval(nc)%p1,liqfrac(nc),ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting new liquid composition'\n goto 1000\n endif\n enddo\n call get_state_var_value(npliq,yyy,encoded,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n npliqval=npliqval*yyy\n write(*,'(a,F7.2,\"% \",F7.2,\": \",10(1x,F8.4))')'Liquid:',&\n 1.0D2*npliqval,ceq%tpval(1),(liqfrac(nc),nc=1,nsch)\n! turn on debug info in meq_sameset\n! iadd=-1\n endif\n! take a step in the axis variable T\n call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ceq%tpval(1).lt.axarr(1)%axmin) then\n write(*,*)'At low T limit ',axarr(1)%axmin\n goto 900\n endif\n! calculate until a phase change\n! write(*,*)'Calling meq_sameset',ceq%tpval(1),npliqval\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,&\n inmap,ceq)\n! write(*,*)'Back from meq_sameset',ceq%tpval(1),gx%bmperr\n if(iadd.eq.0 .and. irem.eq.0) then\n! Store the equilibrium along the line\n call map_store(mapline,axarr,1,maptop%saveceq)\n! write(*,*)'Stored calculated equilibrium'\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibria',gx%bmperr\n goto 1000\n endif\n endif\n enddo line\n! exit line loop when iadd or irem nonzero, i.e. new set of phases\n if(.not.solids) then\n! if solids FALSE set it TRUE\n solids=.TRUE.\n axarr(1)%axinc=axarr(1)%axinc/fact1\n fact1=1.0D0\n endif\n! Maybe not store here because the T is not correct\n! call map_store(mapline,axarr,1,maptop%saveceq)\n! write(*,*)'Stored calculated equilibrium'\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibria',gx%bmperr\n goto 1000\n endif\n! use map_calcnode to create new mapnode and mapline. \n! We should not set any fix phases, just continue along the axis\n! as with a step command with different sets of stable phases\n call map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq)\n! in map_calcnode a new _MAPNODE and _MAPLINE is created with the new set\n! of phases. Store the end point of the line\n nullify(maptop%plotlink)\n! Terminate the current line, must be after calcnode ...\n call map_lineend(mapline,axarr(1)%lastaxval,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Rest error ',gx%bmperr\n gx%bmperr=0\n endif\n write(*,*)'Per cent liquid and T',1.0D2*npliqval,ceq%tpval(1)\n if(.not.(npliqval.gt.0.01)) then\n! terminate if npliqval<0.01 BUT IT DOES NOT WORK ???\n write(*,*)'Terminating as liquid fraction less than 1%'\n goto 900\n! else\n! if(npliqval.gt.0.01) then\n! write(*,*)'Terminating as liquid fraction less than 1%'\n! goto 900\n! endif\n endif\n! The Scheil simulation continue along the same axis with new set of phases.\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error return from map_findline, terminating'\n goto 1000\n endif\n ceq=>mapline%lineceq\n! write(*,*)'SMP2A calling calceq7 after findline,',allocated(mapfix),mode\n! Evidently we have to call calceq7 to initiate meqrec ??\n meqrec=>mapline%meqrec\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed calling calceq7',gx%bmperr\n goto 1000\n endif\n! check if zero fraction of liquid here\n call get_state_var_value(npliq,yyy,encoded,ceq)\n write(*,*)'SMP2A Scheil liquid fraction: ',yyy\n if(yyy.lt.0.03) then\n! Terminate the current line\n call map_lineend(mapline,axarr(1)%lastaxval,ceq)\n goto 900\n endif\n! we have to locate the condition records for the liquid comp in the new ceq\n firstcond=>ceq%lastcondition%next\n pcond=>firstcond\n ploop2: do while(.TRUE.)\n if(pcond%active.ne.0) cycle ploop2\n svr=>pcond%statvar(1)\n do nc=1,nsch\n if(svr%statevarid.eq.scheilsvr(nc)%statevarid .and. &\n svr%argtyp.eq.1 .and.&\n svr%component.eq.scheilsvr(nc)%component) then\n scheilval(nc)%p1=>pcond\n! write(*,*)'Found scheil condition in new ceq: ',nc \n endif\n enddo\n pcond=>pcond%next\n if(associated(pcond,firstcond)) exit ploop2\n! write(*,*)'Looping conditions in new ceq'\n enddo ploop2\n! write(*,*)'Node T=',ceq%tpval(1)\n enddo node\n write(*,*)'Never here!'\n!\n!===========================================\n! exit here if no liquid left of at low T limit\n900 continue\n! maybe clean up?\n1000 continue\n return\n end subroutine step_scheil\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_scheil2\n!\\begin{verbatim}\n subroutine step_scheil2(maptop,noofaxis,axarr,seqxyz,fast,starteq)\n! calculates a Scheil-Gulliver solidification simulation with fast elements\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! fast is array with names of fast diffusing elements, fast(i)=' ' for last\n! starteq is an equilibrium with just liquid stable\n implicit none\n integer noofaxis,seqxyz(*)\n character*2 fast(*)\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n! max number of components and fast diffusing elements\n integer, parameter :: mscheil=20,mfast=3\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n integer inactive(4),mode,nc,nsch,liquid,jfast,nfast,fastix(mfast),iel\n! notremove is a phase which just became stable, do not remove\n integer slice,slices,offset,notremove,keep\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n type(meq_setup), pointer :: meqrec\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond,firstcond,axcond\n double precision xxx,yyy,zzz,fact,fact1,axvalok,npliqval,liqconst(20)\n double precision sameact(mfast)\n double precision slicefrac(1000)\n character eqname*24,phname*24,npliq*24,encoded*72,mucondition*24\n integer, parameter :: maxsavedceq=1800\n! turns off convergence control for T\n integer, parameter :: inmap=1\n logical solids\n! needed to store links to condition values\n TYPE smp_scheil_condval\n! these pointers must be updated for each new line (equilibrium)\n type(gtp_condition), pointer :: p1\n integer fcond\n end type smp_scheil_condval\n! These two arrays keep track of conditions and liquid compositions\n! the first is pointers to the condition record, the second is statevariable id\n type(smp_scheil_condval), dimension(mscheil) :: scheilval\n type(smp_scheil_condval), dimension(mfast) :: mucond\n TYPE(gtp_state_variable), target, dimension(mscheil) :: scheilsvr\n!\n! write(*,*)'In step_scheil'\n if(noofaxis.ne.1) then\n write(kou,*)'Scheil simulations use one axis variable'\n goto 1000\n endif\n! axis condition must be T, extract its value\n call locate_condition(axarr(1)%seqz,pcond,starteq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%statev.ne.1) then\n! pcond%statev=1 means T\n write(*,*)'Axis condition must be T'\n gx%bmperr=4399; goto 1000\n endif\n! first argument 1 means to get the value\n axcond=>pcond\n call condition_value(1,pcond,xxx,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,F10.2)')'Scheil start T=',xxx\n!\n inactive=0\n! inactive(1)=-1 means only one exit point with direcition -1\n inactive(1)=-1\n! generate step/map datastructure needed for plotting and phase set changes.\n call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! There should be two maplines generated, the stable phase should be the liquid\n! but do not be fuzzy, one may quech a two-phase mixture\n! write(*,*)'Scheil step 1',allocated(maptop%linehead)\n! write(*,*)'Scheil lineheads: ',size(maptop%linehead),&\n! maptop%linehead(1)%axandir\n! create array of equilibrium records for saving results\n seqy=maxsavedceq\n call create_saveceq(maptop%saveceq,seqy)\n if(gx%bmperr.ne.0) goto 1000\n! Mark this as a Scheil step\n maptop%type_of_node=3\n! ensure plotlink is nullified!!\n nullify(maptop%plotlink)\n! initiate node counter done, line counter will be incremented\n if(maptop%seqx.gt.1) write(*,85)maptop%seqx,maptop%seqy+1\n85 format('Previous step/map results saved'/&\n 'New mapnode/line equilibria indices will start from: ',i3,i5)\n! take the first (only) line created by map_startpoint\n! write(*,*)'Calling map_findline'\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Back from map_findline in Scheil'\n ceq=>mapline%lineceq\n meqrec=>mapline%meqrec\n mode=-1\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) goto 1000\n xxx=ceq%tpval(1)\n if(meqrec%nstph.gt.1) then\n write(*,*)'More than one phase stable at startpoint'\n gx%bmperr=4399; goto 1000\n endif\n! check stable phase is liquid\n call get_phasetup_name(meqrec%phr(meqrec%stphl(1))%phtupix,phname)\n if(gx%bmperr.ne.0) goto 1000\n liquid=meqrec%phr(meqrec%stphl(1))%iph\n write(*,*)'Stable phase at start: ',trim(phname),liquid\n npliq='NP('//trim(phname)//') '\n!=======================================================\n! check number of fast diffusion elements (can be zero ...)\n nfast=1\n do while(fast(nfast).ne.' ')\n! write(*,*)'SMP2A fast diffusing elements: \"',fast(nfast),'\"'\n call find_element_by_name(fast(nfast),fastix(nfast))\n if(gx%bmperr.ne.0) goto 1000\n nfast=nfast+1\n if(nfast.gt.mfast) then\n write(*,*)'SMP2A too many fast diffusing elements',nfast\n gx%bmperr=4399; goto 1000\n endif\n enddo\n! OK if nfast is 0 here, this routine should work anyway ... (replace original)\n nfast=nfast-1\n if(nfast.gt.0) then\n write(*,*)'SMP2A number of fast diffusing elements: ',nfast\n jfast=1\n else\n write(*,*)'SMP2A No fast diffusing elements'\n jfast=0\n endif\n!=========================================================\n! extract relevant conditions and store in scheilval and scheilsvr\n firstcond=>ceq%lastcondition%next\n pcond=>firstcond\n nc=0\n nsch=0\n ploop: do while(.TRUE.)\n! skip condition if %active nonzero (the condition is not active)\n! write(*,*)'SMP2A inside ploop',pcond%active,&\n! pcond%statvar(1)%statevarid,pcond%statvar(1)%component\n if(pcond%active.ne.0) goto 100\n nc=nc+1\n! to prevent eternal loop\n if(nc.gt.20) exit ploop\n! write(*,'(a,i3,a,i5)')'Condition ',nc,' type ',pcond%statev\n if(pcond%statev.lt.0) then\n write(*,*)'Fix phases not allowed as conditions'\n gx%bmperr=4399; goto 1000\n endif\n svr=>pcond%statvar(1)\n! write(*,*)'State variable id: ',svr%statevarid,svr%argtyp\n! statvarid<10 means potential, allow and ignore\n if(svr%statevarid.le.10) goto 100\n! 11 <= statvarid <=15 are G, H etc, not allowed. Neither is Y\n if(svr%statevarid.le.15 .or. svr%statevarid.ge.20) then\n write(*,*)'Illegal condition for Scheil simulation',svr%statevarid\n gx%bmperr=4399; goto 1000\n endif\n! Allowed state variables are N, X, B and W without phase specification\n! argtyp=0 means total such as N=1\n if(svr%argtyp.eq.0) goto 100\n! argtyp=1 means component, >1 other means phase or compset specification\n if(svr%argtyp.gt.1) then\n write(*,*)'Condition has wrong type of arguments: ',svr%argtyp\n gx%bmperr=4399; goto 1000\n endif\n if(pcond%symlink1.gt.0) then\n! value must not be a symbol\n write(*,*)'Condition value must not be a symbol'\n gx%bmperr=4399; goto 1000\n endif\n nsch=nsch+1\n scheilval(nsch)%p1=>pcond\n scheilval(nsch)%fcond=0\n! save state variable but change it to include liquid phase index\n scheilsvr(nsch)=svr\n! replace argtyp and add phase and compset\n scheilsvr(nsch)%argtyp=3\n scheilsvr(nsch)%phase=liquid\n scheilsvr(nsch)%compset=1\n if(jfast.gt.0) then\n if(svr%component.eq.fastix(jfast)) then\n! is this element fast diffusing?\n! we should add a condition on the chemical potential of this component\n! Set current value of the chemical potential ...\n mucondition='MU('//trim(fast(jfast))//') '\n! ok write(*,*)'SMP2A Fast diffusing element: ',trim(mucondition)\n call get_state_var_value(mucondition,xxx,encoded,ceq)\n if(gx%bmperr.ne.0) goto 1000\n nv=len_trim(mucondition)+1\n write(mucondition(nv:),666)xxx\n666 format('= ',F14.6)\n! this condition should be set as last ... I hope\n nv=0\n! this condition should be added last\n! write(*,*)'SMP2A mucondition: ',trim(mucondition),nv\n call set_condition(mucondition,nv,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! check that this is the last condition, MU=3\n mucond(jfast)%p1=>ceq%lastcondition\n mucond%fcond=nsch\n scheilval(nsch)%fcond=jfast\n! write(*,*)'SMP2A set condition: ',trim(mucondition),nsch,jfast\n svr=>mucond(jfast)%p1%statvar(1)\n! deactivate MU condition\n ceq%lastcondition%active=1\n jfast=jfast+1\n if(jfast.gt.nfast) jfast=0\n! write(*,*)'SMP2A new condition: ',svr%statevarid,svr%component\n endif\n endif\n! Puuuuuh, condition allowed, link to its current value\n100 continue\n pcond=>pcond%next\n! current value\n! write(*,*)'SMP2A next condition: ',pcond%statev,pcond%active\n if(associated(pcond,firstcond)) exit ploop\n enddo ploop\n! write(*,*)'SMP2A have exited ploop'\n! call list_conditions(kou,ceq)\n! if(nfast.gt.0) then\n! write(*,*)'Unfinished'\n! goto 1000\n! endif\n!-----------------------------\n! write(*,'(a,i3,a,i3)')'Found ',nc,' active conditions and saved ',nsch\n! test that we can extract (and set) liquid conditions and state variable\n do nc=1,nsch\n svr=>scheilsvr(nc)\n call state_variable_val(svr,xxx,ceq)\n! write(*,'(a,i3,2F10.6)')'Liquid initial conditions: ',&\n! nc,scheilval(nc)%p1%prescribed,xxx\n enddo\n! initial\n npliqval=one\n solids=.FALSE.\n slices=-1\n! this is number of initial equilibria to be skipped\n! It may include one extra per new line, I am not sure ...\n offset=2\n! Now find T when first solid phase will appear\n! mapx does not seem to be used, inmap=1 turn off T convergence test(?)\n! all data in meqrec was set calling calceq7 above\n! axis conditio\n! first argument 1 means to get the value\n call condition_value(1,axcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n irem=0; iadd=0; nc=0; notremove=0; keep=-1\n! iadd=-1 turn on verbose in meq_sameset\n! iadd=-1\n! large step before first solid appears\n fact1=1.0D1\n axarr(1)%axinc=fact1*axarr(1)%axinc\n axvalok=xxx\n!==================================================== big loop\n node: do while(.TRUE.)\n! follow axis including nodepoints with phase changes\n line: do while(iadd.le.0 .and. irem.eq.0)\n if(solids) then\n! write(*,*)'SMP2A inside line loop',ceq%tpval(1),slices\n! update the liquid composition\n! We have located the pcond records for each new line below\n! write(*,*)'Update liquid composition at T=',ceq%tpval(1)\n! If slices>0 then change conditions of fast diffusing elements to MU\n! if(slices.ge.0) then\n! write(*,*)'SMP2A slices: ',slices,mapline%last\n! endif\n do nc=1,nsch\n! this call extract the liquid composition\n if(scheilval(nc)%fcond.gt.0) then\n! this is a fast diffusing element, use mucond\n write(*,*)'SMP2A to set MU condition',&\n scheilval(nc)%fcond,slices\n endif\n! else\n svr=>scheilsvr(nc)\n call state_variable_val(svr,liqconst(nc),ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error extracting liquid composition'\n goto 1000\n endif\n! and this sets it as the overall composition\n call condition_value(0,scheilval(nc)%p1,liqconst(nc),ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting new liquid composition'\n goto 1000\n endif\n! endif\n enddo\n! calculate fraction of liquid remaining and slicefrac\n call get_state_var_value(npliq,yyy,encoded,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n! slicefrac is fraction of solid at this timestep (slices)\n if(slices.gt.1000) then\n write(*,*)'SMP2A exit after 1000 solidification steps'\n gx%bmperr=4399; goto 1000\n endif\n if(slices.eq.0) slices=1\n slicefrac(slices)=(one-yyy)*npliqval\n npliqval=npliqval*yyy\n write(*,670)ceq%tpval(1),1.0D2*npliqval,1.0D2*slicefrac(slices),&\n slices,nsch,(liqconst(nc),nc=1,nsch)\n670 format('SMP2A T=',F8.2,'K, liq ',2F7.2,'% ',2i3,10(1x,F7.4))\n! turn on debug info in meq_sameset\n! iadd=-1\n endif\n! take a step in the axis variable T\n call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(ceq%tpval(1).lt.axarr(1)%axmin) then\n write(*,*)'At low T limit ',axarr(1)%axmin\n goto 900\n endif\n! write(*,*)'Calling meq_sameset',ceq%tpval(1),npliqval\n allslices: do while(.TRUE.)\n! If fast diffusing element we calculate simultaneously the equilibrium\n! with liquid and all saved equilibria with a MU condition.\n! write(*,*)'SMP2A inside allslices: ',ceq%tpval(1),slices\n call meq_sameset(irem,iadd,mapx,mapline%meqrec,mapline%meqrec%phr,&\n inmap,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Scheil2 error return from meq_sameset',gx%bmperr\n goto 1000\n endif\n! if irem is equal to notremove at first step ignore ...\n if(irem.gt.0 .and. irem.eq.notremove) then\n write(*,*)'SMP2A do not remove',irem,ceq%tpval(1)\n keep=3\n irem=0\n endif\n! if set of phases change extit line\n if(iadd.ne.0 .or. irem.ne.0) exit line\n! if no fast diffusing element we have calculated a new equilibrium\n if(nfast.eq.0 .or. slices.lt.0) exit allslices\n! calculate equilibria in all previous slices and sum amount of fast elements\n! and loop allslices until total amount of fast diffusing element correct\n write(*,*)'calling calc_allslices',slices\n if(calc_allslices(maptop,mapline,slices,offset,fastix,&\n slicefrac)) then\n! if calc_allslices is .TRUE. we calculated a new equilibrium\n slices=slices+1\n write(*,*)'Back from calc_allslices: ',slices\n exit allslices\n endif\n enddo allslices\n! clear noremove after 3 steps to avoid a second phase change\n keep=keep-1\n if(keep.eq.0) notremove=0\n! offset is incremented for all equilibria until first solid\n if(slices.lt.0) then\n offset=offset+1\n else\n! change the condition in mapline%lineceq on faset diffusing element to be MU\n! write(*,*)'SMP2A store: ',mapline%lineceq%tpval(1),ceq%tpval(1)\n endif\n! Store the equilibrium and step in T\n call map_store(mapline,axarr,1,maptop%saveceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Scheil2 error storing equilibria',gx%bmperr\n goto 1000\n endif\n enddo line\n! exit line loop when iadd or irem nonzero, i.e. new set of phases\n if(.not.solids) then\n! if solids FALSE set it TRUE, this is first solid appearing\n solids=.TRUE.\n axarr(1)%axinc=axarr(1)%axinc/fact1\n fact1=1.0D0\n! This is first solid appearing, change fast elements to MU conditions\n do jfast=1,nfast\n iel=mucond(jfast)%p1%statvar(1)%component\n mucondition='MU('//trim(fast(iel))//')'\n call get_state_var_value(mucondition,xxx,encoded,ceq)\n if(gx%bmperr.ne.0) goto 1000\n write(*,*)'SMP2A first solid, ',trim(mucondition),xxx,iadd\n enddo\n! initiate slices to count how many slices of solids we have\n slices=0\n endif\n! save value of iadd, not allowed to be removed by calc_node\n notremove=iadd\n write(*,*)'SMP2A Found new phase',iadd,irem,slices\n! use map_calcnode to create new mapnode and mapline. \n! We should not set any fix phases, just continue along the axis\n! as with a step command with different sets of stable phases\n call map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq)\n! in map_calcnode a new _MAPNODE and _MAPLINE is created with the new set\n! of phases. Store the end point of the line\n if(gx%bmperr.ne.0) then\n write(*,*)'Error return from map_calcnode',gx%bmperr\n goto 1000\n endif\n nullify(maptop%plotlink)\n! Terminate the current line, must be after calcnode ...\n call map_lineend(mapline,axarr(1)%lastaxval,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Reset error ',gx%bmperr\n gx%bmperr=0\n endif\n\n write(*,665)ceq%tpval(1),1.0D2*npliqval,slices,iadd,irem\n665 format('SMP2A T=',F7.2,' K and liquid ',F7.2,'%',3i5)\n if(.not.(npliqval.gt.0.01)) then\n! terminate if npliqval<0.01 BUT IT DOES NOT WORK ???\n write(*,*)'Terminating as liquid fraction less than 1%'\n goto 900\n endif\n! The Scheil simulation continue along the same axis with new set of phases.\n write(*,*)'SMP2A calling map_findline'\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error return from map_findline, terminating'\n goto 1000\n endif\n! write(*,*)'SMP2A back from map_findline'\n! write(*,*)'SMP2A back from map_findline',associated(mapline)\n! write(*,*)'SMP2A back from map_findline',associated(mapline%lineceq)\n ceq=>mapline%lineceq\n if(slices.lt.0) slices=0\n! write(*,*)'SMP2A calling calceq7 after findline,',slices\n! Evidently we have to call calceq7 to initiate meqrec ??\n meqrec=>mapline%meqrec\n call calceq7(mode,meqrec,mapfix,ceq)\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4222 .or. gx%bmperr.eq.4210) then\n write(*,*)'Scheil cannot handle invariant equilibrium',gx%bmperr\n else\n write(*,*)'Failed caculating start of new line',gx%bmperr\n endif\n goto 1000\n endif\n! check if zero fraction of liquid here\n call get_state_var_value(npliq,yyy,encoded,ceq)\n! write(*,*)'SMP2A Scheil liquid fraction: ',yyy,slices\n if(yyy.lt.0.01D0) then\n! Terminate the current line\n call map_lineend(mapline,axarr(1)%lastaxval,ceq)\n goto 900\n endif\n! we have to locate the condition records for the liquid comp in the new ceq\n! write(*,*)'SMP2A locating conditions'\n firstcond=>ceq%lastcondition%next\n pcond=>firstcond\n nv=0\n! write(*,*)'SMP2A entering ploop2',nsch\n ploop2: do while(.TRUE.)\n! eternal loop?\n! write(*,*)'SMP2A locating Scheil conditions in new ceq',nv\n if(pcond%active.eq.0) then\n! condition is active\n svr=>pcond%statvar(1)\n do nc=1,nsch\n if(svr%statevarid.eq.scheilsvr(nc)%statevarid .and. &\n svr%argtyp.eq.1 .and.&\n svr%component.eq.scheilsvr(nc)%component) then\n if(scheilval(nc)%fcond.gt.0) then\n! mucond(jfast)%p1=>ceq%lastcondition\n! mucond%fcond=nsch\n! write(*,*)'SMP2A found MU condition'\n mucond(scheilval(nc)%fcond)%p1=>pcond\n! temporarily MU condition not implemented\n scheilval(nc)%p1=>pcond\n else\n scheilval(nc)%p1=>pcond\n! write(*,*)'Found scheil condition in new ceq: ',nc \n endif\n endif\n enddo\n endif\n pcond=>pcond%next\n nv=nv+1\n if(associated(pcond,firstcond)) exit ploop2\n enddo ploop2\n! write(*,*)'Node T=',ceq%tpval(1)\n iadd=0; irem=0\n enddo node\n write(*,*)'Never here!'\n!\n!===========================================\n! exit here if no liquid left at low T limit\n900 continue\n! maybe clean up?\n1000 continue\n return\n end subroutine step_scheil2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function calc_allslices\n!\\begin{verbatim}\n logical function calc_allslices(maptop,mapline,slices,&\n offset,fastix,slicefrac)\n! calculates all equilibria in saveceq and sums amount of fast element\n! maptop map node record\n! slices is number of equilibria in saveceq\n! offset are the number of equilibria saved before first solid\n! fast are fast diffusing elements\n! slicefrac is fraction of total for each slice\n!\n implicit none\n integer slices,fastix(*),offset\n double precision slicefrac(*)\n TYPE(map_node), pointer :: maptop\n type(map_line), pointer :: mapline\n!\\end{verbatim}\n integer ieq,iel,iph,ics,nv,nofel\n integer, parameter :: mode=-1\n type(map_fixph), allocatable :: mapfix\n TYPE(gtp_equilibrium_data), pointer :: ceq\n type(meq_setup), pointer :: meqrec\n double precision sxmol(20),smass(20),stotmol,totmass,sumslices\n double precision cxmol(20),xmol(20),wmass(20),totmol,amount\n logical converged\n!\n write(*,*)'SMP2A in calc_allslices to calculate ',mapline%last,slices,offset\n converged=.FALSE.\n if(slices.eq.1) then\n write(*,*)'SMP2A initiating sliceq'\n sliceq=mapline%lineceq\n sliceq%nexteq=0\n converged=.TRUE.\n goto 1000\n endif\n nofel=noel()\n if(nofel.gt.20) then\n write(*,*)'SMP2A max 20 elements for Scheil with fast elements'\n gx%bmperr=4399; goto 1000\n endif\n! Change conditions to use MU of fast diffusing elements and current T\n! calculate equilibria in all slices for current MU and T\n sumslices=zero\n do ieq=1,slices\n sumslices=sumslices+slicefrac(ieq)\n! set of stable phases may change, for example delta-ferrite tranform to fcc\n! DISCOVERY HERE, conditions were still pointing to mapline%lineceq !!!\n! Now the list of conditions not saved, only local and allocated data\n! We have to extract phase amounts and constitutions, ignoring liquid\n! and calculate new equilibria with current T and MU of fast diffusing element\n! using sliceq\n if(ieq.eq.slices-1) then\n ceq=>maptop%saveceq%savedceq(offset+ieq)\n! Sum amounts of diffusing components, is liquid included? YES\n! call calc_molmass(sxmol,smass,stotmol,totmass,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n cxmol=zero\n ics=1\n sumx: do iph=1,noph()\n! skip liquid and unstable phases\n if(ceq%phase_varres(1)%amfu.ge.1.0D-1 .or.&\n ceq%phase_varres(1)%amfu.eq.zero) cycle sumx\n call calc_phase_molmass(iph,ics,xmol,wmass,&\n totmol,totmass,amount,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! totmol is total number of moles of phase, xmol(iel) is mole fraction of iel\n do iel=1,nofel\n cxmol(iel)=cxmol(iel)+totmol*xmol(iel)\n enddo\n write(*,10)'allslices1: ',iph,amount,&\n (cxmol(nv),nv=1,nofel)\n10 format(a,i3,1pe12.4,10(0pF6.3))\n enddo sumx\n! slicefrac(ieq) is fracion of this slice of solid\n write(*,10)'allslices2: ',0,slicefrac(ieq),&\n (sxmol(nv),nv=1,nofel)\n meqrec=>mapline%meqrec\n! set amounts as conditions together with MU including T, P and N=1\n! call calceq7(mode,meqrec,mapfix,ceq)\n! if(gx%bmperr.ne.0) then\n! write(*,*)'Error slice ',ieq,gx%bmperr\n! gx%bmperr=0;\n! endif\n! write(*,*)'SMP2A slice and T: ',ieq+offset,ceq%tpval(1)\n! call list_conditions(kou,ceq)\n endif\n enddo\n write(*,*)'Sum slicefracs: ',sumslices\n! sum up amount of fast element(s) in all slices, multiply with the\n! size of the slice and return. Several calculations with\n! different values of MU mab be needed.\n converged=.TRUE.\n1000 continue\n calc_allslices=converged\n return\n end function calc_allslices\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine step_paraequil\n!\\begin{verbatim}\n subroutine step_paraequil(maptop,noofaxis,axarr,seqxyz,tupix,fastelno,starteq)\n! calculates a paraequilibrium diagram\n! maptop map node record\n! noofaxis must be 1\n! axarr array of axis records\n! seqxyz indices for map and line records\n! starteq is an equilibrium with just two phases stable\n! tupix are phasetuple indices of two phases\n! fastelno fast diffusing component index\n!\n! TO BE MODIFIED\n!\n! we will use the same overall conditions except for the carbon\n implicit none\n integer noofaxis,seqxyz(*),tupix(*),fastelno\n type(map_axis), dimension(noofaxis) :: axarr\n TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n integer jj,jp,seqz,iadd,irem,nv,saveq,lokcs,mapx,idir,seqx,seqy,kpos\n integer inactive(4),mode,nc,npara,liquid,errall\n type(map_node), pointer :: mapnode\n type(map_line), pointer :: mapline\n type(map_fixph), allocatable :: mapfix\n! we have to choose between meqrec or meqrec1 .... normal step use meqrec1\n type(meq_setup), pointer :: meqrec\n type(meq_setup), allocatable, target :: meqrec1\n type(gtp_state_variable), target :: fastxsvr,fastmusvr\n type(gtp_state_variable), target :: matrixsvr,growxsvr\n type(gtp_state_variable), pointer :: svr\n type(meq_phase), pointer :: phr\n type(gtp_condition), pointer :: pcond,axcond\n double precision xxx,yyy,zzz,fact,fact1,axvalok\n character eqname*24,phname*24,npliq*24,encoded*72,setmucond*64\n integer, parameter :: maxsavedceq=1800\n! temporary storage of results\n double precision xpara(2)\n! turns off convergence control for T\n integer, parameter :: inmap=1\n! needed to store links to condition values\n TYPE smp_paraequil_condval\n! these pointers must be updated for each new line (equilibrium)\n type(gtp_condition), pointer :: p1\n end type smp_paraequil_condval\n! These two arrays keep track of conditions and liquid compositis\n! the first is pointers to the condition record, the second is statevariable id\n! type(smp_paraequil_condval), dimension(20) :: paraval\n! TYPE(gtp_state_variable), target, dimension(20) :: parasvr\n!\n! write(*,*)'SMP2A In step_paraequil',tupix(1),tupix(2),fastelno\n if(noofaxis.ne.1) then\n write(kou,*)'Paraequilibrium simulations one axis variable'\n goto 1000\n endif\n! ceq=>starteq\n jp=1\n findxcond: do while(.true.)\n! find the condition on the amount of the fast diffusing element\n! ?? does this loop through all conditions number 1..n? YES\n call locate_condition(jp,pcond,starteq)\n if(gx%bmperr.eq.4295) then\n! this error code means no more conditions\n gx%bmperr=0; exit findxcond\n endif\n if(gx%bmperr.ne.0) goto 1000\n! skip conditions not active\n if(pcond%active.ne.0) cycle findxcond\n svr=>pcond%statvar(1)\n! write(*,*)'findcond: ',jp,svr%statevarid,svr%argtyp,svr%component\n if(svr%component.eq.fastelno) then\n if(svr%argtyp.ne.1) then\n write(*,*)'Problem, condition not on overall fraction'\n stop 'paraeq 3'\n endif\n! fastxcondno=jp\n! here it should be assigned, not a pointer\n fastxsvr=svr\n endif\n! avoid eternal loop?\n jp=jp+1\n if(jp.gt.20) stop 'eternal loop in step_paraeq'\n enddo findxcond\n if(allocated(meqrec1)) deallocate(meqrec1)\n allocate(meqrec1,stat=errall)\n if(errall.ne.0) then\n write(*,*)'MM Allocation error 19: ',errall\n gx%bmperr=4370; goto 1000\n endif\n meqrec=>meqrec1\n! write(*,*)'Calling calc_paraeq first time',tupix(1),tupix(2),fastelno\n! check we can calculate a paraequilibrium\n call calc_paraeq(tupix,fastelno,xpara,meqrec,meqrec1,starteq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Sorry, cannot calculate an initial paraequilibrium',gx%bmperr\n goto 1000\n endif\n! write(*,'(a,2F10.6)')'first paraeq:',xpara(1),xpara(2)\n!\n! gx%bmperr=4399; goto 1000\n! ================================================================= \n inactive=0\n! inactive(1)=-1 is used when only one exit point with direcition -1\n! generate step/map datastructure needed for plotting and phase set changes.\n! in map_startpoint an equilibrium will be calculated and maplines created\n call map_startpoint(maptop,noofaxis,axarr,seqxyz,inactive,starteq)\n if(gx%bmperr.ne.0) goto 1000\n! create storage area for results\n! write(*,*)'Back from map_startpoint'\n call create_saveceq(maptop%saveceq,maxsavedceq)\n if(gx%bmperr.ne.0) goto 1000\n! Mark this as a paraequil step\n maptop%type_of_node=4\n! ensure plotlink is nullified!!\n nullify(maptop%plotlink)\n! write(*,*)'Taking the first line'\n! take the first line created by map_startpoint\n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 1000\n ceq=>mapline%lineceq\n mode=-1\n call locate_condition(axarr(1)%seqz,axcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n!----------------------------------------------- line loop\n jp=0\n lineloop: do while(.TRUE.)\n! there will be no phase changes during the STEP command, no new nodes\n jp=jp+1\n! write(*,*)'SMP2A Calculating paraequilibrium',jp\n call calc_paraeq(tupix,fastelno,xpara,meqrec,meqrec1,ceq)\n if(gx%bmperr.ne.0) then\n! terminate the line and check if more lines\n goto 500\n endif\n! if(jp.eq.0) then\n! We need the meqrec below ...\n! maptop%meqrec=meqrec\n! endif\n! first argument 1 means to get the value\n call condition_value(1,axcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,'(a,F12.6,\": \",2F10.6)')'SMP2A paraeq:',xxx,xpara(1),xpara(2)\n! calculation OK, save it\n call map_store(mapline,axarr,1,maptop%saveceq)\n! write(*,*)'Stored calculated equilibrium'\n if(gx%bmperr.ne.0) then\n write(*,*)'Error storing equilibria',gx%bmperr\n goto 1000\n endif\n! take a step, at second line the step is zero ... why??\n! write(*,*)'SMP2A Calling map_step2',size(meqrec%phr)\n! call map_step2(maptop,mapline,meqrec,meqrec%phr,axvalok,1,axarr,ceq)\n! in call to map_step2 meqrec is not a pointer !!\n call map_step2(maptop,mapline,meqrec1,meqrec%phr,axvalok,1,axarr,ceq)\n if(gx%bmperr.ne.0) goto 500\n! when outside limits aapline%more is negative\n if(mapline%more.lt.0) then\n! this indicate outside axis limits, call map_findline or finish\n call map_lineend(mapline,axarr(abs(mapline%axandir))%lastaxval,ceq)\n goto 510\n endif\n cycle lineloop\n! treating problems \n500 continue\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2A error in step_paraequil',gx%bmperr\n! terminate the line, error code cleared\n call map_lineend(mapline,axarr(mapline%axandir)%lastaxval,ceq)\n! some errors maybe fatal \n endif\n510 continue\n! take another line created by map_startpoint\n \n call map_findline(maptop,axarr,mapfix,mapline)\n if(gx%bmperr.ne.0) goto 1000\n if(.not.associated(mapline)) then\n! write(*,*)'SMP2A no more lines'\n! call list_conditions(kou,ceq)\n exit lineloop\n endif\n ceq=>mapline%lineceq\n! axcond changed because ceq changed!!\n! write(*,*)'New line, change axis condition record'\n! call list_conditions(kou,ceq)\n call locate_condition(axarr(1)%seqz,axcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! Wow, forgot > \n svr=>axcond%statvar(1)\n call state_variable_val(svr,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'Next line start at: ',xxx\n! call list_conditions(kou,ceq)\n! first argument 0 means to set the value NOT ALWAYS T BEWARE\n! call condition_value(0,axcond,xxx,ceq)\n! if(gx%bmperr.ne.0) goto 1000\n! call list_conditions(kou,ceq)\n! meqrec contain information from the calculated equilibrium\n meqrec=>mapline%meqrec\n enddo lineloop\n!===========================================\n! exit here when followed the line in both directions remove all axcond\n900 continue\n! maybe clean up?\n! Allow plotting tie-lines\n maptop%tieline_inplane=1\n1000 continue\n! write(*,*)'Finished step_paraequil, list condition?'\n! call list_conditions(kou,ceq)\n return\n end subroutine step_paraequil\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine auto_startpoints\n!\\begin{verbatim}\n subroutine auto_startpoints(maptop,noofaxis,axarr,seqxyz,starteqs)\n! Calculates 5 equilibria and store them as start points for mapping\n! maptop map node record\n! noofaxis must be 2\n! axarr array of axis records\n! seqxyz indices for map and line records\n! starteq equilibrium record for starting\n implicit none\n integer noofaxis,seqxyz(*)\n type(map_axis), dimension(noofaxis) :: axarr\n! TYPE(gtp_equilibrium_data), pointer :: starteq\n TYPE(starteqlista), dimension(*) :: starteqs\n TYPE(map_node), pointer :: maptop\n!\\end{verbatim}\n! genrate one startpoint in each corner and one in the center\n! For the corner add one directions along each axis\n! For the center add 4 directions, totally 12 lines\n! For isothermal sections one corner startpoint will be lost \n! startpoint 0.02x, 0.02y; direction +x and +y\n! startpoint 0.94x, 0.02y; direction -x and +y\n! startpoint 0.94x, 0.94y; direction -x and -y (lost in isothermal section)\n! startpoint 0.02x, 0.94y; direction +x and -y\n! startpoint 0.3x, 0.3y; all 4 directions (should work also in isothermal)\n integer seqz1,seqz2,j1,j2,mode,nss\n double precision xx1,xx2\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq,starteq\n type(gtp_condition), pointer :: pcond1,pcond2\n double precision, dimension(2), parameter :: x1=[0.02,0.92]\n double precision, dimension(2), parameter :: x2=[0.02,0.92]\n character*24 eqname\n!\n if(noofaxis.ne.2 .or. &\n btest(globaldata%status,GSNOAUTOSP)) goto 1000\n! goto 1000\n! the rest here works but not converting the startpoint to lines.\n write(*,*)'SMP *** in auto_startpoints'\n ceq=>starteqs(1)%p1\n! added assignment to started as used below\n starteq=>ceq\n mode=1\n eqname='_STARTEQ_00'\n nss=0\n! loop for corners\n100 continue\n cycle1: do j1=1,2\n!-----------\n xx2=axarr(2)%axmin+x2(j2)*(axarr(2)%axmax-axarr(2)%axmin)\n seqz2=axarr(2)%seqz\n call locate_condition(seqz2,pcond2,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed find 2nd condition ',j1,j2\n gx%bmperr=0\n cycle cycle1\n endif\n! first argument 1 means get value, 0 means set value\n call condition_value(0,pcond2,xx2,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting start point condition',gx%bmperr\n gx%bmperr=0; cycle cycle1\n endif\n cycle2: do j2=1,2\n write(*,*)'SMP auto ',j1,j2\n nss=nss+1\n xx1=axarr(1)%axmin+x1(j1)*(axarr(1)%axmax-axarr(1)%axmin)\n seqz1=axarr(1)%seqz\n call locate_condition(seqz1,pcond1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed find first condition ',j1,j2\n gx%bmperr=0\n cycle cycle2\n endif\n! first argument 1 means get value, 0 means set value\n call condition_value(0,pcond1,xx1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting start point condition',gx%bmperr\n gx%bmperr=0; cycle cycle2\n endif\n! calculate equilibrium\n! write(*,130)'SMP startpoint: ',nss,xx1,xx2\n130 format(a,i3,2(1pe14.4))\n! call list_conditions(kou,ceq)\n call calceq2(mode,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed calculate startpoint'\n gx%bmperr=0\n else\n! enter a start equilibrum with two directions\n write(*,*)'SMP eqname: ',eqname\n call incunique(eqname(10:11))\n write(*,*)'SMP eqname: ',eqname\n call copy_equilibrium(neweq,eqname,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed to store starteq: ',trim(eqname),gx%bmperr\n gx%bmperr=0; cycle cycle2\n endif\n write(*,*)'SMP Created equilibrium: ',trim(eqname),neweq%eqno\n neweq%multiuse=20+nss\n! create the list, ceq is always same equilibrium as starteq\n neweq%nexteq=ceq%nexteq\n! starteq not assigned here ... set to ceq above /BoS 20200220\n starteq%nexteq=neweq%eqno\n endif\n enddo cycle2\n enddo cycle1\n! a start point in the middle\n500 continue\n xx1=0.7*axarr(1)%axmin+0.3*axarr(1)%axmax\n seqz1=axarr(1)%seqz\n call locate_condition(seqz1,pcond1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed find first condition',3,3\n gx%bmperr=0\n goto 1000\n endif\n! first argument 1 means get value, 0 means set value\n call condition_value(0,pcond1,xx1,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting first central point condition',gx%bmperr\n gx%bmperr=0; goto 1000\n endif\n xx2=0.6*axarr(2)%axmin+0.4*axarr(2)%axmax\n seqz2=axarr(2)%seqz\n call locate_condition(seqz2,pcond2,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed find 2nd condition ',j1,j2\n gx%bmperr=0\n goto 1000\n endif\n! first argument 1 means get value, 0 means set value\n call condition_value(0,pcond2,xx2,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error setting second central point condition',gx%bmperr\n gx%bmperr=0; goto 1000\n endif\n! calculate equilibrium\n! write(*,130)'SMP startpoint: ',5,xx1,xx2\n! call list_conditions(kou,ceq)\n call calceq2(mode,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP failed calculate startpoint'\n gx%bmperr=0\n else\n! enter a start equilibrum with two directions\n call incunique(eqname(10:11))\n call copy_equilibrium(neweq,eqname,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Failed to store start equilibrium',gx%bmperr\n gx%bmperr=0; goto 1000\n endif\n neweq%multiuse=30 \n neweq%nexteq=starteq%nexteq\n starteq%nexteq=neweq%eqno\n endif\n1000 continue\n write(*,*)'SMP *** leaving auto_startpoint'\n return\n end subroutine auto_startpoints\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine reset_plotoptions\n!\\begin{verbatim}\n subroutine reset_plotoptions(graphopt,plotfile,textlabel)\n! if new axis then reset default plot options\n! plot ranges and their defaults\n character plotfile*(*)\n type(graphics_options) :: graphopt\n type(graphics_textlabel), pointer :: textlabel\n!\\end{verbatim}\n integer savebit\n graphopt%gibbstriangle=.FALSE.\n graphopt%rangedefaults=0\n! axistype 0 is linear, 1 is logarithmic\n graphopt%axistype=0\n! labeldefaults(1) is the title!!!\n graphopt%labeldefaults=0\n graphopt%tielines=0\n graphopt%plotmin=zero\n graphopt%dfltmin=zero\n graphopt%plotmax=one\n graphopt%scalefact=one\n graphopt%dfltmax=one\n graphopt%appendfile=' '\n! do not reset font!\n! graphopt%font='Arial'\n! This is confused ... GRWIN=0 if WIndows, GRWIN=1 if not windows ... SUCK\n! if(btest(graphopt%status,GRWIN)) savebit=1\n! if the bit GRKEEP is set it should remain set\n! savebit=0\n! if(btest(graphopt%status,GRKEEP)) savebit=1\n! if(savebit.ne.0) graphopt%status=ibset(graphopt%status,GRKEEP)\n! remove all texts ... loosing some memory ...\n nullify(graphopt%firsttextlabel)\n graphopt%labelkey='top right font \"'//trim(graphopt%font)//',12\" '\n nullify(graphopt%firsttextlabel)\n nullify(textlabel)\n plotfile='ocgnu'\n! reset status but by default spawn plots\n graphopt%status=0\n graphopt%status=ibset(graphopt%status,GRKEEP)\n! lowerleftcorner\n graphopt%lowerleftcorner=' '\n! default plot terminal\n graphopt%gnutermsel=1\n! plot linetype default 1\n graphopt%linetype=1\n! no plot symbols\n graphopt%linewp=0\n! axis tics size etc\n graphopt%textonaxis=0\n! setgrid\n graphopt%setgrid=0\n! do not reset plotend if set\n! plotend=plotenddefault\n! write(*,*)'Plot options reset'\n return\n end subroutine reset_plotoptions\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/stepmapplot/smp2B.F90", "content": "! included in smp2.F90. Generating graphics using GNUPLOT\n\n!\\addtotable subroutine ocplot2\n!\\begin{verbatim}\n subroutine ocplot2(ndx,maptop,axarr,graphopt,version,ceq)\n! subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,pform,&\n! version,ceq)\n! Main plotting routine, generates a GNUPLOT data file for a step/map calc\n! NOTE for isothermal section ocplot3 is used (when 2 axis with wildcards)\n! ndx is mumber of plot axis, \n! - pltax is text with plotaxis variables\n! - filename is the name of the GNUPLOT file\n! maptop is map_node record with all results\n! axarr is array of axis records\n! graphopt is graphical option record\n! NOT USED: pform is type of output (screen/acrobat/postscript/gif)\n! ceq is equilibrium record\n implicit none\n integer ndx\n! character pltax(*)*(*),filename*(*),pform*(*)\n character version*(*)\n type(map_axis), dimension(*) :: axarr\n type(map_node), pointer :: maptop\n type(graphics_options) :: graphopt\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n! local variables set from graphopt\n! character pltax(2)*64,filename*64,pform*32\n character pltax(2)*64,filename*128\n!\n type(map_ceqresults), pointer :: results\n TYPE(gtp_equilibrium_data), pointer :: curceq\n type(map_node), pointer :: mapnode,invar,localtop\n type(map_line), pointer :: mapline\n logical wildcard,hashtag\n character ch1*1,gnuplotline*256,pfd*128,pfc*256\n character pfh*128,dummy*24\n double precision, dimension(:,:), allocatable :: anp\n double precision, dimension(:), allocatable :: xax,yyy\n! save isopleth invariants in special array, max 50 invariants\n double precision xyinv(4,50)\n integer ninv\n! Too big??\n! integer, parameter :: maxval=10000\n! plotting isothermal section Cr-Fe-Mo required more than 2000\n integer, parameter :: maxval=4000\n integer, dimension(:), allocatable :: nonzero,linzero,linesep\n! integer, dimension(:), allocatable :: linesep\n! encoded2 stores returned text from get_many ... 2048 is too short ...\n! selphase used when plotting data just for a selected phase like y(fcc,*)\n character statevar*64,encoded1*1024,encoded2*4096,selphase*24,funsym*24\n character*128, dimension(:), allocatable :: phaseline\n integer i,ic,jj,k3,kk,kkk,lokcs,nnp,np,nrv,nv,nzp,ip,nstep,nnv,nofapl\n integer nr,line,next,seqx,nlinesep,ksep,iax,anpax,notanp,appfil,errall\n double precision xmax,xmin,ymax,ymin,value,anpmin,anpmax\n! used for Scheil\n double precision npflval\n logical scheilorder\n! lhpos is last used position in lineheader\n integer giveup,nax,ikol,maxanp,lcolor,lhpos,repeat,anpdim,qp\n integer nix,stoichfix,invlines,invnode,nrett,mfix\n integer, allocatable, dimension(:) :: ixpos\n! setting color on isopleth lines? Dimension is max different fix phases\n integer, allocatable, dimension(:,:) :: phamfu\n integer fixphasecolor\n! trying to understand\n integer ttunodeid,ttuheads,ttutoplines,ttuline,ttuplotline,haha\n character date*8,mdate*12,title*128,backslash*2,lineheader*1024\n character deftitle*128,labelkey*64\n logical overflow,first,last,novalues,selectph,varofun,moretops,isopleth\n logical, allocatable, dimension(:) :: nevernone\n! dot derivatives should not be calcuated at first point of a range\n logical skipdotder\n! textlabels\n type(graphics_textlabel), pointer :: textlabel\n! line identification (title)\n character*16, dimension(:), allocatable :: lid\n! character*32, dimension(:), allocatable :: lid\n!\n! write(*,*)'In ocplot2 graphopt%status: ',maptop%status,MAPINVARIANT\n! transfer from graphics record to local variables\n! initiate lines_excluded\n lines_excluded=0\n scheilorder=.FALSE.\n! create the terminal plot_line record\n allocate(lastplotline)\n nullify(lastplotline%nextline)\n lastplotline%type=-1\n plotline1=>lastplotline\n! when creating a new plotline: ??\n! 1: allocate(plotline%nextline)\n! 2: plotline%nextline%nextline=>plotline1\n! 3: ploline1=>plotline1%nextline\n! transfer from graphics record to local variables\n pltax(1)=graphopt%pltax(1)\n pltax(2)=graphopt%pltax(2)\n isopleth=btest(graphopt%status,GRISOPLETH)\n! write(*,*)'ocplot2 wildcard: ',trim(pltax(1)),' & ',trim(pltax(2))\n! if(index(pltax(1),'*').gt.0 .or. index(pltax(2),'*').gt.0) then\n! fixed in PMON6\n! allow plotting phase compositions also for isopleths ...\n! isopleth=.FALSE.\n! endif\n if(isopleth) write(*,*)'smp2b plotting isopleth'\n filename=graphopt%filename\n funsym=' '\n! for isopleths this value determine the line color\n fixphasecolor=1\n! If wildcard on two axis use ocplot3 to extract data (tie-lines in plane)\n if(index(pltax(1),'*').gt.0 .and. index(pltax(2),'*').gt.0) then\n! write(*,*)'Using ocplot3'\n call ocplot3(ndx,pltax,filename,maptop,axarr,graphopt,&\n version,ceq)\n goto 1000\n endif\n! for tzero lines there is no meqrec record, meqrec%phr not allocated\n! write(*,*)'In ocplot2: ',maptop%lines,allocated(maptop%linehead)\n moretops=.FALSE.\n seqx=0\n call date_and_time(date)\n mdate=\" \"//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//\" \"\n deftitle='OpenCalphad '//version//': '//mdate//': with GNUPLOT'\n if(graphopt%labeldefaults(1).eq.0) then\n title=deftitle\n else\n! alwas inlcude open calphad and date, add user title at the end\n! 123456789.123456789.123456789\n! 'Open Calphad 3.0 2015-03-16 : with GNUPLOT'\n jj=len_trim(deftitle)\n title=deftitle(1:jj+1)//graphopt%plotlabels(1)\n endif\n!\n if(.not.associated(maptop)) then\n write(kou,*)'In ocplot2 but nothing to plot'\n gx%bmperr=4247; goto 1000\n endif\n! write(*,*)'Entering OC plot version 2: ',&\n! pltax(1)(1:len_trim(pltax(1))),', ',pltax(2)(1:len_trim(pltax(2))),&\n! maptop%next%seqx\n if(graphopt%rangedefaults(1).ne.0) then\n write(*,11)'x',graphopt%plotmin(1),graphopt%plotmax(1)\n11 format('SMP limits set by user for ',a,': ',2(1pe14.6))\n endif\n if(graphopt%rangedefaults(2).ne.0) then\n write(*,11)'y',graphopt%plotmin(2),graphopt%plotmax(2)\n endif\n! allocate as many items in linesep as there are mapnodes.\n! Hm, if merging plots the number of separators needed can be any value\n jj=100+10*maptop%next%seqx+1\n! write(*,*)'SMP: Allocating linesep: ',jj\n allocate(linesep(jj),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 1: ',errall\n gx%bmperr=4370; goto 1000\n endif\n nax=maptop%number_ofaxis\n linesep=0\n! allocate texts to identify the lines on the gnuplot file\n! write(*,*)'SMP: Allocating phaseline: ',jj\n allocate(phaseline(jj),stat=errall)\n allocate(phamfu(2,jj),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 2: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! sometimes phaseline used containing rubbish ...\n phaseline=' '\n! zero array fr isopleth fix phase\n phamfu=0\n! if(maptop%number_ofaxis.gt.1) then\n! write(*,*)'Warning: may not not handle map graphics correctly',jj\n! endif\n!\n giveup=0\n nrv=maxval\n! write(*,*)'SMP: allocating xax: ',nrv\n allocate(xax(nrv),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 3: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! to insert MOVE at axis terminations\n nlinesep=1\n phaseline(1)=' '\n phaseline(2)=' '\n! nv is number of values to plot\n nv=0\n! min and max not used by gnuplot but may be useful if plotpackage change\n! or for manual scaling.\n xmin=1.0D20\n xmax=-1.0D20\n ymin=1.0D20\n ymax=-1.0D20\n maxanp=1000\n np=maxanp\n qp=1\n ninv=0\n wildcard=.FALSE.\n selectph=.FALSE.\n hashtag=.FALSE.\n selphase=' '\n graphopt%specialdiagram=0\n if(maptop%type_of_node.eq.3) then\n! this change the order of plotting the lines, maybe needed only for PFL/PFS ??\n scheilorder=.TRUE.\n endif\n do iax=1,2\n! write(*,*)'Allocating for axis: ',iax\n call capson(pltax(iax))\n if(pltax(iax)(1:4).eq.'PFL ' .or. pltax(iax)(1:4).eq.'PFS ') then\n if(maptop%type_of_node.eq.3) then\n! this is a function only used for plotting phase fraction liquid or solids\n! in Scheil simulations.\n npflval=one\n! this indicates to ocplot2B that one must use plot \"-\" ...etc\n! to have different colors and labels on different lines\n! write(*,*)'ocplot2: Setting graphopt%specialdiagram=2'\n graphopt%specialdiagram=2\n else\n write(*,*)'Plot axis PFL/PFS are reserved for Scheil simulations'\n gx%bmperr=4399; goto 1000\n endif\n endif\n! wildcard1: if(index(pltax(iax),'*').gt.0) then\n wildcard1: if(index(pltax(iax),'*').gt.0 .or. &\n index(pltax(iax),'(#)').gt.0) then\n! searching for (#) avoids problem when # is used for comp. sets or sublattatice\n i=index(pltax(iax),'#')\n if(i.gt.0 .and.&\n (pltax(iax)(i+1:i+1).eq.')'.or.pltax(iax)(i+1:i+1).eq.',')) then\n! this means the phase name is #, indicating all phases including dormant\n! Note that # is used to indicate composition sets, thus ignore #2 etc\n hashtag=.TRUE.\n! write(*,*)'SMP2B hastag set true',trim(pltax(iax)),i\n endif\n if(wildcard) then\n write(*,*)'in OCPLOT2 one axis variable with wildcard allowed'\n goto 1000\n endif\n! wildcards allowed only on one axis, we do not know how many columns needed\n! allocate as many array elements as columns\n anpdim=np\n! write(*,*)'SMP: allocating anp1: ',np*nrv\n allocate(anp(np,nrv),stat=errall)\n! write(*,*)'SMP: allocating anp2: ',np\n! nonzero indicates for each column if there is any nonzero value\n! columns with only zero values will be eliminated before plotting\n allocate(nonzero(np),stat=errall)\n! write(*,*)'SMP: allocating nonzero: ',np\n! linzero indicate for the present block of equilibria for each column\n! if this column contain nonzero values\n allocate(linzero(np))\n! write(*,*)'SMP: allocating yyy: ',np\n allocate(yyy(np),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 5: ',errall\n gx%bmperr=4370; goto 1000\n endif\n nzp=np\n! nzp should be dimension of yyy, np returns the number of values in yyy\n! yyy is to extract state variable values for the column with wildcard\n! NOTE binary phase diagrams are plotted with wildcard axis like x(*,cr) vs T\n! nevernone is an attempt to remove columns that are zero by the value NaN\n allocate(nevernone(np),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 6: ',errall\n gx%bmperr=4370; goto 1000\n endif\n nevernone=.FALSE.\n nonzero=0\n wildcard=.TRUE.\n anpax=iax\n! we can have wildcards as np(*), w(fcc,*) or w(*,cr) or y(gas,*)\n! IT IS NOT ALLOWED TO HAVE y(*,*) ... only one wildcard\n! when we plot things like y(fcc,*) we should only select equilibria\n! with fcc stable. Check if * is before or after a ,\n! NOTE that a single * without , can be phase or component:\n! MU(*) is for a component, HM(*) is for a phase \n! For MQMQA one sometimes plot N(*,component) when phase have zero amount\n ikol=index(pltax(iax),',')\n! write(*,*)'smp2b selectph: ',trim(pltax(iax)),ikol\n if(ikol.gt.0) then\n! if the * is after the , then extract the phase name before \n! and set selecrph to TRUE\n if(pltax(iax)(ikol+1:ikol+1).eq.'*') then\n nrv=index(pltax(iax),'(')\n if(nrv.lt.ikol) then\n selphase=pltax(iax)(nrv+1:ikol-1)\n! write(*,*)'SMP2B wildcard selected phase: ',trim(selphase)\n selectph=.TRUE.\n endif\n! else\n! we can also have N(*,constituent) plotting MQMQA diagrams? Never here\n! write(*,*)'SMP2B plotting: ',trim(pltax(iax))\n endif\n! else\n! this is perfectly possible, for example NP(*)\n! write(*,*)'SMP2B: Wildcard without ,!'\n endif\n endif wildcard1\n enddo\n if(.not.wildcard) then\n anpdim=1\n allocate(anp(anpdim,nrv),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 7: ',errall\n gx%bmperr=4370; goto 1000\n endif\n wildcard=.FALSE.\n nnp=1\n anpax=2\n endif\n! zero anp, maybe waste of time but ...\n anp=zero\n! if anpax is 1, notanp is 2, if anpax is 2, notanp is 1\n notanp=3-anpax\n localtop=>maptop\n! write(*,*)'In ocplot2, looking for segmentation fault 2'\n!-------------\n! come back here if there is another localtop in plotlink!\n77 continue\n! change all \"done\" marks in mapnodes to zero\n! write(*,*)'SMP2B ocplot2 at label 77A: ',localtop%lines\n ikol=0\n do nrv=1,localtop%lines\n if(allocated(localtop%linehead)) localtop%linehead(nrv)%done=0\n enddo\n! we sometimes have a segmentation fault when several maptops ...\n if(associated(localtop%next)) then\n mapnode=>localtop%next\n invnode=0\n if(btest(mapnode%status,MAPINVARIANT)) then\n invnode=size(mapnode%linehead)\n! write(*,*)'ocplot2 invariant node 1',invnode\n endif\n else\n write(*,*)'Mapnode next link missing 1'\n goto 79\n endif\n! write(*,*)'SMP2B ocplot2 at label 77B: ',localtop%lines\n thisloop: do while(.not.associated(mapnode,localtop))\n do nrv=1,mapnode%lines\n mapnode%linehead(nrv)%done=0\n enddo\n if(.not.associated(mapnode%next)) then\n write(*,*)'Mapnode next link missing 2'\n exit thisloop\n endif\n mapnode=>mapnode%next\n enddo thisloop\n!-----------\n79 continue\n if(.not.associated(localtop%saveceq)) then\n write(*,*)'Plot data structure has no results to plot'\n gx%bmperr=4399; goto 1000\n endif\n results=>localtop%saveceq\n mapnode=>localtop\n line=1\n! looking for segmentation fault running map11.OCM as part of all.OCM in oc4P\n! This error may be due to having created (or not created) composition sets ...\n! write(*,*)'SMP2B ocplot2 after label 79'\n! extract the names of stable phases for this lone\n\n! write(*,*)'mapnode index: ',mapnode%seqx\n! write(*,*)'Before label 100: ',results%free\n!------------------------------------------- begin loop 100\n! loop back here from ??\n100 continue\n! write(*,*)'SMP2B ocplot2 at label 100',localtop%seqx,line,&\n! size(localtop%linehead)\n mapline=>localtop%linehead(line)\n! TRYING TO UNDERSTAND WHAT IS HAPPENING HERE ....\n ttunodeid=localtop%seqx\n ttuheads=size(localtop%linehead)\n ttutoplines=localtop%lines\n ttuline=line\n ttuplotline=nv\n! write(*,101)'At 100',ttunodeid,ttuheads,ttutoplines,ttuline,ttuplotline\n101 format('Line selected: ',a,': nodeid ',i3,', heads/lines: ',2i2,&\n ' index: ',i2,', plotline: ',2i4)\n! initiate novalues to false for each line\n novalues=.false.\n! skip first point if dot derivative\n skipdotder=.TRUE.\n! We have a segmentation fault sfter this in oc4P when running map11.OCM\n! at the end of running all macros. \n! write(*,*)'In ocplot2, looking for segmentation fault 3'\n! skip line if EXCLUDEDLINE set\n if(btest(mapline%status,EXCLUDEDLINE)) then\n! write(*,*)'Skipping a line 3'\n lines_excluded=lines_excluded+1\n if(line.lt.mapnode%lines) then\n line=line+1\n goto 100\n else\n goto 500\n endif\n endif\n! We jump here from where?? ... several places\n110 continue\n! mark line is plotted\n! write(*,*)'Values from mapline ',mapline%lineid\n! loop for all calculated equilibria, phases and composition sets\n! write(*,*)'Before label 150: ',mapline%lineid\n!150 continue\n nr=mapline%first\n if(mapline%done.ne.0) goto 220\n mapline%done=-1\n! if(ocv()) write(*,*)'Plotting line: ',&\n! write(*,*)'Plotting line: ',&\n! mapline%lineid,mapline%number_of_equilibria,mapline%termerr\n!--------------\n ttunodeid=localtop%seqx\n ttuheads=size(localtop%linehead)\n ttutoplines=localtop%lines\n ttuline=line\n ttuplotline=nv\n! write(*,101)'at 110',ttunodeid,ttuheads,ttutoplines,ttuline,&\n! ttuplotline\n!--------------\n if(mapline%lineid.le.0) then\n write(*,*)'Skipping line with id less or equal to zero'\n goto 500\n elseif(mapline%number_of_equilibria.le.0) then\n! write(*,*)'Skipping line with no equilibria.'\n goto 500\n endif\n first=.TRUE.\n! last set true when we reach the last equilibrium on the line\n last=.FALSE.\n! we may have empty lines due to bugs ...\n! write(*,*)'Axis with wildcard and not: ',anpax,notanp\n!200 continue\n! this is the loop for all equilibria in the line\n! write(*,*)'SMP2: nr and nv: ',nr,nv\n! Possibly skip last if mapline%termerr not zero\n! if(mapline%termerr.ne.0) write(*,*)'SMP2B termerr:',mapline%termerr\n nrett=nv+1\n plot1: do while(nr.gt.0)\n! nr is index to stored equilibrium\n if(last.and. mapline%termerr.ne.0) then\n! skip this equilibrium!!\n nr=0\n! write(*,*)'Skipping last point of a line in the plot'\n! same as cycle plot1 but maybe safer??\n goto 220\n! cycle plot1\n endif\n nv=nv+1\n if(nv.ge.maxval) then\n write(*,*)'Too many points to plot',maxval\n goto 600\n endif\n curceq=>results%savedceq(nr)\n! write(*,201)'SMP2B Current: ',nr,nv,curceq%tpval(1)\n if(ocv()) write(*,201)'Current equilibrium: ',nr,nv,curceq%tpval(1)\n201 format(a,2i5,F8.2,1pe14.6)\n! extract the names of stable phases to phaseline from the first equilibrium\n! Note that the information of the fix phases have not been saved\n if(first) then\n! segmentation fault after here\n! write(*,*)'In ocplot2, looking for segmentation fault 4A'\n first=.false.\n kk=1\n! leave space to write fixphasecolor index first\n if(isopleth) kk=5\n! if(selectph) novalues=.TRUE.\n phloop: do jj=1,noph()\n! write(*,*)'In ocplot2, segmentation fault 4Ax',jj,noofcs(jj)\n do ic=1,noofcs(jj)\n k3=test_phase_status(jj,ic,value,curceq)\n if(gx%bmperr.ne.0) goto 1000\n stableph1: if(k3.gt.0) then\n! this phase is stable or fix\n call get_phase_name(jj,ic,dummy)\n if(gx%bmperr.ne.0) goto 1000\n if(selectph) then\n! this is an attempt to remove lines from irrelevant equilibria when plotting\n! data for a specific phase like y(fcc#4,*) which is not stable??\n if(abbr_phname_same(dummy,trim(selphase))) then\n novalues=.FALSE.\n! write(*,217)'SMP2B novalues set FALSE',&\n! mapline%lineid,trim(dummy),trim(selphase)\n217 format(a,i5,2x,a,2x,a)\n exit phloop\n else\n novalues=.TRUE.\n! write(*,*)'SMP2B novalues set TRUE',mapline%lineid\n endif\n endif\n if(.not.novalues) then\n! I think this phaseline is no longer used ?? YES it is\n! write(*,*)'SMP addto phaseline 1: ',trim(dummy),&\n! nlinesep\n phaseline(nlinesep)(kk:)=dummy\n kk=len_trim(phaseline(nlinesep))+2\n endif\n linecolor: if(isopleth .and. value.eq.zero) then\n! attempt to have the same color for all lines with same fix phase\n kkk=10*jj+ic\n do mfix=1,nlinesep\n if(kkk.eq.phamfu(1,mfix)) then\n phamfu(1,nlinesep)=kkk\n phamfu(2,nlinesep)=phamfu(2,mfix)\n! write(*,*)'smp2b same: ',kkk,phamfu(1,mfix)\n exit linecolor\n endif\n enddo\n if(mfix.gt.nlinesep) then\n phamfu(1,nlinesep)=kkk\n phamfu(2,nlinesep)=fixphasecolor\n fixphasecolor=fixphasecolor+1\n! save phase names in lid for KET, how many phases?\n if(.not.allocated(lid)) then\n allocate(lid(20))\n lid=' '\n endif\n lid(fixphasecolor-1)=dummy\n endif\n! write(*,'(a,7i5)')'smp2b phasecolor: ',nlinesep,mfix,&\n! kkk,jj,fixphasecolor\n endif linecolor\n endif stableph1\n enddo\n enddo phloop\n! finding place to change color of line in Scheil simulations\n! write(*,'(a,i3,2x,a)')'ocplot2 extract stable phases ',&\n! nlinesep,trim(phaseline(nlinesep))\n! do kkk=1,nlinesep\n! write(*,'(a,i3,3i5)')'smp2b color: ',nlinesep,&\n! kkk,phamfu(1,kkk),phamfu(2,kkk)\n! enddo\n! This destroyed phaseline for map with tie-lines in plasne ...\n if(isopleth) &\n write(phaseline(nlinesep)(1:3),'(i3)')phamfu(2,nlinesep)\n! write(*,117)'smp2b phaseline: ',nlinesep,phamfu(2,nlinesep),&\n! trim(phaseline(nlinesep))\n117 format(a,2i5,2x,a)\n! the segmentation fault was that linzero not always allocated ....\n if(allocated(linzero)) linzero=0\n endif\n! no wildcards allowed on this axis\n statevar=pltax(notanp)\n! write(*,'(a,a,3i4,1pe12.4)')'In ocplot2, segmentation fault 4Ay1: ',&\n! trim(statevar),nr,nv,notanp,curceq%tpval(1)\n if(skipdotder) then\n! If skipdotder and this is a dot derivative return error code to skip value\n! write(*,*)'smp2B skipping point A: ',trim(statevar),nv\n! skipdotder=.FALSE.; special_circumstances=1\n special_circumstances=1\n endif\n if(statevar(1:4).eq.'PFL ' .or. statevar(1:4).eq.'PFS ') then\n call meq_get_state_varorfun_value('NPM(LIQUID) ',&\n value,encoded1,curceq)\n value=npflval*value\n npflval=value\n if(statevar(1:4).eq.'PFS ') value=one-value\n else\n call meq_get_state_varorfun_value(statevar,value,encoded1,curceq)\n! write(*,*)'SMP axis variable 1: ',trim(encoded1),value,gx%bmperr\n if(gx%bmperr.ne.0) then\n! this error should not prevent plotting the other points FIRST SKIPPING\n write(*,212)'SMP skipping a point 1, error evaluating: ',&\n statevar(1:10),curceq%tpval(1),nv,nr,gx%bmperr\n212 format(a,a,f10.2,3i5)\n! buperr resets putfun error \n gx%bmperr=0; buperr=0\n nv=nv-1; goto 215\n endif\n endif\n xax(nv)=value\n! write(*,201)'at 202: ',nr,nv,curceq%tpval(1),value\n! xax(nv)=curceq%tpval(1)\n! macro step1 run in parallel plotting cp has segm fault after this line\n! write(*,*)'After label 200: ',mapline%lineid,nr,nv\n if(xax(nv).lt.xmin) xmin=xax(nv)\n if(xax(nv).gt.xmax) xmax=xax(nv)\n! second axis\n statevar=pltax(anpax)\n! varofun=.FALSE.\n! write(*,*)'In ocplot2: wildcard, selectph and novalues:',&\n! wildcard,selectph,novalues\n if(wildcard) then\n! NEW ignore data for this equilibrium if NOVALUES is TRUE\n! because \"selphase\" not equal to the stable phase found above\n if(novalues) then\n! write(*,*)'Ignoring equilibria without ',trim(selphase)\n yyy=zero\n! np=1\n! skip this equilibrium, nv=nv-1, and take next equilibrium, increement nr!!\n nv=nv-1\n goto 199\n else\n! write(*,*)'SMP2B wildcard value 1: ',nr,trim(statevar)\n! write(*,*)'In ocplot2, segmentation fault after 4C1: ',&\n! trim(statevar),nooftup()\n! segmentation fault is inside this call for map11.OCM\n! probably because new composition set created\n! write(*,*)'SMP2B get_many ',trim(statevar),nzp,selectph,hashtag\n! nzp is dimentsion of yyy, np is number of values\n! write(*,*)'\u0007SMP2B calling get_many_svar: ',trim(statevar)\n call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq)\n! write(*,*)'In ocplot2, segmentation fault search: '\n if(gx%bmperr.ne.0) then\n write(*,*)'Error return from \"get_many_svar',gx%bmperr\n goto 1000\n endif\n! write(*,223)'SMP2B values: ',np,(yyy(i),i=1,np)\n! problem that part of encoded2 desctroyed in late calls, it is OK here\n! write(*,737)len_trim(encoded2),trim(encoded2)\n737 format('smp2b: debug encoded2 ',i5/a/)\n! write(*,738)(yyy(qp),qp=1,np)\n738 format('SMP mm: ',(10F7.3))\n! compiling without -finit-local-zero gives a segmentation fault here\n! running the MAP11 macro\n qp=np\n! write(*,*)'SMP2B wildcard value 2: ',nr,trim(statevar)\n! write(*,223)'SMP2B Values: ',np,(yyy(i),i=1,np)\n! if(selectph) then\n! write(*,*)'SMP2B: number of values: ',trim(selphase),np,nv\n223 format(a,i3,20F8.4)\n! endif\n nix=np\n! we must allocate the array to indicate which values that should e plotted\n if(allocated(ixpos)) deallocate(ixpos)\n allocate(ixpos(nix),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 8: ',errall\n gx%bmperr=4370; goto 1000\n endif\n! This quite complicated IF is to handle the case when the wildcard is\n! is a phase or component/constituent\n! write(*,*)'SMP2B stvarix: ',trim(statevar),selectph\n if(statevar(1:2).EQ.'MU' .or. &\n statevar(1:2).EQ.'AC' .or. statevar(1:4).EQ.'LNAC' .or. &\n selectph.and.(&\n statevar(1:2).EQ.'N(' .or. statevar(1:2).EQ.'B(' .or. &\n statevar(1:2).EQ.'X(' .or. statevar(1:2).EQ.'X%' .or. &\n statevar(1:2).EQ.'W(' .or. statevar(1:2).EQ.'W%')) then\n! for the state variables MU(*), AC(*), LNAC(*), N(*), X(*), W(*) the *\n! means component, not phase, set selectph=.FALSE.\n! write(*,*)'SMP Wildcard means component! ',trim(statevar),np\n! not calling stvarix, all values should be included\n! Allocation should be number of components\n ixpos=1\n elseif(.not.selectph .and. .not.hashtag) then\n! elseif(selectph) then\n! this routine supress values for phases that are not relevant ...\n! IT SHOULD NOT BE USED FOR CASES LIKE Y(GAS,*)\n! write(*,737)len_trim(encoded2),trim(encoded2)\n! allocation should be number of phases\n! if \n! write(*,'(a,a/a,2i5)')'SMP2B stvarix1: ',trim(statevar),&\n! trim(encoded2),nlinesep,nix\n call stvarix(statevar,phaseline(nlinesep),&\n encoded2,nix,ixpos)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2B yaxis error: \"',trim(statevar),'\"'\n goto 1000\n endif\n else\n! here we may have hashtag TRUE\n! write(*,*)'SMP2B Hashtag: ',hashtag\n! We should supress values for suspended phases !!!\n if(hashtag) then\n call hashtag_susphix(statevar,phaseline(nlinesep),&\n encoded2,nix,ixpos,curceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2B failed handle hashtag'\n goto 1000\n endif\n else\n ixpos=1\n endif\n endif\n endif\n! if(hashtag) then\n! all values are used\n! ixpos=1\n! endif\n! write(*,*)'On ocplot2, segmentation fault 4D1'\n! write(*,213)trim(encoded2),np,(yyy(ic),ic=1,np)\n213 format('WILDCARD: ',a,i3/6(1pe12.4))\n! write(*,214)np,(ixpos(ic),ic=1,np)\n214 format('ixpos: ',12i3)\n! write(*,16)'val: ',kp,nr,gx%bmperr,(yyy(i),i=1,np)\n16 format(a,2i3,i5,/6(1pe11.3/))\n anpmin=1.0D20\n anpmax=-1.0D20\n lcolor=0\n! write(*,'(a,90i3)')'SMP ixpos: ',(ixpos(jj),jj=1,np)\n! write(*,*)'On ocplot2, segmentation fault before 4D2',np\n! this is a loop for all values for this equilibria\n! Here we may try to replace zero values by RNONE ???\n! write(*,*)'SMP2B RNONE: ',RNONE\n do jj=1,np\n if(last) then\n if(linzero(jj).ne.0) then\n! in last equilibria we may have a value from the new phase at the node\n anp(jj,nv)=yyy(jj)\n! elseif(yyy(jj).ne.zero) then\n! write(*,*)'SMP skipping a value for line ',nlinesep\n endif\n else\n! trying to avoid plotting a line at zero for unstable/unused state variables \n! now we have used stvarix to identify the relevant phases\n if(yyy(jj).eq.zero) then\n if(ixpos(jj).eq.0) then\n! for STEP calculations try to make the ending a property at zero\n! for MAP calculations just ignore the point ... also for STEP ...\n anp(jj,nv)=rnone\n else\n anp(jj,nv)=zero\n endif\n else\n! Hm, jumps from zero to finite values in step1, fig 3 plotting w(phase,cr) ..\n! if(nv.gt.1 .and. anp(jj,nv-1).eq.rnone) then\n! anp(jj,nv-1)=zero\n! endif\n anp(jj,nv)=yyy(jj)\n endif\n! difficult ...\n if(yyy(jj).ne.rnone .and. ixpos(jj).ne.0) then\n! ths is the trick to supress lines for phases that are never stable\n nonzero(jj)=1\n linzero(jj)=1\n! save the first column with nonzero for use with invariants\n if(ikol.eq.0) ikol=jj\n if(anp(jj,nv).gt.anpmax) anpmax=anp(jj,nv)\n if(anp(jj,nv).ne.rnone .and. &\n anp(jj,nv).lt.anpmin) anpmin=anp(jj,nv)\n! extract state variable jj used for table headings and key\n if(.not.allocated(lid)) then\n allocate(lid(np+5),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 9: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n if(.not.isopleth) then\n! if not isopleth save variable symbol in lid for headings (KEY)\n! getext( , ,2, , , ) returns next text item up to a space\n call getext(encoded2,lcolor,2,encoded1,'x',lhpos)\n lid(jj)=encoded1\n! lid is 16 characters\n kk=len_trim(encoded1)\n if(kk.gt.len(lid(jj))) then\n! lid(jj)(7:)='..'//encoded1(kk-6:kk)\n! proposal by Chunhui, modified by 2 positions\n! 12 12345\n lid(jj)(10:)='..'//encoded1(kk-4:kk)\n endif\n endif\n else\n! skip state variable\n call getext(encoded2,lcolor,2,encoded1,'x ',lhpos)\n endif\n endif\n enddo\n! write(*,*)'OK Point: ',nr,nv,xax(nv)\n else\n! A single state variable or function value like CP\n! I HAVE HAD PROBLEMS WITH NEGATIVE CP HERE \n! try skipping this value (below) if last equilibrium on the line \n! varofun=.TRUE.\n! segmentation fault if I plot Cp after shifting to a NEW MAPTOP record\n! write(*,'(a,F8.2,a,a)')'SMP meq_get_state_varofun 7: T=',&\n! curceq%tpval(1),' axis: ',trim(statevar)\n! encoded1 not set correctly for dot derivative !!\n! encoded1='dummy'\n! there is a segmentation fault in this call\n! segmentation fault if maptop changed (several map/step commands)\n if(skipdotder) then\n! return error code if calculating a derivative at first point of line\n! write(*,*)'smp2B skipping point B: ',trim(statevar),nv\n skipdotder=.FALSE.; special_circumstances=1\n endif\n! special Scheil simulation \n if(statevar(1:4).eq.'PFL ' .or. statevar(1:4).eq.'PFS ') then\n call meq_get_state_varorfun_value('NPM(LIQUID) ',&\n value,encoded1,curceq)\n value=npflval*value\n npflval=value\n if(statevar(1:4).eq.'PFS ') value=one-value\n encoded1=statevar\n else\n! end special Scheil, evaluate function normally\n call meq_get_state_varorfun_value(statevar,value,&\n encoded1,curceq)\n! encoded1 here is wrong?? not Cp when it should be, also when no error\n! write(*,*)'SMP axis value 7: ',trim(encoded1),value,gx%bmperr\n if(gx%bmperr.ne.0) then\n! SECOND Skipping\n if(gx%bmperr.ne.4373) &\n write(*,212)'SMP Skipping a point 2,error evaluating: ',&\n statevar(1:10),curceq%tpval(1),nv,nr,gx%bmperr\n nv=nv-1; goto 215\n endif\n endif\n! save to use in lid if not allocated\n funsym=encoded1\n if(results%savedceq(nr)%nexteq.eq.0) then\n! THIRD ?? Skipping\n! write(*,212)'SMP skip last evaluated symbol: ',&\n! trim(statevar),curceq%tpval(1),nv,nr,gx%bmperr\n if(trim(statevar).ne.trim(encoded1)) then\n! If \"statevar\" not equal to \"encoded1\" skip last point\n! This is a clumsy way to avoid negative CP=H.T values at end of lines ...\n nv=nv-1; goto 215\n endif\n endif\n! if(gx%bmperr.ne.0) goto 1000\n anp(1,nv)=value\n! macro test step1 run in parallel has segme fault plotting cp before this line\n! write(*,201)'at 19: ',nr,nv,curceq%tpval(1),value\n! write(*,19)'Bug: ',nr,nv,seqx,xax(nv),anp(1,nv)\n19 format(a,3i4,2(1pe12.4))\n anpmin=anp(1,nv)\n anpmax=anp(1,nv)\n endif\n if(anpmin.lt.ymin) ymin=anpmin\n if(anpmax.gt.ymax) ymax=anpmax\n215 continue\n! reset any previous error code\n if(gx%bmperr.ne.0) then\n! write(*,*)'SMP reset error code ',gx%bmperr\n gx%bmperr=0\n endif\n199 continue\n nr=curceq%nexteq\n if(nr.gt.0) then\n if(results%savedceq(nr)%nexteq.eq.0) then\n! write(*,*)'We have found last equilibria along the line: ',nr\n last=.TRUE.\n! skipdotder=TRUE means skip dot derivatives at first equilibrium in next line\n skipdotder=.TRUE.\n endif\n endif\n!>>>>>>>>>>>>>>>>>>>>>>>>>> starting a line\n! write(*,*)'Next equilibrium: ',nr,nv,xax(nv)\n! read(*,17)ch1\n17 format(a)\n enddo plot1\n220 continue\n! finished one line\n! write(*,*)'SMP2B at 220: nr and nv: ',nr,nv\n invariant_lines: if(nax.gt.1) then\n!---------------------------------------------------------------\n!------------------ special for invariant lines ?? and others\n!---------------------------------------------------------------\n! for phase diagram always move to the new line \n map1: if(nlinesep.ge.1) then\n newsep: if(linesep(nlinesep).lt.nv) then\n! we should never have several linesep for the same value of nv!\n nlinesep=nlinesep+1\n linesep(nlinesep)=nv\n! names of phases on new line\n phaseline(nlinesep+1)=' '\n! write(*,*)'adding empty line 1',nlinesep,linesep(nlinesep)\n inv: if(localtop%tieline_inplane.gt.0 .and. &\n associated(mapline%end)) then\n! write(*,*)'Tie-lines in plane, an invariant equil here'\n! extract values for invariant equilibrium\n invar=>mapline%end\n if(ocv()) write(*,*)'Invariant eq: ',&\n invar%seqx,invar%savednodeceq\n if(invar%savednodeceq.lt.0) then\n write(*,*)'SMP equilibrium not saved, skipping'\n goto 222\n endif\n! This is a check for node with 2 stoichiometric phases, if so skip first line\n! if(invar%artxe.eq.1) then\n! write(*,*)'Found node with 2 stoichiomeric phases'\n! endif\n curceq=>results%savedceq(invar%savednodeceq)\n!-------------------\n! get the names of stable phases from the node equilibrium record\n kk=1\n stoichfix=0\n extractphnames: do jj=1,noph()\n do ic=1,noofcs(jj)\n! value is amount of phase?\n k3=test_phase_status(jj,ic,value,curceq)\n if(k3.gt.0) then\n! this phase is stable or fix\n! write(*,*)'SMP addto phaseline 2: ',trim(dummy),&\n! nlinesep\n call get_phase_name(jj,ic,dummy)\n if(kk.lt.100) phaseline(nlinesep)(kk:)=dummy\n kk=len_trim(phaseline(nlinesep))+2\n stoichfix=stoichfix+1\n endif\n enddo\n enddo extractphnames\n! invariant write(*,*)'SMP2 phases: ',trim(phaseline(nlinesep)),nlinesep\n if(stoichfix.gt.3) then\n write(*,*)'SMP2B too many stable phases at invariant',&\n stoichfix\n stoichfix=3\n endif\n!-------------------\n! axis without wildcard\n statevar=pltax(notanp)\n if(skipdotder) then\n! skip calculating a derivative if this is first point of a region\n! write(*,*)'smp2B skipping point C: ',trim(statevar),nv\n skipdotder=.FALSE.; special_circumstances=1\n endif\n call meq_get_state_varorfun_value(statevar,value,&\n encoded1,curceq)\n! write(*,*)'SMP axis variable 3: ',encoded1(1:3),value\n if(gx%bmperr.ne.0) then\n! THIRD skipping\n write(*,212)'SMP skipping a point 3, error evaluating ',&\n statevar,curceq%tpval(1),nv,0,gx%bmperr\n goto 222\n endif\n! save symbol name if lid not allocated\n funsym=encoded1\n! This is tielines inplane, normally 3 lines to generate\n! but when 2 stoichiometric phass with same composition one is not set stable\n! nv=nv+3\n! NOTE if not wildcard nv is decremented in next \"else\" statement\n nv=nv+stoichfix\n if(nv.ge.maxval) then\n write(*,*)'Too many points to plot 2',maxval\n goto 600\n endif\n do invlines=0,stoichfix-1\n xax(nv-invlines)=value\n enddo\n! write(*,335)'New line: ',nlinesep,nv,linesep(nlinesep),&\n! statevar(1:5),value\n335 format(a,3i4,' <',a,'> ',3(1pe14.6))\n! axis with possible wildcard\n statevar=pltax(anpax)\n! write(*,*)'In ocplot2, segmentation fault 4H'\n wild2: if(wildcard) then\n! this cannot be a state variable derivative\n! write(*,*)'SMP2B wildcard value 3: ',nr,statevar(1:20)\n call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq)\n if(gx%bmperr.ne.0) goto 1000\n! we have to handle axis values that are zero what is np here???\n nix=np\n! to supress suspended phases\n! write(*,'(a,a/a,2i5)')'SMP2B stvarix2: ',trim(statevar),&\n! trim(encoded2),nlinesep,nix\n call stvarix(statevar,phaseline(nlinesep),&\n encoded2,nix,ixpos)\n if(gx%bmperr.ne.0) goto 1000\n! save one non-zero value per line, 3 lines\n ic=0\n do jj=1,np\n! np is the number of values retrieved by get_many_svar\n! only those with nonzero values in ixpos should be used, one per line.\n if(ixpos(jj).ne.0) then\n anp(ikol,nv-ic)=yyy(jj)\n ic=ic+1\n endif\n enddo\n! for RNONE = NaN add empty line after invariant ...\n if(linesep(nlinesep).lt.nv) then\n! we should never have several linesep for the same value of nv!\n nlinesep=nlinesep+1\n linesep(nlinesep)=nv\n! write(*,*)'Empty line after invariant: ',nlinesep,nv\n endif\n else\n! if no wildcard extract the phase with zero amount\n\n nv=nv-stoichfix\n goto 225\n endif wild2\n222 continue\n! else\n! write(*,*)'SMP no else link ...'\n endif inv\n endif newsep\n endif map1\n! jump here if no wildcard\n225 continue\n endif invariant_lines\n! \n if(invnode.ne.0) then\n! write(*,'(a,3i4,2(1pe12.4))')'ocplot2 Invariant isopleth node: ',&\n! invnode,ninv,nrett,xax(nrett),anp(1,nrett)\n if(ninv.eq.0) then\n! the first invariant isopleth \n ninv=ninv+1\n xyinv(1,1)=xax(nrett); xyinv(2,1)=anp(1,nrett)\n xyinv(3,1)=xax(nrett); xyinv(4,1)=anp(1,nrett)\n else\n! check if anp value same as already saved invariant\n cinv: do kk=1,ninv\n if(abs(anp(1,nrett)-xyinv(2,kk)).lt.1.0D-4) then\n! same ... check if x values lesser than xyinv(1,kk) or greater than xyinv(3,kk)\n if(xax(nrett).lt.xyinv(1,kk)) xyinv(1,kk)=xax(nrett)\n if(xax(nrett).gt.xyinv(3,kk)) xyinv(3,kk)=xax(nrett)\n goto 227\n endif\n enddo cinv\n! this is a new invariant, do not accept zero values\n if(abs(xax(nrett)).gt.1.0D-6.and.abs(anp(1,nrett)).gt.1.0D-6) then\n ninv=ninv+1\n xyinv(1,ninv)=xax(nrett); xyinv(2,ninv)=anp(1,nrett)\n xyinv(3,ninv)=xax(nrett); xyinv(4,ninv)=anp(1,nrett)\n! write(*,*)'New invariant:',ninv,xyinv(1,ninv),xyinv(2,ninv)\n! else\n! write(*,*)'Invariant with zero values ignored'\n endif\n227 continue\n endif\n endif\n!---- take next node along the same line\n! Then jump back to label 100 and plot other lines ... a bit stupid ...\n230 continue\n! write(*,*)'SMP2B at 230: nr and nv: ',nr,nv\n kk=seqx\n if(associated(mapline%end)) then\n seqx=mapline%end%seqx\n else\n seqx=0\n endif\n240 continue\n! write(*,'(a,5i5,l2)')'ocplot2 next node: ',seqx,nlinesep,&\n! linesep(nlinesep),nv,line,scheilorder\n if(seqx.eq.0) then\n if(nlinesep.gt.0) then\n if(linesep(nlinesep).lt.nv) then\n! we should never have several linesep for the same value of nv!\n nlinesep=nlinesep+1\n linesep(nlinesep)=nv\n! write(*,*)'adding empty line 2',nlinesep,linesep(nlinesep)\n endif\n endif\n! Hm, this was not designed for multicomponent isopleths ....\n if(line.eq.2) then\n! write(*,*)'ocplot2 jump to label 500',line\n goto 500\n endif\n if(scheilorder) then\n! The mapnodes must be followed in numeric order\n! ane they have just one line each.\n line=1\n! write(*,*)'SMP2B scheilorder',localtop%seqx,&\n! localtop%next%seqx,localtop%previous%seqx\n localtop=>localtop%previous\n mapline=>localtop%linehead(1)\n! write(*,*)'ocplot2 newline ',nlinesep,linesep(nlinesep)\n goto 110\n endif\n line=2\n! jump back to label 100 for next line\n! write(*,*)'ocplot2 jump to label 100 for line 2'\n goto 100\n else\n if(kk.eq.seqx) then\n if(giveup.gt.3) then\n write(*,*)'infinite loop ?'\n seqx=0\n goto 240\n endif\n giveup=giveup+1\n endif\n mapnode=>localtop%next\n invnode=0\n if(btest(mapnode%status,MAPINVARIANT)) then\n invnode=size(mapnode%linehead)\n! write(*,*)'ocplot2 invariant node 2',invnode\n endif\n! loop through all mapnodes\n250 continue\n! write(*,*)'ocplot2, at label 250: ',mapnode%seqx,seqx\n! if(mapnode%seqx.eq.seqx) then\n! If just for STEP then check number of axis for calculation\n if(graphopt%noofcalcax.eq.1 .and. mapnode%seqx.eq.seqx) then\n! >>> this is just for step, for map one must find line connected\n do haha=1,size(mapnode%linehead)\n mapline=>mapnode%linehead(haha)\n if(mapline%done.eq.0) then\n if(.not.btest(mapline%status,EXCLUDEDLINE)) then\n! write(*,*)'ocplot2 jump to label 110',&\n! seqx,mapline%number_of_equilibria\n goto 110\n else\n lines_excluded=lines_excluded+1\n endif\n endif\n enddo\n endif\n! write(*,*)'ocplot2 associated? ',associated(mapnode,localtop),&\n! mapnode%seqx,seqx\n if(.not.associated(mapnode,localtop)) then\n mapnode=>mapnode%next\n invnode=0\n if(btest(mapnode%status,MAPINVARIANT)) then\n invnode=size(mapnode%linehead)\n! Does all invariant nodes have the same number of stable phases YES!\n! But they can have different number of line exits\n! write(*,*)'ocplot2 invariant node 3',invnode,mapnode%seqx\n endif\n goto 250\n else\n! we have gone through all mapnodes without finding one with index seqx!!\n! write(*,*)'Cannot find node: ',seqx\n! this seems not to be a problem .... probably already found.\n seqx=0; goto 240\n endif\n endif\n!------------------------------------------- end loop 100\n! check if we can find any lines not starting from localtop to be plotted\n500 continue\n! write(*,*)'ocplot2 at 500 ',seqx\n! write(*,*)'In ocplot2, looking for segmentation fault 5'\n! mapnode=>localtop%next\n! when we have several plots localtop is the important one!!\n mapnode=>localtop\n invnode=0\n if(btest(mapnode%status,MAPINVARIANT)) then\n invnode=size(mapnode%linehead)\n! if(invnode.ne.mapnode%lines) write(*,*)'SMP2B check invnodes 1!'\n! write(*,*)'ocplot2 invariant node 4',invnode\n endif\n! Check for unplotted lines\n anymoretoplot: do while(.TRUE.)\n! write(*,*)'>>>>>Checking unplotted lines at node: ',mapnode%seqx\n jjline: do jj=1,mapnode%lines\n if(mapnode%linehead(jj)%done.eq.0) then\n if(ocv()) write(*,*)'Found a line in node: ',mapnode%seqx,jj\n line=jj\n if(nlinesep.gt.0) then\n if(linesep(nlinesep).lt.nv) then\n! we should never have several linesep for the same value of nv!\n nlinesep=nlinesep+1\n linesep(nlinesep)=nv\n! write(*,*)'adding empty line:',nlinesep,linesep(nlinesep)\n endif\n endif\n mapline=>mapnode%linehead(line)\n! skip line if EXCLUDEDLINE set\n if(btest(mapline%status,EXCLUDEDLINE)) then\n cycle jjline\n endif\n! write(*,*)'SMP2B jump to 110 for line ',jj,&\n! ' in mapnode ',mapnode%seqx\n! %done=-1 means already plotted ...\n! mapnode%linehead(jj)%done=-1\n goto 110\n endif\n enddo jjline\n mapnode=>mapnode%next\n invnode=0\n if(btest(mapnode%status,MAPINVARIANT)) then\n invnode=size(mapnode%linehead)\n! if(invnode.ne.mapnode%lines) write(*,*)'SMP2B check invnodes 2!'\n! write(*,*)'ocplot2 invariant node 5',invnode\n endif\n if(associated(mapnode,localtop)) exit anymoretoplot\n enddo anymoretoplot\n!--------------------------------------------\n! end extracting data\n600 continue\n overflow=.FALSE.\n! but we may have another maptop !!\n if(associated(localtop%plotlink) .and. .not.scheilorder) then\n if(.not.moretops) then\n write(*,*)'More than one maptop record'\n moretops=.true.\n endif\n localtop=>localtop%plotlink\n goto 77\n endif\n! write(*,*)'Number of points: ',nv\n if(.not.wildcard) then\n np=1; nrv=nv\n! write(*,*)'Extracted values: ',nrv\n goto 800\n endif\n!============================================================\n! remove columns that are only zeroes\n! write(*,*)'Now remove colums with just zeros',nv,nrv\n! read(*,17)ch1\n ic=0\n! if a selected phase has been plotten np and qp may be different\n! select the largest!\n nnp=max(np,qp)\n! write(*,651)'SMP wildcard, np=, qp, nnp, ic: ',wildcard,np,qp,nnp,ic\n651 format(a,l2,10i5)\n!------------------------------------------ begin loop 650\n650 ic=ic+1\n660 continue\n if(ic.gt.nnp) goto 690\n! nonzero(ic) is a column with nonzero value to plot ... redundant??\n if(nonzero(ic).eq.0) then\n! shift all values from ic+1 to np\n if(nnp.gt.maxanp) then\n write(kou,*)'Too many points in anp array 1',maxanp,nv,nnp\n overflow=.TRUE.\n nnp=maxanp\n endif\n if(nv.gt.maxval) then\n write(kou,*)'Too many points in anp array 2',maxval,nv\n overflow=.TRUE.\n nv=maxval\n endif\n if(.not.allocated(lid)) then\n! write(*,*)'SMP allocating lid 3: ',np\n allocate(lid(np+5),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 10: ',errall\n gx%bmperr=4370; goto 1000\n endif\n endif\n do jj=ic,nnp-1\n do nnv=1,nv\n anp(jj,nnv)=anp(jj+1,nnv)\n enddo\n nonzero(jj)=nonzero(jj+1)\n! also shift label\n lid(jj)=lid(jj+1)\n enddo\n nnp=nnp-1\n goto 660\n endif\n! there is no more space in arrays to plot\n if(overflow) then\n write(*,*)'plot data overflow',nv,nnp\n goto 690\n endif\n goto 650\n!------------------------------------------ end loop 650\n! nnp is the number of columns to plot\n! nv is the number of separate lines\n690 continue\n! write(*,651)'SMP at 690: ',wildcard,np,qp,nnp,ic\n nrv=nv\n np=nnp\n! goto 800\n!============================================ generate gnuplot file\n800 continue\n! are there any isopleth invariants?\n if(ninv.gt.0) then\n do kk=1,ninv\n! nlinesep is last line with data, linesep(nlinsesp) is index of last data line\n! write(*,'(\"Isoinv: \",3i4,4(1pe12.4))')nlinesep,linesep(nlinesep),&\n! kk,(xyinv(jj,kk),jj=1,4)\n! add these to lines to be plotted\n kkk=nlinesep\n if(len_trim(phaseline(kkk)).gt.0) then\n write(*,*)'smp2b phaseline: \"',trim(phaseline(kkk)),'\"',kkk\n endif\n phaseline(kkk)='100 invariant equilibrium'\n phaseline(kkk+1)=' '\n! write(*,*)'smp2b isoinv: \"',trim(phaseline(kkk)),'\"',kkk\n jj=linesep(kkk)\n nlinesep=nlinesep+1\n! the line nlinesep contain 2 points, beginning and end of invariant line\n linesep(nlinesep)=jj+2\n xax(jj+1)=xyinv(1,kk); anp(1,jj+1)=xyinv(2,kk)\n xax(jj+2)=xyinv(3,kk); anp(1,jj+2)=xyinv(4,kk)\n nrv=nrv+2\n enddo\n endif\n! add the invariant lines to be plotted\n! two points for each invariants (X and Y)\n!\n! write(*,808)np,nv,nlinesep,maxanp,maxval\n! write(*,'(a,(16i4))')'SMP pp: ',(linesep(kk),kk=1,nlinesep)\n808 format('plot data used: ',3i7,' out of ',2i7)\n if(np.eq.0) then\n write(kou,*)'No data to plot',np\n write(*,*)'SMP2B axis 1: ',trim(pltax(1)),', 2:',trim(pltax(2))\n gx%bmperr=4248\n goto 1000\n endif\n!------------------------------------------------------------\n if(.not.allocated(lid)) then\n! lid is \"LineIdenifier and changes color for each line with different meaning\n! if(np.ge.1) then\n! lid should always be allocated if np>1, but ... one never knows \n! write(*,*)'ocplot2 allocate lid 4: ',np,nlinesep\n! if(scheilorder) then\n! for Scheil simulations phaseline(1..nlinesep) are phase names\n! allocate(lid(nlinesep-1),stat=errall)\n! do i=1,nlinesep-1\n! jj=len_trim(phaseline(i))\n! if(jj.le.32) then\n! lid(i)=phaseline(i)\n! else\n! Too long list, replace the middle by ...\n! lid(i)=phaseline(i)(1:22)//'...'//phaseline(i)(jj-6:jj)\n! endif\n! write(*,*)'ocplot2 phaseline: ',trim(lid(i))\n! enddo\n! Wow, set np=nlinesep-1 to have separate colors of Scheil lines\n! write(*,*)'ocplot2 change np to nphaseline: '\n! np=nlinesep-1\n! else\n! normally np=1 if we come here, plotting a single value\n! write(*,*)'Allocating lid: ',trim(encoded1),':',trim(funsym),np\n allocate(lid(np),stat=errall)\n if(errall.ne.0) then\n write(*,*)'SMP2B Allocation error 11: ',errall\n gx%bmperr=4370; goto 1000\n endif\n do i=1,np\n lid(i)=funsym\n enddo\n endif\n! endif\n!------------------------------------------------------------\n2000 continue\n! write(*,*)'We are at 2000 '\n!----------------------------------------------------------------------\n!\n call get_plot_conditions(encoded1,maptop%number_ofaxis,axarr,ceq)\n!\n! option to create a CSV table\n if(btest(graphopt%status,GRCSVTABLE)) then\n call list_csv(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,&\n phaseline,title,filename,version,encoded1)\n else\n! NOW pltax should be the the axis labels if set manually\n if(graphopt%labeldefaults(2).ne.0) pltax(1)=graphopt%plotlabels(2)\n if(graphopt%labeldefaults(3).ne.0) pltax(2)=graphopt%plotlabels(3)\n! write(*,*)' >>>>>>>>**>>> plot file: ',trim(filename)\n call ocplot2B(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,&\n phaseline,title,filename,graphopt,version,encoded1,fixphasecolor)\n! title,filename,graphopt,pform,version,encoded1)\n! goto 900\n endif\n! deallocate, not really needed for local arrays ??\n deallocate(anp)\n deallocate(xax)\n deallocate(linesep)\n if(allocated(yyy)) then\n deallocate(yyy)\n deallocate(nonzero)\n endif\n1000 continue\n return\n end subroutine ocplot2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ocplot2B\n!\\begin{verbatim} %-\n subroutine ocplot2B(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,&\n phaseline,title,filename,graphopt,version,conditions,fixphasecolor)\n! called from ocplot2 to generate the GNUPLOT file after extracting data\n! np is number of columns (separate lines), if 1 no labelkey\n! nrv is number of values to plot\n! nlinesep is the number of separate lines (index to linesep)\n! linesep is the row index when a line to be plotted finishes (1..nlinesep)\n! pltax are axis labels\n! xax array of values for single valued axis (T or mu etc)\n! anpax=2 if axis with single value is column 2 and (multiple) values in\n! columns 3 and higher\n! anp array of values for axis with multiple values (can be single values also)\n! lid array with a label for the different lines\n! title Title of the plot\n! filename GNUPLOT file name, (also used for pdf/ps/gif file)\n! graphopt is graphical option record\n! conditions is a character with the conditions for the diagram\n! fixphasecolor is used for isopleths to know how many columns are needed\n implicit none\n integer np,anpax,nlinesep,fixphasecolor\n integer ndx,nrv,linesep(*),anpdim,npx\n character pltax(*)*(*),filename*(*),lid(*)*(*),title*(*)\n character conditions*(*),version*(*),phaseline(*)*(*)\n type(graphics_options) :: graphopt\n double precision xax(*),anp(anpdim,*)\n double precision scale1,scalem\n type(graphics_textlabel), pointer :: textlabel\n!\\end{verbatim}\n!----------------------------------------------------------------------\n! internal\n integer ii,jj,kk,lcolor,appfil,nnv,ic,repeat,ksep,nv,k3,kkk,nofapl,iz\n integer, parameter :: mofapl=100\n integer, parameter :: maxmultiplotlines=100\n! ltf1 is a LineTypeoFfset for current plot when appending a plot, 0 default\n! linewp is plotting with points along the line\n integer appfiletyp,lz,ltf1,linewp\n! appending an multiplot in ocplot2B\n! sleep time in microseconds\n integer, parameter :: us=500000\n integer multibuffline\n character multibuffer(maxmultiplotlines)*128\n logical appendmultiplot\n! other things ...\n character pfc*128,pfh*128,backslash*2,appline*128,inline*8,colord*5\n character applines(mofapl)*128,gnuplotline*256,labelkey*64,rotate*16\n character labelfont*32,linespoints*12,tablename*16,year*16,hour*16\n! for handling appended plots use $Appendx \n character datablock*8,applot*13\n logical isoplethplot\n! write the gnuplot command file with data appended\n!\n! write(*,10)'in ocplot2B: ',np,anpax,nrv,nlinesep,trim(title),&\n! (linesep(kk),kk=1,nlinesep)\n! write(*,*)'smp2b isoplethplot 2: ',btest(graphopt%status,GRISOPLETH)\n10 format(a,4i5,a/(15i4))\n! graphopt%specialdiagram=2 is a Scheil plot phase amount/vs T\n! if(graphopt%specialdiagram.eq.2) then\n! write(*,*)'In ocplot2B scheil: ',graphopt%specialdiagram\n! just check all is OK\n! do kk=1,nlinesep-1\n! write(*,*)'phaseline: ',kk,': ',trim(phaseline(kk))\n! enddo\n! endif\n multibuffline=0\n nofapl=0\n appendmultiplot=.FALSE.\n ltf1=0\n if(graphopt%appendfile(1:1).ne.' ') ltf1=10\n if(index(filename,'.plt ').le.0) then \n kk=len_trim(filename)\n pfc=filename(1:kk)//'.'//'plt '\n kkk=kk+4\n else\n pfc=filename\n kk=index(pfc,'.')-1\n kkk=len_trim(filename)+1\n endif\n write(*,*)'SMP2B writing gnuplot file: ',trim(pfc)\n open(21,file=pfc,access='sequential',status='unknown')\n write(21,1600)trim(title)\n1600 format('# GNUPLOT file generated by OpenCalphad'/'# ',a/&\n '# subroutine ocplot2B')\n! if there is just one curve do not write any key. May be overriiden later ..\n if(graphopt%gnutermsel.lt.1 .or. &\n graphopt%gnutermsel.gt.graphopt%gnutermax) then\n write(*,*)'Unknown graphics terminal: ',graphopt%gnutermsel\n goto 1000\n elseif(graphopt%gnutermsel.gt.1) then\n! terminal 1 is screen without any output file\n pfh=filename(1:kk)//'.'//graphopt%filext(graphopt%gnutermsel)\n! set the screen as a comment ...\n write(21,840)trim(graphopt%gnuterminal(1)),&\n trim(graphopt%gnuterminal(graphopt%gnutermsel)),trim(pfh)\n840 format('#set terminal ',a/'set terminal ',a/'set output \"',a,'\"')\n else\n! terminal 1 is screen without any output file, add PDF as comment\n write(21,841)trim(graphopt%gnuterminal(graphopt%gnutermsel)),&\n trim(graphopt%gnuterminal(3))\n841 format('set terminal ',a/'#set terminal ',a/'#set output \"ocgnu.pdf\"')\n!841 format('set terminal ',a)\n endif\n! for isopleths we will generate one column for each phase even if there\n! are just a single value in anpax. To handle this we need different\n! values of \"np\" for these columns\n isoplethplot=btest(graphopt%status,GRISOPLETH)\n npx=np\n if(isoplethplot) then\n! This is the number of columns with phases in the isopleth incl. invariant\n npx=fixphasecolor\n endif\n! this part is independent of which axis is a single value\n!------------------ some GNUPLOT colors:\n! colors are black: #000000, red: #ff000, web-green: #00C000, web-blue: #0080FF\n! dark-yellow: #C8C800, royal-blue: #4169E1, steel-blue #306080,\n! gray: #C0C0C0, cyan: #00FFFF, orchid4: #804080, chartreuse: 7CFF40\n! if just one line set key off for that line.\n if(graphopt%specialdiagram.eq.2) then\n! for Scheil\n labelkey=' on font \"Arial,12\" '\n elseif(npx.eq.1 .and. graphopt%appendfile(1:1).eq.' ') then\n labelkey=' off'\n else\n labelkey=graphopt%labelkey\n endif\n call date_and_time(year,hour)\n! write(*,*)'\"',year,'\" \"',hour,'\"'\n tablename='OCT'//year(3:8)//hour(1:6)\n! write(*,*)'Plot heading 2? ',btest(graphopt%status,GRNOTITLE)\n call replace_uwh(conditions)\n if(btest(graphopt%status,GRNOTITLE)) then\n write(21,858)trim(title),trim(conditions),trim(graphopt%font)\n else\n write(21,859)trim(title),trim(conditions),trim(graphopt%font)\n endif\n858 format('#set title \"',a,' \\n #',a,'\" font \"',a,',10\" ')\n859 format('set title \"',a,' \\n ',a,'\" font \"',a,',10\" ')\n lz=graphopt%linetype\n! replace _ and & in axis texts by \"\\_\" and \"\\&\"\n! write(*,*)'Replacing _ and &: ',trim(pltax(2))\n call replace_uwh(pltax(1))\n call replace_uwh(pltax(2))\n! write(*,*)'Debug: \"',graphopt%logofont,'\"'\n if(isoplethplot) then\n write(21,8601)graphopt%xsize,graphopt%ysize,&\n trim(pltax(1)),trim(pltax(2)),graphopt%logofont,trim(labelkey),&\n ltf1+1,ltf1+2,ltf1+3,ltf1+4,ltf1+5,&\n ltf1+6,ltf1+7,ltf1+8,ltf1+9,ltf1+10\n! add information of any scaling factors for the axis \"xf\" or \"yf\"\n! if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1)\n! if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2)\n8601 format('set origin 0.0, 0.0 '/&\n 'set size ',F8.4,', ',F8.4/&\n 'set xlabel \"',a,'\"'/'set ylabel \"',a,'\"'/&\n! the compiler did not detect the missing , between 4' in ... F8.4', ' ....\n!8601 format('set origin 0.0, 0.0 '/&\n! 'set size ',F8.4', ',F8.4/&\n! 'set xlabel \"',a,'\"'/'set ylabel \"',a,'\"'/&\n! Help with stackoverflow to fix nice logo independent of plot size!\n! 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"Garamond Bold,20\"'/&\n! the logofont depend on OS, MacOS does not provide Garamond\n 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"',a,'\"'/&\n 'set key ',a/&\n 'set linetype ',i2,' lc rgb \"#000000\" lw 2 pt 10'/&\n 'set linetype ',i2,' lc rgb \"#4169E1\" lw 2 pt 6'/&\n 'set linetype ',i2,' lc rgb \"#00C000\" lw 2 pt 3'/&\n 'set linetype ',i2,' lc rgb \"#FF0000\" lw 2 pt 2'/&\n 'set linetype ',i2,' lc rgb \"#FF00FF\" lw 2 pt 4'/&\n 'set linetype ',i2,' lc rgb \"#C8C800\" lw 2 pt 5'/&\n 'set linetype ',i2,' lc rgb \"#C0C0C0\" lw 2 pt 7'/&\n 'set linetype ',i2,' lc rgb \"#00FFFF\" lw 2 pt 8'/&\n 'set linetype ',i2,' lc rgb \"#804080\" lw 2 pt 9'/&\n 'set linetype ',i2,' lc rgb \"#7CFF40\" lw 2 pt 1'/&\n '# for invariants, orange'/&\n 'set linetype 100 lc rgb \"#FFC000\" lw 3 pt 1')\n else\n write(21,860)graphopt%xsize,graphopt%ysize,&\n trim(pltax(1)),trim(pltax(2)),graphopt%logofont,trim(labelkey),&\n! trim(pltax(1)),trim(pltax(2)),trim(labelkey),&\n ltf1+1,lz,ltf1+2,lz,ltf1+3,lz,ltf1+4,lz,ltf1+5,lz,&\n ltf1+6,lz,ltf1+7,lz,ltf1+8,lz,ltf1+9,lz,ltf1+10,lz\n860 format('set origin 0.0, 0.0 '/&\n 'set size ',F8.4,', ',F8.4/&\n 'set xlabel \"',a,'\"'/'set ylabel \"',a,'\"'/&\n! Help with stackoverflow to fix nice logo independent of plot size!\n! 'set label \"~O{.0 C}\" at graph -0.1, -0.1 font \"Garamond Bold,20\"'/&\n! 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"Garamond Bold,20\"'/&\n 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"',a,'\"'/&\n 'set key ',a/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#000000\" lw 2 pt 10'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#4169E1\" lw 2 pt 6'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#00C000\" lw 2 pt 3'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#FF0000\" lw 2 pt 2'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#FF00FF\" lw 2 pt 4'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#C8C800\" lw 2 pt 5'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#C0C0C0\" lw 2 pt 7'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#00FFFF\" lw 2 pt 8'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#804080\" lw 2 pt 9'/&\n 'set style line ',i2,' lt ',i2,' lc rgb \"#7CFF40\" lw 2 pt 1'/&\n '# for invariants, faded read'/&\n 'set style line 100 lt 1 lc rgb \"#FF3333\" lw 3 pt 1')\n endif\n! Plot grid?\n if(graphopt%setgrid.eq.1) write(21,777)\n777 format('set grid')\n! add some useful things for maniplulation of graph\n write(21,8000)\n8000 format(/'# Some useful GNUPLOT commands for editing the figure'/&\n '# ** THIS IS A DASHED LINE (on pdf/wxt):'/&\n '# set style line 15 lt 0 lc rgb \"#C8C800\" lw 2 pt 2'//&\n '# set pointsize 0.6'/&\n '# set label \"text\" at 0.5, 0.5 rotate by 60 font \"arial,12\"'/&\n '# set xrange [0.5 : 0.7] '/&\n '# ** ADDING MANUALLY A LINE AND KEEP SCALING:'/&\n '# set arrow from x0, y0 to x1,y1 nohead linestyle 1'/&\n '# ** ADD A RED DOT AT 0.1,1000:'/&\n '# set obj 1 circle fc rgb \"#FF0000\" fs sol size 0.02 noclip at 1,1'/&\n '# ** MODIFY THE PLOTTED VALUE ON AN AXIS:'/&\n '# plot for [i=] ... using (2*column(i)/(1-2*column(i))):2 with ...'/&\n '# ** PLOTTING SYMBOLS INSTEAD OF LINE:'/&\n '# ... using 2:i with points pt 7 ps 3 '/&\n '# ** OVERLAY PLOTS: '/&\n '# set multiplot'/&\n '# set xrange [] writeback'/&\n '# ... plot someting'/&\n '# set xrange restore'/&\n '# ... plot more using same axis scaling '/&\n '# unset multiplot'/)\n!\n if(graphopt%rangedefaults(1).ne.0) then\n! user defined ranges for x axis\n write(21,870)'x',graphopt%plotmin(1),graphopt%plotmax(1)\n870 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ')\n endif\n if(graphopt%rangedefaults(2).ne.0) then\n! user defined ranges for y axis\n write(21,870)'y',graphopt%plotmin(2),graphopt%plotmax(2)\n endif\n!----------------------\n! logarithmic axis\n if(graphopt%axistype(1).eq.1) then\n write(21,151)'x'\n151 format('set logscale ',a)\n endif\n if(graphopt%axistype(2).eq.1) then\n write(21,151)'y'\n endif\n!------------------------------------------------------------\n! set labels (user added text in diagram)\n textlabel=>graphopt%firsttextlabel\n do while(associated(textlabel))\n rotate=' '\n if(textlabel%angle.ne.0) write(rotate,177)textlabel%angle\n177 format(' rotate by ',i5)\n labelfont=' '\n! write(*,*)'textfontscale: ',textlabel%textfontscale\n if(textlabel%textfontscale.ne.one) then\n! write(labelfont,178)int(10*textlabel%textfontscale)\n!178 format(' font \"Sans,',i2,'\" ')\n! write(*,1178)trim(graphopt%font),int(10*textlabel%textfontscale)\n!1178 format(' SMP2B font \"',a,',',i2,'\" ')\n write(labelfont,178)trim(graphopt%font),&\n int(10*textlabel%textfontscale)\n178 format(' font \"',a,',',i2,'\" ')\n endif\n! if(textlabel%angle.eq.0) then\n write(21,1505)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,&\n trim(labelfont),trim(rotate)\n1505 format('set label \"',a,'\" at ',1pe12.4,', ',1pe12.4,a,a)\n! else\n! write(21,1506)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,&\n! textlabel%angle\n!1506 format('set label \"',a,'\" at ',1pe12.4,', ',1pe12.4,&\n! ' rotate by ',i5)\n! endif\n textlabel=>textlabel%nexttextlabel\n enddo\n!---------------------------------------------------------------\n! handle appended files here ....\n!\n! write(*,*)'ocplot2B append?',trim(graphopt%appendfile)\n appfildata: if(graphopt%appendfile(1:1).eq.' ') then\n appfil=0\n else\n appfil=23\n write(kou,*)'Appending data from: ',trim(graphopt%appendfile)\n open(appfil,file=graphopt%appendfile,status='old',&\n access='sequential',err=1750)\n!\n write(21,1719)trim(graphopt%appendfile)\n1719 format(//78('#')/'# APPENDED from ',a)\n! copy all lines up to \"plot\" to new graphics file\n nnv=0\n1710 continue\n read(appfil,1720,end=1750)appline\n1720 format(a)\n! note if append file is GIBBSTRIANGLE\n if(appline(1:10).eq.'# GIBBSTRI') then\n write(*,*)'Warning: appended file is in Gibbstriangle format,',&\n ' plot will be strange!'\n goto 1710\n endif\n! skip other comment lines\n if(appline(1:1).eq.'#') goto 1710\n! save lines between \"set multiplot\" and \"unset multiplot\" to a buffer\n! appending a file which contains an already appended part\n! copy all lines to a buffer\n if(appline(1:14).eq.'set multiplot ') then\n! write(*,*)'ocplot2B Found multiplot in appended file'\n if(multibuffline.gt.0) then\n write(*,*)'smp2B appending twice, will probably fail',multibuffline\n else\n multibuffline=1\n! write(*,*)'ocplot2B appending a \"set multiplot\"'\n endif\n appendmultiplot=.TRUE.\n goto 1710\n endif\n if(appline(1:16).eq.'unset multiplot ') then\n! write(*,*)'ocplot2B found \"unset multiplot\", saved ',&\n! multibuffline,' lines'\n appendmultiplot=.FALSE.\n! do iz=1,multibuffline-1\n! write(*,*)'ocplot2B: 'trim(multibuffer(iz))\n! enddo\n! pause mouse ??\n exit appfildata\n! goto 1710\n endif\n if(appendmultiplot) then\n if(multibuffline.gt.maxmultiplotlines) then\n write(*,*)'Too many appendbuffer lines',multibuffline\n else\n multibuffer(multibuffline)=appline\n multibuffline=multibuffline+1\n endif\n goto 1710\n endif\n!------------------------------------------------------------------\n! ignore some lines with \"set\" in the append file\n! set title\n! set xlabel\n! set ylabel\n! set xrange\n! set yrange\n! set terminal\n! set origin\n! set size\n! set key\n if(appline(1:10).eq.'set title ' .or.&\n appline(1:11).eq.'set xlabel ' .or.&\n appline(1:11).eq.'set ylabel ' .or.&\n appline(1:11).eq.'set xrange ' .or.&\n appline(1:11).eq.'set yrange ' .or.&\n appline(1:11).eq.'set output ' .or.&\n appline(1:13).eq.'set terminal ' .or.&\n appline(1:11).eq.'set origin ' .or.&\n appline(1: 9).eq.'set size ' .or.&\n appline(1: 8).eq.'set key ') then\n! write(*,*)'ignoring append line ',trim(appline)\n goto 1710\n endif\n!------------------------------------------------------------------\n! changes here in the new subroutine ocplot2B\n! write(*,*)'SMP: appline1: ',trim(appline)\n ii=index(appline,'plot \"-\"')\n if(ii.gt.0) then\n applines(1)=appline\n appfiletyp=1\n else\n! modify to dataplot inside multiplot\n ii=index(appline,\"plot '-'\")\n if(ii.gt.0) then\n applines(1)=appline\n appfiletyp=1\n else\n! we can also have a \"plot for ... \" do not change applines(1)\n ii=index(appline,\"plot for \")\n if(ii.le.0) then\n! just copy the file to ocgnu.plt\n write(21,'(a)')trim(appline)\n goto 1710\n else\n! this is a \"plot for\" appfile using a table that has already been copied\n applines(1)=appline\n appfiletyp=2\n endif\n endif\n endif\n! we have now found the plot command in the append file. There can be more\n write(*,*)'SMP appfiletyp: ',appfiletyp\n! here we save the actual plot commands from the appendfile!!\n applines(1)=appline\n! write(*,*)'SMP appline1: ',trim(applines(1))\n ic=1\n1730 continue\n! if line ends with \\ then read more\n ii=len_trim(appline)\n! write(*,*)'There are more? ',appline(i:ii),ii,ic\n if(appline(ii:ii).eq.'\\') then\n! if(appline(ii:ii).eq.' ') then\n! continuation lines !! NOTE EACH plot expected at the beginning of the line\n read(appfil,1720,end=1750)appline\n ic=ic+1\n if(ic.ge.mofapl) then\n write(*,*)'Too many header lines in append file',ic\n else\n applines(ic)=appline\n endif\n goto 1730\n endif\n nofapl=ic\n write(*,*)'Read applines header lines: ',nofapl\n! debug output of saved plot command\n! nofapl=ic\n! write(*,*)(trim(applines(jj)),jj=1,nofapl)\n! write(*,*)'appline: ',trim(appline),ic\n! close(appfil)\n! appfil=0\n goto 1770\n! endif\n! write(*,*)'SMP appline1B: ',trim(appline)\n write(21,1720)trim(appline)\n nnv=nnv+1\n goto 1710\n! error oppening append file\n1750 continue\n write(21,1719)'# end of append',multibuffline\n! write(*,1719)' end of append',multibuffline\n write(kou,*)'Error opening or reading the append file, skipping it'\n close(appfil)\n appfil=0\n1770 continue\n endif appfildata\n! end of appendfile special\n!-----------------------------------------------\n! text in lower left corner\n ii=len_trim(graphopt%lowerleftcorner)\n if(ii.gt.0) then\n! in square diagram below figure\n! write(21,209)trim(graphopt%lowerleftcorner)\n!209 format('set label \"',a,'\" at graph -0.10, -0.08 ')\n write(21,209)trim(graphopt%lowerleftcorner)\n209 format('set label \"',a,'\" at graph -0.05, -0.05 ')\n endif\n! if lowerleftcorner is empty ignore it\n!---------------------------------------------------------------\n! this is new subroutine ocplot2B\n!---------------------------------------------------------------\n!========================================= begin using plot for\n! ANPAX is axis with multiple values\n if(anpax.ne.0) then\n scalem=graphopt%scalefact(anpax)\n scale1=graphopt%scalefact(3-anpax)\n else\n scalem=graphopt%scalefact(1)\n scale1=graphopt%scalefact(2)\n endif\n if(graphopt%specialdiagram.eq.2) then\n!============================================== start Scheil\n! Handle Scheil diagram with color changes along a single line\n! ONLY if one axis is PFL or PFS!!! NOT if one plot composition of a phase\n! write(*,*)'ocplot2B special for Scheil with PFL or PFS',nlinesep\n! if there is an appended file we must set multiplot here ...\n if(appfil.gt.0) then\n write(*,*)'ocplot2B adding set multiplot'\n write(21,3828)\n endif\n backslash=',\\'\n! All lines to plot, colord can be 2:3 or 3:2 depending what is on the axis\n colord=' 2:3 '\n! no need to change, evidently xax and anp are already shifted ... suck\n! write(*,'(a,a,2F12.6)')'ocplot2B colord: ',colord,xax(1),anp(1,1)\n!\n! this should be written AFTER entering the data part, what about several\n datablock='$Append1'\n! applot='plot '//datablock\n! do kk=1,nlinesep-1\n! call replace_uwh(phaseline(kk))\n! write(21,1999)applot,colord,kk,trim(phaseline(kk)),backslash\n!1999 format('# ',a,' using 'a,' with lines ls ',i2,' title \"',a,'\"',a)\n! applot='\"\"'\n! if(kk.eq.nlinesep-2) backslash=' '\n! enddo\n! write(*,*)\n! the loop below the initial one, removed after testing\n backslash=',\\'\n inline='plot \"-\"'\n! commented away and using new datablock inside multiplot\n do kk=1,nlinesep-1\n call replace_uwh(phaseline(kk))\n write(21,2000)inline,colord,kk,trim(phaseline(kk)),backslash\n2000 format('# ',a,' using ',a,' with lines ls ',i2,' title \"',a,'\"',a)\n inline='\"\"'\n if(kk.eq.nlinesep-2) backslash=' '\n enddo\n! Then all data with an empty line and a line with a single \"e\" \n! between each line.\n! nlinesep is number of separate lines to plot (with different sets of phases)\n! linesep(1..nlinesep) is number of lines of data for each line to plot\n! nrv is total lines with lines with data to write\n! write(*,*)'ocplot2B linesep: ',(linesep(jj),jj=1,nlinesep)\n! begin datablock\n write(21,'(a,\" << EOD \")')datablock\n write(21,'(a)')'# Line 1, phases: '//trim(phaseline(1))\n jj=2\n ltw: do nv=1,nrv\n! write(*,'(3i4,1pe12.4)')'ocgnu2B data: ',jj,nv,linesep(jj),xax(nv)\n if(nv.eq.linesep(jj)) then\n! a new line start\n if(jj.eq.nlinesep) exit ltw\n write(21,'(i4,2F12.6)')nv,xax(nv),anp(1,nv)\n write(21,2100)jj,trim(phaseline(jj))\n2100 format(/'e'/'# Line ',i3,' phases ',a)\n jj=jj+1\n endif\n write(21,'(i4,2F12.6)')nv,xax(nv),anp(1,nv)\n enddo ltw\n write(21,2110)\n2110 format(/'e'/)\n! end of appended data?\n write(21,'(a)')'EOD end of appended data'\n! We should add the datablock plot command here\n applot='plot '//datablock\n backslash=',\\'\n do kk=1,nlinesep-1\n call replace_uwh(phaseline(kk))\n write(21,1999)applot,colord,kk,trim(phaseline(kk)),backslash\n 1999 format(a,' using ',a,' with lines ls ',i2,' title \"',a,'\"',a)\n applot='\"\"'\n! remove backslash at last line\n if(kk.eq.nlinesep-2) backslash=' '\n enddo\n!\n!2110 format(/'e'/'pause mouse')\n! close(21)\n! Finished writing plot file\n! stop 'test'\n goto 4000\n!============================================== end Scheil\n endif\n! now write all data once as a table ended with EOD\n write(21,3000)nrv,trim(tablename)\n3000 format(//'# begin of data with lines',i7/'$',a,' << EOD')\n!\n! A digit before the first phase gives number of columns to plot\n! write(*,*)'smp2b: isopleth? ',isoplethplot,np,npx\n if(isoplethplot) read(phaseline(1),'(i3)')fixphasecolor\n! write(*,*)'SMP2B replace _ in keys: ',npx\n do jj=1,npx\n! remove _ in keys\n call replace_uwh(lid(jj))\n enddo\n if(graphopt%tielines.gt.0) then\n write(*,*)'ocplot2 does not plot tielines,',&\n ' they are perpendicular to the potential axis'\n endif\n! columnheaders used as keys\n if(isoplethplot) then\n! This column headin is not set before\n lid(npx)='Invariant'\n! write(*,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,npx)\n write(21,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,npx)\n!2900 format(a,i3,2x,10(a,2x))\n else\n! write(*,*)'SMP2B mqmqa plot?'\n write(21,3100)'KEYS: ',trim(pltax(3-anpax)),(trim(lid(jj)),jj=1,np)\n3100 format(a,' ',100(a,' '))\n endif\n ksep=2\n write(21,*)'# First line: ',trim(phaseline(1))\n! write(*,*)'smp2b isoplethplot 3: ',isoplethplot,&\n! btest(graphopt%status,GRISOPLETH),fixphasecolor\n do nv=1,nrv\n!---------------------------------------------------------------\n! values written multiplied with graphopt%scalefact, \n! first value is single valued axis (can be X or Y axis) multiplied with scale1\n! remaining values multiplied scalem\n write(21,'(i4,1pe16.6)',advance='no')nv,scale1*xax(nv)\n! note that isopletpots have np=1\n do jj=1,np-1\n! second and later columns represent Y axis\n if(anp(jj,nv).ne.rnone) then\n write(21,2821,advance='no')scalem*anp(jj,nv)\n else\n write(21,'(a)',advance='no')' NaN '\n endif\n enddo\n if(isoplethplot) then\n! fixphasecolor 100 means invariant\n if(fixphasecolor.lt.100) then\n! dummy column values up to fixphasecolor\n do jj=1,fixphasecolor-1\n write(21,'(\" NaN \")',advance='no')\n enddo\n! This column has real value, then maybe additional columns with dummy values\n! note only anp(1,nv) has any value!!\n write(21,2821,advance='no')scalem*anp(1,nv)\n do jj=1,npx-fixphasecolor-1\n write(21,'(\" NaN \")',advance='no')\n enddo\n! The last colum is for invariants which are written seperatey below\n write(21,'(\" NaN \")')\n else\n! this is an invariant, last column has values. There may be no invariant!\n do jj=1,npx-1\n write(21,'(\" NaN \")',advance='no')\n enddo\n write(21,2821)scalem*anp(1,nv)\n endif\n elseif(anp(jj,nv).ne.rnone) then\n write(21,2821)scalem*anp(jj,nv)\n else\n write(21,'(a)')' NaN '\n endif\n!2820 format(i4,1pe16.6)\n2821 format(1pe16.6)\n!2822 format(' NaN ')\n!---------------------------------------------------------------\n! here we shift to another line and color\n if(nv.eq.linesep(ksep)) then\n! an empty line in the plot file means a MOVE to the next point.\n if(nv.lt.nrv) then\n! write(21,3819)ksep-1,trim(phaseline(ksep-1)),trim(phaseline(ksep))\n!3819 format('# shift of line ',i3,2x,a//'# new line ',a)\n! sometimes phaseline is empty ... and not needed anyway and create stray lines\n write(21,3819)ksep-1\n3819 format('# shift of line ',i3//)\n! write(*,*)'SMP2B readfixcolor: ',trim(phaseline(ksep)),ksep\n if(isoplethplot) read(phaseline(ksep),'(i3)')fixphasecolor\n else\n! try to avoid rubbish\n! write(21,3821)ksep-1,trim(phaseline(ksep-1))\n!3821 format('# end of line ',i3,2x,a//)\n write(21,3821)ksep-1\n3821 format('# end of line ',i3//)\n endif\n! test of uninitiallized variable, ksep must not exceed nlinesep\n ksep=min(ksep+1,nlinesep)\n endif\n enddo\n write(21,3823)\n3823 format('EOD'//)\n if(appfil.gt.0) then\n! if there is an appendfile add set multiplot\n write(*,*)'ocplot2B trying to include appfile ...'\n! The \"writeback\" is important for uniform scaling of multiplots\n! NOTE this is also used for Scheil above\n write(21,3828)\n3828 format('set multiplot'/&\n 'set xrange [] writeback'/'set yrange [] writeback')\n endif\n! If no file appended the line types are (i-2)\n! if a file appended then line types are (i-2+ltf1(=10))\n! if anpax is axis with single value (1=x, 2=y)\n! if(isoplethplot) then\n! write(21,3800)trim(tablename)\n!3800 format('plot $',a,' using 2:3:4 with lines lc variable notitle')\n! elseif(anpax.eq.1) then\n! here we use npx for both isopleths and others!\n if(graphopt%linewp.le.1) then\n if(anpax.eq.1) then\n! linewp=0 is dashed and =1 is line without point\n write(21,3900)npx+2,trim(tablename),ltf1\n3900 format('plot for [i=3:',i2,'] $',a,' using i:2',&\n ' with lines ls (i-2+',i2,') title columnheader(i)') \n else\n write(21,3910)npx+2,trim(tablename),ltf1\n3910 format('plot for [i=3:',i2,'] $',a,' using 2:i',&\n ' with lines ls (i-2+',i2,') title columnheader(i)') \n endif\n else\n! plot line with points at every linewp-1 calculated point\n if(anpax.eq.1) then\n write(21,3600)npx+2,trim(tablename),ltf1,graphopt%linewp-1\n3600 format('plot for [i=3:',i2,'] $',a,' using i:2',&\n ' with lp ls (i-2+',i2,') pi ',i3,' title columnheader(i)') \n else\n write(21,3610)npx+2,trim(tablename),ltf1,graphopt%linewp-1\n3610 format('plot for [i=3:',i2,'] $',a,' using 2:i',&\n ' with lp ls (i-2+',i2,') pi ',i3,' title columnheader(i)') \n endif\n endif\n! write(*,*)'SMP2 linespoint increment 1:',graphopt%linewp-1\n!=================================================================\n! we come here after plotting a Scheil diagram above, try including appfiles\n4000 continue\n!=================================================================\n! plot command from appfil\n if(appfil.gt.0) then\n! write(*,*)'ocplot2B appending a file at label 3912'\n! try to avoid overlapping keys ...\n! The \"restore\" for x/yrange means the scaling from the \"plot for\"\n! will be used also for the appended data\n write(21,3912)trim(graphopt%font)\n3912 format('set key bottom right font \"',a,',12\"'/&\n 'set xrange restore'/'set yrange restore')\n if(appfiletyp.eq.2) then\n! just one line with plot for ... \n! the data to append is already copied as a table\n write(21,'(a)')trim(applines(1))\n! if applines>0 write those lines before \"unset\"\n if(multibuffline.gt.0) then\n do iz=1,multibuffline-1\n write(21,'(a)')trim(multibuffer(iz))\n enddo\n endif\n multibuffline=0\n write(21,'(a)')'unset multiplot #appfiletype 2'\n! write(21,'(a)')'unset multiplot'\n close(appfil)\n appfil=0\n elseif(multibuffline.gt.0) then\n! these are \"plot \"-\" ... lines, not connected to \"set multiplot\"\n write(21,'(a,2i7)')'# not appfiletype 2, multibufline, nofapl',&\n multibuffline,nofapl\n do iz=1,multibuffline-1\n write(21,'(a)')trim(multibuffer(iz))\n enddo\n multibuffline=0\n do jj=1,nofapl\n write(21,'(a)')trim(applines(jj))\n enddo\n write(21,'(a)')'unset multiplot #appfiletype 1'\n close(appfil)\n appfil=0\n endif\n endif\n! if the plot command is \"plot '-' ... then\n! copy the data from the append file, it should be correctly formatted\n! as I understand appfil muste always be 0 here ... no\n if(appfil.gt.0) then\n if(multibuffline.gt.0) then\n write(*,*)' *** ocplot2B appending multiplot',multibuffline\n do iz=1,multibuffline-1\n write(21,'(a)')trim(multibuffer(iz))\n enddo\n multibuffline=0\n! write(21,'(a)')'unset multiplot # closing appfil'\n endif\n! appfile header lines\n write(*,*)'Appfile header lines: ',nofapl\n ic=0\n write(21,'(a)')'# Copying appfile data'\n! these line contain the 'plot \"-\" ...\"\n do jj=1,nofapl\n write(21,'(a)')trim(applines(jj))\n enddo\n1900 continue\n! this is copying the actual data to plot from the append file.\n! write(*,*)'Copying appfile data'\n read(appfil,884,end=1910)appline\n884 format(a)\n ic=ic+1\n! skip pause mouse\n if(appline(1:12).eq.'pause mouse ') goto 1900\n write(21,884)trim(appline)\n goto 1900\n! end of copying appfile data\n1910 continue\n write(*,*)'Appended ',ic,' data lines'\n! if(multibuffline.gt.0) then\n! ocplot2B add multiple plot \"multplot\" commands ....\n! write(*,*)'ocplot2B adding prevous multplot ...',multibuffline\n! do iz=1,multibuffline-1\n! write(21,884)trim(multibuffer(iz))\n! enddo\n! endif\n! write(21,'(a)')'unset multiplot'\n write(21,'(a)')'unset multiplot # closing appfil 3'\n close(appfil)\n appfil=0\n endif\n!------------------------------------------------------\n! write(*,*)'In OCPLOT2B finished 1 \"',pform(1:1),'\"'\n if(graphopt%gnutermsel.eq.1) then\n! if not hardcopy pause gnuplot. Mouse means clicking in the graphics window\n! will close it. I would like to have an option to keep the graphics window...\n write(21,990)trim(graphopt%plotend)\n!990 format('pause mouse')\n990 format(a)\n endif\n close(21)\n! write(*,*)'In OCPLOT2B closed ',trim(pfc),kkk\n if(appfil.ne.0) close(appfil)\n appfil=0\n!-------------------------------------------------------------------\n! execute the GNUPLOT command file\n gnuplotline='gnuplot '//pfc(1:kkk)//' & '\n! Uncomment the following line for OS having gnuplot5 and \n! comment the above line with gnuplotline='gnuplot '//pfc(1:kkk)//' & '\n! gnuplotline='gnuplot5 '//pfc(1:kkk)//' & '\n! Reason - Choose the gnuplot command as per the Operating System's \n! existing command \"gnuplot\", \"gnuplot5\"etc..\n! Or, give the path of the gnuplot file as described below:\n! if gnuplot cannot be started with gnuplot give normal path ...\n! gnuplotline='\"c:\\program files\\gnuplot\\bin\\wgnuplot.exe\" '//pfc(1:kkk)//' '\n k3=len_trim(gnuplotline)+1\n! write(kou,*)'Gnuplot command file: ',pfc(1:kk+4)\n if(graphopt%gnutermsel.ne.1) then\n write(kou,*)'Graphics output file: ',pfh(1:kk+4)\n endif\n! plotonwin is set by compiler option, if 1 we are running microspft windows\n if(lines_excluded.gt.0) write(kou,11)lines_excluded\n11 format('SMP Some calculated lines are excluded from the plot',i5)\n if(plotonwin.eq.1) then\n! call system without initial \"gnuplot \" keeps the window !!!\n if(btest(graphopt%status,GRKEEP)) then\n! write(*,*)'plot command: \"',gnuplotline(9:k3),'\"'\n! write(*,*)'Trying to spawn: ',trim(gnuplotline)\n! call system(gnuplotline(9:k3))\n! spawn plot on Windows ?? NOT ISO-TERMAL DIAGRAM\n! write(*,*)'executing command: \"start /B '//trim(gnuplotline)\n! call execute_command_line('start /B '//gnuplotline(9:k3))\n write(*,*)'SMP2B executing command: \"start /B '//trim(gnuplotline)//'\"'\n call execute_command_line('start /B '//trim(gnuplotline))\n! sleep 500 miliseconds\n call usleep(us)\n! WORKS WITH OCPLOT3B\n! call execute_command_line('start /B '//trim(gnuplotline))\n else\n! write(*,*)'plot command: \"',gnuplotline(1:k3),'\"'\n! call system(gnuplotline)\n write(*,*)'SMP2B executing command: \"'//trim(gnuplotline)//'\"'\n call execute_command_line(gnuplotline)\n! sleep 500 miliseconds\n call usleep(us)\n endif\n else\n! plot on non-windows system without \"start /B ...\n! how to implement GRKEEP?\n write(*,*)'SMP2B executing command: '//trim(gnuplotline)\n call execute_command_line(gnuplotline)\n! sleep 500 miliseconds\n call usleep(us)\n endif\n1000 continue\n return\n end subroutine ocplot2B\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ocplot3\n!\\begin{verbatim}\n! subroutine ocplot3(ndx,pltax,filename,maptop,axarr,graphopt,pform,&\n subroutine ocplot3(ndx,pltax,filename,mastertop,axarr,graphopt,&\n version,ceq)\n! special to plot isothermal sections (two columns like x(*,cr) x(*,ni))\n! or other diagrams with two extensive variable on the axis\n! ndx is mumber of plot axis, \n! pltax is text with plotaxis variables\n! filename is intermediary file (maybe not needed)\n! mastertop is the map_node record with all results\n! axarr are axis records\n! graphopt is graphics record (should be extended to include more)\n! pform is graphics form\n! NOT USED: pform is type of output (screen or postscript or gif)\n implicit none\n integer ndx\n character pltax(*)*(*),filename*(*),version*(*)\n type(map_axis), dimension(*) :: axarr\n type(map_node), pointer :: mastertop\n type(graphics_options) :: graphopt\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim} %+\n integer, parameter :: maxsame=200\n type(map_node), pointer :: plottop,curtop,endnode,maptop\n type(map_line), pointer :: curline\n type(gtp_equilibrium_data), pointer :: curceq\n type(map_ceqresults), pointer :: results\n integer ii,jj,point,plotp,lines,eqindex,lasteq,nooftups,lokcs,jph,same,kk\n integer, parameter :: maxval=4000,mazval=100\n double precision, allocatable :: xval(:,:),yval(:,:),zval(:,:),tieline(:,:)\n integer offset,nofeq,sumpp,last,nofinv,ntieline,mtieline,noftielineblocks\n double precision xxx,yyy\n character*64, dimension(:), allocatable :: phaseline\n! TO BE REPLACED BY GNUTERMSEL: pform\n! character pform*8\n integer, allocatable :: plotkod(:),lineends(:)\n character xax1*8,xax2*24,yax1*8,yax2*24,axis1*32,axisx(2)*32,axisy(2)*32\n character phname*32,encoded*1024,axis*32\n character lid(2,maxsame)*24\n integer nooflineends,ephl,invnode\n double precision xmin, xmax, ymin, ymax\n!\n! do not change mastertop!\n maptop=>mastertop\n! xval and yval and ccordinates to plot, \n! points on one line is xval(1,jj),yval(1,jj)\n! points on the other line is xval(2,jj),yval(2,jj)\n! zval is an occational point zval(1,kk),zval(2,kk) at line ends (invariants)\n! plotkod is a specific code for each point\n! normal point just the index, -1 means point should be suppressed\n! -100 or -101 is a tieline; -1000 an invariant\n! lineends is the index in xval/yval for an end of line\n if(.not.associated(maptop)) then\n write(*,*)'No data to plot'\n goto 1000\n endif\n allocate(xval(2,maxval))\n allocate(yval(2,maxval))\n allocate(plotkod(maxval))\n allocate(zval(2,maxsame))\n allocate(lineends(maxsame))\n! phaseline is the name of the phases stable along a line\n allocate(phaseline(maxsame))\n nooflineends=0\n! write(*,17)\n17 format(//'Using ocplot3')\n! extract the axis variables\n jph=index(pltax(1),'*')\n xax1=pltax(1)(1:jph-1)\n xax2=pltax(1)(jph+1:)\n jph=index(pltax(2),'*')\n yax1=pltax(2)(1:jph-1)\n yax2=pltax(2)(jph+1:)\n!\n! initiate loop to extract values\n point=0\n plotp=0\n nofinv=0\n xmin=zero; xmax=zero; ymin=zero; ymax=zero\n! if graphopt%tielines not zero check if the tielines are in plane ...\n! %tieline_tieline_inplane <0 means step, 0 means isopleth\n if(graphopt%tielines.gt.0) then\n if(maptop%tieline_inplane.le.0) then\n write(kou,*)' Warning, tie-lines may be wrong'\n! graphopt%tielines=0\n endif\n endif\n! same is incremented for each line\n same=0\n sumpp=0\n plottop=>maptop\n curtop=>plottop\n nooftups=nooftup()\n! nooftup=noofphasetuples()\n100 continue\n if(.not.allocated(curtop%linehead)) goto 500\n lines=size(curtop%linehead)\n results=>plottop%saveceq\n invnode=0\n if(btest(plottop%status,MAPINVARIANT)) then\n invnode=size(plottop%linehead)\n write(*,*)'ocplot3 invariant node 1',invnode\n endif\n noftielineblocks=0\n! write(*,*)'SMP Number of lines: ',lines\n node: do ii=1,lines\n! up to version 5.014: (june 2018)\n! curline=>curtop%linehead(ii)\n! because crash plotting a ternary with 2 start points I changed\n! curline=>plottop%linehead(ii)\n! BUT the line above does not work for map10 and map3 (last plot of H)\n! so until further investigations I keep:\n curline=>curtop%linehead(ii)\n if(btest(curline%status,EXCLUDEDLINE)) then\n write(*,*)'Excluded line: ',ii,curline%lineid,lines\n cycle node\n endif\n eqindex=curline%first\n lasteq=curline%last\n if(eqindex.le.0 .or. eqindex.gt.lasteq) cycle node\n last=same\n same=same+1\n if(same.gt.maxsame) then\n write(*,*)'Too many lines to plot ',maxsame\n cycle node\n endif\n nofeq=lasteq+1-eqindex\n axisx=' '\n axisy=' '\n ntieline=0\n! write(*,*)'Plotting tie-lines: ',graphopt%tielines\n if(graphopt%tielines.gt.0) then\n! estimate the number of tie-lines to extract\n mtieline=nofeq/graphopt%tielines\n! write(*,*)'Number of tie-lines: ',mtieline\n allocate(tieline(4,mtieline+5))\n! write(*,*)'Allocating for tielines: ',mtieline+1\n! UNFINISHED: try to have equal number of equilibria at the beginning and end \n endif\n line: do eqindex=eqindex,lasteq\n! extract for each stable phase the state variable in pltax \n point=point+1\n curceq=>results%savedceq(eqindex)\n if(.not.associated(curceq)) then\n write(*,*)'SMP error, equilibrium missing?: ',&\n curtop%seqx,curline%lineid,eqindex\n cycle line\n endif\n! find the stable phases (max 3)\n plotp=plotp+1\n if(plotp.gt.maxval) then\n write(*,*)'Too many points to plot ',maxval\n cycle node\n endif\n jj=1\n ephl=1\n equil: do jph=1,nooftups\n lokcs=phasetuple(jph)%lokvares\n call get_phasetup_name(jph,phname)\n! crash as lokcs not valid ... the 3rd of 4th time plotted ...\n! write(*,321)'SMP bug? ',curtop%seqx,curline%lineid,eqindex,&\n! jph,lokcs,trim(phname)\n321 format(a,2i4,i5,2i4,' : ',a)\n! crash next line in alcrni-1200 mapping ...\n if(curceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then\n if(jj.ge.3) then\n if(eqindex.eq.lasteq) then\n! skip this point if it is the last \n plotp=plotp-1\n! write(*,*)'ocplot3 indexing error, skipping last point'\n endif\n cycle equil\n endif\n! the generation of the axis state variable is needed just once for all points \n! if we save the axis text ...\n plotkod(plotp)=same\n call get_phasetup_name(jph,phname)\n phaseline(same)(ephl:)=phname\n ephl=min(len_trim(phaseline(same))+2,62)\n if(same.gt.last) then\n lid(jj,same)=phname\n endif\n!\n!>>>>>>> here we should allow a wildcard axis like ac(*)\n!>>>>>>> without any phase label!! \n! \n if(axisx(1)(1:1).eq.' ') then\n axisx(1)=trim(xax1)//trim(phname)//trim(xax2)\n axisy(1)=trim(yax1)//trim(phname)//trim(yax2)\n elseif(axisx(2)(1:1).eq.' ') then\n axisx(2)=trim(xax1)//trim(phname)//trim(xax2)\n axisy(2)=trim(yax1)//trim(phname)//trim(yax2)\n endif\n! write(*,*)'We are here 1X: ',trim(axisx(jj))\n call meq_get_state_varorfun_value(axisx(jj),xxx,encoded,curceq)\n xval(jj,plotp)=xxx\n if(xxx.lt.xmin) then\n xmin=xxx\n elseif(xxx.gt.xmax) then\n xmax=xxx\n endif\n! write(*,*)'We are here 1Y: ',trim(axisy(jj))\n call meq_get_state_varorfun_value(axisy(jj),xxx,encoded,curceq)\n yval(jj,plotp)=xxx\n if(xxx.lt.ymin) then\n ymin=xxx\n elseif(xxx.gt.ymax) then\n ymax=xxx\n endif\n! write(*,19)'X/Y axis variable: ',plotp,trim(axis),&\n! xval(jj,plotp),xxx,point\n!19 format(a,i5,2x,a,2F10.6,2i5)\n jj=jj+1\n endif\n enddo equil\n if(graphopt%tielines.gt.0) then\n! exact coordinates for tielines each ntieline equilibria\n! write(*,*)'saving tieline?',eqindex,&\n! mod(eqindex,graphopt%tielines),ntieline,plotp\n if(mod(eqindex,graphopt%tielines).eq.0) then\n ntieline=ntieline+1\n tieline(1,ntieline)=xval(1,plotp)\n tieline(2,ntieline)=yval(1,plotp)\n tieline(3,ntieline)=xval(2,plotp)\n tieline(4,ntieline)=yval(2,plotp)\n endif\n endif\n! write(*,23)'phase line: ',same,last,trim(lid(1,same)),&\n! trim(lid(2,same))\n last=same\n! write(*,21)xval(1,plotp),yval(1,plotp),&\n! xval(2,plotp),yval(2,plotp),plotp\n!21 format('phase 1: ',2F10.7,10x,'phase 2: ',2F10.7,i7)\n lineends(same)=plotp\n enddo line\n! check if line ends in a node and add its coordinates for the same phases\n endnode=>curline%end\n if(associated(endnode)) then\n! there is a node at the end, extracts its ceq record\n curceq=>endnode%nodeceq\n plotp=plotp+1\n if(plotp.gt.maxval) then\n write(*,*)'Too many points to plot 1:',maxval\n gx%bmperr=4399; goto 1000\n endif\n do jj=1,2\n! write(*,*)'We are here 2:',trim(axisx(jj))\n call meq_get_state_varorfun_value(axisx(jj),xxx,encoded,curceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error extracting end points'\n goto 1000\n endif\n xval(jj,plotp)=xxx\n call meq_get_state_varorfun_value(axisy(jj),yyy,encoded,curceq)\n if(gx%bmperr.ne.0) goto 1000\n yval(jj,plotp)=yyy\n enddo\n! write(*,*)'Endnode x,y: ',plotp,xxx,yyy\n! correct lineends!!\n lineends(same)=plotp\n endif\n! write(*,23)'phase line: ',same,plotp,trim(lid(1,same)),trim(lid(2,same))\n23 format(a,2i5,3x,a,' and ',a)\n noftielineblocks=noftielineblocks+1\n if(ntieline.gt.0) then\n! All tielines on the same line with a space in between\n same=same+1\n phaseline(same)='tie-line'\n do eqindex=1,ntieline\n plotp=plotp+1\n if(plotp.gt.maxval) then\n write(*,*)'Too many points to plot 2:',maxval\n gx%bmperr=4399; goto 1000\n endif\n xval(1,plotp)=tieline(1,eqindex)\n yval(1,plotp)=tieline(2,eqindex)\n! this means the tie-lines will be plotted twice ... but why not??\n xval(2,plotp)=tieline(1,eqindex)\n yval(2,plotp)=tieline(2,eqindex)\n plotkod(plotp)=-100\n plotp=plotp+1\n if(plotp.gt.maxval) then\n write(*,*)'Too many points to plot 3:',maxval\n gx%bmperr=4399; goto 1000\n endif\n xval(1,plotp)=tieline(3,eqindex)\n yval(1,plotp)=tieline(4,eqindex)\n xval(2,plotp)=tieline(3,eqindex)\n yval(2,plotp)=tieline(4,eqindex)\n lineends(same)=plotp\n plotkod(plotp)=-101\n enddo\n lid(1,same)='tieline'\n lid(2,same)='tieline'\n endif\n! no longer any use of tieline\n if(allocated(tieline)) deallocate(tieline)\n enddo node\n!----------------------------------------------------------------------\n! finished all lines in this curtop, take next\n! but first generate the monovariant (not invariant)\n curtop=>curtop%next\n if(.not.associated(curtop,maptop)) then\n! write(*,*)'Extracting data from node'\n curceq=>curtop%nodeceq\n if(associated(curceq)) then\n! write(*,*)'Extracting data from node equilibrium'\n plotp=plotp+1\n if(plotp.gt.maxval) then\n write(*,*)'Too many points to plot 4:',maxval\n gx%bmperr=4399; goto 1000\n endif\n jj=1\n same=same+1\n ephl=1\n nodeequil: do jph=1,nooftups\n lokcs=phasetuple(jph)%lokvares\n if(curceq%phase_varres(lokcs)%phstate.ge.PHENTSTAB) then\n! plotkod set to -1 to indicate monovariant (not invariant)\n plotkod(plotp)=-1\n call get_phasetup_name(jph,phname)\n phaseline(same)(ephl:)=phname\n ephl=min(len_trim(phaseline(same))+2,62)\n! write(*,*)'Stable phase ',trim(phname),jj\n! if(jj.lt.3) lid(jj,same)='invariant'\n if(jj.lt.3) lid(jj,same)='monovariant'\n axis=trim(xax1)//trim(phname)//trim(xax2)\n! write(*,*)'We are here 3: ',trim(axis)\n call meq_get_state_varorfun_value(axis,xxx,encoded,curceq)\n if(jj.ge.3) then\n nofinv=nofinv+1\n zval(1,nofinv)=xxx\n else\n xval(jj,plotp)=xxx\n endif\n axis=trim(yax1)//trim(phname)//trim(yax2)\n call meq_get_state_varorfun_value(axis,xxx,encoded,curceq)\n if(jj.ge.3) then\n zval(2,nofinv)=xxx\n else\n yval(jj,plotp)=xxx\n endif\n jj=jj+1\n endif\n enddo nodeequil\n lineends(same)=plotp\n endif\n! jump back to label 100\n goto 100\n endif\n! do jj=1,same\n! write(*,23)'phases: ',same,jj,trim(lid(1,jj)),trim(lid(2,jj))\n! enddo\n!------------------------------------------------\n! Jump here if there is a line with illegal lineid\n772 continue\n! there can be more maptops linked via plotlink\n if(associated(plottop%plotlink)) then\n jj=plottop%seqx\n plottop=>plottop%plotlink\n write(*,*)'ocplot3B current and next maptop: ',jj,plottop%seqx\n! this added 180918 to plot results from several MAP commands\n curtop=>plottop\n maptop=>plottop\n! write(*,*)'Current number of lines: ',same,plotp,&\n! allocated(curtop%linehead)\n goto 100\n endif\n!========================================================\n call get_plot_conditions(encoded,maptop%number_ofaxis,axarr,ceq)\n! now we should have all data to plot in xval and yval arrays\n500 continue\n write(*,808)same,plotp,maxsame,maxval\n808 format('plot data used: ',2i7,' out of ',2i7)\n! write(*,*)'found lines/points to plot: ',same,plotp,nofinv\n! write(*,502)(lineends(ii),ii=1,same)\n502 format(10i5)\n! set default xmin, xmax etc ...\n graphopt%dfltmin(1)=xmin\n graphopt%dfltmin(2)=ymin\n graphopt%dfltmax(1)=xmax\n graphopt%dfltmax(2)=ymax\n! NOW pltax should be the the axis labels if set manually\n if(graphopt%labeldefaults(2).ne.0) pltax(1)=graphopt%plotlabels(2)\n if(graphopt%labeldefaults(3).ne.0) pltax(2)=graphopt%plotlabels(3)\n call ocplot3B(same,nofinv,lineends,2,xval,2,yval,2,zval,plotkod,pltax,&\n lid,phaseline,filename,graphopt,version,encoded)\n deallocate(xval)\n deallocate(yval)\n deallocate(plotkod)\n1000 continue\n return\n end subroutine ocplot3\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\begin{verbatim} %-\n subroutine ocplot3B(same,nofinv,lineends,nx1,xval,ny1,yval,nz1,zval,plotkod,&\n pltax,lid,phaseline,filename,graphopt,version,conditions)\n! called by ocplot3 to write the GNUPLOT file for two wildcard columns\n! same is the number of lines to plot\n! nofinv number of monovariants (not invariants)\n! lineends array with row numbers where each line ends\n! nx1 first dimension of xval\n! xval 2D matrix with values to plot on x axis\n! ny1 first dimension of yval\n! yval 2D matrix with values to plot on y axis\n! nz1 first dimension of zval\n! zval 2D matrix with third point of monovariant (not invariant) triangles\n! plotkod integer array indicating the type of line (-1 skip line)\n! pltax text for axis\n! lid array with GNUPLOT line types\n! phaseline is phase names of phase stable along the line\n! filename is intermediary file (maybe not needed)\n! graphopt is graphics option record\n! maptop is map_node record with all results\n! REPLACED BY gnutermsel pform is type of output (screen/acrobat/postscript/gir)\n! conditions is a text with conditions for the calculation\n implicit none\n! character pltax(*)*(*),filename*(*),pform*(*),lid(nx1,*)*(*),conditions*(*)\n character pltax(*)*(*),filename*(*),lid(nx1,*)*(*),conditions*(*)\n character version*(*)\n character phaseline(*)*(*)\n type(graphics_options) :: graphopt\n integer same,plotkod(*),nx1,ny1,nz1,nofinv\n integer lineends(*)\n double precision xval(nx1,*),yval(ny1,*),zval(nz1,*)\n!\\end{verbatim}\n integer, parameter :: maxcolor=200,mofapl=100\n integer ii,jj,kk,jph,offset,n1,nofapl,ltf2\n type(graphics_textlabel), pointer :: textlabel\n character gnuplotline*256,date*12,mdate*12,title*128\n character deftitle*64,backslash*2\n! pointincremet emergy fix\n character piincrement*8\n character labelkey*64,applines(mofapl)*128,appline*128,pfc*128,pfh*128\n integer sumpp,np,appfil,ic,nnv,kkk,lcolor(maxcolor),iz,again\n integer done(maxcolor),foundinv,fcolor,k3\n character color(maxcolor)*24,rotate*16,labelfont*32,linespoints*12\n integer naptitle,apptitles(maxcolor)\n! we plot monovariant twice, once with border once with filledcurves!!\n! integer noofmono,jjj,monovariant2(100)\n integer, parameter :: monovariantborder=11\n integer xtieline,xmonovariant,lz\n integer, parameter :: us=500000\n! now a global variable\n! character monovariant*6\n! Gibbs triangle variables\n logical plotgt,appgt\n double precision sqrt3,xxx,yyy,xmax,ymax,ltic,xf,yf,xmin,ymin\n! \n write(*,*)'Using the rudimentary graphics in ocplot3B!',graphopt%linett\n! light green 'fc \"#B0FFB0\" notitle ',a)\n! very faint green 'fc \"#F0FFF0\" notitle ',a)\n! yellow 'fc \"#FFFF00\" notitle ',a)\n! goldenrod 'fc \"#DAA520\" notitle ',a)\n! dark green monovariant='50FF50'\n! monovariant='00FFFF'\n! write(*,*)'Filename: ',trim(ocgnu)\n!\n ltf2=0\n call date_and_time(date)\n mdate=\" \"//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//\" \"\n deftitle='OpenCalphad '//version//': '//mdate//': with GNUPLOT'\n if(graphopt%labeldefaults(1).eq.0) then\n title=deftitle\n else\n! default inlcude open calphad and date, add user title at the end\n title=trim(deftitle)//' '//graphopt%plotlabels(1)\n endif\n! np should be the number of different lines to be plotted\n! if there is just one line do not write any key. May be overriiden later ..\n np=same\n write(*,*)'ocplot3B append?',trim(graphopt%appendfile(1:1))\n if(np.eq.1 .and. graphopt%appendfile(1:1).eq.' ') then\n labelkey=' off'\n else\n labelkey=graphopt%labelkey\n endif\n! problems with identifying monovariants (not invariants) and tie-lines lines\n lcolor=0\n!\n if(index(filename,'.plt ').le.0) then \n kk=len_trim(filename)\n pfc=filename(1:kk)//'.'//'plt '\n kkk=kk+4\n else\n pfc=filename\n endif\n!\n write(kou,*)'SMP2B filename: ',trim(pfc)\n! write(kou,*)'Graphics format: ',graphopt%gnutermsel\n open(21,file=pfc,access='sequential',status='unknown')\n write(21,110)trim(title)\n110 format('# GNUPLOT file generated by OpenCalphad'/'# ',a/&\n '# subroutine ocplot3B')\n if(graphopt%gnutermsel.lt.1 .or. &\n graphopt%gnutermsel.gt.graphopt%gnutermax) then\n write(*,*)'Unknown graphics terminal: ',graphopt%gnutermsel\n goto 1000\n elseif(graphopt%gnutermsel.gt.1) then\n! terminal 1 is screen without any output file\n pfh=filename(1:kk)//'.'//graphopt%filext(graphopt%gnutermsel)\n! set the screen as a comment ...\n write(21,840)trim(graphopt%gnuterminal(1)),&\n trim(graphopt%gnuterminal(graphopt%gnutermsel)),trim(pfh)\n840 format('#set terminal ',a/'set terminal ',a/'set output \"',a,'\"')\n! 840 format('set terminal ',a/'set output \"',a,'\"')\n else\n! terminal 1 is screen without any output file, add PDF as comment\n write(21,841)trim(graphopt%gnuterminal(graphopt%gnutermsel)),&\n trim(graphopt%gnuterminal(3))\n841 format('set terminal ',a/'#set terminal ',a/'#set output \"ocgnu.pdf\"')\n!841 format('set terminal ',a)\n endif\n if(graphopt%gibbstriangle) then\n! write(*,*)'Gibbs triangle diagrams are under development!'\n! xmax should be the largest scale value of x and y axis (same length!!)\n xmax=one\n plotgt=.true.\n if(graphopt%rangedefaults(1).ne.0) then\n xmax=min(xmax,graphopt%plotmax(1))\n endif\n if(graphopt%rangedefaults(2).ne.0) then\n xmax=min(xmax,graphopt%plotmax(2))\n endif\n! graphopt%plotmin(1) etc are user defined\n! graphopt%dfltmin(1..3) and dfltmax(1..3) are generated above\n! write(*,*)'SMP2B xmin,ymin: ',graphopt%dfltmin(1),graphopt%dfltmin(2)\n! write(*,*)'SMP2B xmax,ymax: ',graphopt%dfltmax(1),graphopt%dfltmax(2)\n ltic=0.01*xmax\n sqrt3=0.5D0*sqrt(3.0D0)\n write(21,844)sqrt3*xmax,xmax\n! These maybe not necessary ... 0.866 is 0.5*sqrt(3)\n844 format('# GIBBSTRIANGLE '/&\n 'set bmargin 3'/'set lmargin 3'/'set rmargin 3'/'set tmargin 3'/&\n 'set origin 0.0, 0.0 '/&\n 'set size ratio 0.866'/&\n 'set yrange [0:',F10.6,']'/'set xrange [0:',F10.6,']'/&\n 'set noborder'/'set noxtics'/'set noytics')\n! This replaces axis without tics, only a tic in the middle\n write(21,845)xmax, xmax, 0.5*xmax, sqrt3*xmax, 0.5*xmax, sqrt3*xmax,&\n! next 3 values are value and position for max values of Y axis\n! xmax, 0.343*xmax, sqrt3*(xmax+0.15d0), &\n xmax, 0.39, sqrt3*(one+0.17d0), &\n! next 3 values are value and positions of max values for X axis\n! xmax, 0.92, -5.0*ltic, &\n xmax, 0.95, -3.0*ltic, &\n! next 6 values are min values for X and Y axis\n xmin , -0.04, -0.03, ymin , -0.1, 0.01, &\n! these are rudimentary ticmarks, now going inside triangle !!!\n 0.25*xmax, 0.5*sqrt3*xmax, 0.25*xmax+2*ltic, 0.5*sqrt3*xmax, &\n 0.25*xmax, 0.5*sqrt3*xmax, 0.25*xmax+ltic, 0.5*sqrt3*xmax-1.5*ltic,&\n 0.75*xmax, 0.5*sqrt3*xmax, 0.75*xmax-2*ltic, 0.5*sqrt3*xmax, &\n 0.75*xmax, 0.5*sqrt3*xmax, 0.75*xmax-ltic, 0.5*sqrt3*xmax-1.5*ltic,&\n 0.5*xmax,0.0,0.5*xmax,1.5*ltic\n845 format('set style line 90 lt 1 lw 1 pt -1 ps 1'/&\n 'set style line 91 lt 1 lw 1 pt -1 ps 1'/&\n 'set arrow 1 from 0,0 to ',F8.4,', 0.0 nohead linestyle 90'/&\n 'set arrow 2 from ',F8.4,', 0 to ',F8.4,',',F8.4,&\n ' nohead linestyle 90'/&\n 'set arrow 3 from ',F8.4,',',F8.4,' to 0,0 nohead linestyle 90'/&\n '# axis max values ...'/&\n 'set label \"',F6.2,'\" at graph ',F8.4,',',F8.4/& \n 'set label \"',F6.2,'\" at graph ',F8.4,',',F8.4/& \n '# axis min values ...'/&\n 'set label \"',F6.2,'\" at graph ',F8.4,',',F8.4/& \n 'set label \"',F6.2,'\" at graph ',F8.4,',',F8.4/& \n '# tickmarks ...'/&\n 'set arrow 4 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,&\n ' nohead linestyle 91'/&\n 'set arrow 5 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,&\n ' nohead linestyle 91'/&\n 'set arrow 6 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,&\n ' nohead linestyle 91'/&\n 'set arrow 7 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,&\n ' nohead linestyle 91'/&\n 'set arrow 8 from ',F8.4,',',F8.4,' to ',F8.4,',',F8.4,&\n ' nohead linestyle 91'/&\n '# end most of special Gibbs triangle')\n else\n plotgt=.false.\n endif\n!\n! write(*,*)'Plot heading 3? ',btest(graphopt%status,GRNOTITLE)\n if(btest(graphopt%status,GRNOTITLE)) then\n write(21,128)trim(title),trim(conditions),trim(graphopt%font)\n else\n call replace_uwh(conditions)\n write(21,129)trim(title),trim(conditions),trim(graphopt%font)\n endif\n call replace_uwh(pltax(1))\n! Plot grid?\n if(graphopt%setgrid.eq.1) write(21,777)\n777 format('set grid')\n! add information of any scaling factors for the axis \"xf\" or \"yf\"\n! if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1)\n! if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2)\n write(21,130)graphopt%xsize,graphopt%ysize,&\n trim(pltax(1)),trim(labelkey)\n128 format('#set title \"',a,' \\n #',a,'\" font \"',a,',10\"')\n129 format('set title \"',a,' \\n ',a,'\" font \"',a,',10\"')\n130 format('set origin 0.0, 0.0 '/&\n 'set size ',F8.4,', ',F8.4/&\n 'set xlabel \"',a,'\"'/&\n 'set key ',a)\n call replace_uwh(pltax(2))\n if(plotgt) then\n! OC logo added by Catalina Pineda\n! when Gibbs triangle the ylabel and logo must be placed carefully\n! THIS IS THE Y-AXIS WITH 60 degrees angle\n write(21,131)trim(pltax(2)), 0.15*xmax, 0.37*xmax,graphopt%logofont\n131 format('set label \"',a,'\" at ',F8.4,',',F8.4,' rotate by 60 '/&\n! Help with stackoverflow to fix nice logo independent of plot size!\n 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"',a,'\"')\n! 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"Garamond Bold,20\"')\n! 'set label \"~O{.0 C}\" at graph -0.1, -0.1 font \"Garamond Bold,20\"')\n! we should also enforce same length of X and Y axis !!!\n else\n! SQUARE DIAGRAM\n write(21,132)trim(pltax(2)),graphopt%logofont\n132 format('set ylabel \"',a,'\"'/&\n! Help with stackoverflow to fix nice logo independent of plot size!\n 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"',a,'\"')\n! 'set label \"~O{.0 C}\" at screen 0.02, 0.03 font \"Garamond Bold,20\"')\n! 'set label \"~O{.0 C}\" at graph -0.1, -0.1 font \"Garamond Bold,20\"')\n endif\n lz=graphopt%linetype\n write(21,133)lz,lz,lz,lz,lz,lz,lz,lz,lz,lz\n133 format('# if the value after solid is 0 the monovariants are transparent'/&\n 'set style fill transparent solid 1'/&\n 'set style line 1 lt ',i2,' lc rgb \"#000000\" lw 2 pt 10'/&\n 'set style line 2 lt ',i2,' lc rgb \"#00C000\" lw 2 pt 2'/&\n 'set style line 3 lt ',i2,' lc rgb \"#4169E1\" lw 2 pt 7'/&\n 'set style line 4 lt ',i2,' lc rgb \"#FF0000\" lw 2 pt 3'/&\n 'set style line 5 lt ',i2,' lc rgb \"#00FFFF\" lw 2 pt 10'/&\n 'set style line 6 lt ',i2,' lc rgb \"#FF00FF\" lw 2 pt 5'/&\n 'set style line 7 lt ',i2,' lc rgb \"#804080\" lw 2 pt 6'/&\n 'set style line 8 lt ',i2,' lc rgb \"#00C000\" lw 2 pt 8'/&\n 'set style line 9 lt ',i2,' lc rgb \"#C0C0C0\" lw 2 pt 1'/&\n 'set style line 10 lt ',i2,' lc rgb \"#DAA520\" lw 2 pt 4')\n! add some useful things for manual maniplulation of graph\n write(21,8000)\n8000 format(/'# Some useful GNUPLOT commands for editing the figure'/&\n '# *** THIS IS A DASHED LINE (on pdf/wxt):'/&\n '# set style line 15 lt 0 lc rgb \"#C8C800\" lw 2 pt 2'//&\n '# set pointsize 0.6'/&\n '# set label \"text\" at 0.5, 0.5 rotate by 60 font \"Arial,12\"'/&\n '# set xrange [0.5 : 0.7] '/&\n '# *** ADDING MANUALLY A LINE AND KEEP SCALING:'/&\n '# set arrow from x0, y0 to x1,y1 nohead linestyle 1'/&\n '# *** ADD A RED DOT AT 1,100:'/&\n '# set obj 1 circle fc rgb \"#FF0000\" fs sol size 0.02 noclip at 1,1'/&\n '# *** PLOTTING SYMBOLS INSTEAD OF LINE:'/&\n '# ... using 2:i with points pt 7 ps 3'/&\n '# ** MODIFY THE AXIS VALUE:'/&\n '# plot for [i=] ... using (2*column(i)/(1-2*column(i))):2 with ...'/&\n '# ** OVERLAY PLOTS: '/&\n '# set multiplot'/&\n '# set xrange [] writeback'/&\n '# ... plot someting'/&\n '# set xrange restore'/&\n '# ... plot more using same axis scaling '/&\n '# set nomultiplot'/)\n!\n! 'set style line 10 lt 2 lc rgb \"#00FFFF\" lw 2 pt 10'/&\n! orange is #FF4500\n! goldenrod hex: DAA520\"\n! line style 11 is monovariant (not invariant), 12 tieline\n! 'set style line 11 lt 2 lc rgb \"goldenrod\" lw 3'/&\n! 'set style line 11 lt 2 lc rgb \"#DAA520\" lw 3'/&\n! 'set style line 12 lt 2 lc rgb \"goldenrod\" lw 1')\n! 'set style line 11 lt 2 lc rgb \"#804080\" lw 3'/&\n! 'set style line 12 lt 2 lc rgb \"#804080\" lw 1')\n! 'set style line 11 lt 2 lc rgb \"#7CFF40\" lw 3'/&\n! for monovariants use filledcurves fc \"#xxxxxx\" AND linestyle 11\n write(21,134)tielinecolor,tielinecolor\n! line style 11 is for the limits of the monovariants, 12 for tie-lines\n134 format('set style line 11 lt 2 lc rgb \"#',a,'\" lw 3'/&\n 'set style line 12 lt 2 lc rgb \"#',a,'\" lw 1')\n! 'set style line 12 lt 2 lc rgb \"#7CFF40\" lw 1')\n! The last two styles (11 and 12) are for monovariants (not invariants)\n! and tielines\n!\n! ranges for x and y\n if(graphopt%rangedefaults(1).ne.0) then\n! user defined ranges for x axis\n write(21,150)'x',graphopt%plotmin(1),graphopt%plotmax(1)\n150 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ')\n endif\n if(graphopt%rangedefaults(2).ne.0) then\n! user defined ranges for y axis\n write(21,150)'y',graphopt%plotmin(2),graphopt%plotmax(2)\n endif\n!----------------------\n! logarithmic axis\n if(graphopt%axistype(1).eq.1) then\n write(21,151)'x'\n151 format('set logscale ',a)\n endif\n if(graphopt%axistype(2).eq.1) then\n write(21,151)'y'\n endif\n!----------------------\n! line labels\n! set labels\n textlabel=>graphopt%firsttextlabel\n do while(associated(textlabel))\n if(plotgt) then\n xxx=textlabel%xpos+0.5D0*textlabel%ypos\n! sqrt3=0.5D0*sqrt(3.0D0)\n yyy=sqrt3*textlabel%ypos\n else\n xxx=textlabel%xpos\n yyy=textlabel%ypos\n endif\n! write(*,*)'SMP text: ',textlabel%textline,textlabel%xpos,xxx,plotgt\n!----------------------- new\n rotate=' '\n if(textlabel%angle.ne.0) write(rotate,177)textlabel%angle\n177 format(' rotate by ',i5)\n labelfont=' '\n! write(*,*)'textfontscale: ',textlabel%textfontscale\n if(textlabel%textfontscale.ne.one) then\n! write(labelfont,178)int(10*textlabel%textfontscale)\n!178 format(' font \"Sans,',i2,'\" ')\n write(labelfont,178)trim(graphopt%font),&\n int(10*textlabel%textfontscale)\n178 format(' font \"',a,',',i2,'\" ')\n endif\n! if(textlabel%angle.eq.0) then\n! write(21,1505)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,&\n write(21,1505)trim(textlabel%textline),xxx,yyy,&\n trim(labelfont),trim(rotate)\n1505 format('set label \"',a,'\" at ',1pe12.4,', ',1pe12.4,a,a)\n! else\n! write(21,1506)trim(textlabel%textline),textlabel%xpos,textlabel%ypos,&\n! textlabel%angle\n!1506 format('set label \"',a,'\" at ',1pe12.4,', ',1pe12.4,&\n! ' rotate by ',i5)\n! endif\n! textlabel=>textlabel%nexttextlabel\n! OLD below\n! if(textlabel%angle.eq.0) then\n! write(21,160)trim(textlabel%textline),xxx,yyy,&\n!160 format('set label \"',a,'\" at ',1pe14.6,', ',1pe14.6)\n! else\n! write(21,161)trim(textlabel%textline),xxx,yyy,textlabel%angle\n!161 format('set label \"',a,'\" at ',1pe14.6,', ',1pe14.6,&\n! ' rotate by ',i5)\n! endif\n jj=len_trim(textlabel%textline)\n textlabel=>textlabel%nexttextlabel\n enddo\n!---------------------------------------------------------------\n! handle heading of appended files here ....\n!\n if(graphopt%appendfile(1:1).eq.' ') then\n appfil=0\n else\n appfil=23\n write(kou,*)'Appending data from: ',trim(graphopt%appendfile)\n open(appfil,file=graphopt%appendfile,status='old',&\n access='sequential',err=280)\n!\n write(21,210)'# APPENDED from '//trim(graphopt%appendfile)\n appgt=.false.\n! copy all lines up to \"plot\" to new graphics file\n nnv=0\n200 continue\n read(appfil,210,end=290)appline\n210 format(a)\n! if(appline(1:1).eq.'#') then\n! write(*,*)'input: ',trim(appline),appgt\n! endif\n if(appline(1:15).eq.'# GIBBSTRIANGLE') then\n appgt=.true.\n if(.not.plotgt) then\n write(*,*)'Append file is in Gibbstriangle format'\n goto 280\n endif\n endif\n! skip other comment lines\n if(appline(1:1).eq.'#') goto 200\n!------------------------------------------------------------------\n! ignore some lines with \"set\" in the append file\n! set title\n! set xlabel\n! set ylabel\n! set xrange\n! set yrange\n! set output\n! set terminal\n! set size\n! set key\n if(appline(1:10).eq.'set title ' .or.&\n appline(1:11).eq.'set xlabel ' .or.&\n appline(1:11).eq.'set ylabel ' .or.&\n appline(1:11).eq.'set xrange ' .or.&\n appline(1:11).eq.'set yrange ' .or.&\n appline(1:11).eq.'set output ' .or.&\n appline(1:13).eq.'set terminal ' .or.&\n appline(1:11).eq.'set origin ' .or.&\n appline(1: 9).eq.'set size ' .or.&\n appline(1: 8).eq.'set key ') then\n! write(*,*)'ignoring append file line ',trim(appline)\n goto 200\n endif\n!------------------------------------------------------------------\n if(index(appline,'plot \"-\"').gt.0 .or. &\n index(appline,\"plot '-'\").gt.0 .or. &\n index(appline,\"plot for \").gt.0) then\n! this is ocplot3B, reading plot command lines\n if(plotgt) then\n! check if append file has square or triangular coordinates ...\n if(.not.appgt) then\n! If GIBBSTRIANGLE they must be converted unless already a triangle ....\n write(*,*)'Please use append file with Gibbs triangle'\n goto 280\n endif\n elseif(appgt) then\n! a triangular append file must be transformed to square ...\n write(*,*)'Please use append file with square coordinates'\n goto 280\n endif\n applines(1)=appline\n ic=1\n230 continue\n! if line ends with \\ then read more\n ii=len_trim(appline)\n! write(*,*)'There are more? ',appline(i:ii),ii,ic\n if(appline(ii:ii).eq.'\\') then\n! continuation lines\n read(appfil,210,end=290)appline\n ic=ic+1\n if(ic.ge.mofapl) then\n write(*,*)'Too many head lines in append file',ic\n else\n applines(ic)=appline\n endif\n goto 230\n endif\n nofapl=ic\n goto 290\n else\n! ignore all lines until \"plot \"-\" ...\n goto 200\n endif\n! These are coordinate lines\n write(21,210)trim(appline)\n nnv=nnv+1\n goto 200\n! error oppening append file\n280 continue\n write(kou,*)' *** Cannot open or read the append file, skipping it'\n close(appfil)\n appfil=0\n290 continue\n! do not close the append file, we have to read the data also!\n! write(*,*)'Finished reading appendfile head: ',nofapl,ic\n endif\n! coordinate the content of lid with the colors\n! do ii=1,same\n! write(*,*)'phases: ',ii,trim(lid(1,ii)),' ',trim(lid(2,ii))\n! enddo\n nnv=0\n iz=0\n! color(1)=' '\n color=' '\n! if(2*same.gt.maxcolor) then\n! write(*,*)'Number of lines: ',2*same,maxcolor\n! endif\n pair: do jj=1,2\n! maybe same must be incremented with the number of tieline blocks??\n! and ivariants?? They have separate plot commands ...\n point: do ii=1,same\n iz=iz+1\n! plotkod -1 negative means ignore\n! plotkod -100 and -101 used for tie-lines\n if(jj.eq.2 .and. plotkod(iz).eq.-1) then\n write(*,*)'SMPB: Ignoring this line ',jj,iz,plotkod(iz)\n! cycle pair\n cycle point\n endif\n do ic=1,nnv\n if(trim(lid(jj,ii)).eq.trim(color(ic))) then\n if(iz.gt.maxcolor) then\n write(kou,*)'lcolor dimension overflow',iz\n else\n lcolor(iz)=ic\n endif\n goto 295\n endif\n enddo\n! no match, increment nnv and assign that color to lcolor\n! skip colors 11 and 12, reserved for monovariants and tielines\n nnv=nnv+1\n lcolor(iz)=nnv\n color(nnv)=lid(jj,ii)\n! write(*,293)'color select: ',nnv,jj,ii,iz,trim(color(nnv))\n293 format(a,4i5,' \"',a,'\"')\n295 continue\n enddo point\n enddo pair\n! write(*,*)'Finished assigning colors',iz\n! replace _ by - (in phase names). nnv is number of titles \n do kk=1,nnv\n297 continue\n jj=index(color(kk),'_')\n if(jj.gt.0) then\n color(kk)(jj:jj)='-'\n goto 297\n endif\n enddo\n!---------------------------------------------------------------\n! check for monovariants (not invariant) and tieline and replace color!\n do ii=1,2*same\n if(lcolor(ii).le.0) then\n write(*,*)'missing color in ',ii,' out of ',2*same,' set to 9'\n lcolor(ii)=9\n! else\n! write(*,*)'original: ',ii,lcolor(ii),trim(color(lcolor(ii)))\n endif\n enddo\n lcolor1: do ii=1,2*same\n jj=lcolor(ii)\n if(trim(color(jj)).eq.'invariant') then\n write(*,*)' *** wrong: invariant color ',jj,trim(color(jj))\n endif\n if(trim(color(jj)).eq.'monovariant') then\n! write(*,*)'found monovariant ',ii,jj,2*same\n lcolor(ii)=11\n! color(11)='invariant'\n color(11)='monovariant'\n do kk=ii+1,2*same\n if(lcolor(kk).eq.jj) then\n! write(*,*)'subsequent: ',kk,lcolor(kk),jj,11\n lcolor(kk)=11\n endif\n enddo\n! why exit?\n! exit lcolor1\n endif\n enddo lcolor1\n lcolor2: do ii=1,2*same\n jj=lcolor(ii)\n if(jj.le.0 .or. jj.gt.maxcolor) then\n! this is a line that should not be plotted ...\n write(*,*)'smp2B: problem: ',ii,jj\n lcolor(ii)=11\n cycle lcolor2\n endif\n if(trim(color(jj)).eq.'tieline') then\n! write(*,*)'found tie-line ',ii,jj\n lcolor(ii)=12\n color(12)='tie-line'\n do kk=ii+1,2*same\n if(lcolor(kk).eq.jj) lcolor(kk)=12\n enddo\n! why exit?\n! exit lcolor2\n endif\n enddo lcolor2\n! do ii=1,2*same\n! write(*,*)'Final: ',ii,lcolor(ii),trim(color(lcolor(ii)))\n! enddo\n!----------------------------------------------------------------\n if(plotgt) then\n! convert all coordinates to a Gibbs trangle, ax and ay are the square coordin\n! x = ax + 0.5*ay\n! y = 0.5*sqrt(3)*ay\n!\n! As the 3rd point of the monovariant is connected to the xval/yval I must\n! make the same loop as below when plotting ...\n! write(*,*)'Converting coordinates to Gibbs Triangle',same,lineends(1)\n foundinv=0\n! sqrt3=0.5D0*sqrt(3.0D0)\n sumpp=0\n do jj=1,same\n if(sumpp+1.eq.lineends(jj)) then\n foundinv=foundinv+1\n! write(*,*)'Monovariant at ',foundinv,sumpp\n sumpp=sumpp+1\n xval(1,sumpp)=xval(1,sumpp)+5.0D-1*yval(1,sumpp)\n xval(2,sumpp)=xval(2,sumpp)+5.0D-1*yval(2,sumpp)\n zval(1,foundinv)=zval(1,foundinv)+5.0D-1*zval(2,foundinv)\n zval(2,foundinv)=sqrt3*zval(2,foundinv)\n yval(1,sumpp)=sqrt3*yval(1,sumpp)\n yval(2,sumpp)=sqrt3*yval(2,sumpp)\n else\n do while(sumpp.lt.lineends(jj))\n sumpp=sumpp+1\n xval(1,sumpp)=xval(1,sumpp)+5.0D-1*yval(1,sumpp)\n xval(2,sumpp)=xval(2,sumpp)+5.0D-1*yval(2,sumpp)\n yval(1,sumpp)=sqrt3*yval(1,sumpp)\n yval(2,sumpp)=sqrt3*yval(2,sumpp)\n enddo\n endif\n enddo\n endif\n!----------------------------------------------------------------\n! text in lower left corner\n ii=len_trim(graphopt%lowerleftcorner)\n if(graphopt%gibbstriangle) then\n if(ii.gt.3) then\n! write(21,208)trim(graphopt%lowerleftcorner),-0.14\n!208 format('set label \"',a,'\" at graph ',F10.4,', -0.05 ')\n write(21,208)trim(graphopt%lowerleftcorner),-0.05\n208 format('set label \"',a,'\" at graph ',F10.4,', -0.03 ')\n elseif(ii.gt.0) then\n write(21,208)trim(graphopt%lowerleftcorner),-0.08\n endif\n elseif(ii.gt.0) then\n! in square diagram below figure\n write(21,209)trim(graphopt%lowerleftcorner)\n209 format('set label \"',a,'\" at graph -0.10, -0.08 ')\n endif\n! if lowerleftcorner is empty ignore it\n!----------------------------------------------------------------\n!----------------------------------------------------------------\n! Finished all options, now deal with the data to plot!\n! this is subroutine ocplot3B for two extensive axis\n!----------------------------------------------------------------\n! Here we generate the datafile with coordinates to plot\n! if nx1 or ny1 is 1 plot all on other axis versus single axis coordinate\n! if nx1=ny1 plot the pairs xval(1..nx1,jj) yval(1..ny1,jj)\n!----------------------\n backslash=',\\'\n! empty line before the plot command\n write(21,*)\n! here we should start from the value in graphopt%linett\n ii=0\n kk=graphopt%linett-1\n if(kk.ne.0) then\n write(*,*)'SMP2B: Ignoring manipulation of line colors'\n endif\n! if graphopt%linestyle=0 use lines, otherwise linespoints\n! this never worked ...\n! if(graphopt%linestyle.eq.0) then\n linespoints='lines ls'\n piincrement=' '\n if(graphopt%linewp.gt.1) then\n! this should add a symbol at each calculated line but it does not work (yet)\n! linespoints='lp lt '\n linespoints='lp ls '\n write(piincrement,'(\" pi \",i3,1x)')graphopt%linewp-1\n endif\n! write(*,*)'smp2B linesplot increment 2: \"',piincrement,'\"',graphopt%linewp\n! write(*,*)'SMP2B plotting lines: ',trim(linespoints),graphopt%linewp\n done=0\n! noofmono=0\n! Here we write all plot \"-\" using ... and subsequent \"\" using ...\n naptitle=0\n xtieline=0\n xmonovariant=0\n kkloop: do kk=1,2\n jjloop: do jj=1,same\n ii=ii+1\n if(ii.eq.1) then\n if(lcolor(ii).eq.11) then\n! this is monovariant!\n! this is the first plot command, ii=1 so kk must be 1!!\n if(kk.eq.1) then\n write(21,306)monovariant,backslash\n306 format('plot \"-\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" notitle ',a)\n xmonovariant=jj\n! write(*,*)'SMP monovariant 1: ',xmonovariant\n else\n! this else branch is impossible, when ii=1 then kk=1 !!! but ...\n write(21,307)monovariant,trim(color(lcolor(ii))),backslash\n307 format('plot \"-\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" title \"',a,'\"',a)\n! light green 'fc \"#B0FFB0\" title \"',a,'\"',a)\n! very faint green 'fc \"#F0FFF0\" title \"',a,'\"',a)\n! faint yellow 'fc \"#EEFFCC\" title \"',a,'\"',a)\n endif\n elseif(lcolor(ii).eq.12) then\n! tie-line\n write(21,308)'lines',lcolor(ii),&\n trim(color(lcolor(ii))),backslash\n xtieline=jj\n! write(*,*)'SMP xtieline 1: ',xtieline\n308 format('plot \"-\" using 1:2 with ',a,' ls ',i2,' notitle ',a)\n else\n! normal line with label\n! SUDDENLY lcolor(ii) is not set null !!\n! write(*,*)'SMP2B ocplot3B 1: ',ii,'\"',linespoints,'\"'\n! write(*,*)'SMP2B ocplot3B 2: ',lcolor(ii),color(lcolor(ii))\n write(21,309)trim(linespoints),lcolor(ii),&\n trim(piincrement),trim(color(lcolor(ii))),backslash\n endif\n naptitle=naptitle+1\n apptitles(naptitle)=lcolor(ii)\n!309 format('plot \"-\" using 1:2 with ',a,' ls ',i2,' title \"',a,'\"',a)\n309 format('plot \"-\" using 1:2 with ',a,1x,i2,1x,a,' title \"',a,'\"',a)\n done(lcolor(1))=1\n else\n! all lines except the first plotted here\n! the last line for the plot command has no backslash --- except if append file\n if(ii.eq.2*same .and. appfil.eq.0) backslash=' '\n! we can only use linestyles 1 to 10 except for monovariants and tie-lines\n fcolor=lcolor(ii)\n if(fcolor.gt.12) then\n fcolor=mod(fcolor,10)\n if(fcolor.eq.0) fcolor=10\n! fixed Nath MoNiRe isotherm at 1500 K had some lines with no lcolor assignment!\n elseif(fcolor.le.0) then\n lcolor(ii)=1\n fcolor=1\n endif\n cone: if(done(lcolor(ii)).eq.1) then\n! we have already a title for this line ... except tie-lines and monovariant\n if(lcolor(ii).eq.11) then\n if(kk.eq.1) then\n! first time plotting an invariant use thick lines\n write(21,320)'lines ls',monovariantborder,' ',backslash\n! save the index of the last monovariant to add title!\n xmonovariant=jj\n! write(*,*)'SMP monovariant 2: ',xmonovariant\n else\n! if kk=2 check if this is last monovariant, if so add title\n if(jj.eq.xmonovariant) then\n write(21,318)monovariant,trim(color(11)),backslash\n318 format('\"\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" title \"',a,'\" ',a)\n! write(*,*)'SMP monovariant 5: ',xmonovariant,jj\n else\n write(21,319)monovariant,backslash\n319 format('\"\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" notitle ',a)\n endif\n endif\n elseif(lcolor(ii).eq.12) then\n! tie-line, if kk==2 and xtieline==jj add label\n if(kk.eq.1) then\n write(21,320)'lines ls',fcolor,' ',backslash\n xtieline=jj\n! write(*,*)'SMP xtieline 2: ',xtieline\n elseif(xtieline.ne.jj) then\n write(21,320)'lines ls',fcolor,' ',backslash\n else\n write(21,299)'lines',fcolor,trim(color(12)),backslash\n299 format('\"\" using 1:2 with ',a,' ls ',i2,&\n ' title \"',a,'\" ',a)\n! write(*,*)'SMP xtieline 5:',jj,xtieline\n endif\n else\n! normal line with no title\n! write(*,320)trim(linespoints),fcolor,backslash\n write(21,320)trim(linespoints),fcolor,&\n trim(piincrement),backslash\n endif\n!320 format('\"\" using 1:2 with ',a,' ls ',i2,' notitle ',a)\n320 format('\"\" using 1:2 with ',a,1x,i2,1x,a,' notitle ',a)\n else \n! we have a new line withou title\n if(fcolor.eq.11) then\n if(kk.eq.1) then\n! first time plotting a monovariant use thick lines\n write(21,320)'lines ls',monovariantborder,' ',backslash\n xmonovariant=jj\n! write(*,*)'SMP monovariant 3: ',xmonovariant\n else\n if(jj.eq.xmonovariant) then\n! this is the last monovariant, add title\n write(21,321)monovariant,&\n trim(color(lcolor(ii))),backslash\n321 format('\"\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" title \"',a,'\"',a)\n! write(*,*)'SMP monovariant 4: ',xmonovariant,jj\n else\n! not the last monovariant, notitle\n write(21,325)monovariant,backslash\n325 format('\"\" using 1:2 with filledcurves ',&\n 'fc \"#',a,'\" notitle ',a)\n endif\n endif\n elseif(fcolor.eq.12) then\n! this is a tie-line without title\n if(kk.eq.1) then\n! if kk=1 no not add title, just keep track of last tie-line\n write(21,320)'lines ls',fcolor,' ',backslash\n xtieline=jj\n! write(*,*)'SMP xtieline 3: ',xtieline\n else\n! if kk=2 add title if xtieline=jj\n if(jj.eq.xtieline) then\n write(21,331)'lines ls',fcolor,&\n trim(color(lcolor(ii))),backslash\n! write(*,*)'SMP xtieline 4:',jj,xtieline\n else\n write(21,320)'lines ls',fcolor,' ',backslash\n endif\n endif\n else\n! any normal line add title\n write(21,331)trim(linespoints),fcolor,&\n trim(piincrement),trim(color(lcolor(ii))),backslash\n endif\n naptitle=naptitle+1\n apptitles(naptitle)=lcolor(ii)\n!331 format('\"\" using 1:2 with ',a,' ls ',i2,' title \"',a,'\"',a)\n331 format('\"\" using 1:2 with ',a,1x,i2,1x,a,' title \"',a,'\"',a)\n done(lcolor(ii))=1\n endif cone\n endif\n enddo jjloop\n enddo kkloop\n! if we have an append file we must add the plotcommands in applines(1:nofapl)\n! we made sure a few lines above that there is a backslash at last line above\n if(appfil.gt.0) then\n! match the titles of all applines with those used above in lcolor\n! and make sure the line with the same title has the same color\n! note there is only one color for monovariants ... problem with lcolor ...\n! call ocappfixlabels(nofapl,applines,same,color,lcolor,nnv)\n call ocappfixlabels(nofapl,applines,same,color,apptitles,nnv)\n! replace the 'plot \"-\" ' by just '\"\" ' \n applines(1)='\"\" '//applines(1)(9:)\n! write(*,*)'from append file',nofapl,trim(applines(1))\n do ii=1,nofapl\n write(21,'(a)')trim(applines(ii))\n enddo\n endif\n! goto 500\n! we have to include the scaling factors graphopt%scalefact(1,2)\n xf=one; yf=one\n if(graphopt%scalefact(1).ne.one) xf=graphopt%scalefact(1)\n if(graphopt%scalefact(2).ne.one) yf=graphopt%scalefact(2)\n! write(*,*)'SMP2B x/y factors: ',xf,yf\n! loop for all line coordinates\n! sumpp=0\n do kk=1,2\n! again=sumpp\n foundinv=0\n sumpp=0\n do jj=1,same\n! handle monovariants, just one point, just once\n! the monovariants (not invariants) will be plotted twice ...\n if(sumpp+1.eq.lineends(jj)) then\n foundinv=foundinv+1\n sumpp=sumpp+1\n! write(*,*)'Assumed to be an monovariant!',foundinv,kk\n write(21,600)jj,lcolor(jj)\n600 format('# Line ',2i5,' representing a monovariant')\n write(21,549)xf*xval(1,sumpp),yf*yval(1,sumpp)\n write(21,549)xf*xval(2,sumpp),yf*yval(2,sumpp)\n write(21,549)xf*zval(1,foundinv),yf*zval(2,foundinv)\n write(21,549)xf*xval(1,sumpp),yf*yval(1,sumpp)\n! we are at the end of a line, write a blank line\n write(21,548)jj,trim(phaseline(jj))\n! write(21,548)jj\n548 format('e '//'# end of monovariant',i5,2x,a/)\n else\n! this is the beginning of a line to be plotted\n if(lcolor(jj).eq.12) then\n write(21,605)jj,lcolor(jj)\n605 format('# Line ',2i5,' representing tielines')\n else\n write(21,610)jj,lcolor(jj),trim(color(lcolor(jj)))\n610 format('# Line ',2i5,' representing phase: ',a)\n endif\n do while(sumpp.lt.lineends(jj))\n sumpp=sumpp+1\n write(21,549)xf*xval(kk,sumpp),yf*yval(kk,sumpp)\n!549 format(2e15.6,4i7)\n549 format(2(1pe16.6),4i7)\n! plotkod -101 means tieline\n! UNFINISHED: VALGRIND indicates plotkod(sumpp) is uninitiallized??\n if(plotkod(sumpp).eq.-101) write(21,552)\n552 format(1x)\n enddo\n! we are at the end of a line, write a blank line\n write(21,551)jj,trim(phaseline(jj))\n! write(21,551)jj\n551 format('e '//'# end of line',i5,2x,a/)\n endif\n enddo\n enddo\n!------------------------------------------------------------------------\n! finally copy the data from the append file, it should be correctly formatted\n if(appfil.gt.0) then\n ic=0\n1900 continue\n read(appfil,884,end=1910)appline\n884 format(a)\n ic=ic+1\n if(appline(1:12).eq.'pause mouse ') then\n write(*,*)'reading appendfile ends at \"puase mouse\"'\n goto 1910\n else\n write(21,884)trim(appline)\n goto 1900\n endif\n1910 continue\n write(*,*)'Appended ',ic,' data lines'\n close(appfil)\n appfil=0\n endif\n!------------------------------------------------------\n! if(pform(1:1).eq.' ') then\n if(graphopt%gnutermsel.eq.1) then\n! if not hardcopy pause gnuplot. Mouse means clicking in the graphics window\n! will close it. I would like to have an option to spawn the graphics window...\n! so it is kept while continuing the program.\n write(21,990)trim(graphopt%plotend)\n990 format(a)\n!990 format('pause mouse')\n!990 format('e'//'pause mouse')\n else\n! add pause mouse as comment\n write(21,991)\n991 format('# pause mouse')\n endif\n close(21)\n if(appfil.ne.0) close(appfil)\n appfil=0\n\n! write(21,565)\n!565 format('e'//'pause mouse'/)\n! close(21)\n!\n! gnuplotline='gnuplot ocgnu.plt '\n gnuplotline='gnuplot '//trim(pfc)//' & '\n! if gnuplot cannot be started with gnuplot give normal path ...\n! gnuplotline='\"c:\\program files\\gnuplot\\bin\\wgnuplot.exe\" '//pfc(1:kkk)//' '\n k3=len_trim(gnuplotline)+1\n write(*,*)'Gnuplot command line: ',trim(gnuplotline)\n! if(pform(1:1).ne.' ') then\n if(graphopt%gnutermsel.ne.1) then\n write(*,*)'Graphics output file: ',trim(pfh)\n endif\n if(lines_excluded.gt.0) write(kou,11)lines_excluded\n11 format('SMP Some calculated lines excluded from the plot',i5)\n! plotonwin set by compiler option, 1 means windows \n if(plotonwin.eq.1) then\n if(btest(graphopt%status,GRKEEP)) then\n! this is a TERNARY PLOT with 2 extensive axis\n! write(*,*)'executing command '//trim(gnuplotline(9:))\n! call system(gnuplotline(9:))\n write(*,*)'SMP2B executing Command: \"start /B '//trim(gnuplotline)//'\"'\n! WORKS WITH OCPLOT3B\n call execute_command_line('start /B '//trim(gnuplotline))\n! sleep 500 miliseconds\n call usleep(us)\n else\n write(*,*)'SMP2B executing command '//trim(gnuplotline)\n call execute_command_line(gnuplotline)\n! sleep 500 miliseconds\n call usleep(us)\n endif\n else\n! plot on non-windows system\n! how to implement GRKEEP?\n write(*,*)'SMP2B executing command '//trim(gnuplotline)\n call execute_command_line(gnuplotline)\n! sleep 500 miliseconds\n call usleep(us)\n endif\n!900 continue\n1000 continue\n return\n end subroutine ocplot3B\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine calc_diagram_point\n!\\begin{verbatim}\n subroutine calc_diagram_point(axarr,pltax,xxx,xxy,line,ceq)\n! calculates the equilibrium for axis coordinates xxx,xxy\n! to obtain the set of stable phases\n! axarr specifies calculation axis, \n! pltax plot axis\n! xxx and xxy are axis coordinates for calculating a point\n! line is a character where the stable phases at the point is returned\n! ceq is the current equilibrium, should be the default with axis conditions\n! ONLY COORDINATES FOR CALCULATION AXIS ALLOWED\n implicit none\n type(map_axis), dimension(*) :: axarr\n double precision xxx,xxy\n character line*(*),pltax(*)*(*)\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jax,nax,kk,jj,ic,k3\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svrrec\n double precision value\n character dummy*24\n!\n! write(*,*)'Not implemented yet'\n! goto 1000\n!\n! We should check if plotaxis are the same as those used for calculation!!! \n! x-axis\n dummy=' '\n if(xxx.lt.axarr(1)%axmin .or. xxx.gt.axarr(1)%axmax) then\n write(*,11)'X value outside axis limits',xxx,&\n axarr(1)%axmin,axarr(1)%axmax\n11 format(a,3(1pe14.5))\n gx%bmperr=4399; goto 1000\n endif\n call locate_condition(axarr(1)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! first argument 1 means to extract the value, 0 means to set the value\n call condition_value(0,pcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%active.ne.0) then\n! active=0 means condition is active\n pcond%active=0\n! we must indicate if T or P are now fixed ...\n! if(pcond%statev.eq.1) then\n! mapline%meqrec%tpindep(1)=.FALSE.\n! elseif(pcond%statev.eq.2) then\n! mapline%meqrec%tpindep(1)=.FALSE.\n! endif\n endif\n! y-axis\n if(xxy.lt.axarr(2)%axmin .or. xxy.gt.axarr(2)%axmax) then\n write(*,11)'Y value outside axis limits',xxy,&\n axarr(2)%axmin,axarr(2)%axmax\n gx%bmperr=4399; goto 1000\n endif\n call locate_condition(axarr(2)%seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call condition_value(0,pcond,xxy,ceq)\n if(gx%bmperr.ne.0) goto 1000\n if(pcond%active.ne.0) then\n! active=0 means condition is active\n pcond%active=0\n! we must indicate if T or P are now fixed ... ??\n! if(pcond%statev.eq.1) then\n! mapline%meqrec%tpindep(1)=.FALSE.\n! elseif(pcond%statev.eq.2) then\n! mapline%meqrec%tpindep(1)=.FALSE.\n! endif\n endif\n! calculate the equilibrium without global minimization\n! call list_conditions(kou,ceq)\n call calceq3(0,.FALSE.,ceq)!\n if(gx%bmperr.ne.0) then\n write(*,*)'Calculation failed'\n goto 1000\n endif\n! extract the names of the stable phases\n kk=1\n do jj=1,noph()\n do ic=1,noofcs(jj)\n k3=test_phase_status(jj,ic,value,ceq)\n if(k3.gt.0) then\n! this phase is stable or fix\n call get_phase_name(jj,ic,dummy)\n line(kk:)=dummy\n kk=len_trim(line)+2\n! write(*,*)'Stable phases ',trim(line)\n endif\n enddo\n enddo\n! replace _ with - in phase names\n100 continue\n kk=index(line,'_')\n if(kk.gt.0) then\n line(kk:kk)='-'\n goto 100\n endif\n1000 continue\n return\n end subroutine calc_diagram_point\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function abbr_phname_same\n!\\begin{verbatim}\n logical function abbr_phname_same(full,short)\n! return TRUE if short is a correct abbreviation of full\n! This is used in macro step4 to plot fractions in different composition sets\n implicit none\n character*(*) full,short\n!\\end{verbatim}\n logical same\n integer k1,k2\n character*1 ch1,ch2\n! write(*,*)'Comparing ',trim(full)//' : '//trim(short)\n same=.false.\n! unequal if full has no # or different index after\n k1=index(short,'#')\n if(k1.gt.0) then\n k2=index(full,'#')\n if(k2.le.0) then\n! full has no compset\n! if short has #1 then the full phase without # should be accepted\n! write(*,*)'full has no compset: ',short(k1+1:k1+1),k2\n if(short(k1+1:k1+1).eq.'1') then\n same=.true.\n goto 1000\n endif\n else\n! the character after # must be the same\n if(short(k1+1:k1+1).eq.full(k2+1:k2+1)) then\n same=.true.\n goto 1000\n endif\n endif\n endif\n! if short is without # then all compsets match\n if(compare_abbrev(short,full)) then\n same=.true.\n endif\n1000 continue\n! write(*,*)'Comparing ',trim(short)//' with '//trim(full),' is ',same\n abbr_phname_same=same\n return\n end function abbr_phname_same\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine get_plot_conditions\n!\\begin{verbatim}\n subroutine get_plot_conditions(text,ndx,axarr,ceq)\n! extracts the conditions from ceq and replaces those that are axis variables\n implicit none\n character text*(*)\n integer ndx\n type(map_axis), dimension(*) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer jj,seqz,ip,jp,kp\n character symbol*24\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svrrec,svr2\n logical ok1\n!\n! get all conditions\n call get_all_conditions(text,-1,ceq)\n! write(*,*)'PC1: ',trim(text),ndx\n replace: do jj=1,ndx\n! replace the conditions that are X or Y axis\n seqz=axarr(jj)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n svrrec=>pcond%statvar(1)\n symbol=' '\n ip=1\n call encode_state_variable(symbol,ip,svrrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n! write(*,*)'SMP2B debug: \"',trim(text),'\" \"',symbol(1:ip-1),'\"'\n jp=index(trim(text),symbol(1:ip-1))\n77 continue\n! strange bug because index does not find match with T as first condition\n if(jp.eq.0 .and. text(1:1).eq.symbol(1:1)) then\n jp=1\n! write(*,*)'SMP2B attempt to fix problem creates infinite loop?',jp\n endif\n if(jp.gt.0) then\n! minor error here when conditons are N(A)+N(B)=1 and N(B)=axis. One should\n! skip matches with N(A) or N(B), not preceeded by ' ' and followd by '='\n! write(*,*)'SMP2B: \"',trim(text),'\" ',jp\n ok1=.false.\n if(jp.eq.1) then\n ok1=.true.\n else\n! fortran can test conditions in any order,\n! if jp=1 one must not test text(jp-1:jp-1)\n if(jp.gt.1 .and. text(jp-1:jp-1).eq.' ') ok1=.true.\n endif\n if(ok1 .and. text(jp+ip-1:jp+ip-1).eq.'=') then\n seqz=jp+index(text(jp:),'=')-1\n ip=jp+index(text(jp:),' ')-1\n if(jj.eq.1) then\n text(seqz:)='=X, '//text(ip:)\n else\n text(seqz:)='=Y, '//text(ip:)\n endif\n else\n! search the text following\n! write(*,*)'PC2: \"',text(jp-1:jp-1),'\" \"',&\n! text(jp+ip-1:jp+ip-1),'\"'\n kp=jp+1\n jp=index(text(kp:),symbol(1:ip-1))\n if(jp.gt.0) jp=kp+jp-1\n goto 77\n endif\n else\n write(*,*)'SMP2B Cannot find: \"',symbol(1:ip-1),'\" in ',trim(text)\n endif\n enddo replace\n! if line too long (>200) divide in middle\n jj=len_trim(text)\n if(jj.gt.250) then\n! text 1:ip\n ip=jj/3\n call find_space_in_text(text,ip,10)\n text(ip+4:)=text(ip:)\n text(ip:ip+3)=' \\n '\n! maybe some character get lost ... no one will notice\n! text ip+4:2*ip+8\n jp=2*ip+4\n call find_space_in_text(text,jp,10)\n text(jp+4:)=text(jp:)\n text(jp:jp+3)=' \\n '\n! write(*,*)'Dividing condition text 3 parts',ip,jp,jj\n elseif(jj.gt.100) then\n! write(*,*)'Dividing condition text in the middle',jj\n jj=jj/2\n call find_space_in_text(text,jj,10)\n text(jj+4:)=text(jj:)\n text(jj:jj+3)=' \\n '\n endif\n1000 continue\n return\n end subroutine get_plot_conditions\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine find_space_in_text\n!\\begin{verbatim}\n subroutine find_space_in_text(text,jp,maxc)\n! moves jp max +/-maxc charactres to find a space (? or , or : or )\n! If none found do not change jp\n implicit none\n character text*(*)\n integer jp,maxc\n!\\end{verbatim}\n integer ap\n ap=jp\n add: do ap=jp,jp+maxc\n if(text(ap:ap).eq.' ') goto 900\n enddo add\n sub: do ap=jp-1,jp-maxc,-1\n if(text(ap:ap).eq.' ') goto 900\n enddo sub\n! no space found\n ap=jp\n900 continue\n! write(*,*)'SMP2B: ',text(jp-maxc:jp+maxc),jp,ap\n jp=ap\n return\n end subroutine find_space_in_text\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable double precision function get_axis_phase_value\n!\\begin{verbatim}\n double precision function get_axis_phase_value(phase,axis,axarr,ceq)\n! extacts the condition for one axis and if is something like X(A)\n! it changes to x(phase,A) and extracts and returns that value !!\n! if it is a potential like T it just returns its value\n implicit none\n character phase*(*)\n integer axis\n type(map_axis), dimension(*) :: axarr\n type(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n integer seqz,ip\n character symbol*64,dummy*64\n double precision value\n type(gtp_condition), pointer :: pcond\n type(gtp_state_variable), pointer :: svrrec,svr2\n!\n value=zero\n! find the condition for axis \"axis\"\n seqz=axarr(axis)%seqz\n call locate_condition(seqz,pcond,ceq)\n if(gx%bmperr.ne.0) goto 1000\n svrrec=>pcond%statvar(1)\n! write(*,*)'Value of axis',axis,' for phase ',trim(phase),svrrec%statevarid\n if(svrrec%statevarid.le.9) then\n! it is a potential, extract its current value\n symbol=' '\n ip=1\n call encode_state_variable(symbol,ip,svrrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n call get_state_var_value(symbol,value,dummy,ceq)\n elseif(svrrec%argtyp.eq.1) then\n! it is an extensive variable (%statevarid>=10) for a component such as X(A)\n! A smarter way is to modify svrrec to insert phase/compset index ...\n! edit the phase into the symbol\n symbol=' '\n ip=1\n call encode_state_variable(symbol,ip,svrrec,ceq)\n if(gx%bmperr.ne.0) goto 1000\n ip=index(symbol,'(')\n dummy=symbol(ip+1:)\n symbol(ip+1:)=trim(phase)//','\n ip=len_trim(symbol)\n symbol=symbol(1:ip)//dummy\n! write(*,*)'SMP2B value of: ',trim(symbol)\n! call get_stable_state_var_value(symbol,value,dummy,ceq)\n call get_state_var_value(symbol,value,dummy,ceq)\n if(gx%bmperr.ne.0) goto 1000\n else\n write(*,*)'Illegal axis type: ',svrrec%statevarid,svrrec%argtyp\n gx%bmperr=4399\n endif\n1000 continue\n! write(*,*)'SMP2B value of: ',trim(symbol),value\n get_axis_phase_value=value\n return\n end function get_axis_phase_value\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_stored_equilibria\n!\\begin{verbatim}\n subroutine list_stored_equilibria(kou,axarr,maptop)\n! list all nodes and lines from step/map\n! use amed to exclude/include lines\n! kou output unit\n! axarr array with axis records\n! maptop map node record\n integer kou\n type(map_node), pointer :: maptop\n type(map_axis), dimension(*) :: axarr\n!\\end{verbatim} %+\n type(map_ceqresults), pointer :: results\n type(map_node), pointer :: mapnode,localtop\n type(gtp_equilibrium_data), pointer :: thisceq\n type(gtp_condition), pointer :: pcond\n type(meq_setup), pointer :: lineeq\n integer kl,ll,jax,nax,jj,jk,phtupix\n double precision, dimension(:), allocatable :: axxx\n type(gtp_state_variable), pointer :: svrrec\n logical once\n character*100 phases\n!\n if(.not.associated(maptop)) then\n write(kou,*)'No stored equilibria'\n goto 1000\n endif\n if(associated(maptop%plotlink)) then\n write(*,*)'The plotlink is set !!! '\n endif\n results=>maptop%saveceq\n if(.not.associated(results)) then\n write(kou,*)'No stored equilibria'\n goto 900\n endif\n nax=maptop%number_ofaxis\n allocate(axxx(nax))\n write(kou,90)\n90 format('List of all stored equilibria')\n! if there has been several STEP/MAP there can be several localtop\n localtop=>maptop\n!\n! return here if there has been several step/map commands\n99 continue\n mapnode=>localtop\n! list all mapnodes for this step/map command\n100 continue\n! mapnode=>localtop\n write(kou,101)mapnode%seqx,mapnode%nodeceq%tpval(1),mapnode%noofstph,&\n mapnode%savednodeceq,mapnode%lines\n! mapnode%savednodeceq,mapnode%status,mapnode%lines\n101 format(' Mapnode: ',i3,' at T=',F10.2,', ',i2,' phases, ceq saved ',&\n i5,', exting lines: ',i2)\n do kl=1,mapnode%lines\n if(.not.associated(mapnode%linehead(kl)%end)) then\n if(mapnode%linehead(kl)%termerr.gt.0) then\n write(kou,105)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria,&\n mapnode%linehead(kl)%termerr\n105 format(' Line ',i3,', id: ',i3,' with ',i5,&\n ' equilibria ended with error: ',i6)\n else\n write(kou,110)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria\n110 format(' Line ',i3,', id: ',i3,' with ',i5,&\n ' equilibria ending at axis limit')\n endif\n else\n ll=mapnode%linehead(kl)%end%seqx\n write(kou,120)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria,ll\n120 format(' Line ',i3,', id: ',i3,' with ',i5,&\n ' equilibria ending at node ',i3)\n endif\n if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then\n write(*,*)'Line excluded'\n cycle\n endif\n ll=mapnode%linehead(kl)%first\n! write(*,*)'SMP2B allcrach 1: ',ll\n! BOS 191224 add phase names\n! tzero lines has no meqrec%phr allocated NOTE kl is K-EL not K-ETT\n! for tzero lines it is listed line 3 and 4 although there are only 2 ????\n if(ll.gt.0 .and. allocated(mapnode%linehead(kl)%meqrec%phr)) then\n! only if there is an link to a linehead\n lineeq=>mapnode%linehead(kl)%meqrec\n phases=' '\n jk=1\n do jj=1,lineeq%nstph\n! write(*,*)'SMP2B allcrach 2: ',jj,lineeq%stphl(jj),&\n! lineeq%phr(lineeq%stphl(jj))%phtupix\n phtupix=lineeq%phr(lineeq%stphl(jj))%phtupix\n if(jk.lt.72) then\n call get_phasetup_name(phtupix,phases(jk:))\n jk=len_trim(phases)+2\n else\n phases(jk:)=' ... more'\n endif\n enddo\n write(*,*)'Phases: ',trim(phases)\n! BOS 191224 end add phase names\n! write(*,*)'list first equilibrium ',ll\n! write(*,*)'axis: ',mapnode%number_ofaxis\n if(.not.allocated(results%savedceq)) then\n write(*,*)'Cannot find link to saved equilibria! '\n else\n once=.true.\n write(kou,140)\n140 format('Saved ceq link T X')\n ceqloop: do while(ll.gt.0)\n thisceq=>results%savedceq(ll)\n do jax=1,nax\n call locate_condition(axarr(jax)%seqz,pcond,thisceq)\n if(gx%bmperr.ne.0) goto 300\n svrrec=>pcond%statvar(1)\n call state_variable_val(svrrec,axxx(jax),thisceq)\n if(gx%bmperr.ne.0)then\n if(once) then\n write(*,*)' *** Error ',gx%bmperr,&\n ' reset, data may be missing'\n once=.false.\n endif\n gx%bmperr=0\n endif\n enddo\n write(kou,150)ll,thisceq%nexteq,thisceq%tpval(1),axxx\n150 format(2i9,f9.2,5(1pe13.5))\n ll=thisceq%nexteq\n enddo ceqloop\n endif\n endif\n300 continue\n if(gx%bmperr.ne.0) then\n write(*,*)' *** Error ',gx%bmperr,' reset, data maybe missing'\n gx%bmperr=0\n endif\n enddo\n! write(kou,160)mapnode%seqx,mapnode%previous%seqx\n160 format('Current node: ',i2,' followed by: ',i2)\n mapnode=>mapnode%previous\n! localtop=>localtop%previous\n if(.not.associated(mapnode,localtop)) goto 100\n! plotlink needed if there has been several step/map commands\n900 continue\n if(associated(localtop%plotlink)) then\n write(lut,910)\n910 format(/'Results from a previous step/map command,',&\n ' equilibrium numbers will overlap')\n localtop=>localtop%plotlink\n write(*,*)'Setting result link'\n results=>localtop%saveceq\n if(.not.associated(results)) then\n write(kou,*)'No stored equilibria'\n goto 900\n endif\n goto 99\n endif\n!\n write(kou,*)'That is all'\n1000 continue\n return\n end subroutine list_stored_equilibria\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine amend_stored_equilibria\n!\\begin{verbatim} %-\n subroutine amend_stored_equilibria(axarr,maptop)\n! allows amending inactive/acive status of all lines from step/map\n type(map_node), pointer :: maptop\n type(map_axis), dimension(*) :: axarr\n!\\end{verbatim}\n character cline*12,status*8,ch1*1,phline*78\n type(map_ceqresults), pointer :: results\n type(map_node), pointer :: mapnode,localtop,testnode\n type(gtp_equilibrium_data), pointer :: thisceq\n type(gtp_condition), pointer :: pcond\n integer kl,ll,jax,last,nax\n double precision, dimension(:), allocatable :: axxx\n type(gtp_state_variable), pointer :: svrrec\n logical all\n!\n if(.not.associated(maptop)) then\n write(kou,*)'No stored equilibria'\n goto 1000\n endif\n if(associated(maptop%plotlink)) then\n write(*,*)'There is more than one maptop record'\n endif\n localtop=>maptop\n! if(associated(localtop,maptop)) write(*,*)'maptop same as localtop' \n nax=localtop%number_ofaxis\n allocate(axxx(nax))\n write(kou,90)\n nullify(results)\n90 format('Amend all stored equilibria ... from several maptops')\n!\n! return here if %plotlink is not empty\n! each plotlink has its own results link to saveceq\n99 continue\n last=len(cline)\n call gparcdx('Only excluded? ',cline,last,1,ch1,'Y','?PLOT options')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n all=.FALSE.\n else\n all=.TRUE.\n endif\n! there can be lines associated with several maptops\n! but I have trouble finding them. They should be linked by plotlink\n mapnode=>localtop\n results=>mapnode%saveceq\n100 continue\n! mapnode=>maptop\n if(associated(localtop,mapnode)) write(*,*)'mapnode same as localtop' \n if(.not.associated(results)) then\n write(kou,*)'No stored equilibria'\n goto 900\n endif\n status=' '\n write(kou,102)mapnode%seqx,mapnode%nodeceq%tpval(1),&\n mapnode%noofstph,mapnode%savednodeceq\n102 format(' Mapnode: ',i5,' at T=',F10.2,' with ',i2,&\n ' stable phases, ceq saved in ',i5)\n write(*,*)'Number of exit lines: ',mapnode%lines\n lineloop: do kl=1,mapnode%lines\n if(mapnode%linehead(kl)%number_of_equilibria.eq.0) then\n write(*,*)'Skipping empty line >>>'\n cycle lineloop\n endif\n if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then\n status='EXCLUDED'\n else\n status='INCLUDED'\n endif\n call line_with_phases_withdgm0(phline,mapnode%linehead(kl)%lineceq)\n if(gx%bmperr.ne.0) then\n phline='Sorry cannot list stable phases'\n gx%bmperr=0\n endif\n if(.not.associated(mapnode%linehead(kl)%end)) then\n if(mapnode%linehead(kl)%termerr.gt.0) then\n write(kou,105)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria,&\n mapnode%linehead(kl)%termerr,status,trim(phline)\n105 format(' Line ',i3,', id: ',i3,' with ',i5,&\n ' equilibria ended with error: ',i6,2x,a/' with phases: ',a)\n else\n write(kou,110)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria,status,trim(phline)\n110 format(' Line ',i3,', id: ',i3,' with ',i5,&\n ' equilibria ending at axis limit.',2x,a/' with phases: ',a)\n endif\n else\n ll=mapnode%linehead(kl)%end%seqx\n write(kou,120)kl,mapnode%linehead(kl)%lineid,&\n mapnode%linehead(kl)%number_of_equilibria,ll,status,trim(phline)\n120 format(' Line ',i3,', id: ',i3,' with ',&\n i5,' equilibria ending at node ',i3,2x,a/' with phases: ',a)\n endif\n ll=mapnode%linehead(kl)%first\n! if deleted ask for Restore, else ask for Keep or Delete\n last=len(cline)\n if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then\n call gparcdx(' *** Include this line? ',cline,last,1,ch1,'N',&\n '?PLOT options')\n elseif(all) then\n call gparcdx('Exclude this line? ',cline,last,1,ch1,'N',&\n '?PLOT options')\n else\n cycle lineloop\n endif\n if(biglet(ch1).eq.'Y') then\n if(btest(mapnode%linehead(kl)%status,EXCLUDEDLINE)) then\n mapnode%linehead(kl)%status=&\n ibclr(mapnode%linehead(kl)%status,EXCLUDEDLINE)\n write(kou,*)'Line activated'\n else\n mapnode%linehead(kl)%status=&\n ibset(mapnode%linehead(kl)%status,EXCLUDEDLINE)\n write(kou,*)'Line inactivated'\n endif\n elseif(biglet(ch1).eq.'Q') then\n goto 1000\n endif\n enddo lineloop\n mapnode=>mapnode%previous\n if(.not.associated(mapnode,localtop)) then\n goto 100\n endif\n900 continue\n! plotlink needed if there has been several step/map commands\n if(associated(localtop%plotlink)) then\n write(lut,910)\n910 format(/'Results from a previous step/map command,',&\n ' equilibrium numbers will overlap')\n localtop=>localtop%plotlink\n goto 99\n endif\n write(kou,*)'That is all'\n1000 continue\n return\n end subroutine amend_stored_equilibria\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine list_csv_table\n!\\begin{verbatim} %\n subroutine list_csv(np,nrv,nlinesep,linesep,pltax,xax,anpax,anpdim,anp,lid,&\n phaseline,title,filename,version,encoded1)\n! list results from a STEP as an CSV (Comma Separated Values) table\n! called from ocplot2 when all values extraced\n! np number of regions\n! nrv total number of lines with calculated values\n! nlinesep number of lines for each region\n! linesep(j..nlinesep) is index of last line for region j\n! pltax are heading of table columns, each region separate headings\n! xax values on single value axis\n! anpax not used\n! anpdim first dimension of anp\n! anp values of axis with (possibly) multiple values\n! lid column headings for each region ?\n! phaseline ??\n! title of plot\n! filename output file\n! graphopt record\n! version of OC\n! encoded1 all conditions\n! \n! use ov\n integer np,nrv,nlinesep,anpax,anpdim\n integer linesep(*)\n character filename*(*),title*(*),version*(*),encoded1*(*)\n character pltax(*)*(*),phaseline(*)*(*),lid(*)*(*)\n double precision xax(*),anp(anpdim,*)\n! not needed?\n! character lid(*)*(*)\n!\\end{verbatim}\n integer jj,kk\n!\n! write(*,'(a,10i5)')'SMP2B: in list_csv',np,nrv,nlinesep,anpax,anpdim\n! write(*,'(a,a,a,i3,1pe12.4)')'SMP2B: plotfile: \"',trim(filename),'\"',&\n! len_trim(filename),rnone\n write(*,*)'SMP2B writing csv file: ',trim(filename)\n if(filename(1:1).ne.' ') then\n open(22,file=filename,access='sequential',status='unknown',err=1100)\n lut=22\n else\n lut=kou\n endif\n! header\n if(np.eq.1) then\n write(lut,100)trim(pltax(1)),trim(lid(np))\n elseif(np.le.100) then\n write(lut,101,advance='no')trim(pltax(1)),(trim(lid(jj)),jj=1,np-1)\n write(lut,102)trim(lid(np))\n else\n write(*,*)'Cannot tablulate when more than 100 variables ...'\n endif\n100 format('\"',a,'\", \"',a,'\"')\n101 format('\"',a,'\"',100(',\"',a,'\"'))\n102 format(a,'\"')\n! loop for lines\n do jj=1,nrv\n write(lut,200,advance='no')xax(jj)\n200 format(1PE13.5)\n201 format(',',1PE13.5)\n202 format(',')\n! loop for columns except first and last value \n do kk=1,np-1\n if(anp(kk,jj).ne.rnone) then\n write(lut,201,advance='no')anp(kk,jj)\n else\n write(lut,202,advance='no')\n endif\n enddo\n if(anp(np,jj).ne.rnone) then\n write(lut,201)anp(np,jj)\n else\n write(lut,202)\n endif\n enddo\n if(lut.ne.kou) close(lut)\n1000 continue\n return\n! failed open output file\n1100 continue\n write(*,*)'Cannot open file: ',trim(filename)\n goto 1000\n end subroutine list_csv\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine ocappfixlabels\n!\\begin{verbatim}\n subroutine ocappfixlabels(nofapl,applines,same,color,appcol,nnv)\n! check if there are the same labels in applines. They are normally phase\n! names and should be the same !! use the same color for the same phase!!\n! if we find a title matching we must change all lines with the same ls x\n! to the value of x in the new file !!\n! nofapl: number of lines to plot in appfile \n! applines: the plot command lines from appfile\n! same: number of lines to plot in the current calculation\n! color: the titles in the current calculation\n! appcol: the linestyle for color in the current calculation\n! clast: the last used linestyle in the current calculation\n implicit none\n integer nofapl,same,nnv\n character*(*) applines(nofapl),color(*)\n integer appcol(*)\n!\\end{verbatim}\n integer i1,j1,k1,nols,ip,jp,found,oldls,newls\n integer, parameter :: mofapl=100\n integer nyttls(nofapl)\n character endofline*(2),title*24\n integer changels(2,nofapl)\n! the line label is color(lcolor(jj)) ... suck. Use the index of color as nyls\n! write(*,*)'ocappfixlabels: ',nofapl,same,nnv\n! do j1=1,same\n! if(color(j1)(1:1).ne.' ') write(*,'(i3,2x,a,i4)')j1,trim(color(j1)),&\n! appcol(j1)\n! enddo\n! do i1=1,nofapl\n! write(*,'(i3,2x,a)')i1,trim(applines(i1))\n! enddo\n! we have to check if there are new phases in the appfile. They should\n! be given color/labels that start from nnv\n! unique for the appfile. They should be given colors nnv and higher!\n!\n! still problem for CHI with the bef-500-gibbs testfile\n!\n! The applines look like:\n! \"\" using 1:2 with filledcurves fc \"#EEFFCC\" title \"monovariant\",\\\n! \"\" using 1:2 with lines ls 4 title \"BCC-A2\",\\\n! \"\" using 1:2 with lines ls 12 title \"tie-line\",\\\n! \"\" using 1:2 with lines ls 4 notitle ,\\\n! each title (in color) is associated with a ls value (in lcolor)\n! if we find a matching title in applines change the ls value to lcolor\n! for all lines with the ls value\n! for titles in applines with no title in color use last free ls\n endofline=',\\'\n found=0\n newls=nnv\n loop1: do j1=1,nofapl\n if(j1.eq.nofapl) endofline=' '\n! check if the line has a title\n ip=index(applines(j1),' title ')\n if(ip.gt.0) then\n! write(*,*)' *** Found title: ',trim(applines(j1)),j1\n title=applines(j1)(ip+8:)\n jp=index(title,'\"')\n if(jp.eq.0) then\n write(*,*)'Missing \": ',trim(applines(j1)),j1\n stop\n else\n title(jp:)=' '\n endif\n if(trim(title).eq.'tie-line' .or.&\n trim(title).eq.'monovariant') then\n! titles \"tie-line\" and \"monovariant\" are just replaced by notitle\n applines(j1)(ip:)=' notitle'//endofline\n! write(*,*)'removed tie/mono: ',trim(applines(j1)),j1\n cycle loop1\n endif\n! compare with color(1..same)\n! write(*,*)'Comparing with old labels'\n loop2: do i1=1,same\n if(color(i1)(1:1).eq.' ') cycle loop2\n if(trim(color(i1)).eq.trim(title)) then\n! we have found the applines title in current labels\n! write(*,*)'Found title: ',trim(title)\n applines(j1)(ip:)=' notitle'//endofline\n! write(*,*)'removed: ',trim(applines(j1)),j1\n! we must also save the value after ' line ls ' to change other lines\n! \"\" using 1:2 with lines ls 4 title \"BCC-A2\",\\\n ip=index(applines(j1),' lines ls ')\n if(ip.gt.0) then\n jp=ip+9\n ip=ip+10\n call getint(applines(j1),jp,oldls)\n if(buperr.ne.0) then\n write(*,*)'No ls number: ',trim(applines(j1))\n stop\n endif\n found=found+1\n changels(1,found)=oldls\n changels(2,found)=i1\n write(applines(j1)(ip:ip+1),'(i2)')i1\n! write(*,69)'Changing ls: ',trim(applines(j1)),oldls,i1,found\n69 format(a,a,5i4)\n else\n write(*,*)'missing \"lines ls\" in: ',trim(applines(j1))\n stop\n endif\n cycle loop1\n endif\n! write(*,*)'No match: ',trim(title),' ',trim(color(i1)),i1,same\n enddo loop2\n! if we come here we have a new title in the appfiles,\n! that should be assigned newls\n ip=index(applines(j1),' lines ls ')+10\n if(ip.le.0) then\n write(*,*)'Old color in appfile: ',trim(applines(j1))\n stop\n else\n! reuse the same color for something else\n! changing like this created problems below ... try reuse old color\n! write(applines(j1)(ip:ip+1),'(i2)')same+1\n applines(j1)(ip:ip+1)='01'\n write(*,*)'New color in appfile: ',trim(applines(j1))\n endif\n else\n! this is a line without title but we may have to change number after \"line ls\"\n ip=index(applines(j1),' lines ls ')\n if(ip.gt.0) then\n! write(*,'(a,10(i4,i3))')'changels: ',&\n! (changels(1,k1),changels(2,k1),k1=1,found)\n jp=ip+9\n ip=ip+10\n call getint(applines(j1),jp,oldls)\n if(buperr.ne.0) then\n write(*,*)'Cannot find ls number: ',trim(applines(j1)),found\n stop\n endif\n! write(*,*)'Found ls number: ',oldls\n! ignore 11 and 12 as they are tie-lines or monovariant\n if(oldls.eq.11 .or. oldls.eq.12) cycle loop1\n! seach for replacement\n getls: do k1=1,found\n! if(changels(1,k1).ne.oldls) cycle getls\n if(changels(1,k1).eq.oldls) goto 100\n enddo getls\n! if k1>found then we have not found oldls\n if(k1.gt.found) then\n write(*,79)'Cannot find old ls: ',oldls,k1,found,j1,&\n trim(applines(j1))\n79 format(a,4i3,' in ',a)\n write(*,'(10(i2,i3))')(changels(1,k1),changels(2,k1),k1=1,found)\n! replace colow with 01\n ip=index(applines(j1),' lines ls ')\n applines(j1)(ip+10:ip+11)='01'\n! stop\n endif\n! write the new ls number in applines(j1)\n100 continue\n! write(applines(j1)(ip:ip+1),'(i2)')changels(2,k1)\n! line above must be wrong, changed to that below 2021.03.08/BoS, then removed \n! write(applines(j1)(ip+10:ip+11),'(i2)')changels(2,k1)\n! write(*,*)'Changed ls: ',trim(applines(j1))\n! else\n! write(*,*)'skipping: ',trim(applines(j1))\n endif\n endif\n enddo loop1\n! write(*,*)'New applines'\n! do j1=1,nofapl\n! write(*,*)j1,trim(applines(j1))\n! enddo\n1000 continue\n return\n end subroutine ocappfixlabels\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine stvarix \n!\\begin{verbatim}\n subroutine stvarix(statevar,phaseline,encoded,nix,ixpos)\n! extract the indices of corresponding wildcard state variables\n! For example X(*,O) replace \"*\" with phase names in phline\n! and search which index correspond to X(C1_MO2#2,O) in encoded ... suck\n! statevar: with ONE wildcard (for a phase)\n! phaseline: phase names separated by a space\n! encoded: state variables returned by get_many(...) separated by a space\n! nix: number of state variables in encoded\n! ixpos: integer array with corresponding index for values\n! NOTE is there is a # in the statevar then ALL values should be included\n implicit none\n integer nix,ixpos(*)\n character*(*) statevar, phaseline, encoded\n!\\end{verbatim}\n character sstring*48,phase*32,prefix*24,suffix*24,cha*1\n integer ip,jp,kp,lp,pix,vix\n! write(*,*)'stvarix: ',trim(statevar)\n! write(*,*)'phases: \"',trim(phaseline),'\"'\n! write(*,*)'encoded: \"',trim(encoded),'\"'\n! initiate ipos to zero\n! write(*,8)1,trim(statevar),len_trim(encoded),trim(encoded)\n!8 format('smp2B: ',i1,' searching for \"',a,'\" in encoded with length ',i5/a/)\n!\n ixpos(1:nix)=0\n ip=index(statevar,'*')\n! if no wildcard skip\n if(ip.le.0) goto 1000\n! debug check search string:\n! write(*,8)2,trim(statevar),len_trim(encoded),trim(encoded)\n prefix=statevar(1:ip-1)\n suffix=statevar(ip+1:)\n!\n ip=1\n jp=index(phaseline,' ')\n outside: do while(jp.gt.ip)\n! create search string with phase name replacing wildcard\n sstring=trim(prefix)//phaseline(ip:jp-1)//trim(suffix)\n! write(*,*)'Seach for: \"',trim(sstring),'\"',jp\n pix=0\n kp=1\n lp=index(encoded,' ')\n! write(*,*)'encoded item: ',trim(encoded(kp:lp-1)),kp,lp-1\n inside: do while(lp.gt.kp) \n pix=pix+1\n! write(*,*)'Same? ',trim(sstring),' and ',trim(encoded(kp:lp-1)),pix\n! read(*,10)cha\n10 format(a)\n if(trim(sstring).eq.trim(encoded(kp:lp-1))) then\n! vix=vix+1\n! it seems simpler to indicate for each possible value that it is relevent\n ixpos(pix)=1\n! than to return an array with the relevant values ...\n! ixpos(vix)=pix\n! write(*,*)'Found: ',trim(sstring),vix,ixpos(vix)\n! select next phase name\n ip=jp+1\n jp=jp+index(phaseline(jp+1:),' ')\n cycle outside\n endif\n! compare with next item in encoded\n kp=lp+1\n lp=lp+index(encoded(lp+1:),' ')\n! write(*,*)'Next encoded item: ',trim(encoded(kp:lp-1)),kp,lp-1\n! read(*,10)cha\n enddo inside\n write(*,*)'SMP2B: Cannot find: ',trim(sstring)\n gx%bmperr=4399; goto 1000\n enddo outside\n! write(*,70)nix,(ixpos(vix),vix=1,nix)\n70 format('SMP nix: ',i3,30i2)\n! write(*,*)'vix mm: ',vix,(ixpos(vix),vix=1,nix)\n1000 continue\n return\n end subroutine stvarix\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine hashtag_susphix \n!\\begin{verbatim}\n subroutine hashtag_susphix(statevar,phaseline,encoded,nix,ixpos,ceq)\n! replace # with non-suspended phase names in DGM(#)\n! statevar: DGM(#) wildcard (for a phase)\n! phaseline: phase names separated by a space\n! encoded: state variables returned by get_many(...) separated by a space\n! nix: number of state variables in encoded\n! ixpos: integer array with corresponding index for values\n implicit none\n integer nix,ixpos(*)\n character*(*) statevar, phaseline, encoded\n TYPE(gtp_equilibrium_data), pointer :: ceq\n!\\end{verbatim}\n character sstring*48,phase*32,prefix*24,suffix*24,cha*1\n integer ip,jp,kp,lp,pix,lpre,lenc,iph,ics\n double precision amfu\n! write(*,*)'SMP2B hastag_suspix: ',trim(statevar),nix\n! write(*,*)'phases: \"',trim(phaseline),'\"'\n! write(*,*)'encoded: \"',trim(encoded),'\"'\n! initiate ipos to zero\n! write(*,8)1,trim(statevar),len_trim(encoded),trim(encoded)\n!8 format('smp2B: ',i1,' searching for \"',a,'\" in encoded with length ',i5/a/)\n!\n lenc=len_trim(encoded)\n! write(*,*)'SMP2B in hashtag_susphix: ',trim(statevar)\n! write(*,'(a,a)')'SMP2B phaseline: ',trim(phaseline)\n! write(*,'(a,a)')'SMP2B encoded: ',lenc\n!\n ixpos(1:nix)=0\n ip=index(statevar,'#')\n! if no hashtag skip\n if(ip.le.0) goto 1000\n! if hashtag not followed ) or , it indicate a composition set, skip\n if(.not.(statevar(ip+1:ip+1).eq.')' .or. statevar(ip+1:ip+1).eq.',')) &\n goto 1000\n! debug check search string:\n! write(*,8)2,trim(statevar),len_trim(encoded),trim(encoded)\n prefix=statevar(1:ip-1)\n lpre=len_trim(prefix)\n! write(*,*)'SMP2B hastag1: \"',prefix(1:lpre),'\"',len(encoded)\n!\n ip=1\n pix=0\n ixpos(1:nix)=0\n! we can ignore phaseline and we skip all phases in encoded that are suspended\n do while(ip.lt.lenc)\n jp=index(encoded(ip:),prefix(1:lpre))\n kp=index(encoded(ip:),' ')\n phase=encoded(ip+jp+lpre-1:ip+kp-3)\n! write(*,'(a,a,a,3i5)')'SMP2B hashtag 2: \"',trim(phase),'\"',ip,jp,kp\n! update ip for next phase\n ip=ip+kp\n! write(*,*)'SMP2B rest: ',trim(encoded(ip:))\n! find phase number/set \n! call find_phase_by_name_exact(phase,iph,ics)\n call find_phase_by_name(phase,iph,ics)\n if(gx%bmperr.ne.0) then\n write(*,*)'SMP2B hashtag found nonexisting phase name: ',phase\n endif\n pix=pix+1\n if(test_phase_status(iph,ics,amfu,ceq).ge.PHDORM) then\n! this phase is not suspended, it should be included\n! it seems simpler to indicate for each possible value that it is relevent\n ixpos(pix)=1\n! than to return an array with the relevant values ...\n! write(*,*)'not suspended: ',trim(phase),pix,ixpos(pix)\n! else\n! write(*,*)'suspended: ',trim(phase)\n endif\n enddo\n1000 continue\n return\n end subroutine hashtag_susphix\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine replace_UWH\n!\\begin{verbatim}\n subroutine replace_uwh(text)\n! replaces underscore by a hyphen for texts used in GNUPLOT\n! replaces ampersand, &, by @\n implicit none\n character*(*) text\n!\\end{verbatim}\n integer jj\n! replace _ by - in lid\n jj=-1\n do while(jj.ne.0)\n! replace _ by - in lid because _ is interpreted as subscript (as LaTeX)\n if(jj.gt.0) text(jj:jj)='-'\n jj=index(text,'_')\n enddo\n jj=-1\n do while(jj.ne.0)\n! replace & by z in lid because & is treated strangely by GNUPLOT\n if(jj.gt.0) text(jj:jj)='%'\n jj=index(text,'&')\n enddo\n! write(*,*)'SMP2B text without \"_\": ',trim(text)\n return\n end subroutine replace_uwh\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n" }, { "path": "src/userif/pmon6.F90", "content": "!\nMODULE cmon1oc\n!\n! Copyright 2012-2025, Bo Sundman, France\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n! Contact persion: Bo.Sundman@gmail.com\n!\n!------------------------------------------------------------------\n!\n!*****************************\n! command line monitor for OC \n!*****************************\n!\n use ocsmp\n use liboceqplus\n! \n! parallel processing, set in gtp3.F90\n!$ use omp_lib\n!\n implicit none\n!\n! option record\n TYPE ocoptions\n! unit for listing, default is kou (screen)\n integer lut\n end TYPE ocoptions\n type(ocoptions) :: optionsset\n!\ncontains\n!\n subroutine oc_command_monitor(version,linkdate,narg,argline)\n! command monitor\n implicit none\n!\n! linkdat is date when program was linked\n! argline and narg are inline arguments\n character linkdate*(*),version*(*),argline(*)*(*)\n integer narg\n! various symbols and texts, version 6\n character :: ocprompt*8='--->OC6:'\n character name1*24,name2*24,name3*24,dummy*24,line*80,model*72,chshort*1\n integer, parameter :: ocmonversion=75\n! for the on-line help, at present turn off by default, if a HTML file set TRUE\n character*128 browser,latexfile,htmlfile,unformfile,xtdbdef\n logical :: htmlhelp=.FALSE.\n! logical :: htmlhelp=.TRUE.\n! element symbol and array of element symbols for database use\n character elsym*2,ellist(maxel)*2,elbase(maxel)*2,parael*2\n! more texts for various purposes\n character text*72,string*256,ch1*1,chz*1,selection*27,funstring*1024\n character axplot(2)*24,axplotdef(2)*24,quest*20\n! character longstring*2048,optres*40\n character longstring*5000,optres*40\n! measure calculate carefully\n double precision finish2,start2\n integer endoftime,startoftime\n! separate file names for remembering and providing a default\n character ocmfile*128,ocufile*128,tdbfile*128,xtdbfile*128\n character ocdfile*128,filename*128\n character zext*8,mqmqass*60\n! home for OC and default directory for databases\n! character ochome*64,ocbase*64, change suggested by Chunhui\n character ochome*128,ocbase*128\n! prefix and suffix for composition sets\n character prefix*4,suffix*4\n! element mass\n double precision mass\n! constituent fractions of a phase\n double precision, dimension(maxconst) :: yarr\n! stoichiometry of a specis and sublattice sites of a phase\n double precision, dimension(maxsubl) :: stoik\n! calculated vaules of a function (G, G.T, G.P, G.T.T; G.T.P and G.P.P)\n double precision val(6)\n! estimated chemical potentials after a grid minimization and TP for ref states\n double precision cmu(maxel),tpa(2)\n! the beginning of a sequential list of all ternary methods\n! cpu time measurements\n double precision ending,starting\n!>>>> has to be reorganized ------------------------------------\n! axis variables and limits\n! default values used for axis variables\n double precision dinc,dmin,dmax\n! graphics record for plot ranges, texts and defaults\n type(graphics_options) :: graphopt\n integer grunit\n! species for ternary extrapolation method\n character xspecies(3)*24,tkmode*6\n! path to start directory declared inside metlib!!\n! character macropath*128\n! plot texts\n! type(graphics_textlabel), allocatable, target :: textlabel\n type(graphics_textlabel), pointer :: textlabel\n type(graphics_textlabel), pointer :: labelp\n! axis data structures\n type(map_axis), dimension(5) :: axarr\n! if more than one start equilibrium these are linked using the ceq%next index\n! type(gtp_equilibrium_data), pointer :: starteq\n! type(starteq_lista), dimension(20) :: starteqs\n! for map results\n type(map_node), pointer :: maptop,mapnode,maptopsave,maptopcheck\n! type(map_line) :: mapline\n! seqxyz has initial values of seqx, seqy and seqz\n! integer noofaxis,noofstarteq,seqxyz(3)\n integer noofaxis,seqxyz(3)\n! csv file converion\n integer ioc,ip\n! this should be removed\n! TYPE(ssm_node), pointer :: resultlist\n! for paraequilibrium meqrec is needed also here\n TYPE(meq_setup), pointer :: meqrec\n TYPE(meq_setup), allocatable, target :: meqrec1\n!<<<<<<<--------------------------------------------------------------\n! used for element data and R*T\n double precision h298,s298,rgast\n! temporary reals\n double precision xxx,xxy,xxz,totam,cpham,xpara(2),gms\n! input data for grid minimizer\n double precision, dimension(maxel) :: xknown,aphl\n! arrays for grid minimization results\n integer, dimension(maxel) :: iphl,icsl,nyphl\n! selected kommand and subcommands\n integer kom,kom2,kom3,kom4\n! selected output mode for results and the default, list output unit lut\n integer listresopt,lrodef,lut,afo\n! integers used for elements, phases, composition sets, equilibria, defaults\n integer iel,iph,ics,ieq,idef,iph2,tupix(2),icond\n! for gradients in MU and interdiffusivities\n integer nend\n! for mqmqanend, a negative value needed att first call to mqmqa_species\n! it is declared in gt3_dd2.F90\n! integer :: mqmqanend=-100\n! dimension of mugrad for 16x16 matrix \n!CCI\n double precision, allocatable, dimension(:) :: mugrad,mobilities\n double precision, allocatable, dimension(:) :: nsites\n integer, allocatable, dimension(:) :: nkl\n integer nsub\n!CCI\n!-------------------\n! selection of minimizer and optimizer\n integer minimizer,optimizer\n! plot unit for experimental data used in enter many_equilibria\n integer :: plotdataunit(9)=0,plotunit0=0\n! temporary integer variables in loops etc\n integer i1,i2,j4,j5,j2,iax,threads,modelx,jquad\n! more temporary integers\n integer jp,kl,svss,language,last,leak,j3,tzcond,eetcond\n! and more temporary integers\n integer ll,lokcs,lokph,lokres,loksp,lrot,maxax\n! and more temporary integers\n integer mode,ndl,neqdef,noelx,nofc,nopl,nops,nv,nystat,times,fromeq\n! temporary matrix\n! double precision latpos(3,3)\n! used to call init_gtp for the NEW command\n integer intv(10)\n double precision dblv(10)\n! debugging mqmqma_data%const lines ... lines 5236 ff\n integer ik,ij,kp,s1,thiscon\n! ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij,\n! type(gtp_mqmqa_var), pointer :: mqmqavar\n type(gtp_phase_varres), pointer :: mqmqavar\n!-------------------\n! variables for lmdif\n! integer, parameter :: lwam=2500\n integer :: lwam=2500,nfev\n integer :: nopt1=100, mexp=0,nvcoeff=0,nopt,iflag,mexpdone=0,nvcoeffdone=0\n integer, allocatable, dimension(:) :: iwam\n double precision, allocatable, dimension(:) :: wam\n! tccovar is the covariance matrix used to calculate RSD as in Thermo-Calc\n double precision, allocatable, dimension(:,:) :: fjac,cov1,cormat,tccovar\n double precision :: optacc=1.0D-3\n logical :: updatemexp=.true.\n! saved parameters for analyze\n double precision, allocatable, dimension(:,:) :: savedcoeff\n double precision savesumerr,delta\n integer analyze,cormatix,nvcoeffsave,mexpsave,iz,jz,ztyp\n! this is least square error from using LMDIF\n! 1: previous value, 2 new value, 3 normalized error (divided by m-n)\n double precision err0(3)\n! occational segmentation fault when deallocating www ....\n! double precision, dimension(maxw) :: www\n! double precision, dimension(:), allocatable :: www\n double precision, dimension(:), allocatable :: errs\n double precision, dimension(:), allocatable :: coefs\n! external new_assessment_calfun\n! external calfun\n!-------------------\n! loop variable when entering constituents of a phase\n integer icon,flc\n! array with constituents in sublattices when entering a phase\n! only used for interactive entering the mqmqa_constituent\n character, dimension(25) :: const*24\n! This is for species in the mqmqa model which may contain commas \",\"\n character mqmqacon*24\n! mqmqa quadbonds\n double precision quadbonds(4)\n! for macro and logfile and repeating questions\n logical logok,stop_on_error,once,wildcard,twice,startupmacro,temporary\n logical listzero,maptopbug\n! default plot axis for some STEP command:\n! 1 for SEPARATE, 2 SCHEIL, 3 TZERO, 4 PARAEQUIL, 5 LIQUID_EET\n logical stepspecial(5)\n! fast elements for Scheil, max 3\n character*2 fast(3)\n! unit for logfile input, 0 means no logfile\n integer logfil\n! remember default for calculate phase\n integer defcp\n! for state variables as conditions\n integer istv\n double precision coeffs(10),textfontscale\n TYPE(gtp_state_variable), target :: stvrvar\n TYPE(gtp_state_variable), pointer :: stvr\n! TYPE(gtp_state_variable), dimension(10) :: stvarr\n TYPE(gtp_condition), pointer :: pcond,firstc\n! current equilibrium records\n TYPE(gtp_equilibrium_data), pointer :: ceq,neweq\n TYPE(gtp_phase_varres), pointer :: parres\n! addition record used for listing calculated values\n type(gtp_phase_add), pointer :: addrec\n!\n character actual_arg(2)*16\n! character cline*128,option*80,aline*128,plotfile*256,eqname*24\n character cline*256,option*80,aline*128,plotfile*256,eqname*24,aux*4\n! variable phase tuple\n type(gtp_phasetuple), pointer :: phtup\n! MQMQA asymmetry\n! character*3 new_asymmetry\n integer asymter,new_toop\n!CCI\n integer :: indexPrecond, indexSplitsolver, typeOfChange\n!CCI\n!----------------------------------------------------------------\n! here are all commands and subcommands\n! character (len=64), dimension(6) :: oplist\n integer, parameter :: ncbas=30,nclist=27,ncalc=18,ncent=21,ncread=9\n integer, parameter :: ncam1=18,ncset=27,ncadv=18,ncstat=6,ncdebug=12\n integer, parameter :: nselect=6,nlform=6,noptopt=9,mqmqacc=6,nsetbit=6\n integer, parameter :: ncamph=18,naddph=12,nclph=6,nccph=6,nrej=9,nsetph=6\n integer, parameter :: nsetphbits=15,ncsave=6,nplt=15,nstepop=9\n integer, parameter :: nplt2=18\n integer, parameter :: ninf=15\n! basic commands\n character (len=16), dimension(ncbas), parameter :: cbas=&\n ['AMEND ','CALCULATE ','SET ',&\n 'ENTER ','EXIT ','LIST ',&\n 'QUIT ','READ ','SAVE ',&\n 'HELP ','INFORMATION ','BACK ',&\n 'NEW ','MACRO ','ABOUT ',&\n 'DEBUG ','SELECT ','DELETE ',&\n 'STEP ','MAP ','PLOT ',&\n 'HPCALC ','FIN ','OPTIMIZE ',&\n 'SHOW ',' ',' ',&\n ' ',' ',' ']\n! in French\n! 'MODIFIEZ ','CALCULEZ ','REGLEZ ',&\n! 'ENTREZ ','EXIT ','AFFICHER ',&\n! 'QUIT ','LIRE ','SAUVGARDE ',&\n! 'AIDEZ ','INFORMATION ','RETURNEZ ',&\n! 'NOUVEAU ','MACRO ','ABOUT ',&\n! 'DEBUG ','SELECTIONEZ ','EFFACEZ ',&\n! 'STEP ','MAP ','DESSINEZ ',&\n! 'HPCALC ','FIN ',' ']\n! NOTE a command line can contain options preceded by /\n! for example \"list /out=myfile.dat all_data\" or\n!-------------------\n! subcommands to LIST\n character (len=16), dimension(nclist) :: clist=&\n ['DATA ','SHORT ','PHASE ',&\n 'STATE_VARIABLES ','BIBLIOGRAPHY ','MODEL_PARAM_ID ',&\n 'AXIS ','TPFUN_SYMBOLS ','QUIT ',&\n 'PARAMETER ','EQUILIBRIA ','RESULTS ',&\n 'CONDITIONS ','SYMBOLS ','LINE_EQUILIBRIA ',&\n 'OPTIMIZATION ','MODEL_PARAM_VAL ','ERROR_MESSAGE ',&\n 'ACTIVE_EQUILIBR ','ELEMENTS ','EXCELL_CSV_FILE ',&\n 'MQMQA_SPECIAL ','ESTIMAT_ACCURACY','WORKING_DIRECTOR',&\n ' ',' ',' ']\n!-------------------\n! subsubcommands to LIST DATA\n character (len=16), dimension(nlform) :: llform=&\n ['SCREEN ',' ','MACRO ',&\n ' ',' ',' ']\n!-------------------\n! subsubcommands to LIST PHASE\n character (len=16), dimension(nclph) :: clph=&\n ['DATA ','CONSTITUTION ','MODEL ',&\n ' ',' ',' ']\n!-------------------\n! subsubcommands to LIST OPTIMIZE results\n character (len=16), dimension(noptopt) :: optopt=&\n ['SHORT ','LONG ','COEFFICIENTS ',&\n 'GRAPHICS ','DEBUG ','MACRO ',&\n 'EXPERIMENTS ','CORRELATION_MTRX','TC_RSD ']\n!-------------------\n! subsubcommands to LIST MQMQA_SPECIALS\n character (len=16), dimension(mqmqacc) :: mqmqalist=&\n ['QUADS ','ASYMMETRIES ','DEBUG ',&\n 'EXCESS ','AMEND_VARKAPPA ',' ']\n!------------------- subcommands to CALCULATE\n character (len=16), dimension(ncalc) :: ccalc=&\n ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',&\n 'TRANSITION ','QUIT ','GLOBAL_GRIDMIN ',&\n 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA ',&\n 'WITH_CHECK_AFTER','TZERO_POINT ','CAREFULLY ',&\n 'ONLY_GRIDMIN ','BOSSES_METHOD ','PARAEQUILIBRIUM ',&\n 'LIQUID_EET ',' ',' ']\n!-------------------\n! subcommands to CALCULATE PHASE\n character (len=16), dimension(nccph) :: ccph=&\n ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES ',&\n 'CONSTITUTION_ADJ','DIFFUSION_COEFF ','QUIT ']\n!-------------------\n! subcommands to ENTER\n character (len=16), dimension(ncent) :: center=&\n ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',&\n 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',&\n 'CONSTITUTION ','EXPERIMENT ','QUIT ',&\n 'EQUILIBRIUM ','SYMBOL ','OPTIMIZE_COEFF ',&\n 'COPY_OF_EQUILIB ','COMMENT ','MANY_EQUILIBRIA ',&\n 'MATERIAL ','PLOT_DATA ','GNUPLOT_TERMINAL',&\n ' ',' ',' ']\n!-------------------\n! subcommands to READ\n character (len=16), dimension(ncread) :: cread=&\n ['UNFORMATTED ','TDB ','QUIT ',&\n 'DIRECT ','XTDB ','SELECTED_PHASES ',&\n 'ENCRYPTED ',' ',' ']\n!-------------------\n! subcommands to SAVE\n! note SAVE TDB, MACRO, LATEX part of LIST DATA !!\n character (len=16), dimension(ncsave) :: csave=&\n ['TDB ',' ','QUIT ',&\n 'DIRECT ','UNFORMATTED ','XTDB ']\n!-------------------\n! subcommands to AMEND first level\n! many of these should be subcommands to PHASE\n character (len=16), dimension(ncam1) :: cam1=&\n ['SYMBOL ','ELEMENT ','SPECIES ',&\n 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',&\n 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',&\n 'COMPONENTS ','GENERAL ','ASSESSMENT_RESLT',&\n 'OPTIMIZING_COEFS','EQUILIBRIUM ','REDUNDANT_SETS ',&\n 'LINES ','START_CONSTIT ',' ']\n!-------------------\n! subsubcommands to AMEND PHASE\n! the UNIQUAC model specified when entering the phase\n character (len=16), dimension(ncamph) :: camph=&\n ['ADDITION ','COMPOSITION_SET ','DISORDERED_FRACS',&\n ' ','DIFFUSION ','DEFAULT_CONSTIT ',&\n 'TERNARY_EXTRAPOL','FCC_PERMUTATIONS','BCC_PERMUTATIONS',&\n 'REMOVE_COMPSETS ','ASYMMETRIES ','AQUEUS_MODEL ',&\n 'QUASICHEM_MODEL ','FCC_CVM_TETRAHDR',' ',&\n ' ',' ','QUIT ']\n!-------------------\n! subsubsubcommands to PHASE ADDITION\n character (len=16), dimension(naddph) :: caddph=&\n ['MAGNETIC_CONTRIB','QUIT ','GADDITION ',&\n 'TWOSTATE_LIQUID ','SCHOTTKY_ANOMALY','VOLUME_MODEL1 ',&\n 'LOWT_CP_MODEL ','LIQUID_2STATE ',' ',&\n 'ELASTIC_MODEL_1 ',' ','SMOOTH_CP_STEP ']\n!-------------------\n! subcommands to SET\n character (len=16), dimension(ncset) :: cset=&\n ['CONDITION ','STATUS ','ADVANCED ',&\n ' ','INTERACTIVE ','REFERENCE_STATE ',&\n 'QUIT ','ECHO ','PHASE ',&\n 'UNITS ','LOG_FILE ','WEIGHT ',&\n 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',&\n 'VERBOSE ','AS_START_EQUILIB','BIT ',&\n 'OPTCOEFF_VARIABL','OPTCOEFF_SCALED ','LMDIF_ACCURACY ',&\n 'RANGE_EXPER_EQU ','OPTCOEFF_FIXED ','SYSTEM_VARIABLE ',&\n 'INITIAL_T_AND_P ','LINEAR_SYSTEM ','GRID_GENERATOR ']\n! subsubcommands to SET STATUS\n character (len=16), dimension(ncstat) :: cstatus=&\n ['ELEMENT ','SPECIES ','PHASE ',&\n 'CONSTITUENT ',' ',' ']\n! 123456789.123456---123456789.123456---123456789.123456\n! subsubcommands to SET ADVANCED\n character (len=16), dimension(ncadv) :: cadv=&\n ['EQUILIB_TRANSFER','QUIT ','SYMBOL ',&\n 'GRID_DENSITY ','SMALL_GRID_ONOFF','MAP_SPECIALS ',&\n 'GLOBAL_MIN_ONOFF','OPEN_POPUP_OFF ','WORKING_DIRECTRY',&\n 'HELP_POPUP_OFF ','EEC_METHOD ','LEVEL ',&\n 'NO_MACRO_STOP ','PROTECTION ','IGNORE_MACRO_ERR',&\n 'XTDB_DEFAULTS ',' ',' ']\n! 123456789.123456---123456789.123456---123456789.123456\n! subsubcommands to SET BITS\n character (len=16), dimension(nsetbit) :: csetbit=&\n ['EQUILIBRIUM ','GLOBAL ','PHASE ',&\n ' ',' ',' ']\n! 123456789.123456---123456789.123456---123456789.123456\n! subsubcommands to SET PHASE\n character (len=16), dimension(nsetph) :: csetph=&\n ['QUIT ','STATUS ','DEFAULT_CONSTIT ',&\n 'AMOUNT ','BITS ','CONSTITUTION ']\n! 123456789.123456---123456789.123456---123456789.123456\n!-------------------\n! subsubsubcommands to SET PHASE BITS\n! Some bits can still be set here by numbers but the text is no longer shown\n! most bits are set by AMEND PHASE command\n character (len=16), dimension(nsetphbits) :: csetphbits=&\n [' ',' ',' ',&\n ' ',' ',' ',&\n ' ','NO_AUTO_COMP_SET','QUIT ',&\n 'EXTRA_DENSE_GRID',' ',' ',&\n ' ',' ',' ']\n\n! 123456789.123456---123456789.123456---123456789.123456\n!-------------------\n! subcommands to STEP\n character (len=16), dimension(nstepop) :: cstepop=&\n ['NORMAL ','SEPARATE ','QUIT ',&\n 'CONDITIONAL ','TZERO ','LIQUID_EET ',&\n 'SCHEIL_GULLIVER ','PARAEQUILIBRIUM ','FAST ']\n! 123456789.123456---123456789.123456---123456789.123456\n!-------------------\n! subcommands to DEBUG\n character (len=16), dimension(ncdebug) :: cdebug=&\n ['FREE_LISTS ','STOP_ON_ERROR ','PARAMETER_STRUCT',&\n 'SPECIES ','TPFUN ','BROWSER ',&\n 'TRACE ','SYMBOL_VALUE ','MAP_STARTPOINTS ',&\n 'GRID ','TERNARY_MQMQA ','BOMBMATTA ']\n!-------------------\n! subcommands to SELECT, maybe some should be CUSTOMMIZE ??\n character (len=16), dimension(nselect) :: cselect=&\n ['EQUILIBRIUM ','MINIMIZER ','GRAPHICS ',&\n 'LANGUAGE ','OPTIMIZER ',' ']\n!-------------------\n! subcommands to DELETE\n character (len=16), dimension(nrej) :: crej=&\n ['ELEMENTS ','SPECIES ','PHASE ',&\n 'QUIT ','COMPOSITION_SET ','EQUILIBRIUM ',&\n 'STEP_MAP_RESULTS',' ',' ']\n!-------------------\n! subcommands to INFORMATION\n character (len=16), dimension(ninf) :: cinf=&\n ['ELEMENTS ','SPECIES ','PHASES ',&\n 'QUIT_INFO ','COMPOSITION_SET ','EQUILIBRIUM ',&\n 'HELP_SYSTEM ','CONDITIONS ','DATABASES ',&\n 'CHANGES ','PHASE_DIAGRAM ','PROPERTY_DIAGRAM',&\n 'STATE_VARIABLES ',' ',' ']\n!-------------------\n! subcommands to PLOT OPTIONS/ GRAPHICS OPTIONS\n! Now there are two levels (using EXTRA) but still a mess\n character (len=16), dimension(nplt) :: cplot=&\n ['RENDER ','SCALE_RANGES ','FONT ',&\n 'AXIS_LABELS ',' ','TITLE ',&\n 'GRAPHICS_FORMAT ','OUTPUT_FILE ',' ',&\n 'QUIT ','POSITION_OF_KEYS','APPEND ',&\n 'TEXT_LABEL ',' ','EXTRA ']\n! subsubcommands to PLOT EXTRA\n character (len=16), dimension(nplt2) :: cplot2=&\n ['COLOR ','LOGSCALE ','RATIOS_XY ',&\n 'LINE_TYPE ','MANIPULATE_LINES','PAUSE_OPTION ',&\n 'LOWER_LEFT_TEXT ','TIE_LINES ','GIBBS_TRIANGLE ',&\n 'QUIT ','SPAWN ','NO_HEADING ',&\n 'AXIS_FACTOR ','GRID ',' ',&\n ' ',' ',' ']\n!-------------------\n! 123456789.123456---123456789.123456---123456789.123456\n! minimizers\n character (len=16), dimension(2) :: minimizers=&\n ['LUKAS_HILLERT ','SUNDMAN_HILLERT ']\n!------------------------------------------------------------------------\n! optimizers\n character (len=16), dimension(2) :: optimizers=&\n ['LMDIF ','VA05AD ']\n!------------------------------------------------------------------------\n!\n! before we come here gtp_init has been called in the main program\n! some defaults\n! write(*,*)'Start of OC command line monitor'\n language=1\n logfil=0\n defcp=1\n seqxyz=0\n! ceq has no value here!!! Moved this to gtp3A: initialize_global_parameters\n! ceq%gmindif=default_mingridmin\n! defaults for several step special\n stepspecial=.FALSE.\n! save the working directory (where OC is started?)\n call getcwd(workingdir)\n! write(*,*)'Working directory is: ',trim(workingdir)\n! this is used to save the path to any directory where a macro is started\n! macropath=' '\n! initiate command line history\n myhistory%hpos=0\n! defaults for optimizer, number of variable coefficients\n nvcoeff=0\n! present the software\n write(kou,10)version,trim(linkdate),ocmonversion,gtpversion,hmsversion,&\n smpversion\n10 format(/'Open Calphad (OC) software version ',a,', linked ',a,/&\n 'with command line monitor version ',i3//&\n 'This program is available with a GNU General Public License.'/&\n 'either version 2 of the License, or any later version.'/&\n 'It includes the General Thermodynamic Package, version ',A,','/&\n \"Hillert's equilibrium calculation algorithm version \",A,','/&\n 'step/map/plot software version ',A,' using GNUPLOT 5.2 graphics.'/&\n 'Numerical routines are extracted from LAPACK and BLAS and'/&\n 'the assessment procedure uses LMDIF from ANL.'/)\n!\n! lines starting with !$ will be included when compiling with -fopenmp\n!$ write(kou,11)\n11 format('Linked with OpenMp for parallel execution')\n!\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! Default gnuterminals, edit these as they may not be same on your systems\n graphopt%gnutermid=' '\n! graphopt%status=0 initiated to zero\n! Screen is terminal 1\n graphopt%gnutermid(1)='SCREEN '\n! default font, not reinitiated if set explicitly\n graphopt%font='Arial '\n! MAX 80 characters to set terminal .... HERE FONT AND SIZE IS SET\n! test compilation ...\n!\n#ifdef aqplt\n! Aqua plot screen on some Mac systems\n graphopt%gnuterminal(1)='aqua size 600,500 font \"'//&\n trim(graphopt%font)//',16\"'\n! it should be #elif not #elseif .... suck\n#elif qtplt\n! Qt plot screen on some LINUX systems\n graphopt%gnuterminal(1)='qt size 600,500 font \"'//&\n trim(graphopt%font)//',16\"'\n! graphopt%gnuterminal(1)='qt size 600,500 font \"arial,16\"'\n#elif x11\n! x11 plot screen on other LINUX systems \n graphopt%gnuterminal(1)='x11 size 840,700 font \"'//&\n trim(graphopt%font)//',16\"'\n! graphopt%gnuterminal(1)='x11 size 840,700 font \"arial,16\"'\n#else\n! wxt default plot screen (used on most Window systems)\n! graphopt%gnuterminal(1)='wxt size 940,700 font \"'//&\n graphopt%gnuterminal(1)='wxt size 840,700 font \"'//&\n trim(graphopt%font)//',16\"'\n! write(*,*)'pmon: \"',trim(graphopt%gnuterminal(1)),'\"'\n! graphopt%gnuterminal(1)='wxt size 840,700 font \"arial,16\"'\n! This uses 'start /B ' in front of plot command to spawn plot windows\n! graphopt%status=ibset(graphopt%status,GRKEEP)\n! graphopt%gnuterminal(1)='wxt size 900,600 font \"arial,16\"'\n#endif\n graphopt%filext(1)=' '\n! NOTE THAT THE SCREEN PLOT WINDOW ALLOWS YOU TO SELECT FILE OUTPUT\n! Postscript\n i1=2\n graphopt%gnutermid(i1)='PS '\n graphopt%gnuterminal(i1)='postscript color solid fontscale 1.2'\n graphopt%filext(i1)='ps '\n! Adobe Portable Document Format (PDF)\n i1=3\n graphopt%gnutermid(i1)='PDF '\n!--------- #ifdef qtplt\n! On LINUX ??\n! graphopt%gnuterminal(i1)='pdfcairo '\n!----------#else\n! NOTE size is in inch\n! graphopt%gnuterminal(i1)='pdf color solid size 6,5 enhanced font \"arial,16\"'\n graphopt%gnuterminal(i1)='pdf color solid size 6,5 enhanced font \"'//&\n trim(graphopt%font)//',16\"'\n!----------#endif\n graphopt%filext(i1)='pdf '\n! Graphics Interchange Format (GIF)\n i1=4\n graphopt%gnutermid(i1)='GIF '\n graphopt%gnuterminal(i1)='gif enhanced fontscale 0.7'\n graphopt%filext(i1)='gif '\n graphopt%gnutermax=i1\n! Portable graphics format (PNG)\n i1=5\n graphopt%gnutermid(i1)='PNG '\n graphopt%gnuterminal(i1)='png enhanced fontscale 0.7'\n graphopt%filext(i1)='png '\n graphopt%gnutermax=i1\n! by default spawn plots\n graphopt%status=ibset(graphopt%status,GRKEEP)\n! if winhlp set also GRKEEP\n#ifdef winhlp \n! write(*,*)'UI: Setting windows bit 2: ',GRKEEP\n! This uses 'start /B ' in front of plot command to spawn plot windows\n graphopt%status=ibset(graphopt%status,GRKEEP)\n#endif\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! jump here after NEW to reinitiallize all local variables also\n20 continue\n! clear file names\n ocmfile=' '; ocufile=' '; tdbfile=' '; xtdbfile=' '\n! clear some other variables\n dummy=' '; name1=' '; name2=' '; name3=' '\n tzcond=0\n eetcond=0\n parael=' '\n! initiating the equence of mqmqaquads, declared in models/gtp3_dd2.F90\n mqmqanend=-100\n! initiallize ploted, it is not done in reset_plotoptions\n graphopt%plotend='pause mouse'\n! reset plot ranges and their defaults\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n! default list unit\n optionsset%lut=kou\n lut=kou\n! default for list short\n chshort='A'\n! set default minimizer, 2 is matsmin, 1 does not work ...\n minimizer=2\n! set default optimimzer, 1 is LMDIF, 2 is VA05AD (no longer available)\n optimizer=1\n! by default no stop on error and no logfile\n stop_on_error=.false.\n logfil=0\n buperr=0\n! initiate the limit on number of equilibria saved during step/map\n totalsavedceq=0\n!\n! nopenpopup is declared in metlib3.F90 and dis/allow open popup windows\n! it is initiated to FALSE, if user change it will not be reinitiated here\n! nopenpopup=.FALSE.\n! in init_gtp the first equilibrium record is created and \n! firsteq has been set to that\n!\n!25 continue\n! default values of T and P. NOTE these are not set as conditions\n firsteq%tpval(1)=1.0D3\n firsteq%tpval(2)=1.0D5\n!\n! default list result option\n lrodef=1\n! default axis limits set to be 0 and 1\n maxax=5\n noofaxis=0\n! state variable for plot axis (only 2)\n do j4=1,2\n axplotdef(j4)=' '\n enddo\n! remove any results from step and map\n nullify(maptop)\n nullify(mapnode)\n nullify(maptopsave)\n! entered start equilibria\n nullify(starteqs(1)%p1)\n noofstarteq=0\n! set default fractions when entering composition\n xknown=one\n! set default equilibrium to 1 and current equilibrium (CEQ) to firsteq\n neqdef=1\n ceq=>firsteq\n! >>> we should remove all equilibria !! ??\n! here one should read a user initialisation file as a macro\n! file can be at current directory or at home directory\n! initiate on-line help\n! local environment: please create OCHOME as an environment variable\n ochome=' '\n call get_environment_variable('OCHOME ',ochome)\n startupmacro=.FALSE.\n! if help is not set then set these filenames as blanks\n browser=' '\n latexfile=' '\n htmlfile=' '\n#ifdef winhlp\n! BROWSER FOR WINDOWS\n! browser='C:\\PROGRA~1\\INTERN~1\\iexplore.exe '\n browser='C:\\\"Program Files\\Mozilla Firefox\"\\firefox.exe '\n#elif lixhlp\n! BROWSER FOR LINUX\n browser='/usr/bin/firefox '\n! browser='firefox '\n#elif machlp\n! BROWSER FOR MAC\n browser='/Applications/Firefox.app/Contents/MacOS/firefox '\n! browser='firefox '\n#endif\n noochome: if(ochome(1:1).eq.' ') then\n! there is no OCHOME environment variable, maybe a local ochelp.html?\n inquire(file='ochelp.html ',exist=logok)\n if(.not.logok) then\n write(*,*)'Warning, no environment variable OCHOME and no help file'\n htmlfile=' '\n htmlhelp=.FALSE.\n else\n write(*,*)'Warning, no environment variable OCHOME but local help file'\n htmlfile='ochelp.html'\n htmlhelp=.TRUE.\n endif\n call init_help(browser,htmlfile)\n else\n! there is a OCHOME environment variable\n! both LINUX and WINDOWS accept / as separator between directory and file names\n write(*,*)'Found OC home directory (OCHOME): ',trim(ochome)\n#ifdef winhlp\n! HTML FILE FOR WINDOWS\n! normal tex/html help files\n htmlfile=trim(OCHOME)//'\\'//'ochelp.html'\n#elif lixhlp\n! HTML FILE FOR LINUX\n htmlfile=trim(OCHOME)//'/'//'ochelp.html'\n#elif machlp\n! HTML FILE FOR MAC\n htmlfile=trim(OCHOME)//'/'//'ochelp.html'\n#endif\n call init_help(browser,htmlfile)\n if(.not.ochelp%htmlhelp) then\n write(kou,*)'Warning, no file \"ochelp.html\" at OCHOME or no browser'\n write(kou,*)trim(browser)\n write(kou,*)trim(htmlfile)\n htmlhelp=.FALSE.\n else\n write(kou,*)'Online help by '//trim(browser)//&\n ' and ochelp.html'\n endif\n! default directory for databases\n ocbase=trim(ochome)//'/databases'\n cline=trim(ochome)//'/start.OCM '\n inquire(file=cline,exist=logok)\n if(logok) then\n write(*,*)'Reading your startup macro: ',trim(cline)\n last=0\n! This just open the file and sets input unit to file\n call macbeg(cline,last,logok)\n startupmacro=.TRUE.\n endif\n endif noochome\n! initiate XML defaults\n lowTdef='298.15 '; hightdef='6000 '; bibrefdef='U.N. Known';\n eldef='VA /-'; unary1991=.TRUE.; includemodels=.FALSE.\n! running a initial macro file\n write(*,*)'Working directory is: ',trim(workingdir)\n!\n! finished initiallization\n!\n!\n!============================================================\n! return here for next command\n100 continue\n if(gx%bmperr.ne.0) goto 990\n if(buperr.ne.0) goto 990\n! turn off any options set\n call ocmon_reset_options(optionsset)\n! initiate command level for help routines\n call helplevel1('Initiate help level for OC')\n! handling of inline arguments ONCE\n if(.not.startupmacro .and. narg.gt.0) then\n! at present accept only one argument assumed to be a macro file name\n narg=0\n cline=argline(1)\n last=0\n! if(cline(1:1).eq.'<') then\n! write(*,*)'OC reads can start a macro from the command line'\n! else\n call macbeg(cline,last,logok)\n! macropath=string\n! endif\n endif\n! write(*,*)'----------TOP LEVEL COMMAND INPUT'\n! read the command line with gparc to have output on logfile\n! NOTE read from macro file if set.\n last=len(aline)\n aline=' '\n cline=' '\n call gparcx(ocprompt,aline,last,5,cline,' ','?TOPHLP')\n j4=0\n! write(*,*)'Back from gparcx 1: \"',trim(cline),'\"',j4,last\n if(len_trim(cline).gt.80) then\n write(kou,101)\n101 format(' *** Warning: long input lines may be truncated',&\n ' and cause errors')\n endif\n! with empty line just prompt again, j4 incremented by eolch\n if(eolch(cline,j4)) goto 100\n! with macro command prefix character just prompt again\n if(cline(j4:j4).eq.'@') goto 100\n! with the new help facilities \"tophlp\" is difficult ...\n! write(*,*)'Back from gparcx 2: \"',trim(cline),'\"',j4\n if(cline(j4:j4+1).eq.'? ') then\n! just provide the menu as help\n j4=0\n call q3helpx(cline,j4,cbas,ncbas)\n goto 100\n endif\n! Now finally detect the command\n kom=ncomp(cline,cbas,ncbas,last)\n! write(*,*)'Here if \"??\"',kom,last\n if(kom.le.0) then\n if(kom.lt.0) then\n write(kou,*)'Ambiguous command, available commands are:'\n else\n write(kou,*)'No such command, available commands are:'\n endif\n last=1\n cline=' *'\n call q3helpx(cline,last,cbas,ncbas)\n write(*,*)'An OS command must be prefixed by @'\n goto 100\n else\n! check for options .... some of these do not work yet\n! one should check for options after each subcommand or value entered ??\n! call ocmon_set_options(cline,last,optionsset)\n nops=0\n110 continue\n if(.not.eolch(cline,last)) then\n if(cline(last:last).eq.'/') then\n! this is an option!\n call getext(cline,last,2,option,' ',nopl)\n if(buperr.ne.0) then\n write(kou,*)'Error reading option',buperr\n buperr=0; goto 100\n endif\n call ocmon_set_options(option,afo,optionsset)\n if(afo.ne.0) then\n write(kou,*)'Please give the command again'\n goto 100\n endif\n goto 110\n else\n! set \"last\" back one character to prepare for next call of GPARx \n! as the first thing done by GPARx is to increment last by 1 to bypass a ,\n last=last-1 \n endif\n endif\n endif\n! save command for help path MAYBE NOT NEEDED ANY LONGER ??\n if(helprec%level.lt.maxhelplevel) then\n helprec%level=helprec%level+1\n helprec%cpath(helprec%level)=cbas(kom)\n else\n write(*,*)'Warning, exceeded helprec%level limit 1'\n endif\n! The IF loop is for handling of defaults in submenu. \"l ,,,,,\" took all \n! defaults but \"l,,,,,\" did not ....\n! if last>1 and cline(last-1:last-1) is a space and cline(last:last) a comma,\n! increment last\n if(last.eq.1) then\n last=last+1\n elseif(last.lt.len(cline)) then\n if(cline(last:last).ne.' ') then\n if(cline(last+1:last+1).eq.',') last=last+1\n endif\n endif\n!\n!================================================ separating main commands\n!------------------------- separating subcommands\n!......................... separating subsubcommands\n! jump here if there is an inline argument\n! 99 continue\n main: SELECT CASE(kom)\n! command selection\n!=================================================================\n CASE DEFAULT\n write(kou,*)'No such command'\n goto 100\n!=================================================================\n CASE(1) ! AMEND\n! amend subcommands\n! ['SYMBOL ','ELEMENT ','SPECIES ',&\n! 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',&\n! 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',&\n! 'COMPONENTS ','GENERAL ','ASSESSMENT_RESLT',&\n! 'OPTIMIZING_COEFS','EQUILIBRIUM ','REDUNDANT_SETS ',&\n! 'LINES ',' ',' ']\n! disable continue optimization\n! iexit=0\n! iexit(2)=1\n kom2=submenu(cbas(kom),cline,last,cam1,ncam1,4,'?TOPHLP')\n amend: SELECT CASE(kom2)\n CASE DEFAULT\n write(kou,*)'No such amendment',kom2\n! goto 100\n!-------------------------\n case(1) ! amend symbol (of state variable function)\n call gparcx('Symbol name: ',cline,last,1,name1,' ','?Amend symbol')\n call capson(name1)\n do svss=1,nosvf()\n if(name1(1:16).eq.svflista(svss)%name) goto 1020\n enddo\n write(kou,*)'No such symbol'; goto 100\n1020 continue\n if(svflista(svss)%status.ne.0) then\n! if any bit except SVCONST set we cannot amend it\n if(.not.btest(svflista(svss)%status,SVCONST)) then\n write(*,*)'Symbol is not amendable'; goto 100\n endif\n endif\n! No bits or the SVCONST bit is set, it is amendable, get its value\n actual_arg=' '\n xxx=evaluate_svfun_old(svss,actual_arg,1,ceq)\n if(btest(svflista(svss)%status,SVCONST)) then\n! symbol is a numeric constant or evaluated explicitly, we can change its value\n! value must be set in all equilibria ??\n call gparrdx('Give new value: ',cline,last,xxy,xxx,'?Amend symbol')\n if(buperr.eq.0) then\n call set_putfun_constant(svss,xxy)\n goto 100\n else\n! we want to amend something else\n buperr=0\n endif\n endif\n! Now we can set one special bit! But first clear input line\n last=len(cline)\n write(kou,1021)\n1021 format('You can specify:'/&\n ' V for a symbol evaluated only when referenced explicitly'/&\n ' X for a symbol to be evaluated at a particular equilibrium')\n! with SET ADVANCED SYMBOL one can set EXPORT/IMPORT for assessments\n call gparcdx('Please specify V or X',&\n cline,last,1,ch1,'X','?Amend symbol')\n call capson(ch1)\n if(ch1.eq.'V') then\n! If V then set bit to evaluate symbol only when explicitly referenced\n svflista(svss)%status=ibset(svflista(svss)%status,SVFVAL)\n elseif(ch1.eq.'X') then\n! if X then evaluate symbol only at specific equilibrium?\n! For example H298 for experimental data on H(T)-H298\n! BEWARE: if equilibria are calculated in threads this must be calculated\n! before the parallelization, testing bit EQNOTHREAD\n ll=ceq%eqno\n call gparidx('Specify equilibrium number:',cline,last,&\n neqdef,ll,'?Amend symbol evaluated at equilib')\n! UNFINISHED! Check equilibrium exist or only allow current?\n if(neqdef.le.1 .or. neqdef.gt.noeq()) then\n write(*,*)'No such equilibrium'; goto 100\n endif\n svflista(svss)%status=ibset(svflista(svss)%status,SVFEXT)\n svflista(svss)%eqnoval=neqdef\n! set status bit that this equilibrium must be calculated before parallel calc\n ceq%status=ibset(ceq%status,EQNOTHREAD)\n write(*,*)'The value of this symbol calculated in equilibrium: ',&\n neqdef\n goto 100\n else\n write(kou,*)'Illegal letter \"',ch1,'\"'\n endif\n!-------------------------\n case(2) ! amend element\n call gparcx('Element symbol: ',cline,last,1,elsym,' ',&\n '?Amend element')\n call find_element_by_name(elsym,iel)\n if(gx%bmperr.ne.0) goto 100\n call get_element_data(iel,elsym,name1,dummy,mass,h298,s298)\n if(gx%bmperr.ne.0) goto 100\n write(*,'(a)')'You are only allowed to change the mass'\n call gparrdx('New mass: ',cline,last,xxx,mass,'?Amend element')\n call new_element_data(iel,elsym,name1,dummy,xxx,h298,s298)\n! write(kou,*)'Not implemented yet'\n!-------------------------\n case(3) ! amend species\n call gparcx('Species symbol: ',cline,last,1,name1,' ',&\n '?Amend species')\n call find_species_record(name1,loksp)\n if(gx%bmperr.ne.0) goto 100\n write(*,'(a)')'You can only amend UNIQAC area and segments'\n call gparrdx('UNIQAC surface area (q): ',cline,last,xxx,one,&\n '?Amend species')\n if(xxx.le.zero) then\n write(*,'(a)')'Area must be >0, set to default 1.00'\n xxx=one\n endif\n call gparrdx('UNIQAC segments (r): ',cline,last,xxy,one,&\n '?Amend species')\n if(xxy.le.zero) then\n write(*,'(a)')'Segments must be >0, set to default 1.00'\n xxy=one\n endif\n! mark UNIQUAC in species status word and allocate space for values\n call set_uniquac_species(loksp)\n if(gx%bmperr.ne.0) goto 100\n call enter_species_property(loksp,1,xxx)\n call enter_species_property(loksp,2,xxy)\n if(gx%bmperr.ne.0) goto 100\n!-------------------------\n case(4) ! amend phase subcommands\n call gparcx('Phase name: ',cline,last,1,name1,' ','?Amend for phase')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n! sometimes lokph is used below\n call get_phase_record(iph,lokph)\n call get_phasetup_name(iph,name1)\n!\n kom3=submenu('Amend for phase '//trim(name1),&\n cline,last,camph,ncamph,2,'?TOPHLP')\n! write(*,*)'Amend phase subcommand: ',kom3\n amendphase: SELECT CASE(kom3)\n! subsubcommands to AMEND PHASE\n! ['ADDITION ','COMPOSITION_SET ','DISORDERED_FRACS',&\n! ' ','DIFFUSION ','DEFAULT_CONSTIT ',&\n! 'TERNARY_EXTRAPOL','FCC_PERMUTATIONS','BCC_PERMUTATIONS',&\n! 'REMOVE_COMPSETS ','ASYMMETRIES ','AQUEUS_MODEL ',&\n! 'QUASICHEM_MODEL ','FCC_CVM_TETRAHDR',' ',&\n! ' ',' ','QUIT ']\n! old\n!....................................................\n CASE DEFAULT\n write(kou,*)'Amend phase subcommand error'\n!....................................................\n case(1) ! amend phase addition\n kom4=submenu('Addition of',cline,last,caddph,naddph,1,&\n '?TOPHLP')\n! write(*,*)'Amend phase addition: ',kom4\n! ['MAGNETIC_CONTRIB','QUIT ','GADDITION ',&\n! 'TWOSTATE_LIQUID ','SCHOTTKY_ANOMALY','VOLUME_MODEL1 ',&\n! 'LOWT_CP_MODEL ','LIQUID_2STATE ',' ',&\n! 'ELASTIC_MODEL_A ','QUASICHEM_MODEL ','FCC_CVM_TETRAHDR']\n!\n amendphaseadd: SELECT CASE(kom4)\n case default\n write(*,*)'No such addition'\n! Inden magnetism\n case(1) ! amend phase magnetic contribution\n idef=-3\n! zero value of antiferromagnetic factor means Inden-Qing model\n call gparidx('Antiferromagnetic factor: ',&\n cline,last,j4,idef,'?Amend magnetism')\n if(buperr.ne.0) goto 990\n if(j4.eq.0) then\n! Inden-Hillert-Qing-Xiong magnetic model has AFF=0\n call gparcdx('BCC type phase: ',cline,last,1,chz,'N',&\n '?Amend magnetism')\n call gparcdx('Using individual Bohr magnetons: ',&\n cline,last,1,ch1,'N','?Amend magnetism')\n if(.not.(ch1.eq.'Y' .or. ch1.eq.'y')) then\n! write(*,*)'PMON use BMAG parameter as average'\n call set_phase_status_bit(lokph,PHBMAV)\n aux=' '\n else\n write(*,*)'PMON mark use IBM parameter'\n aux(2:2)='I'\n endif\n! xiongmagnetic is a predefined addition index, chz is Y or y for BCC\n j2=xiongmagnetic\n aux(1:1)=chz\n call add_addrecord(lokph,aux,xiongmagnetic)\n else\n if(j4.eq.-1) then\n! Inden magnetic for BCC\n call add_addrecord(lokph,'Y',indenmagnetic)\n else\n! Inden magnetic for FCC\n call add_addrecord(lokph,'N',indenmagnetic)\n endif\n j2=indenmagnetic\n endif\n call gparcdx('Is the addition calculated per mole of atoms?',&\n cline,last,1,ch1,'Y','?Add per formula unit')\n! The magnetic model calculates a molar Gibbs energy, must be multiplied with\n! the number of atoms in the phase. j2 set above to the addition type\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call setpermolebit(lokph,j2)\n endif\n!....................................................\n case(2) ! QUIT\n goto 100\n!....................................................\n case(3) ! amend phase ... addition gaddition\n! different additions can be added for different composition sets\n call get_phase_compset(iph,ics,lokph,lokcs)\n if(gx%bmperr.ne.0) goto 100\n if(allocated(ceq%phase_varres(lokcs)%addg)) then\n xxy=ceq%phase_varres(lokcs)%addg(1)\n else\n! maybe we will use more terms later ....\n xxy=zero\n allocate(ceq%phase_varres(lokcs)%addg(1))\n endif\n!\\hypertarget{Amend phase Gaddition}{}\n call gparrdx('Addition to G in J/FU (formula units): ',&\n cline,last,xxx,xxy,'?Amend Gaddition')\n ceq%phase_varres(lokcs)%addg(1)=xxx\n! set bit that this should be calculated\n ceq%phase_varres(lokcs)%status2=&\n ibset(ceq%phase_varres(lokcs)%status2,CSADDG)\n!....................................................\n case(4,8) ! amend phase add liquid_2state/twostate_liquid\n write(kou,667)\n667 format('This addition require LNTH parameters for the',&\n ' Einstein T of the amorphous state'/'and G2 parameters',&\n ' for the transition to the liquid state.')\n! WRONG IDEA to set bit to allow G2 to be composition independent\n! call gparcdx('Is G2 composition dependent? ',&\n! cline,last,1,ch1,'Y','?Amend twostate liquid')\n! ensure ch1 is a captial letter!\n! call capson(ch1)\n! if ch1 is N then the addition record will have the twostatemodel2(=12) value\n! and the PH2STATE in the phase record must be set also:\n! phlista(lokph)%status1=ibset(phlista(lokph)%status1,PH2STATE)\n! But as phlista is protected it is set inside add_addrecord\n modelx=twostatemodel1\n! inside add_addrecord modelx can be changed to twostatemodel2 if G2 fixed\n ch1='Y'\n call add_addrecord(lokph,ch1,modelx)\n call gparcdx('Is the low T calculated per mole atoms?',&\n cline,last,1,ch1,'Y','?Add per formula unit')\n! The CP model calculates a molar Gibbs energy, must be multiplied with\n! the number of atoms in the phase.\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call setpermolebit(lokph,modelx)\n endif\n!....................................................\n case(5) ! amend phase addition Schottky anomaly\n call add_addrecord(lokph,' ',schottkyanomaly)\n write(*,668)\n668 format('This addition requires the TSCH and CSCH parameters')\n!....................................................\n! VOLUME MODEL1\n case(6) ! volume model1\n call add_addrecord(lokph,' ',volmod1)\n write(*,*)'Added volume model 1'\n!....................................................\n! Einstein low T model\n case(7) ! amend phase LowT_CP_model\n call add_addrecord(lokph,' ',einsteincp)\n write(*,*)'This addition requires the LNTH parameter'\n call gparcdx('Is the addition calculated for one mole atoms? ',&\n cline,last,1,ch1,'Y','?Add per formula unit')\n! The CP model calculates a molar Gibbs energy, must be multiplied with\n! the number of atoms in the phase. j2 set above to the addition type\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call setpermolebit(lokph,einsteincp)\n endif\n!....................................................\n! case(8) ! same as 4\n!....................................................\n case(9) ! not used\n!....................................................\n case(10) ! amend phase elastic model\n! call add_addrecord(lokph,' ',elasticmodel1)\n write(*,*)'This addition is not yet implemented'\n!....................................................\n case(11) ! amend phase addition unused\n continue\n!....................................................\n case(12) ! amend phase ... smooth-Cp-step\n call add_addrecord(lokph,' ',secondeinstein)\n call gparcdx('Is the addition calculated for one mole? ',&\n cline,last,1,ch1,'Y','?Add per formula unit')\n! The CP model calculates a molar Gibbs energy, must be multiplied with\n! the number of atoms in the phase. j2 set above to the addition type\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call setpermolebit(lokph,secondeinstein)\n endif\n write(*,672)\n672 format('This addition recures the THT2 and DCP2 parameters')\n! The smooth CP model calculates a molar Gibbs energy, must be multiplied with\n! the number of atoms in the phase. j2 set above to the addition type\n end select amendphaseadd\n!....................................................\n case(2) ! amend phase composition set add/remove\n call gparcdx('Add new set? ',cline,last,1,ch1,'Y ','?Add new cs')\n if(buperr.ne.0) goto 990\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n call gparcx('Prefix: ',cline,last,1,prefix,' ',&\n '?Add new cs')\n call gparcx('Suffix: ',cline,last,1,suffix,' ',&\n '?Add new cs')\n call enter_composition_set(iph,prefix,suffix,ics)\n if(gx%bmperr.ne.0) goto 990\n! list the number of new composition set\n write(kou,*)'New composition set number is ',ics\n! ask for default constitution of new set\n call ask_default_constitution(cline,last,iph,ics,ceq)\n else\n! remove the highest (max is 9). Can be dangerous. Can not be made if there\n! are several equilibra unless second argument is changed to .TRUE.\n call remove_composition_set(iph,.FALSE.)\n if(gx%bmperr.ne.0) goto 990\n endif\n!....................................................\n case(3) ! amend phase disordered_fracset\n if(.not.allowenter(2)) then\n gx%bmperr=4125\n goto 990\n endif\n! we should check the number of sublattices of the phase ...\n! idef=4\n lokcs=phasetuple(iph)%lokvares\n idef=size(firsteq%phase_varres(lokcs)%sites)\n! write(*,*)'PMON idef: ',idef\n call gparidx('Sum up to sublattice: ',cline,last,ndl,idef,&\n '?Amend phase disordfrac')\n if(buperr.ne.0) goto 990\n call gparcdx('Should the ordered part cancel when disordered? ',&\n cline,last,1,ch1,'N','?Amend phase disordfrac')\n if(buperr.ne.0) goto 990\n if(ch1.eq.'N' .or. ch1.eq.'n') then\n! like sigma which is never completely disordered\n j4=0\n else\n! like FCC ordering where the disordered state can be modeled independently\n j4=1\n write(kou,*)'This phase can be totally disordered'\n endif\n ch1='D'\n call add_fraction_set(iph,ch1,ndl,j4)\n! forgot to add the sites \n lokcs=phasetuple(iph)%lokvares\n if(j4.eq.0) then\n xxx=zero\n do ll=1,ndl\n xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll)\n enddo\n firsteq%phase_varres(lokcs)%disfra%fsites=xxx\n endif\n! write(*,*)'pmon6: ',ndl,xxx\n if(gx%bmperr.ne.0) goto 990\n!....................................................\n case(4) ! Not used\n write(*,*)'Not implemented yet'\n!....................................................\n case(5) ! DIFUSION properties\n! copy the rest of the line to the subroutine\n text=cline(last:)\n call add_addrecord(lokph,text,DIFFCOEFS)\n!....................................................\n case(6) ! amend phase default_constitution\n! to change default constitution of any composition set give #comp.set.\n call ask_default_constitution(cline,last,iph,ics,ceq)\n!....................................................\n case(7) ! TERNARY_EXTRAPOL\n! this command is illegal for phases with sublattices (or permutations? ...)\n call get_sublattice_number(iph,ndl,ceq)\n if(gx%bmperr.ne.0) goto 990\n if(ndl.gt.1) then\n write(*,*)'Toop/Kohler extrapolation not allowed ',&\n 'for phases with 2 or more sublattices'\n goto 100\n endif\n write(kou,677)\n677 format('The ternary extrapolation method is fragile',&\n ' and only limited tests have been made.')\n tkloop: do while(.true.)\n call gparcx('Constituent 1: ',cline,last,1,&\n xspecies(1),' ','?Amend phase ternary extrapol')\n call gparcx('Constituent 2: ',cline,last,1,&\n xspecies(2),' ','?Amend phase ternary extrapol')\n call gparcx('Constituent 3: ',cline,last,1,&\n xspecies(3),' ','?Amend phase ternary extrapol')\n call gparcx('Extrapolations (TiKTi, KKK etc): ',&\n cline,last,1,tkmode,' ','?Amend phase ternary extrapol')\n call capson(tkmode)\n! letters K, M or T allowed in tkmode, T followed by integer, checked inside add\n! this subroutine is in gtp3H.F90 (additions)\n call add_ternary_extrapol_method(lokph,tkmode,xspecies)\n if(gx%bmperr.ne.0) goto 990\n dummy='N'\n call gparcdx('Another special ternary extrapolation for this phase?',&\n cline,last,1,ch1,dummy,'?Amend phase ternary extrapol')\n call capson(ch1)\n if(ch1.ne.'Y') exit tkloop\n enddo tkloop\n!....................................................\n!\\hypertarget{Amend FCC-permutations}{}\n case(8) ! amend phase ... FCC_PERMUTATIONS\n if(check_minimal_ford(lokph)) goto 100\n call set_phase_status_bit(lokph,PHFORD)\n!....................................................\n!\\hypertarget{Amend BCC-permutations}{}\n case(9) ! amend phase ... BCC_PERMUTATIONS\n if(check_minimal_ford(lokph)) goto 100\n call set_phase_status_bit(lokph,PHBORD)\n!....................................................\n case(10) ! amend phase <...> remove_compsets\n write(*,*)'PMON: delete unstable composition sets'\n call delete_unstable_compsets(lokph,ceq)\n!....................................................\n!************************************ begin amend phase ... asymmetries\n case(11) ! amend phase ... ASYMMETRIES for MQMQA phase\n! moved LIST PHASE MQMQA ASYMMETRIES HERE \n if(.not.allocated(tersys)) then\n write(*,*)'No MQMQA phase asymmetries entered'\n goto 100\n endif\n lokcs=phasetuple(iph)%lokvares\n write(*,*)'You can amend MQMQA asymmetry interactivly'\n! copied from gtp3XQ listconst\n! list element names, numbers and quad indices, i1 set to number of quads\n call list_quads(i1)\n!\n! tersys is global data\n write(*,3101)size(tersys)\n3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',&\n /' i tern cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code')\n do iz=1,size(tersys)\n write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n tersys(iz)%isasym,tersys(iz)%asymm\n3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a)\n enddo\n write(*,3301)\n3301 format('Number in cat1/2/3 columns is actual cation,'/&\n 'Number 1, 2 or 3 in T/0 columns refer to the cation colums.'/&\n 'Asymmetry code is KKK for symmetric, Tn for Toop n.')\n!\n skip1: if(.false.) then\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n!\n! skip code below, maybe move to after call to varkappa1\n! listing of fraction in alphbetical order\n write(kou,4123)mqmqa_data%nquad,&\n (ceq%phase_varres(lokcs)%yfr(i1),i1=1,mqmqa_data%nquad)\n4123 format('Fractions ',i2,' in species OC alphabetical order:',/&\n (12F6.3))\n! mqmqaf defined globally\n noq: if(.not.allocated(ceq%phase_varres(lokcs)%mqmqaf%xquad)) then\n write(*,*)'Quads not allocated'\n else\n write(kou,4122)mqmqa_data%nquad,&\n (ceq%phase_varres(lokcs)%mqmqaf%xquad(i1),i1=1,mqmqa_data%nquad)\n4122 format('Fractions ',i2,' in Quad order: ',/(12F6.3))\n\n write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat\n4124 format(/'The ',i3,' quads for ',i2,' cations are arranged ',&\n 'in order of the n cations:'/&\n 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/&\n 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/&\n 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n')\n write(kou,4126)mqmqa_data%quad2compvar\n4126 format('quad2compvar: ',21(1x,i2))\n!\n! write(kou,4127)mqmqa_data%emquad*(mqmqa_data%emquad-1),&\n! mqmqa_data%emquad\n!4127 format('Number of varkappa_ij asymmetry variables, n*(n-1)/2: ',i3/&\n! 'em2quad: ',21(1x,i2))\n! just a blank line\n write(kou,*)\n write(kou,308)'Fractions in OC order ',&\n (i2,i2=1,mqmqa_data%nquad)\n write(kou,308)'Fractions in Quad order ',&\n (mqmqa_data%con2quad(i2),i2=1,mqmqa_data%nquad)\n308 format(a,15i3)\n!\n write(kou,410)newXupdate\n410 format(/'List of compvar, the binary asymmetric composition',&\n ' variables, last update:',i5/&\n ' seq cat_i cat_j varkappa_ij varkappa_ji xi_ij xi_ji')\n! calculate varkappaij and varkappaji correcting for all ternaries\n mqmqavar=>ceq%phase_varres(lokcs)\n call calcasymvar(mqmqavar)\n j4=0\n cat1: do i1=1,mqmqa_data%ncat-1\n cat2: do i2=i1+1,mqmqa_data%ncat\n j4=j4+1\n write(kou,412)j4,i1,i2,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ji,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ij,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ji\n412 format(i5,2i6,3x,4(1PE12.4))\n enddo cat2\n enddo cat1\n endif noq\n!\n write(kou,444)'Values of y_i/k: ',&\n (ceq%phase_varres(lokcs)%mqmqaf%y_ik(i1),i1=1,mqmqa_data%ncat)\n444 format(/a,(10f7.4))\n!\n endif skip1\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n! code above redundant, contune specify ternary asymmetry\n!\n! just an empty line before entering of new asymmetry\n write(kou,*)\n call gparidx('Index of ternary to modify (0=none)?',cline,last,&\n asymter,0,'?Asymmetry modify')\n if(asymter.le.0 .or. asymter.gt.size(tersys)) then\n write(*,*)'No change',size(tersys)\n goto 100\n endif\n write(*,413)\n413 format('Specify the Toop cation as 1, 2 or 3.',/&\n '(When implemented 0 can be used to set symmetric)')\n call gparidx('Specify 0, 1, 2 or 3',cline,last,&\n new_toop,0,'?Asymmetry modify')\n if(new_toop.gt.0 .and. new_toop.le.3) then\n! allow only one asymmetric cation, save new_toop in tersys array\n tersys(asymter)%isasym(new_toop)=new_toop\n tersys(asymter)%asymm='T'//char(ichar('0')+new_toop)//' '\n! tersys will be 'T1 ', 'T2 ' or 'T3 '\n else\n! set isasym zero\n write(kou,*)'Restoring a ternary to symmetric does not work'\n goto 100\n!\n tersys(asymter)%isasym=0\n tersys(asymter)%asymm='KKK'\n! asymter=0\n endif\n! write(*,*)'MM tersys',asymter,' asymm: :',tersys(asymter)%asymm\n! this should change the asymmetry\n! tersys(iz)%asymm=ch3\n! write(*,414)\n414 format('Listing of quads and current asymmetries')\n! mqmqavar=>ceq%phase_varres(lokcs)%mqmqaf\n! this call lists current asymmetries\n! parres=>ceq%phase_varres(lokcs)\n! call varkappadefs(parres)\n! write(*,*)'Back from varkappadefs'\n! each varkappa has a box, just update the global newXupdate\n! mqf=>phres%mqmqaf\n! box=>mqf%compvar(1)\n! newXupdate=box%lastupdate+1\n! we must update all varkappa, there are mqmqa_data%ncat*(mqmqa_data%ncat-1)/2\n newXupdate=newXupdate+1\n parres=>ceq%phase_varres(lokcs)\n do iz=1,mqmqa_data%ncat*(mqmqa_data%ncat-1)/2\n! asymter is the index in the tersys array of the teranry with new asymmetry\n! old call varkappa1(iz,parres,asymter,new_toop)\n call varkappa1(iz,parres,asymter)\n! write(*,*)'MM back from varkappa1',iz\n enddo\n! repeat short listing the asymmetries\n write(*,3101)size(tersys)\n do iz=1,size(tersys)\n write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n tersys(iz)%isasym,tersys(iz)%asymm\n enddo\n write(*,3301)\n! list new asymmetries\n write(*,415)\n415 format('Listing new asymmetries')\n call varkappadefs(parres)\n! call list_quads(i1)\n continue\n!....................................................\n case(12) ! amend phase ... aqueous model\n write(*,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHAQ1)\n!....................................................\n case(13) ! amend phase ... quasicemichal model (2 versions)\n call gparidx('Quasichemical type: ',cline,last,jp,3,&\n '?Amend quasichemical')\n if(jp.lt.0 .or. jp.gt.3) then\n write(*,*)'Value must be between 1 and 3'\n else\n qcmodel=jp\n endif\n! write(kou,*)'Not implemented yet'\n! Future model bits\n! call set_phase_status_bit(lokph,PHQCE)\n! call set_phase_status_bit(lokph,PHFACTCE)\n!....................................................\n case(14) ! amend phase ... FCC_CVM_TETRAHEDRON MODEL\n write(kou,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHCVMCE)\n!....................................................\n case(15) ! amend phase ... unused\n write(kou,*)'Not implemented'\n!....................................................\n case(16) ! moved\n!....................................................\n case(17) ! moved\n!....................................................\n case(18) ! amend phase ... quit\n goto 100\n END SELECT amendphase\n!------------------------- end of amend phase\n case(5) ! amend parameter\n write(kou,*)'Not implemented yet, only ENTER PARAMETER'\n!-------------------------\n case(6) ! amend bibliography (in gtp3D)\n call enter_bibliography_interactivly(cline,last,1,j4)\n!-------------------------\n case(7) ! amend TPFUN symbol\n write(kou,*)' *** Dangerous if you have several equilibria!'\n call gparcx('TP-fun symbol: ',cline,last,1,name1,' ',&\n '?Amend TPfun')\n call find_tpsymbol(name1,idef,xxx)\n if(gx%bmperr.ne.0) then\n write(*,*)'Ambiguouos or unknown symbol'; goto 990\n endif\n if(idef.eq.0) then\n! it is a function , this call just read the function starting with low T etc.\n call enter_tpfun_interactivly(cline,last,funstring,jp)\n! this stores the tpfun, lrot<0 means the symbol already exists\n lrot=-1\n! last argument -1 means not reading from TDB file\n! call store_tpfun(name1,funstring,lrot,.FALSE.)\n call store_tpfun(name1,funstring,lrot,-1)\n if(gx%bmperr.ne.0) goto 990\n! mark functions not calculated. This should be done in all ceq ...\n ceq%eq_tpres(lrot)%tpused(1)=-one\n ceq%eq_tpres(lrot)%tpused(2)=-one\n elseif(idef.eq.2) then\n write(*,*)'You cannot change an optimizing coefficients'\n goto 100\n else\n! it is a constant, you can change if\n call gparrdx('Value: ',cline,last,xxy,xxx,'?Amend TPfun')\n call capson(name1)\n call store_tpconstant(name1,xxy)\n endif\n!-------------------------\n case(8) ! amend constitution (also as ENTER CONST and SET PHASE )\n call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq)\n if(gx%bmperr.ne.0) goto 990\n!-------------------------\n case(9) ! QUIT amend\n continue\n!-------------------------\n case(10) ! amend components\n write(*,*)'WARNING: not fully implemented yet'\n! goto 100\n if(associated(ceq%lastcondition)) then\n write(kou,*)'Warning: All your conditions will be removed'\n endif\n i2=1\n line=' '\n do i1=1,noel()\n call get_component_name(i1,line(i2:),ceq)\n i2=len_trim(line)+2\n enddo\n aline=' '\n call gparcdx('Give all new components: ',cline,last,&\n 5,aline,line,'?Amend components')\n! option is a character with the new components ...\n call amend_components(aline,ceq)\n if(gx%bmperr.ne.0) goto 990\n!-------------------------\n case(11) ! amend general\n call amend_global_data(cline,last)\n!-------------------------\n case(12) ! amend assessment result\n if(.not.allocated(firstash%eqlista)) then\n write(kou,*)'No assessment record'\n goto 100\n elseif(nvcoeff.le.0) then\n write(kou,*)'No variable optimizing coefficients'; goto 100\n elseif(nvcoeff.ne.nvcoeffdone) then\n write(kou,*)'No optimization made with these coefficients',&\n nvcoeff,nvcoeffdone\n goto 100 \n elseif(mexp.ne.mexpdone) then\n write(kou,*)'No optimization made with these experiments',&\n mexp,mexpdone\n goto 100 \n endif\n call gparix('Index of coefficent to change: ',cline,last,&\n analyze,NONE,'?Amend assess result')\n if(buperr.ne.0) goto 990\n xxy=zero\n if(analyze.lt.0) then\n! using a negative coefficient, restore saved coefficients\n! if nvcoefdone and mxexp same\n write(*,*)'Trying to restore saved coefficients'\n if(nvcoeffsave.eq.nvcoeff .and. mexpsave.eq.mexp) then\n if(allocated(savedcoeff)) then\n! if analyze < 0 then restore sevedcoeff\n i2=0\n do j2=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(j2).ge.10) then\n! this a variable coefficient\n i2=i2+1\n firstash%coeffscale(j2)=savedcoeff(1,i2)\n firstash%coeffstart(j2)=savedcoeff(2,i2)\n! I am not sure if xxx should be savedcoeff or scale*start ... ???\n xxx=savedcoeff(3,i2)\n firstash%coeffvalues(j2)=xxx\n firstash%coeffrsd(j2)=zero\n! this should update all other places including TP function \n call change_optcoeff(firstash%coeffindex(j2),xxx)\n endif\n enddo\n deallocate(savedcoeff)\n err0(2)=savesumerr\n write(*,*)'Restored saved coefficients'\n else\n write(*,*)'No coefficients saved'\n endif\n else\n! giving a negative number makes it possible to use ANALYZE again\n! for another set of coefficients and experiments\n write(kou,*)'Cannot restore as variable coefficients ',&\n 'or experiments changed'\n if(allocated(savedcoeff)) deallocate(savedcoeff)\n endif\n goto 100\n else\n if(.not.allocated(savedcoeff)) then\n! when ANALYZE first time save the current set of variable coefficients\n allocate(savedcoeff(3,nvcoeff))\n mexpsave=0\n! if already allocated mexpsave nonzero\n endif\n i2=0\n xxy=zero\n do j2=0,size(firstash%coeffstate)-1\n! only active coefficients saved ... extract the one to be changed\n if(firstash%coeffstate(j2).ge.10) then\n i2=i2+1\n if(mexpsave.eq.0) then\n savedcoeff(1,i2)=firstash%coeffscale(j2)\n savedcoeff(2,i2)=firstash%coeffstart(j2)\n savedcoeff(3,i2)=firstash%coeffvalues(j2)\n! write(*,'(a,3(1pe14.6))')'saved: ',(savedcoeff(iz,i2),iz=1,3)\n firstash%coeffrsd(j2)=zero\n endif\n if(analyze.eq.j2) then\n cormatix=i2\n xxy=savedcoeff(1,i2)*savedcoeff(3,i2)\n! write(*,*)'Coefficient: ',cormatix,xxy\n endif\n endif\n enddo\n if(mexpsave.eq.0) then\n write(*,*)'Saved ',i2,'currently variable coefficients'\n! save current sum of errors, nvcoeff and mexp\n savesumerr=err0(2)\n nvcoeffsave=nvcoeff; mexpsave=mexp\n endif\n endif\n! if xxy is zero it is not an optimized coefficient\n if(xxy.eq.zero) then\n write(kou,*)'Specified coefficent not set as variable',analyze\n if(allocated(savedcoeff)) deallocate(savedcoeff); goto 100\n endif\n! ask for new value with the current value as default\n call gparrdx('New value: ',cline,last,xxx,xxy,'?Amend assess result')\n delta=(xxx-xxy)/firstash%coeffscale(analyze)\n! write(*,*)'Delta: ',xxx-xxy,delta\n! UNFINISHED\n! Now all variable coefficients should be modified using the correlation matrix\n i2=0\n do j2=0,size(firstash%coeffstate)-1\n! modify all other coefficient according to the correlation matrix \n! new_value_i = old_value_i + correlation_matrix_ji * delta (where j=analyze)\n if(firstash%coeffstate(j2).ge.10) then\n i2=i2+1\n xxx=firstash%coeffvalues(j2)\n xxy=xxx+cormat(cormatix,i2)*delta\n! firstash%coeffvalues(j2)=xxy*firstash%coeffscale(j2)\n! %coeffvalues should be of the order 1\n! No change of %coeffstart and %coeffscale\n firstash%coeffvalues(j2)=xxy\n xxz=xxy*firstash%coeffscale(j2)\n! optimizing coefficients are also TP functions, we must update the\n! TP function value!! I do not understand this and \"list tp\" is wrong\n! but it seems to work. If I set the value *firstash%coeffscale it blows up!\n call change_optcoeff(firstash%coeffindex(j2),xxz)\n! set RSD to zero\n firstash%coeffrsd=zero\n! write(*,'(a,2i4,4(1pe12.4))')'New value: ',i2,j2,&\n! xxx,cormat(cormatix,i2),delta,firstash%coeffvalues(j2)\n endif\n enddo\n write(*,*)'To calculate a new set of errors use OPTIMIZE'\n! write(*,*)'Not implemented yet'\n!-------------------------\n case(13) ! amend OPTIMIZING_COEFF, (rescale or recover)\n if(.not.allocated(firstash%eqlista)) then\n write(*,*)'No assessment record allocated'; goto 100\n endif\n call gparcdx('Should the coefficients be rescaled?',&\n cline,last,1,ch1,'N','?Amend optim coeff')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n! set start values to current values\n! firstash%coeffstart=firstash%coeffvalues*firstash%coeffscale\n! firstash%coeffscale=firstash%coeffstart\n! Note the \"current value\" is \"start value\" times \"scaling factor\"\n! firstash%coeffvalues=one\n do j2=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(j2).ge.10) then\n call get_value_of_constant_index(firstash%coeffindex(j2),xxx)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error getting value of assessment coefficient',j2\n goto 100\n endif\n! write(*,*)'Assessment coefficient value: ',xxx\n! Set all values equal to the current value of the TP variable ...\n firstash%coeffscale(j2)=xxx\n firstash%coeffstart(j2)=xxx\n firstash%coeffvalues(j2)=one\n! call change_optcoeff(firstash%coeffindex(j2),xxx)\n endif\n enddo\n firstash%coeffrsd=zero\n call listoptcoeff(mexp,err0,.FALSE.,lut)\n if(allocated(cormat)) then\n deallocate(cormat)\n deallocate(tccovar)\n endif\n else\n call gparcdx('Do you want to recover the coefficients values?',&\n cline,last,1,ch1,'N','?Amend optim coeffs')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n! set current optimizing values back to start values\n! firstash%coeffvalues=firstash%coeffstart*firstash%coeffscale\n do j2=0,size(firstash%coeffstate)-1\n! This affects only current optimizing coefficients!!\n if(firstash%coeffstate(j2).ge.10) then\n xxx=firstash%coeffstart(j2)\n firstash%coeffvalues(j2)=xxx/firstash%coeffscale(j2)\n! we must also change the value of the associated TP variable ??\n call change_optcoeff(firstash%coeffindex(j2),xxx)\n endif\n enddo\n! no change of start value or scaling factor but zero RSD and sum of squares\n firstash%coeffrsd=zero\n if(allocated(cormat)) then\n deallocate(cormat)\n deallocate(tccovar)\n endif\n err0(2)=zero\n call listoptcoeff(mexp,err0,.FALSE.,lut)\n else\n write(kou,557)\n557 format('Nothing done as there are no other amend',&\n ' optimizing option')\n endif\n endif\n!-------------------------\n case(14) ! AMEND EQUILIBRIUM intended to add to experimental list\n write(*,*)'Not implemented yet'\n!-------------------------\n case(15) ! AMEND REDUDANT composition sets\n write(*,*)'This will set all unstable additional composition sets',&\n ' as suspended'\n ll=0\n call suspend_unstable_sets(ll,ceq)\n!-------------------------\n case(16) ! AMEND LINEs of calculated equilibria\n! possible amendment of all stored equilibria as ACTIVE or INACTIVE\n call amend_stored_equilibria(axarr,maptop)\n!-------------------------\n case(17) ! AMEND START_CONSTITUTION for assessments\n! copy constitutions from one equilibrium to another, to handle miscibility gaps\n! Default from \"previous\"\n if(.not.allocated(firstash%coeffstate)) then\n write(kou,*)'This is used during assessments'\n! to copy start values from one experimental equilibria to another\n goto 100\n endif\n ll=max(1,ceq%eqno-1)\n call gparidx('From equilibrium number: ',cline,last,&\n fromeq,ll,'?Amend start_constitution')\n! copy constitutions of non-suspended phases from fromeq to current equilibrium\n call copyfracs(fromeq,ceq)\n! write(*,*)'Not implemented yet'\n!-------------------------\n case(18) ! Nothing defined\n write(*,*)'Not implemented yet'\n END SELECT amend\n!=================================================================\n! calculate subcommands\n! ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',&\n! 'TRANSITION ','QUIT ','GLOBAL_GRIDMIN ',&\n! 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA ',&\n! 'WITH_CHECK_AFTER','TZERO_POINT ','CAREFULLY ',&\n! 'ONLY_GRIDMIN ','BOSSES_METHOD ','PARAEQUILIBRIUM ',&\n! 'LIQUID_EET ',' ',' ']\n CASE(2)\n kom2=submenu(cbas(kom),cline,last,ccalc,ncalc,8,'?TOPHLP')\n calculate: SELECT CASE(kom2)\n CASE DEFAULT\n write(kou,*)'No such calculate command'\n goto 100\n!-------------------------\n CASE(1) ! calculate TPFUN symbols , use current values of T and P\n call gparcdx('name: ',cline,last,5,name1,'*','?Calculate TPfun')\n lrot=0\n iel=index(name1,'*') \n if(iel.gt.1) name1(iel:)=' '\n! as TP functions call each other force recalculation and calculate all\n! even if just a single function is requested\n call change_optcoeff(-1,zero)\n! write(*,*)'PM calc tp: ',notpf()\n do j4=1,notpf()\n! write(*,*)'PM call eval_tpfun: ',notpf()\n call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres)\n if(gx%bmperr.gt.0) goto 990\n enddo\n if(name1(1:1).ne.'*') then\n once=.TRUE.\n2009 continue\n call find_tpfun_by_name(name1,lrot)\n! write(*,*)'cui: ',lrot,iel,gx%bmperr\n if(gx%bmperr.ne.0) then\n if(iel.eq.0) goto 990\n gx%bmperr=0\n else\n! found function number from lrot ???\n j4=lrot\n call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres)\n if(gx%bmperr.gt.0) goto 990\n if(once) then\n once=.FALSE.\n write(lut,2011)1,ceq%tpval\n endif\n write(lut,2012)j4,val\n if(iel.gt.1) goto 2009\n endif\n else\n write(lut,2011)notpf(),ceq%tpval\n2011 format(/'Calculating ',i6,' functions for T,P=',F10.2,1PE15.7/&\n 3x,'No F',11x,'F.T',9x,'F.P',9x,'F.T.T',&\n 7x,'F.T.P',7x,'F.P.P')\n! call cpu_time(starting)\n do j4=1,notpf()\n call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres)\n if(gx%bmperr.gt.0) goto 990\n write(lut,2012)j4,val\n2012 format(I5,1x,6(1PE12.4))\n enddo\n! call cpu_time(ending)\n endif\n! write(kou,2013)ending-starting\n!2013 format('CPU time used: ',1pe15.6)\n!---------------------------------------------------------------\n case(2) ! calculate phase, _all _only_g or _g_and_dgdy, etc\n! asks for phase name and constitution. DO NOT ALLOW * by setting iph=-1\n! before calling!\n iph=-1\n call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq)\n if(gx%bmperr.ne.0) goto 990\n! if iph<0 then * has been given as phase name\n if(iph.lt.0) then\n write(kou,*)'Cannot loop for all phases'\n goto 100\n endif\n! subcommands for calculate phase\n! ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES ',&\n! 'CONSTITUTION_ADJ','DIFFUSION_COEFF ','QUIT ']\n!\n defcp=1\n kom3=submenu('Calculate what for phase?',cline,last,ccph,nccph,defcp,&\n '?TOPHLP')\n! if(kom2.le.0) goto 100\n! ph-a ph-G ph-G+dg/dy\n defcp=kom3\n lut=optionsset%lut\n! use current value of T and P\n if(kom3.ne.4) then\n write(*,2015)ceq%tpval\n2015 format('Using T=',F9.2,' K and P=',1pe14.6,&\n ' Pa, results in J/F.U.')\n endif\n rgast=globaldata%rgas*ceq%tpval(1)\n! this is the number of moles formula units the user specified\n cpham=ceq%phase_varres(lokcs)%amfu\n calcphase: SELECT CASE(kom3)\n!.......................................................\n CASE DEFAULT\n write(kou,*)'Calculate phase subcommand error'\n!.......................................................\n case(1) ! calculate_phase .. calculate phase < > only G\n call calcg(iph,ics,0,lokres,ceq)\n if(gx%bmperr.ne.0) goto 990\n parres=>ceq%phase_varres(lokres)\n write(lut,2031)(cpham*rgast*parres%gval(j4,1),j4=1,4)\n! G=H-T*S; H=G+T*S; S=-G.T; H = G + T*(-G.T) = G - T*G.T\n write(lut,2032)cpham*parres%gval(1,1)/parres%abnorm(1),&\n cpham*(parres%gval(1,1)-ceq%tpval(1)*parres%gval(2,1))*rgast,&\n parres%abnorm(1)\n2031 format(/'G, dG/dT dG/dP d2G/dT2:',4(1PE14.6))\n2032 format('G/RT, H, atoms/F.U:',3(1PE14.6))\n! also list contributions from calculated additions ...!!!\n call list_addition_values(lut,parres)\n!.......................................................\n case(2) ! calculate phase < > G and dG/dy\n call calcg(iph,ics,1,lokres,ceq)\n if(gx%bmperr.ne.0) goto 990\n parres=>ceq%phase_varres(lokres)\n nofc=noconst(iph,ics,firsteq)\n write(lut,2031)(cpham*rgast*parres%gval(j4,1),j4=1,4)\n write(lut,2033)\n2033 format('dG/dy: ... dG/dy_i is NOT THE CHEMICAL POTENTIAL of i!')\n write(lut,2041)(rgast*parres%dgval(1,j4,1),j4=1,nofc)\n2041 format(9x,5e14.4)\n!.......................................................\n case(3) ! calculate phase < > all derivatives\n call gparidx('Number of times: ',cline,last,times,1,&\n '?Calculate phase ... loop')\n! attempt to measure calcg_interal bottlenecks\n! call cpu_time(starting)\n! zputime=starting\n call tabder(iph,ics,times,ceq)\n if(gx%bmperr.ne.0) goto 990\n! write 20 values\n! write(*,'(7(1pE11.3)/7E11.3/7E11.3)')zputime\n write(*,2042)\n2042 format('Values are per mole formula unit'/&\n ' NOTE THAT dG/dy_i is NOT THE CHEMICAL POTENTIAL of i!')\n! if(gx%bmperr.ne.0) goto 990\n!.......................................................\n case(4,5) ! calculate phase with constitution_adjustment\n! or derivatives of chemical potentials and mobility data\n! convert to phase tuple here as that is used in the application call\n do jp=1,nooftup()\n! if(phasetuple(jp)%phaseix.eq.iph .and. &\n if(phasetuple(jp)%ixphase.eq.iph .and. &\n phasetuple(jp)%compset.eq.ics) then\n! write(*,*)'This is phase tuple ',jp\n goto 2044\n endif\n enddo\n write(*,*)'No such tuple'\n goto 100\n2044 continue\n phtup=>phasetuple(jp)\n! Get current constitution of the phase\n call calc_phase_molmass(iph,ics,xknown,aphl,totam,xxy,xxx,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error finding current composition'\n goto 990\n endif\n! ask for overall composition\n totam=one\n quest='Mole fraction of XX:'\n do nv=1,noel()-1\n if(totam.gt.zero) then\n! assume elements as components\n call get_component_name(nv,elsym,ceq)\n quest(18:19)=elsym\n! prompt with current mole fraction:\n call gparrdx(quest,cline,last,xxy,xknown(nv),&\n '?Calculate phase adjust')\n if(buperr.ne.0) then\n buperr=0; xxy=zero\n endif\n if(xxy.gt.totam) then\n write(kou,*)'Fraction too large, set to ',totam\n xxy=totam\n endif\n else\n xxy=zero\n endif\n xknown(nv)=xxy\n totam=totam-xxy\n! yarr is used here to provide an array for the chemical potentials\n yarr(nv)=ceq%cmuval(nv)\n enddo\n! after loop nv=noel()\n call get_component_name(nv,elsym,ceq)\n write(kou,2088)elsym,totam\n2088 format('Mole fraction of ',a,' set to ',F8.5)\n xknown(nv)=totam\n yarr(nv)=ceq%cmuval(nv)\n! use current T and P\n if(kom3.eq.4) then\n! constituent adjustment, the FALSE means not quiet\n call equilph1b(phtup,ceq%tpval,xknown,xxx,yarr,.FALSE.,ceq)\n if(gx%bmperr.ne.0) goto 990\n write(kou,2087)xxx,(yarr(nv),nv=1,noel())\n2087 format(/'Calculated Gibbs energy/FU/RT: ',1pe14.6,&\n ' and the chemical potentials/RT:'/6(1pe12.4))\n else\n!.............................................\n! calculate phase diffusion: chem.pot derivatives and mobilities\n! mugrad(I,J) are derivatives of the chemical potential of endmember I\n! with respect to endmember J\n! mobilities(i) is mobility of component i\n! derivatives of mu and mobilities, the FALSE means not quiet\n! CCI\n call get_sublattice_number(phtup%ixphase,nsub,ceq)\n allocate(nkl(nsub))\n allocate(nsites(nsub))\n call get_sublattice_structure(phtup%ixphase,phtup%compset,&\n nsub,nkl,nsites,ceq)\n nend=1\n do nv=1,nsub\n nend = nend * nkl(nv)\n enddo\n deallocate(nkl)\n deallocate(nsites)\n allocate(mugrad(nend*nend))\n allocate(mobilities(noel()))\n mugrad(:)=zero\n mobilities(:)=zero\n\n call equilph1d(phtup,ceq%tpval,xknown,yarr,.FALSE.,&\n nend,mugrad,mobilities,ceq)\n if(gx%bmperr.ne.0) goto 990\n write(kou,2096)nend\n2096 format(/'Chemical potential derivative matrix, dG_I/dn_J for ',&\n i3,' endmembers')\n write(kou,2094)(nv,nv=1,nend)\n2094 format(3x,6(6x,i6)/(3x,6i12))\n do nv=0,nend-1\n! An extra LF is generated when just 6 components!! use ll, kp j4, i2\n write(kou,2095)nv+1,(mugrad(nend*nv+jp),jp=1,nend)\n!2095 format(i3,6(1pe12.4)/(3x,6e12.4))\n2095 format(i3,6(1pe12.4)/(3x,6e12.4))\n enddo\n write(kou,2098)noel()\n2098 format(/'Mobility values mols/m2/s ?? for',i3,' components')\n write(kou,2095)1,(mobilities(jp),jp=1,noel())\n !CCI\n deallocate(mugrad)\n deallocate(mobilities)\n call list_defined_properties(lut)\n!CCI\n endif\n!.......................................................\n case(6) ! Quit\n! write(*,*)'Not implemeneted yet'\n END SELECT calcphase\n! set bits to warn that listings may be inconsistent\n ceq%status=ibclr(ceq%status,EQNOEQCAL)\n ceq%status=ibset(ceq%status,EQINCON)\n!---------------------------------- end of calculate phase\n case(3) ! calculate equilibrium without initial global minimization\n if(minimizer.eq.1) then\n! Lukas minimizer, first argument=0 means do not use grid minimizer\n! call calceq1(0,ceq)\n write(kou,*)'Not implemented yet'\n else\n call calceq2(0,ceq)\n! check that invmat allocated and stored\n! write(*,*)'inverted y: ',ceq%phase_varres(2)%cinvy(1,1)\n endif\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n goto 990\n endif\n!----------------------------------\n case(4) ! calculate transition\n call calctrans(cline,last,ceq)\n! clear this bit so there there will be no warning the listing is inconsistent\n if(gx%bmperr.ne.0) goto 990\n ceq%status=ibclr(ceq%status,EQINCON)\n!----------------------------------\n case(5) ! quit\n goto 100\n!-----------------------------------------------------------\n case(6) ! calculate global grid minimum\n! This command is depreciated as it has been misunderstood\n write(*,2101)\n2101 format('This command has been removed as it has been misunderstood.',&\n /'It calculated points on the Gibbs energy curves of the ',&\n ' different phases'/'to be used as start points for the',&\n ' actual minimization.'/'It is replaced by the command ',&\n '\"CALCULATE ONLY_GRIDMIN\".'//&\n 'In order to calculate the equilibrium use \"C E\".'/)\n goto 100\n!\n! extract values for mass balance calculation from conditions\n call extract_massbalcond(ceq%tpval,xknown,totam,ceq)\n if(gx%bmperr.ne.0) goto 990\n! debug output\n! write(*,2101)totam,(xknown(j4),j4=1,noel())\n!2101 format('UI N&x: ',F6.3,9F8.5)\n! generate grid and find the phases and constitutions for the minimum.\n! Note: global_gridmin calculates for total 1 mole of atoms, not totam\n! call global_gridmin(1,ceq%tpval,totam,xknown,nv,iphl,icsl,&\n! iphl is dimensioned (1:maxel), maxel=100, it is destroyed inside merge_grid ..\n! call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,&\n! aphl,nyphl,yarr,cmu,iphl,ceq)\n call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,&\n aphl,nyphl,cmu,ceq)\n if(gx%bmperr.ne.0) goto 990\n! write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv)\n! we should write phase tuples ... ?? \n write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv)\n2102 format('Number of stable phases ',i2/13(i4,i2))\n! In some cases \"c n\" converges better if we scale with the total amount here\n do j4=1,nv\n call get_phase_compset(iphl(j4),icsl(j4),lokph,lokcs)\n ceq%phase_varres(lokcs)%amfu=totam*ceq%phase_varres(lokcs)%amfu\n enddo\n! if set clear this bit so we can list the equilibrium\n if(btest(ceq%status,EQNOEQCAL)) ceq%status=ibclr(ceq%status,EQNOEQCAL)\n!2103 format('Stable phase ',2i4,': ',a)\n!---------------------------------------------------------------\n case(7) ! calculate symbol\n! call evaluate_all_svfun(kou,ceq)\n! to calculate derivatives this must be in the minimizer module\n call gparcdx('Name ',cline,last,1,name1,'*','?Calculate symbol')\n! always calculate all state variable functions as they may depend on eachother\n! write(*,*)'UI: calculating all functions'\n call meq_evaluate_all_svfun(-1,ceq)\n if(gx%bmperr.ne.0) then\n! ignore error unless inside macro\n write(*,*)'UI: error calculating all functions', gx%bmperr\n if(kiu.ne.kiud) goto 990\n gx%bmperr=0\n endif\n if(name1(1:1).eq.'*') then\n! this calculate them again ... and lists the values\n call meq_evaluate_all_svfun(lut,ceq)\n else\n! This code is also used in SHOW (command 25)\n call capson(name1)\n! call find_svfun(name1,istv,ceq)\n call find_svfun(name1,istv)\n if(gx%bmperr.ne.0) goto 990\n mode=1\n actual_arg=' ' \n! write(*,*)'UI: calculating the requested function!'\n xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq)\n if(gx%bmperr.ne.0) goto 990\n write(*,2047)name1(1:len_trim(name1)),xxx\n2047 format(a,'= ',1pe16.8)\n endif\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n case(8) ! calculate equilibrium for current equilibrium ceq\n! using the grid minimizer\n if(minimizer.eq.1) then\n! Lukas minimizer, first argument=1 means use grid minimizer\n! call calceq1(1,ceq)\n write(kou,*)'No longer available'\n else\n call calceq2(1,ceq)\n if(gx%bmperr.eq.4204) then\n! if the error code is \"too many iterations\" try without grid minimizer\n! it converges in many cases\n write(*,2048)gx%bmperr\n2048 format('Error ',i5,', cleaning up and trying harder')\n gx%bmperr=0\n call calceq2(0,ceq)\n endif\n endif\n! calceq2 set appropriate bits for listing\n if(gx%bmperr.ne.0) then\n if(gx%bmperr.eq.4204) write(*,2049)\n2049 format('If the conditions allow using the global minimizer, ',&\n ' try \"CALCULATE CAREFULLY\"')\n ceq%status=ibset(ceq%status,EQFAIL)\n goto 990\n endif\n!---------------------------------------------------------------\n case(9) ! calculate all equilibria\n! rather complex to handle both parallel on non-parallel and with/without \n! griminimizer ...\n if(allocated(firstash%eqlista)) then\n call gparcdx('With global minimizer? ',cline,last,1,ch1,'N',&\n '?Calculate all')\n! mode=0 is without grid minimizer ?? mode=-1 ??\n mode=1\n if(ch1.eq.'N' .or. ch1.eq.'n') mode=0\n! if(ch1.eq.'N' .or. ch1.eq.'n') mode=-1\n! Seach for memory leaks\n call gparidx('How many times? ',cline,last,leak,1,'Calculate all')\n! leak<0 means forever ... not allowed but leak=-1 generates output\n iz=leak\n if(leak.lt.1) leak=1\n! Minimize output\n listzero=.false.\n! allow output file, if idef>1 no output\n idef=leak\n lut=optionsset%lut\n jp=0\n i2=0\n! if compiled with parallel and gridminimizser set then calculate\n! sequentially to create composition sets\n! TEST THIS IN PARALLEL !!!\n call cpu_time(xxx)\n call system_clock(count=j4)\n threads=1\n! OPENMP parallel start\n!$ threads=omp_get_num_threads()\n!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n! for parallelizing:\n! YOU MUST UNCOMMENT USE OMP_LIB IN GTP3.F90 or PMON6.F90\n! YOU MUST USE THE SWICH -fopenmp FOR COMPILATION AND WHEN LINKING\n!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n! gridmin: if(mode.eq.1) then\n!\n! return here until leak is zero, a negative leak will never stop\n2060 continue\n gridmin: if(mode.eq.1 .or. &\n btest(globaldata%status,GSNOPAR)) then\n! if we use grid minimizer do not use parallel even if compiled with OpenMP\n do i1=1,size(firstash%eqlista)\n neweq=>firstash%eqlista(i1)%p1\n jp=jp+1\n if(neweq%weight.eq.zero) then\n if(listzero) write(kou,2050)neweq%eqno,neweq%eqname\n2050 format('Zero weight equilibrium ',i4,2x,a)\n else\n i2=i2+1\n call calceq3(mode,.FALSE.,neweq)\n if(gx%bmperr.ne.0) then\n write(kou,2051)gx%bmperr,neweq%eqno,neweq%eqname\n2051 format(' *** Error code ',i5,' for equilibrium ',&\n i5,': ',a,' reset ')\n gx%bmperr=0\n elseif(idef.eq.1) then\n! extract names of stable phases\n jp=1\n line=' '\n do j3=1,nooftup()\n phtup=>phasetuple(j3)\n if(neweq%phase_varres(phtup%lokvares)%phstate.ge.PHENTSTAB) then\n call get_phasetup_name(j3,line(jp:))\n jp=len_trim(line)+2\n endif\n enddo\n call get_state_var_value('GMS ',gms,model,neweq)\n write(lut,2052)neweq%eqno,&\n trim(neweq%eqname),neweq%tpval(1),gms,trim(line)\n2052 format(i4,2x,a,', T=',F8.2,', GMS= ',1pe12.4,', ',a)\n endif\n endif\n! extra symbol calculations ....\n! write(*,*)'Listing extra'\n if(idef.eq.1) then\n call list_equilibrium_extra(lut,neweq,plotunit0)\n if(gx%bmperr.ne.0) then\n write(kou,*)'Error ',gx%bmperr,' reset'\n gx%bmperr=0\n endif\n endif\n enddo\n else\n! Here we calculate without grid minimizer, if parallel we must turn off\n! creating/removing composition sets!! not safe to do that!!\n!$ globaldata%status=ibset(globaldata%status,GSNOACS)\n!$ globaldata%status=ibset(globaldata%status,GSNOREMCS)\n! !$OMP for an OMP directive\n! !$ as \"sentinel\", will be compiled if -fopenmp\n! this statement must not be inside a parallel do ...\n svss=size(firstash%eqlista)\n! NOTE: $OMP threadprivate(gx) declared in TPFUN4.F90 ??\n!----- $OMP parallel do private(neweq)\n!$OMP parallel do private(neweq,gms)\n paraloop: do i1=1,svss\n! do i1=1,size(firstash%eqlista)\n! the error code must be set to zero for each thread ?? !!\n jp=jp+1\n gx%bmperr=0\n neweq=>firstash%eqlista(i1)%p1\n! it seems stupid to get this value each loop but outside it is unity\n!$ threads=omp_get_num_threads()\n if(neweq%weight.eq.zero) then\n if(listzero) write(kou,2050)neweq%eqno,neweq%eqname\n else\n! skip this output\n!-!$ if(.TRUE. .and. idef.eq.1) then\n!$ if(.TRUE. .and. iz.lt.0) then\n! output only if \"number of times\" is negative above\n!$ write(*,663)'Equil/loop/thread/maxth/error: ',&\n!$ neweq%eqname,i1,omp_get_thread_num(),&\n!$ threads,gx%bmperr\n663 format(a,a,5i5)\n! calceq3 gives no output\n!$ call calceq3(mode,.FALSE.,neweq)\n!$ else\n! note first argument zero means do not use grid minimizer\n call calceq3(mode,.FALSE.,neweq)\n!$ endif\n i2=i2+1\n line=' '\n if(gx%bmperr.ne.0) then\n write(kou,2051)gx%bmperr,neweq%eqno,neweq%eqname\n gx%bmperr=0\n elseif(idef.eq.1) then\n if(threads.eq.1) then\n jp=1\n do j3=1,nooftup()\n phtup=>phasetuple(j3)\n if(neweq%phase_varres(phtup%lokvares)%phstate.ge.PHENTSTAB) then\n call get_phasetup_name(j3,line(jp:))\n jp=len_trim(line)+2\n endif\n enddo\n endif\n call get_state_var_value('GMS ',gms,model,neweq)\n write(lut,2052)neweq%eqno,&\n trim(neweq%eqname),neweq%tpval(1),gms,trim(line)\n! Listing extra'\n call list_equilibrium_extra(lut,neweq,plotunit0)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0\n endif\n endif\n endif\n enddo paraloop\n!- $OMP end parallel do not needed???\n! OPENMP parallel end loop\n! allow composition sets to be created again\n!$ globaldata%status=ibclr(globaldata%status,GSNOACS)\n!$ globaldata%status=ibclr(globaldata%status,GSNOREMCS)\n endif gridmin\n call cpu_time(xxz)\n call system_clock(count=ll)\n xxy=ll-j4\n! or should i2 be used ??\n write(*,669)i2,(xxz-xxx)/i2,xxy/i2\n669 format(/'Calculated ',i8,' equlibria, average CPU and clock time',&\n F12.8,1x,F9.5)\n! repeat this until leak is zero, if leak negative never stop.\n leak=leak-1\n if(leak.ne.0) then\n goto 2060\n endif\n!\n call system_clock(count=ll)\n! ?? jp ?? write(kou,664)jp,xxz-xxx,ll-j4,threads\n write(kou,664)xxz-xxx,ll-j4,threads\n!664 format('Calculated equilibria out of ',i5/&\n664 format('Total CPU time: ',1pe12.4,' s and ',i7,' clockcycles',&\n ' using ',i4,' thread(s)')\n! this unit may have been used to extract calculated data for plotting\n if(plotunit0.gt.0) then\n write(kou,670)\n670 format('Closing a GNUPLOT file oc_many0.plt'/&\n 'that may need some editing before plotting')\n write(plotunit0,665)graphopt%plotend\n665 format('e'/a)\n!665 format('e'/'pause mouse'/)\n close(plotunit0)\n! UNFINISHED possibly we could reopen the file again and make oopies \n! of tha data to avoid manual editing\n endif\n else\n write(kou,*)'You must first SET RANGE of experimental equilibria'\n endif\n!---------------------------------------------------------------\n case(10) ! calculate with_check_after\n! this is same as \"calculate no_grid\" but with automatic grid check after\n! we must set global bit 18 and then clear it\n! If bit 20 is set we will clear it now and set it afterwards\n if(btest(globaldata%status,GSNORECALC)) then\n globaldata%status=ibclr(globaldata%status,GSNORECALC)\n temporary=.TRUE.\n else\n temporary=.FALSE.\n endif\n globaldata%status=ibset(globaldata%status,GSTGRID)\n! calculate with no grid before but check after\n call calceq2(0,ceq)\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n endif\n! reset bit GSTGRID and maybe GSNORECALC\n globaldata%status=ibclr(globaldata%status,GSTGRID)\n if(temporary) &\n globaldata%status=ibset(globaldata%status,GSNORECALC)\n!-------------------------------------------------------\n case(11) ! CALCUALTE TZERO\n! The degrees of freedom must be zero\n ll=degrees_of_freedom(ceq)\n if(ll.ne.0) then\n write(*,*)'You must have zero degrees of freedoms for this'\n goto 100\n endif\n write(kou,*)'You should have calculated an equilibrium',&\n ' close to the T0 point'\n! ask for 2 phases and which condition to vary\n! try to remember the phases ... user may try several times\n if(dummy(1:1).ne.' ') dummy=name2\n call gparcdx('First phase ',cline,last,1,name2,dummy,'?Tzero')\n call find_phase_by_name(name2,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n if(dummy(1:1).ne.' ') dummy=name3\n call gparcdx('Second phase ',cline,last,1,name3,dummy,'?Tzero')\n call find_phase_by_name(name3,iph2,ics)\n if(gx%bmperr.ne.0) goto 990\n dummy=name3\n call list_conditions(kou,ceq)\n if(tzcond.eq.0) then\n j2=1\n else\n j2=tzcond\n endif\n call gparidx('Release condition number',cline,last,tzcond,j2,'?Tzero')\n call tzero(iph,iph2,tzcond,xxx,ceq)\n if(gx%bmperr.ne.0) goto 990\n write(*,*)'Equal Gibbs energy at:'\n call list_conditions(kou,ceq)\n! a warning when list equilibria\n ceq%status=ibset(ceq%status,EQINCON)\n!-------------------------------------------------------\n! case(12) ! merged with case(14)\n!-------------------------------------------------------\n case(13) ! Only gridmin no merge\n! extract values for mass balance calculation from conditions\n call extract_massbalcond(ceq%tpval,xknown,totam,ceq)\n if(gx%bmperr.ne.0) goto 990\n! debug output\n! write(*,2101)totam,(xknown(j4),j4=1,noel())\n!2101 format('UI N&x: ',F6.3,9F8.5)\n! generate grid and find the phases and constitutions for the minimum.\n! Note: global_gridmin calculates for total 1 mole of atoms, not totam\n! call global_gridmin(1,ceq%tpval,totam,xknown,nv,iphl,icsl,&\n! iphl is dimensioned (1:maxel), maxel=100, it is destroyed inside merge_grid ..\n! call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,&\n! aphl,nyphl,yarr,cmu,iphl,ceq)\n temporary=.false.\n if(.not.btest(globaldata%status,GSNOMERGE)) then\n temporary=.true.\n globaldata%status=ibset(globaldata%status,GSNOMERGE)\n endif\n call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,&\n aphl,nyphl,cmu,ceq)\n if(temporary) globaldata%status=ibclr(globaldata%status,GSNOMERGE)\n if(gx%bmperr.ne.0) goto 990\n! In some cases \"c n\" converges better? if we scale with the total amount here??\n do j4=1,nv\n call get_phase_compset(iphl(j4),icsl(j4),lokph,lokcs)\n ceq%phase_varres(lokcs)%amfu=totam*ceq%phase_varres(lokcs)%amfu\n enddo\n! if set clear this bit so we can list the equilibrium\n if(btest(ceq%status,EQNOEQCAL)) ceq%status=ibclr(ceq%status,EQNOEQCAL)\n! write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv)\n! we should write phase tuples ... ?? \n write(kou,2102)nv,(iphl(j4),icsl(j4),j4=1,nv)\n!-------------------------------------------------------\n case(12,14) ! Calculate carefully the equilibrium (bosses_method)\n! extract values for mass balance calculation from conditions\n call system_clock(count=startoftime)\n call cpu_time(start2)\n call extract_massbalcond(ceq%tpval,xknown,totam,ceq)\n if(gx%bmperr.ne.0) goto 990\n call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,&\n aphl,nyphl,cmu,ceq)\n if(gx%bmperr.ne.0) goto 990\n j4=1\n if(kom.eq.14) j4=0\n! first parameter 0 means bosses_method, 1 means carefully\n call calculate_carefully(j4,ceq)\n if(gx%bmperr.ne.0) goto 990\n call system_clock(count=endoftime)\n call cpu_time(finish2)\n call get_state_var_value('GS ',xxx,name1,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n write(*,654)finish2-start2,endoftime-startoftime,xxx\n654 format('Final result: ',1pe12.4,' cpu seconds, ',&\n i7,' cc, G=',1pe15.7,' J/mol')\n!-------------------------------------------------------\n case(15) ! CALCULATE PARAEQUILIBRIUM\n write(kou,876)\n876 format('You should have calculated an equilibrium',&\n ' close to the paraequilibrium'/&\n 'and suspended all but the two phases involved')\n! ask for 2 phases and the fast diffusing element\n! try to remember the phases ... user may use the command several times\n if(dummy(1:1).ne.' ') dummy=name2\n call gparcdx('Matrix phase ',cline,last,1,name2,dummy,&\n '?Calculate paraeq')\n call find_phasetuple_by_name(name2,tupix(1))\n if(gx%bmperr.ne.0) goto 990\n if(dummy(1:1).ne.' ') dummy=name3\n call gparcdx('Growing phase ',cline,last,1,name3,dummy,&\n '?Calculate paraeq')\n call find_phasetuple_by_name(name3,tupix(2))\n if(gx%bmperr.ne.0) goto 990\n dummy=name3\n! call list_conditions(kou,ceq)\n call gparcdx('Fast diffusing element',cline,last,1,&\n elsym,parael,'?Calculate paraeq')\n call capson(elsym)\n call find_element_by_name(elsym,icond)\n parael=elsym\n call calc_paraeq(tupix,icond,xpara,meqrec,meqrec1,ceq)\n! set a warning when list result\n ceq%status=ibset(ceq%status,EQINCON)\n if(gx%bmperr.ne.0) goto 990\n write(kou,877)trim(elsym),xpara\n877 format(/'Paraequilibrium fractions of ',a,': ',2F10.6/&\n 'Please note that the phase amounts are not adjusted,',&\n ' only the compositions'/)\n! what are the conditions??\n! call list_conditions(kou,ceq)\n!-------------------------------------------------------\n case(16) ! CALCULATE LIQUID_EET, check how TZERO is calculated\n ll=degrees_of_freedom(ceq)\n if(ll.ne.0) then\n write(*,*)'You must have zero degrees of freedoms for this'\n goto 100\n endif\n write(kou,878)\n878 format(/'The Equi-Entropy T is the temperature where a solid phase ',&\n 'has the same entropy'/'as the liquid phase. This can be ',&\n 'considered as the limit of stability of the'/'solid phase ',&\n 'even if its Gibbs energy may become lower than the Gibbs ',&\n 'energy'/'of the liquid at an even higher T. This command ',&\n 'varies T or a composition'/'of the phase to find EET. ',&\n 'It may fail if there is no EET for the phase.'&\n //'You should have calculated an equilibrium',&\n ' close to the EET point already.')\n! ask for liquid and another phase name and a condition to vary\n! remember the phases ... a user may try several times\n dummy='LIQUID '\n call gparcdx('The liquid phase ',cline,last,1,name2,dummy,'?EET ')\n call find_phase_by_name(name2,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n if(dummy(1:1).ne.' ') dummy=name3\n call gparcdx('The solid phase ',cline,last,1,name3,dummy,'?EET ')\n call find_phase_by_name(name3,iph2,ics)\n if(gx%bmperr.ne.0) goto 990\n dummy=name3\n call list_conditions(kou,ceq)\n if(eetcond.eq.0) then\n j2=1\n else\n j2=eetcond\n endif\n call gparidx('Release condition number',cline,last,eetcond,j2,'?EET')\n call liquid_eet(iph,iph2,eetcond,xxx,ceq)\n if(gx%bmperr.ne.0) then\n! Failed calculation normally means T is negative, try to set it to 1\n! write(*,*)'Value of T: ',ceq%tpval(1), gx%bmperr\n! ceq%tpval(1)=one\n! does not change T ??? Why?\n goto 990\n endif\n write(*,'(/a)')'The two phases has equal entropy at:'\n call list_conditions(kou,ceq)\n! a warning when list equilibria\n ceq%status=ibset(ceq%status,EQINCON)\n!-------------------------------------------------------\n case(17) ! CALCULATE ??\n write(kou,*)'Not implemented yet'\n!-------------------------------------------------------\n case(18) ! CALCULATE ??\n write(kou,*)'Not implemented yet'\n END SELECT calculate\n!=================================================================\n! SET SUBCOMMANDS\n! ['CONDITION ','STATUS ','ADVANCED ',&\n! 'LEVEL ','INTERACTIVE ','REFERENCE_STATE ',&\n! 'QUIT ','ECHO ','PHASE ',&\n! 'UNITS ','LOG_FILE ','WEIGHT ',&\n! 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',&\n! 'VERBOSE ','AS_START_EQUILIB','BIT ',&\n! 'OPTCOEFF_VARIABL','OPTCOEFF_SCALED ','LMDIF_ACCURACY ',&\n! 'RANGE_EXPER_EQU ','OPTCOEFF_FIXED ','SYSTEM_VARIABLE ',&\n! 'INITIAL_T_AND_P ','LINEAR_SYSTEM ','GRID_GENERATOR ']\n CASE(3) ! SET SUBCOMMANDS\n! disable continue optimization\n! iexit=0\n! iexit(2)=1\n kom2=submenu(cbas(kom),cline,last,cset,ncset,1,'?TOPHLP')\n if(kom2.le.0) goto 100\n set: SELECT CASE(kom2)\n CASE DEFAULT\n write(kou,*)'Set subcommand error'\n!-----------------------------------------------------------------------\n CASE(1) ! set condition\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'You have no data!'\n goto 100\n endif\n call set_condition(cline,last,ceq)\n!------------------------------------------------------------------\n CASE(2) ! set status for elements, species, phases, constituents\n name1='STATUS of'\n kom3=submenu(name1,cline,last,cstatus,ncstat,3,'?TOPHLP')\n setstatus: SELECT CASE(kom3)\n!.................................................................\n CASE DEFAULT\n write(kou,*)'Set status subcommand error'\n!.................................................................\n case(1) ! set status element suspend/restore\n call gparcx('Element symbol: ',cline,last,1,name1,' ',&\n '?Set status element')\n call find_element_by_name(name1,iel)\n if(gx%bmperr.ne.0) goto 100\n call gparcdx('New status: ',cline,last,1,ch1,'SUSPEND',&\n '?Set status element')\n call capson(ch1)\n if(ch1.eq.'S') then\n call change_element_status(name1,1,ceq)\n else\n! restore element\n call change_element_status(name1,0,ceq)\n endif\n!.................................................................\n case(2) ! set status species suspend/restore\n call gparcx('Species symbol: ',cline,last,1,name1,' ',&\n '?Set status species')\n call find_species_record(name1,loksp)\n if(gx%bmperr.ne.0) goto 100\n call gparcdx('New status: ',cline,last,1,ch1,'SUSPEND',&\n '?Set status species')\n call capson(ch1)\n if(ch1.eq.'S') then\n call change_species_status(name1,1,ceq)\n else\n call change_species_status(name1,0,ceq)\n endif\n!.................................................................\n case(3) ! set status phase (ENTERED, FIX, DORMANT, SUSPEND or HIDDEN)\n! Now allow multiple phase names and *S, *D and *E\n! argument 5 means whole input line\n call gparcx('Phase name(s): ',cline,last,5,line,'=',&\n '?Set status phase')\n string=line\n3017 continue\n ll=index(string,'=')\n if(ll.eq.0) then\n call gparcx('More phase name(s): ',cline,last,5,line,'=',&\n 'Set status phase')\n string(len_trim(string)+2:)=line\n goto 3017\n endif\n!3018 continue\n! exttract first letter after = (if any)\n j4=ll\n call getext(string,j4,1,name1,' ',iph)\n ch1=name1(1:1)\n! if user has given \"=e 0\" then keep the amount is cline\n cline=string(j4:)\n string(ll:)=' '\n! write(*,*)'s1: ',j4,cline(1:len_trim(cline))\n if(ch1.eq.' ') then\n! if ll==1 then input was finished by equal sign, ask for status\n call gparcdx(&\n 'New status S(uspend), D(ormant), E(ntered) or F(ixed)?',&\n cline,last,1,name1,'E','?Set status phase')\n ch1=name1(1:1)\n else\n last=0\n endif\n nystat=99\n call capson(ch1)\n! new values of status ??\n if(ch1.eq.'S') nystat=phsus\n if(ch1.eq.'D') nystat=phdorm\n if(ch1.eq.'E') nystat=phentered\n if(ch1.eq.'F') nystat=phfixed\n! if(ch1.eq.'H') nystat=phhidden\n! no longer available if(ch1.eq.'N') nystat=5\n if(nystat.eq.99) then\n write(kou,*)'No such status'\n goto 100\n endif\n xxx=zero\n! write(*,*)'s2: ',last,cline(1:len_trim(cline))\n if(nystat.eq.phentered .or. nystat.eq.phfixed) then\n call gparrdx('Amount: ',cline,last,xxx,zero,&\n 'Set status phase amount')\n endif\n call change_many_phase_status(string,nystat,xxx,ceq)\n if(gx%bmperr.ne.0) goto 100\n!.................................................................\n CASE(4) ! set status constituent \n write(kou,*)'Not implemented yet'\n!.................................................................\n case(5) ! set status subcommand status for ?\n write(kou,*)'Not implemented yet'\n!.................................................................\n case(6) ! set status subcommand status for ?\n write(kou,*)'Not implemented yet'\n END SELECT setstatus\n!-----------------------------------------------------------\n case(3) ! set ADVANCED subcommands\n! default is WORKING_DIRECT\n! subsubcommands to SET ADVANCED\n! character (len=16), dimension(ncadv) :: cadv=&\n! ['EQUILIB_TRANSFER','QUIT ','SYMBOL ',&\n! 'GRID_DENSITY ','SMALL_GRID_ONOFF','MAP_SPECIALS ',&\n! 'GLOBAL_MIN_ONOFF','OPEN_POPUP_OFF ','WORKING_DIRECTRY',&\n! 'HELP_POPUP_OFF ','EEC_METHOD ','LEVEL ',&\n! 'NO_MACRO_STOP ','PROTECTION ','IGNORE_MACRO_ERR',&\n! 'XTDB_DEFAULTS ',' ',' ']\n name1='Advanced command'\n! kom3=submenu(name1,cline,last,cadv,ncadv,4,'?TOPHLP')\n! changed default to working_directory\n kom3=submenu(name1,cline,last,cadv,ncadv,9,'?TOPHLP')\n advanced: select case(kom3)\n!.................................................................\n CASE DEFAULT\n write(kou,*)'Set advanced subcommand error'\n!.................................................................\n! SET ADVANCED EQUILIB_TRANSFER\n! transfer a ceq record from map results%savedceq to eqlista\n! so it can be used interactivly\n case(1)\n if(.not.associated(maptop)) then\n write(kou,*)'There are no results from map or step'\n goto 100\n else\n write(kou,3100)maptop%saveceq%free-1\n3100 format('Saved ceq records from 1 to ',i3) \n endif\n write(kou,*)'To transfer CEQ from result area to current'\n call gparidx('Saved ceq number',cline,last,icon,1,&\n 'Set advanced transfer')\n if(icon.gt.0 .and. icon.lt.maptop%saveceq%free) then\n name1='COPIED_RESULTS_'\n i2=len_trim(name1)+1\n call wriint(name1,i2,icon)\n write(*,*)'Equilibrium name: ',i2,': ',name1\n call enter_equilibrium(name1,i1)\n if(gx%bmperr.ne.0) goto 990\n write(*,*)'Created equilibrium ',i1\n! note... this will overwrite the name ...\n eqlista(i1)=maptop%saveceq%savedceq(icon)\n! maybe not possible, eqlista is maybe protected ... no it is not\n write(*,*)'Trying to change name ...'\n eqlista(i1)%eqname=name1\n call selecteq(i1,ceq)\n else\n write(kou,*)'No such saved equilibrium'\n endif\n! set bit that data may be inconsistent\n eqlista(i1)%status=ibset(eqlista(i1)%status,EQINCON)\n!.................................................................\n case(2) ! quit\n continue\n!.................................................................\n case(3) ! SET ADVANCED SYMBOL to connect with TP constants\n! Set the SVCONST bit and allow setting a new value at the same time\n if(.not.allocated(firstash%eqlista)) then\n write(kou,*)'Not allowed as no assessment coefficients'\n goto 100\n endif\n call gparcx('Symbol name: ',cline,last,1,name1,' ',&\n '?Set adv symbol')\n call capson(name1)\n do svss=1,nosvf()\n if(name1(1:16).eq.svflista(svss)%name) exit\n enddo\n if(svss.gt.nosvf()) then\n write(kou,*)'No such symbol'; goto 100\n endif\n if(.not.btest(svflista(svss)%status,SVCONST)) then\n write(kou,*)'Can only be used for constants'; goto 100\n endif\n! Here the symbols can be set to be EXPORTED or EXPORTED to assess coeff\n call gparix('Coefficient index, 0-99?',cline,last,jp,0,&\n '?Export symbol')\n if(jp.le.0 .or. jp.gt.size(firstash%coeffvalues)) then\n write(*,*)'No such coefficent'; goto 100\n endif\n! nv is index to TP function for coefficient\n nv=firstash%coeffindex(jp)\n call gparcdx('Export or Import?',cline,last,1,ch1,'E',&\n 'EXPORT SYMBOL')\n if(ch1.eq.'E') then\n! UNFINISHED\n svflista(svss)%status=ibset(svflista(svss)%status,SVEXPORT)\n! use firstash% record to handle value transfer \n! probably more firstash variables should be set\n firstash%coeffvalues(jp)=svflista(svss)%svfv\n! trying to set bit and copy value to TPFUN\n! impossible as tpfuns is private to general_thermodynamic_package !!\n! tpfuns(nv)%status=ibset(tpfuns(nv)%status,TPEXPORT)\n! save the index to coefficient in %eqnoval !!\n svflista(svss)%eqnoval=jp\n else\n! UNFINISHED this must also set a bit in the TP function/assessment record\n svflista(svss)%status=ibset(svflista(svss)%status,SVIMPORT)\n! trying to set bit and copy value to TPFUN\n! tpfuns(nv)%status=ibset(tpfuns(nv)%status,TPIMPORT)\n endif\n!.................................................................\n case(4) ! SET ADVANCED GRID_DENSITY\n call gparidx('Level: ',cline,last,ll,1,'?Set adv grid-density')\n if(ll.eq.0) then\n! this set GSOGRID, small grid and clears GSXGRID\n globaldata%status=ibset(globaldata%status,GSOGRID)\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n globaldata%status=ibclr(globaldata%status,GSYGRID)\n write(kou,3110)'Sparse','set'\n elseif(ll.eq.1) then\n! DEFAULT, all gridbits are cleared\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n globaldata%status=ibclr(globaldata%status,GSOGRID)\n globaldata%status=ibclr(globaldata%status,GSYGRID)\n write(kou,3110)'Normal','set'\n3110 format(a,' grid ',a)\n elseif(ll.eq.2) then\n! set GSXGRID (and clear GSOGRID and GSYGRID)\n globaldata%status=ibclr(globaldata%status,GSOGRID)\n globaldata%status=ibset(globaldata%status,GSXGRID)\n globaldata%status=ibclr(globaldata%status,GSYGRID)\n write(kou,3110)'Dense','set'\n elseif(ll.eq.3) then\n! set GSYGRID (and clear GSXGRID and GSOGRID)\n globaldata%status=ibclr(globaldata%status,GSOGRID)\n globaldata%status=ibclr(globaldata%status,GSXGRID)\n globaldata%status=ibset(globaldata%status,GSYGRID)\n write(kou,3110)'Only level 0, 1 and 2 implemented'\n else\n write(*,*)'Only level 0, 1 and 2 implemented'\n endif\n!.................................................................\n case(5) ! SET ADVANCED SMALL_GRID_ONOFF\n! replaced by setting grid_density to 0\n write(*,*)'Please use SET ADVANCED GRID 0'\n continue\n! if(btest(globaldata%status,GSOGRID)) then\n! globaldata%status=ibclr(globaldata%status,GSOGRID)\n! write(kou,3110)'Small','reset'\n! else\n! set GSOGRID and clear GSXGRID if set\n! globaldata%status=ibclr(globaldata%status,GSXGRID)\n! globaldata%status=ibset(globaldata%status,GSOGRID)\n! write(kou,3110)'Small','set'\n! endif\n!.................................................................\n case(6) ! MAP_SPECIALS\n ll=mapglobalcheck\n if(ll.le.0) ll=10\n call gparidx('Global test interval during STEP/MAP?: ',&\n cline,last,mapglobalcheck,ll,'?Set adv global onoff')\n! if(nofixphfortip) then\n! write(*,*)'Always using fix phase when mapping'\n! nofixphfortip=.false.\n! else\n! write(*,*)'Map diagrams with tie-lines in phase ',&\n! 'without fix phase'\n! nofixphfortip=.true.\n! endif\n! write(*,*)'Not implemented yet'\n! write(*,*)'end of case 6'\n!.................................................................\n case(7) ! GLOBAL_MIN_ONOFF\n call gparcx('Turn global minimization off?: ',cline,last,&\n 1,ch1,'N','?Set adv global onoff')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n globaldata%status=ibset(globaldata%status,GSNOGLOB)\n write(*,*)'Global minimizer turned off'\n else\n globaldata%status=ibclr(globaldata%status,GSNOGLOB)\n write(*,*)'Global minimizer turned on'\n endif\n! if(btest(globaldata%status,GSNOGLOB)) then\n! globaldata%status=ibclr(globaldata%status,GSNOGLOB)\n! write(*,*)'Global minimizer turned on'\n! else\n! globaldata%status=ibset(globaldata%status,GSNOGLOB)\n! write(*,*)'Global minimizer turned off'\n! endif\n! write(*,*)'Not implemented yet'\n!.................................................................\n case(8) ! OPEN_POPUP_OFF\n call gparcdx('Turn off popup for open? ',cline,last,&\n 1,ch1,'Y','?Set adv open popup')\n if(ch1.eq.'Y') then\n! nopopup is declared in metlib3.F90 module\n! nopenpopup is declared in metlib3.F90 module\n nopenpopup=.TRUE.\n write(kou,*)'Popup windows for open files turned off'\n else\n nopenpopup=.FALSE.\n write(kou,*)'Popup windows for open files enabled'\n endif\n!.................................................................\n case(9) ! WORKING DIRECTORY\n write(kou,*)'Current working directory: ',trim(workingdir)\n write(kou,*)'To change please select an OCM file in the directory'\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! IMPORTANT: extensions also in utilities/ftinydialog.F90/ftinyopen !!!!\n! try to set current working directory as input to allow editing\n! cline=workingdir\n! last=len_trim(cline)\n! call gparcx('New: ',cline,last,1,string,trim(workingdir),&\n! '?Set adv workdir')\n! The promt here is never displayed ...\n ztyp=3\n call gparfilex('Select new working directory',&\n cline,last,1,string,' ',ztyp,'?Set adv workdir')\n inquire(file=string,exist=logok)\n if(.not.logok) then\n write(*,*)'No such directory, working directory not changed'\n elseif(trim(workingdir).ne.trim(string)) then\n! strip away any file name (up to last / or \\)\n j4=len_trim(string)\n ch1=string(j4:j4)\n! write(*,*)'P6 wdir: ',trim(string),' ',ch1,j4 \n do while(j4.gt.0 .and. .not.(ch1.eq.'/' .or. ch1.eq.'\\'))\n j4=j4-1\n ch1=string(j4:j4)\n! write(*,*)'P6 wdir: ',trim(string),' ',ch1,j4 \n enddo\n string(j4:)=' '\n! this is a gfortran special extension\n call chdir(string,i1)\n if(i1.ne.0) then\n write(*,*)'Failed change working directory',i1\n else\n write(*,'(a,a)')'New working directory: ',trim(string)\n workingdir=string\n endif\n endif\n! write(*,*)'Cannot be changed'\n!.................................................................\n case(10) ! HELP_POPUP_OFF\n call gparcdx('Turn off popup help? ',cline,last,&\n 1,ch1,'Y','?Set adv help popup')\n if(ch1.eq.'Y') then\n ochelp%htmlhelp=.FALSE.\n htmlhelp=.FALSE.\n else\n htmlhelp=.TRUE.\n string=browser\n call gparcdx('Browser including full path ',&\n cline,last,1,browser,string,'?Set adv help popup')\n string=htmlfile\n call gparcdx('HTML help file including full path ',&\n cline,last,1,htmlfile,string,'?Set adv help popup')\n call init_help(browser,htmlfile)\n if(.not.ochelp%htmlhelp) write(kou,*)&\n 'Error initiating html help'\n endif\n!.................................................................\n case(11) ! SET ADVANCED EEC_METHOD\n call gparcdx('Turn on equi-entropy criterion (EEC)?',&\n cline,last,1,ch1,'Y','?Set adv EEC')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n!check if there is a phase with liquid but set!!\n anyliq: do j4=1,noph()\n if(test_phase_status_bit(j4,PHLIQ)) exit anyliq\n enddo anyliq\n! if we have not found any liquid j4>noph() here !!\n if(j4.gt.noph()) then\n write(kou,*)'No liquid phase! Set bit 10 of liquid phase'\n goto 100\n endif\n call gparrdx('Low T limit (min 10)?',cline,last,xxx,1.0D3,&\n '?Set adv EEC')\n if(xxx.gt.1.0D1) then\n! set_eec_check is in minimizer/matsmin.F90\n! call set_eec_check(xxx)\n globaldata%sysreal(1)=xxx\n endif\n else\n write(*,*)'EEC method for solids turned off as answer not Y'\n! call set_eec_check(zero)\n globaldata%sysreal(1)=zero\n endif\n!.................................................................\n case(12) ! SET ADVANCED LEVEL\n call gparcdx('I am an beginner of OC: ',cline,last,1,ch1,'N',&\n '?Set adv level')\n if(ch1.eq.'Y') then\n globaldata%status=ibset(globaldata%status,1)\n write(*,*)'Bon courage!'\n else\n call gparcdx('I am an expert of OC: ',cline,last,1,ch1,'N',&\n '?Set adv level')\n if(ch1.eq.'Y') then\n globaldata%status=ibset(globaldata%status,2)\n write(*,*)'Felicitations!'\n else\n write(*,*)'Sorry, not yet'\n endif\n endif\n!.................................................................\n case(13) ! NO_MACRO_STOP on/off\n call gparcdx('Ignore macro @&: ',cline,last,1,ch1,'Y',&\n '?Set adv no-macro-stop')\n! iox(8) is declared in metlib4\n if(ch1.ne.'Y') then\n iox(8)=0\n else\n iox(8)=1\n endif\n!.................................................................\n case(14) ! PROTECTION\n call gparrdx('Code',cline,last,proda,zero,'?Set adv protect')\n call gparrdx('Privilege',cline,last,privilege,zero,&\n '?Set adv protect')\n!.................................................................\n case(15) ! IGNORE_MACRE_ERRORS normally a macro error returns inter\n continue\n!.................................................................\n case(16) ! SET ADVANCED XTDB_DEFAULTS\n dummy=lowtdef\n call gparcdx('Default low T limit',cline,last,1,lowtdef,dummy,&\n '?Set adv xtdb')\n unary1991=.FALSE.\n if(lowtdef.eq.'298.15 ') unary1991=.TRUE.\n dummy=hightdef\n call gparcdx('Default high T limit',cline,last,1,hightdef,dummy,&\n '?Set adv xtdb')\n ch1='N'\n call gparcdx('Include model descriptions (Y to include)',&\n cline,last,1,chz,ch1,'?Set adv xtdb')\n if(chz.eq.'Y') then\n includemodels=.TRUE.\n else\n includemodels=.FALSE.\n endif\n dummy=eldef\n call gparcdx('Default elements (NONE to remove)',&\n cline,last,1,eldef,dummy,'?Set adv xtdb')\n if(dummy(1:5).eq.'NONE ') eldef=' '\n dummy=bibrefdef\n! argument 4 equal to 5 means the whole line is read\n call gparcdx('Default bibiographic reference (One line!)',&\n cline,last,5,bibrefdef,dummy,'?Set adv xtdb')\n!.................................................................\n case(17) ! nit used\n continue\n!.................................................................\n case(18) ! not used\n continue\n end select advanced\n!-----------------------------------------------------------\n case(4) \n write(*,*)'Unused'\n!-----------------------------------------------------------\n! end of macro excution (can be nested)\n case(5) ! set INTERACTIVE\n call macend(cline,last,logok) \n! if this was the startupmacro set it false and possibly read an inline macro ..\n! NOTE a startup macro can call other macros ...\n if(kiu.eq.kiud) startupmacro=.false.\n! macropath=' '\n! write(*,*)'Macro terminated'\n!-----------------------------------------------------------\n case(6) ! set REFERENCE_STATE\n call gparcx('Component name: ',cline,last,1,name1,' ',&\n '?Set reference phase')\n call find_component_by_name(name1,iel,ceq)\n if(gx%bmperr.ne.0) goto 100\n call gparcx('Reference phase: ',cline,last,1,name1,'SER ',&\n '?Set reference phase')\n if(name1(1:4).eq.'SER ') then\n write(kou,*)'Reference state is stable phase at 298.15 K and 1 bar'\n! this means no reference phase, SER is at 298.15K and 1 bar\n iph=-1\n else\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 100\n! temperature * means always to use current temperature\n xxy=-one\n call gparrx('Temperature: /*/: ',cline,last,xxx,xxy,&\n '?Set reference phase')\n! write(*,*)'problem: ',buperr,xxx,xxy,one\n! when calling gparr the default was not \"set\" as default and rubbish returned\n! now the default is always the default even if not shown\n if(buperr.ne.0) then\n buperr=0\n tpa(1)=-one\n elseif(xxx.le.zero) then\n tpa(1)=-one\n else\n tpa(1)=xxx\n endif\n xxy=1.0D5\n call gparrdx('Pressure: ',cline,last,xxx,xxy,&\n '?Set reference phase')\n if(xxx.le.zero) then\n tpa(2)=xxy\n else\n tpa(2)=xxx\n endif\n endif\n call set_reference_state(iel,iph,tpa,ceq)\n if(gx%bmperr.eq.0) then\n! write(kou,3104)\n3104 format(' You may have to make a new calculation before the',&\n ' correct values'/&\n ' of chemical potentials or other properties are shown.')\n endif\n!-----------------------------------------------------------\n case(7) ! quit\n goto 100\n!-----------------------------------------------------------\n case(8) ! set ECHO\n call gparcdx('On?',cline,last,1,ch1,'Y','?Set echo')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n j4=1\n else\n j4=0\n endif\n call set_echo(j4)\n!-----------------------------------------------------------\n case(9) ! set PHASE subcommands (constitution, status)\n call gparcx('Phase name: ',cline,last,1,name1,' ',&\n '?Set phase')\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) then\n if(name1(1:2).eq.'* ') then\n iph=-1\n gx%bmperr=0\n else\n goto 990\n endif\n endif\n! kom3=submenu(cbas(kom),cline,last,csetph,nsetph,2,'?TOPHLP')\n! write(*,*)'submenu promt: ',cbas(kom)\n kom3=submenu('Set for phase what?',cline,last,csetph,nsetph,2,&\n '?TOPHLP')\n setphase: SELECT CASE(kom3)\n CASE DEFAULT\n write(kou,*)'Set phase status subcommand error'\n goto 100\n!............................................................\n case(1) ! quit\n continue\n!............................................................\n! begin code copied from 3045\n case(2) ! SET PHASE STATUS \n if(iph.gt.0) then\n j4=get_phase_status(iph,ics,text,i1,xxx,ceq)\n if(gx%bmperr.ne.0) goto 100\n if(xxx.ge.zero) then\n write(kou,3046)text(1:i1),xxx\n3046 format('Current status is ',a,' with ',1pe15.6,&\n ' formula units.')\n else\n write(kou,3047)text(1:i1)\n3047 format('Current status is ',a)\n endif\n endif\n call gparcdx(&\n 'Suspend, Dormant, Entered, Fixed, Hidden or Not hidden?',&\n cline,last,1,ch1,'SUSPEND','?Set phase status')\n nystat=99\n call capson(ch1)\n! new values of status ??\n if(ch1.eq.'E') nystat=phentered\n if(ch1.eq.'S') nystat=phsus\n if(ch1.eq.'D') nystat=phdorm\n if(ch1.eq.'F') nystat=phfixed\n if(ch1.eq.'H') nystat=phhidden\n! not avail if(ch1.eq.'N') nystat=5\n if(nystat.eq.99) then\n write(kou,*)'No such status'\n goto 100\n endif\n xxx=zero\n if(nystat.eq.phentered .or. nystat.eq.phfixed) then\n call gparrdx('Amount: ',cline,last,xxx,zero,&\n '?Set phase amount')\n endif\n call change_phase_status(iph,ics,nystat,xxx,ceq)\n if(gx%bmperr.ne.0) goto 100\n if(iph.gt.0) then\n j4=get_phase_status(iph,ics,text,i1,xxy,ceq)\n if(gx%bmperr.ne.0) goto 100\n if(xxy.ge.zero) then\n write(kou,3048)text(1:i1),xxy\n3048 format('New status is ',a,' with ',1pe15.6,&\n ' formula units.')\n else\n write(kou,3049)text(1:i1)\n3049 format('New status is ',a)\n endif\n else\n write(kou,*)'New status set for all phases'\n endif\n! end code copied from 3045\n!............................................................\n case(3:4) !set phase default_constit wildcard allowed, also AMOUNT\n! write(*,*)'SET PHASE AMOUNT or DEFAULT_CONST',kom3,iph,ics\n if(kom3.eq.3) then\n! set default constituntion of phase\n! call set_default_constitution(iph,ics,ceq)\n call ask_default_constitution(cline,last,iph,ics,ceq)\n else\n! set phase amount\n call gparrdx('Amount: ',cline,last,xxx,zero,&\n '?Set phase constitution')\n call set_phase_amounts(iph,ics,xxx,ceq)\n endif\n!............................................................\n! subsubsub command\n case(5) ! set phase bits\n if(iph.lt.0) then\n write(kou,*)'Wildcards not allowed in this case'\n goto 100\n endif\n call get_phase_record(iph,lokph)\n kom4=submenu('Set which bit?',cline,last,csetphbits,nsetphbits,9,&\n '?TOPHLP')\n phasebit: SELECT CASE(kom4)\n CASE DEFAULT\n! allow any bit changes for experts ...\n if(btest(globaldata%status,GSADV)) then\n call getint(cline,last,ll)\n if(ll.ge.0 .and. ll.le.31) then\n write(kou,*)'Ahh, you are an expert ... changing bit: ',ll\n if(test_phase_status_bit(lokph,ll)) then\n call clear_phase_status_bit(lokph,ll)\n write(kou,*)'Clearing bit ',ll\n else\n call set_phase_status_bit(lokph,ll)\n endif\n else\n write(kou,*)'Illegal bit number',ll\n endif\n else\n write(kou,*)'Set phase bit subcommand error'\n endif\n!............................................................\n case(1) ! FCC_PERMUTATIONS FORD\n! if check returns .true. it is not allowed to set FORD or BORD\n if(check_minimal_ford(lokph)) goto 100\n write(*,*)' *** WARNING: Depreceated command, use AMEND PHASE'\n call set_phase_status_bit(lokph,PHFORD)\n case(2) ! BCC_PERMUTATIONS BORD\n if(check_minimal_ford(lokph)) goto 100\n write(*,*)' *** WARNING: Depreceated command, use AMEND PHASE'\n call set_phase_status_bit(lokph,PHBORD)\n case(3) ! IONIC_LIQUID_MDL this may require tests and \n! other bits changed ..\n write(*,*)' *** WARNING: set by enter phase I2SL'\n! write(kou,*)'Cannot be set interactivly yet, only from TDB'\n! call set_phase_status_bit(lokph,PHIONLIQ)\n case(4) ! AQUEOUS_MODEL \n write(*,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHAQ1)\n case(5) ! QUASICHEMICAL \n write(*,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHQCE)\n case(6) ! FCC_CVM_TETRADRN\n write(*,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHCVMCE)\n case(7) ! FACT_QUASICHEMCL\n write(*,*)'Not implemented yet'\n! call set_phase_status_bit(lokph,PHFACTCE)\n case(8) ! NO_AUTO_COMP_SET, do not create compsets automatically\n call set_phase_status_bit(lokph,PHNOCS)\n case(9) ! QUIT\n write(kou,*)'No other bits changed'\n case(10) ! EXTRA_DENSE_GRID, this can be toggled ...\n if(test_phase_status_bit(lokph,PHXGRID)) then\n write(kou,*)'Bit already set, is cleared'\n call clear_phase_status_bit(lokph,PHXGRID)\n else\n write(kou,*)'Extra gridpoints for this phase.'\n call set_phase_status_bit(lokph,PHXGRID)\n endif\n case(11) ! PHEECLIQ bit for EEC phase\n! call set_phase_status_bit(lokph,PHFHV)\n write(*,*)'Bit for set for EEC liquid'\n call set_phase_status_bit(lokph,PHEECLIQ)\n call clear_phase_status_bit(lokph,PHID)\n end SELECT phasebit\n!............................................................\n case(6) ! SET PHASE ... CONSTITUTION iph and ics set above\n call ask_phase_new_constitution(cline,last,iph,ics,lokcs,ceq)\n END SELECT setphase\n!-------------------------------------------------------------\n case(10) ! set UNIT (for state variables)\n write(kou,*)'Not implemented yet'\n!-------------------------------------------------------------\n case(11) ! set LOG_FILE\n! tinyfiles_dialog has difficult returning a non-existant file name\n! the argument \"-8\" means open a log file for output\n maptopbug=.true.\n if(associated(maptop)) then\n! write(*,*)'PMON maptop bug 1A?',associated(maptop)\n maptopbug=.false.\n endif\n ztyp=-8\n call gparfilex('Log file name: ',cline,last,1,model,'oclog',ztyp,&\n '?Set logfile')\n name1=model(1:5)\n call capson(name1)\n if(maptopbug .and. associated(maptop)) then\n! for unkown reason maptop has become associated here but was not 8 lines above!\n! write(*,*)'PMON maptop bug 1B?',associated(maptop)\n nullify(maptop)\n write(*,*)'PMON clear link to maptop'\n endif\n if(name1(1:5).eq.'NONE ') then\n! close log file\n call openlogfile(' ',' ',-1)\n logfil=0\n write(*,*)'Log file closed'\n else\n if(len_trim(model).eq.0) then\n model='OCLOG.LOG'\n elseif(index(model,'.LOG ').eq.0) then\n! model=trim(model)//'./OCLOG.LOG'\n model=trim(model)//'.LOG'\n endif\n! write(*,*)'PMON maptop bug 1D?',associated(maptop)\n write(*,*)'Setting logfile to: \"',trim(model),'\"'\n call gparcx('Title: ',cline,last,5,line,' ','?Set logfile')\n call openlogfile(model,line,39)\n! write(*,*)'PMON maptop bug 1D?',associated(maptop)\n if(buperr.ne.0) then\n write(kou,*)'Error opening logfile: ',buperr\n logfil=0\n else\n write(*,'(a,a)')'Commands will be logged in file ',trim(model)\n logfil=39\n endif\n endif\n! write(*,*)'PMON maptop bug 2?',associated(maptop)\n!-------------------------------------------------------------\n case(12) ! set weight\n if(.not.allocated(firstash%eqlista)) then\n write(kou,*)'You must first set a range of experimental equilibria'\n goto 100\n endif\n! NOTE mexp must be updated to the correct number of EXPERIMENTS\n! that is done by OPTIMIZE\n updatemexp=.true.\n mexp=0\n call gparrdx('Weight ',cline,last,xxx,one,'?Set weight')\n if(buperr.ne.0) goto 100\n! The weight must be 0 or positive\n xxx=abs(xxx)\n call gparcdx('Equilibria (abbrev name) or range: ',cline,last,&\n 1,name1,'CURRENT','?Set weight')\n! THINK HOW TO UPDATE MEXP!!! <<<<<<<<<<<<<<<<<<\n if(name1(1:8).eq.'CURRENT ') then\n if(ceq%eqname(1:20).eq.'DEFAULT_EQUILIBRIUM ') then\n write(kou,*)'You cannot set weight for the default equilibrium'\n else\n ceq%weight=xxx\n endif\n elseif(name1(1:1).eq.'*') then\n! set this weight for all\n i2=0\n do i1=1,size(firstash%eqlista)\n firstash%eqlista(i1)%p1%weight=xxx\n i2=i2+1\n enddo\n write(kou,3066)i2\n else\n ll=1\n! write(*,*)'trying to extract a number from: ',trim(name1)\n call getint(name1,ll,i1)\n bupp: if(buperr.eq.0) then\n! user provide a singe number or a range, if range the negative number also\n call getint(name1,ll,i2)\n if(buperr.ne.0) then\n! it was a single number \n buperr=0\n i2=-i1\n endif\n i2=-i2\n ll=0\n! setwei: do j4=i1,i2\n setwei: do j4=1,size(firstash%eqlista)\n if(firstash%eqlista(j4)%p1%eqno.ge.i1 .and. &\n firstash%eqlista(j4)%p1%eqno.le.i2) then\n firstash%eqlista(j4)%p1%weight=xxx\n! write(*,*)'Changing weight for equilibrium ',&\n! firstash%eqlista(j4)%p1%eqno\n ll=ll+1\n endif\n enddo setwei\n write(kou,3066)ll\n else\n! set this weight to all equilibria with name abbriviations fitting name1\n buperr=0\n call capson(name1)\n if(name1(1:1).ne.' ') then\n write(*,*)'Equilibra with names matching: ',trim(name1)\n i2=0\n do i1=1,size(firstash%eqlista)\n if(index(firstash%eqlista(i1)%p1%eqname,&\n name1(1:len_trim(name1))).gt.0) then\n firstash%eqlista(i1)%p1%weight=xxx\n i2=i2+1\n endif\n enddo\n else\n write(*,*)'No name given'\n endif\n write(kou,3066)i2\n endif bupp\n3066 format('Changed weight for ',i5,' equilibria')\n endif\n!-------------------------------------------------------------\n! turn on/off global minimization, creating composition sets\n! convergence limits, iterations, minimum constituent fraction, etc\n case(13) ! set NUMERIC_OPTIONS\n i2=ceq%maxiter\n call gparidx('Max number of iterations: ',cline,last,i1,i2,&\n '?Set numeric')\n if(i1.gt.0) then\n ceq%maxiter=i1\n endif\n!------------\n xxx=ceq%xconv\n call gparrdx('Max error in fraction: ',cline,last,xxy,xxx,&\n '?Set numeric')\n!CCI\n if(xxy.gt.default_minxconv) then\n ceq%xconv=xxy\n else\n ceq%xconv=default_minxconv\n endif\n!CCI\n!------------ what is this? not used in gtp3X.F90\n xxx=ceq%gdconv(1)\n call gparrdx('Max cutoff driving force: ',cline,last,xxy,xxx,&\n '?Set numeric')\n if(xxy.gt.default_mingdconv) then\n ceq%gdconv(1)=xxy\n!CCI\n else\n ceq%gdconv(1)=default_mingdconv\n!CCI\n endif\n!------------ if the point between two gridpoints in a phase is less then merge\n xxx=ceq%gmindif\n call gparrdx('Min difference merging gridpoints: ',cline,last,&\n xxy,xxx,'?Set numeric')\n!CCI\n!strange old value was 1000 times lower -1e-5 in the test vs -1.e-2 as default\n if(xxy.gt.default_mingridmin) then\n ceq%gmindif=xxy\n else\n ceq%gmindif=default_mingridmin\n endif\n!CCI\n!-------------------------------------------------------------\n case(14) ! set axis\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'You have no data!'\n goto 100\n endif\n i1=noofaxis+1\n call gparidx('Axis number',cline,last,iax,i1,'?Set axis')\n if(iax.lt.1 .or. iax.gt.maxax) then\n write(kou,3300)maxax\n3300 format('Axis number must be between 1 and ',i1)\n goto 100\n endif\n! by giving a value of iax lesser than noofaxis one can change an already\n! defined axis, values larger than i1 (=noofaxis+1) not allowed.\n if(iax.gt.i1) then\n iax=i1\n write(kou,*)'Axis must be set in sequential order',&\n ', axis number set to ',iax\n endif\n! as condition one may give a condition number followed by :\n! or a single state variable like T, x(o) etc.\n if(iax.lt.i1) then\n! set the current condition as default answer\n jp=1\n call get_one_condition(jp,name1,axarr(iax)%seqz,ceq)\n if(gx%bmperr.ne.0) goto 990\n jp=index(name1,'=')\n name1(jp:)=' '\n! set current axis limits as default\n dmin=axarr(iax)%axmin\n dmax=axarr(iax)%axmax\n else\n! new axis, defaults 0 and 1\n name1=' '\n dmin=zero\n dmax=one\n endif\n! reset default plot options\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n call gparcdx('Condition varying along axis: ',cline,last,1,&\n text,name1,'?Set axis')\n call capson(text)\n! if(text(1:1).eq.' ') goto 100\n removeaxis: if(text(1:1).eq.' ' .or. text(1:4).eq.'NONE') then\n! this means remove an axis, shift any higher axis down\n if(iax.lt.noofaxis) write(kou,*)'Shifting axis down'\n do i2=iax,noofaxis\n axarr(i2)=axarr(i2+1)\n enddo\n if(noofaxis.gt.1) then\n noofaxis=noofaxis-1\n write(kou,*)'One axis removed'\n! remove axplotdef for all axis!!! one may change from PD to step sep\n axplotdef=' '\n endif\n goto 100\n elseif(trim(name1).eq.trim(text)) then\n! check if same variable, quit this IF loop\n continue\n else ! changed axis variable, set default limits\n dmin=zero\n dmax=one\n i1=len_trim(text)\n if(text(i1:i1).eq.':') then\n! condition given as an index in the condition list terminated by : like \"1:\"\n i1=1\n call getrel(text,i1,xxx)\n if(buperr.ne.0) then\n gx%bmperr=buperr; goto 990\n endif\n i2=int(xxx)\n firstc=>ceq%lastcondition\n if(associated(firstc)) then\n firstc=>firstc%next\n pcond=>firstc%next\n i1=0\n do while(.not.associated(pcond,firstc))\n! increment i1 only for active conditions as listed by list_condition\n if(pcond%active.eq.0) i1=i1+1\n if(i1.eq.i2) goto 3310\n pcond=>pcond%next\n enddo\n gx%bmperr=4131; goto 990\n3310 continue\n else\n gx%bmperr=4131; goto 990\n endif\n! pcond points to condition record for axis, save in (map_axis) :: axarr\n! check that it is not a fix phase condition (istv negative)\n if(pcond%statev.lt.0) then\n write(*,*)'Cannot set fix phase as axis'\n goto 100\n endif\n! copy the state variable to the axis record\n allocate(axarr(iax)%axcond(1))\n axarr(iax)%axcond(1)=pcond%statvar(1)\n! This is probably the only reference needed for the axis condition\n axarr(iax)%seqz=pcond%seqz\n axarr(iax)%more=0\n! remove axplotdef for all axis!!! \n axplotdef=' '\n else ! a condition given as text\n! check if axis variable is a condition, maybe create it if allowed\n! write(*,*)'decoding axis condition: ',text(1:20)\n stvr=>stvrvar\n! this call also accept state variable functions like t_c, cp (if entered)\n! UNIFINISHED: but it also accepts unknown texts ... \n call decode_state_variable(text,stvr,ceq)\n if(gx%bmperr.ne.0) goto 990\n! write(*,*)'check if this state variable is a condition'\n pcond=>ceq%lastcondition\n i1=1; coeffs(1)=one\n! call get_condition(i1,coeffs,istv,indices,iref,unit,pcond)\n call get_condition(i1,stvr,pcond)\n if(gx%bmperr.ne.0) then\n! if new conditions are allowed then maybe enter this as condition\n write(*,*)'You must set the variable as a condition',&\n ' before setting it as axis'\n goto 990\n endif\n axarr(iax)%nterm=pcond%noofterms\n axarr(iax)%istv=pcond%statev\n axarr(iax)%iref=pcond%iref\n axarr(iax)%iunit=pcond%iunit\n! copy the state variable record to the axis record\n if(.not.allocated(axarr(iax)%axcond)) then\n allocate(axarr(iax)%axcond(1))\n endif\n axarr(iax)%axcond(1)=pcond%statvar(1)\n axarr(iax)%seqz=pcond%seqz\n! write(*,*)'Condition sequential index: ',axarr(iax)%seqz\n axarr(iax)%more=0\n! remove axplotdef for all axis!!! \n axplotdef=' '\n endif\n endif removeaxis\n! dmin=axvalold(1,iax)\n! dmin=zero\n once=.TRUE.\n3570 continue\n call gparrdx('Minimal value:',cline,last,xxx,dmin,'?Set axis')\n if(buperr.ne.0) goto 100\n axarr(iax)%axmin=xxx\n! axval(1,iax)=xxx\n! dmax=axvalold(2,iax)\n! dmax=one\n call gparrdx('Maximal value:',cline,last,xxx,dmax,'?Set axis')\n if(buperr.ne.0) goto 100\n if(xxx.le.axarr(iax)%axmin) then\n write(kou,*)'Maximal value must be higher than minimal'\n if(once) then\n once=.FALSE.\n goto 3570\n else\n write(kou,*)'Return to command level'\n goto 100\n endif\n endif\n axarr(iax)%axmax=xxx\n! axval(2,iax)=xxx\n! default step 1/100 of difference ?? several diagram failed ...\n! default step 1/40 of difference, same as TC ...\n dinc=0.025*(axarr(iax)%axmax-axarr(iax)%axmin)\n! default step 1/50 of difference, somethimes better, sometimes worse ...\n! dinc=0.02*(axarr(iax)%axmax-axarr(iax)%axmin)\n call gparrdx('Increment:',cline,last,xxx,dinc,'?Set axis')\n if(buperr.ne.0) goto 100\n if(xxx.lt.0.01*dinc) then\n! someone (me) set xxx=0 and got a lot of trouble ...\n write(*,*)'Too small increment not allowed.'\n xxx=0.01*dinc\n endif\n axarr(iax)%axinc=xxx\n! iax can be smaller than noofaxis if an existing axis has been changed\n if(iax.gt.noofaxis) noofaxis=iax\n! write(*,3602)(axval(i,iax),i=1,3)\n!3602 format(/'axlimits: ',3(1pe12.4))\n!-------------------------------------------------------------\n case(15) ! set input amounts\n call set_input_amounts(cline,last,ceq)\n!-------------------------\n case(16) ! SET VERBOSE\n! This toggles verbose for all commands.\n! it is always turned of fwhen a command is finished ...\n! write(kou,3603)'on/off',globaldata%status,GSVERBOSE\n if(btest(globaldata%status,GSSILENT)) then\n! turn off VERBOSE and turn on SILENT\n! globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n globaldata%status=ibclr(globaldata%status,GSSILENT)\n write(kou,3603)'off',globaldata%status\n else\n! turn on VERBOSE\n! globaldata%status=ibset(globaldata%status,GSVERBOSE)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n write(kou,3603)'on',globaldata%status,GSSILENT\n endif\n3603 format('Silent is turned ',a,2x,z8,i5)\n! if(ocv()) then\n! write(kou,*)'Verbose mode on'\n! else\n! write(kou,*)'Verbose mode off'\n! endif\n!-------------------------\n! the current set of condition sill be used as start equilibrium for map/step\n! Calculate the equilibrium and ask for a direction.\n case(17) ! SET AS_START_EQUILIBRIUM\n if(noofaxis.lt.2) then\n write(kou,*)'You must set two axis first'\n goto 100\n endif\n call calceq2(1,ceq)\n if(gx%bmperr.ne.0) goto 990\n call gparidx('Give an axis direction: ',cline,last,ndl,2,&\n '?Set as start equil')\n if(buperr.ne.0) goto 990\n if(abs(ndl).gt.noofaxis) then\n write(kou,*)'Direction must be +/- axis number'\n goto 100\n endif\n! Store a copy of equilibrium and the direction in a equential list\n! starting with starteq\n eqname='_START_EQUILIBRIUM_'\n jp=len_trim(eqname)+1\n noofstarteq=noofstarteq+1\n call wriint(eqname,jp,noofstarteq)\n call copy_equilibrium(neweq,eqname,ceq)\n if(gx%bmperr.ne.0) goto 990\n neweq%multiuse=ndl\n starteqs(noofstarteq)%p1=>neweq\n! if(associated(starteq)) then\n! starteq%nexteq=neweq%eqno\n! else\n! starteq=>neweq\n! starteq%nexteq=0\n! write(*,*)'Starteq next',starteq%nexteq\n! endif\n write(*,*)'A copy of current equilibrium linked as start eqilibrium'\n!-------------------------\n case(18) ! SET BIT (all kinds of bits) just global implemented\n! ['EQUILIBRIUM ','GLOBAL ','PHASE ',&\n kom3=submenu('Set which status word?',cline,last,csetbit,nsetbit,2,&\n '?TOPHLP')\n setbit: SELECT CASE(kom3)\n CASE DEFAULT\n write(kou,*)'SET BIT subcommand error'\n!................................................................\n case(1) ! equilibrium status word\n! EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, &\n! EQFAIL=4, EQNOACS=5, EQGRIDTEST=6, EQGRIDCAL=7\n3610 continue\n! write(kou,*)'Current equlibrium status: ',ceq%status\n write(kou,3612)ceq%status\n call gparidx('Which bit? ',cline,last,ll,-1,'?Set status bit')\n if(cline(1:1).eq.'?') then\n write(kou,3612)ceq%status\n3612 format('Set/reset bits of the equilibrium status word,',/&\n 'Bit If set means',/&\n ' 0 No threads allowed (no parallel calculation)',/&\n ' 1 No global minimization allowed',/&\n ' 2 No equilibrium has been calculated',/&\n ' 3 Conditions and results not consistent',/'-'/&\n ' 4 Last equilibrium calculation failed',/&\n ' 5 No automatic generation of composition sets',/&\n ' 6 Equilibrim tested by global minimizer',/&\n ' 7 Last results are from a grid minimization'/&\n 'Current value of status word: ',z8)\n goto 3610\n endif\n if(ll.lt.0 .or. ll.gt.7) then\n write(kou,*)'No such bit, no bit changed'\n else\n call gparcdx('Do you want to set the bit?',cline,last,1,&\n ch1,'Y','?Set status bit')\n if(ch1.eq.'Y') then\n ceq%status=ibset(ceq%status,ll)\n write(kou,3614)'set',ceq%status\n3614 format('Bit ',a,', new equilibrium status word: ',z8)\n else\n ceq%status=ibclr(ceq%status,ll)\n write(kou,3614)'cleared',ceq%status\n endif\n endif\n! write(*,*)'Not implemented yet'\n!................................................................\n! maybe change order of questions, maybe check name exits etc ....\n case(2) ! global status word\n3708 continue\n! subroutine TOPHLP forces return with ? in position cline(last:last)\n write(kou,3709)globaldata%status\n3709 format('Current global status word (hexadecimal): ',z8)\n call gparidx('Set/reset global status bit (from 0-31, -1 quits):',&\n cline,last,ll,-1,'?Global status bits')\n if(cline(1:1).eq.'?') then\n write(kou,3710)\n3710 format('Set/reset bits of global status word ',&\n ' (only experts should change these) '/&\n 'Bit If set means:'/&\n ' 0 user is a beginner'/&\n ' 1 user is experienced'/&\n ' 2 user is an expert'/&\n ' 3 global minimizer will not be used'/'-'/&\n ' 4 global minimizer must not merge comp.sets.'/&\n ' 5 there are no data'/&\n ' 6 there are no phases'/&\n ' 7 comp.sets must not be created automatically'/'-'/&\n ' 8 comp.sets must not be deleted automatically'/&\n ' 9 data has changed since last save'/&\n '10 verbose is on'/&\n '11 verbose is permanently on'/'-'/&\n '12 supress warning messages'/&\n '13 no cleanup after an equilibrium calculation'/&\n '14 denser grid used in grid minimizer'/&\n '15 calculations in parallel is not allowed'/'-'/&\n '16 no global test at node points during STEP/MAP'/&\n '17 the components are not the elements'/&\n '18 test if equilibrium global AFTER calculation'/&\n '19 use old grid minimizer'/'-'/&\n '20 do not recalculate if global test AFTER fails'/&\n '21 use old map algorithm'/&\n '22 no automatic startpoints for MAP'/&\n '23-31 unused')\n goto 3708\n endif\n if(ll.lt.0 .or. ll.gt.31) then\n write(kou,*)'No bit changed'\n elseif(btest(globaldata%status,GSADV) .or. ll.le.2) then\n! user must have expert bit set to change any other bit than the user type bit\n call gparcdx('Do you want to set the bit?',cline,last,1,&\n ch1,'Y','?Global status bits')\n if(ch1.eq.'Y') then\n globaldata%status=ibset(globaldata%status,ll)\n write(kou,3617)ll,' set',globaldata%status\n3617 format('Bit ',i2,a,', new equilibrium status word: ',z8)\n else\n globaldata%status=ibclr(globaldata%status,ll)\n write(kou,3617)ll,' cleared',globaldata%status\n endif\n! replaced by question above\n! if(btest(globaldata%status,ll)) then\n! globaldata%status=ibclr(globaldata%status,ll)\n! write(*,3711)'cleared',globaldata%status\n!3711 format('Bit ',a,', new value of status word: ',z8)\n! else\n! globaldata%status=ibset(globaldata%status,ll)\n! write(*,3711)'set',globaldata%status\n! endif\n if(.not.btest(globaldata%status,GSADV)) then\n! if expert/experienced bit is cleared ensure that occational user bit is set\n globaldata%status=ibset(globaldata%status,GSOCC)\n endif\n else\n write(kou,*)'Cannot be changed unless you have expert status'\n endif\n!....................................................\n case(3) ! set bit phase ...\n write(*,*)'Please use set phase ... bit '\n end select setbit\n!-------------------------\n case(19) ! set optcoeff_variabl, 0 to 99\n if(.not.btest(firstash%status,AHCOEF)) then\n write(kou,*)'No optimizing coefficients'\n goto 100\n endif\n! zero the relative standard deviation\n firstash%coeffrsd=zero\n call gparix('Coefficent index/range: ',cline,last,i1,-1,&\n '?Set variable coeff')\n if(i1.lt.0 .or. i1.ge.size(firstash%coeffstate)) then\n! write(*,*)'Dimension ',size(firstash%coeffstate)\n! coefficients have indices 0 to size(firstash%coeffstate)-1\n write(kou,*)'No such coefficient'\n goto 100\n endif\n! upper limit must be negative and must follow directly on same line\n! write(*,*)'pmon: ',last,': ',cline(last:last)\n if(last.lt.len(cline) .and. cline(last:last).eq.'-') then\n! pick up upper range limit as a negative value, \n! the question should thus never be asked ...\n last=last-1\n call gparix('Upper index (as negative): ',cline,last,i2,-i1,&\n '?Set variable coeff')\n if(i2.lt.0) then\n! a negative value, its positive value must be >=i1\n i2=-i2\n if(i2.lt.i1) then\n i2=i1\n write(kou,*)'Illegal range, setting variable just: ',i1\n endif\n! elseif(i1.ge.size(firstash%coeffstate)) then\n! coefficients have indices 0 to size(firstash%coeffstate)-1\n! i2=size(firstash%coeffstate)-1\n! write(kou,*)'Setting all coefficients fixed after ',i1\n else\n! any other value ignored\n i2=i1\n write(kou,*)'Not understood, setting variable just: ',i1\n endif\n else\n i2=i1\n endif\n! write(*,*)'pmon: ',i1,i2\n! possible loop if i2>i1\n j4=i1\n3740 continue\n! write(*,*)'pmon: ',i1,i2,j4\n xxy=firstash%coeffvalues(j4)*firstash%coeffscale(j4)\n! this coefficient is not used, igore unless i1=i2\n if(i2.gt.i1 .and. firstash%coeffstate(j4).eq.0) goto 3745\n if(firstash%coeffstate(j4).lt.10) then\n nvcoeff=nvcoeff+1\n endif\n firstash%coeffstate(j4)=10\n if(i1.eq.i2) then\n! when setting a single coefficient variable ask for value\n call gparrdx('Start value: ',cline,last,xxx,xxy,&\n '?Set variable coeff')\n if(buperr.ne.0) goto 100\n! set new value\n call change_optcoeff(firstash%coeffindex(j4),xxx)\n if(gx%bmperr.ne.0) goto 100\n firstash%coeffvalues(j4)=one\n firstash%coeffscale(j4)=xxx\n firstash%coeffstart(j4)=xxx\n else\n! coefficient used, set it variable with current value\n xxx=xxy\n endif\n3745 if(i2.gt.j4) then\n j4=j4+1\n goto 3740\n endif\n write(kou,*)'Number of variable coefficients are ',nvcoeff\n!------------------------- \n case(20) ! set optcoeff_scaled\n write(*,*)'Not implemeneted yet'\n! if(firstash%coeffstate(i1).lt.10) then\n! nvcoeff=nvcoeff+1\n! endif\n! zero the relative standard deviation\n! firstash%coeffrsd=zero\n!-------------------------\n case(21) ! set lmdif_accuracy, always propose the default!\n optacc=1.0D-3\n call gparrdx('LMDIF accuracy: ',cline,last,xxx,optacc,&\n '?Set optimizer conditions')\n write(kou,'(\"LMDIF accuracy set to \",1pe12.4)')xxx\n optacc=xxx\n!-------------------------\n case(22) ! set range_experimental_equilibria\n if(allocated(firstash%eqlista)) then\n write(kou,*)'Experimental equilibria already entered'\n goto 100\n endif\n call gparidx('First equilibrium number: ',cline,last,i1,2,&\n '?Set range')\n j4=noeq()\n call gparidx('Last equilibrium number: ',cline,last,i2,j4,&\n '?Set range')\n if(i2.lt.i1) then\n write(kou,*)'No equilibria?'\n goto 100\n endif\n! allocate the firstash%eqlista array and store equilibrium numbers\n j4=i2-i1+1\n firstash%firstexpeq=i1\n write(*,*)'Allocating firstash%eqlista ',j4,i1\n allocate(firstash%eqlista(j4))\n do i2=1,j4\n firstash%eqlista(i2)%p1=>eqlista(i1)\n i1=i1+1\n enddo\n! close the plotdataunits!\n do i1=1,9\n if(plotdataunit(i1).gt.0) then\n write(plotdataunit(i1),22)graphopt%plotend\n22 format('e'/a)\n!22 format('e'/'pause mouse'/)\n close(plotdataunit(i1))\n plotdataunit(i1)=0\n endif\n enddo\n! write(*,*)'Not implemeneted yet'\n!-------------------------\n case(23) ! set optcoeff_fixed\n! if(.not.allocated(firstash%eqlista)) then\n! check not needed?\n! write(*,*)'Error \"firstash%eqlista\" not allocated'\n! goto 100\n! endif\n if(.not.btest(firstash%status,AHCOEF)) then\n write(kou,*)'No optimizing coefficients'\n goto 100\n endif\n! zero the relative standard deviation\n firstash%coeffrsd=zero\n! lower limit or range\n call gparix('Coeffient index/range: ',cline,last,i1,-1,&\n '?Set fix coeff')\n if(i1.lt.0 .or. i1.ge.size(firstash%coeffstate)) then\n! write(*,*)'Dimension ',size(firstash%coeffstate)\n! coefficients have indices 0 to size(firstash%coeffstate)-1\n write(kou,*)'No such coefficient'\n goto 100\n endif\n! allow writing range on same line as 5-7 but also as 5 -7 on separate lines\n! write(*,*)'pmon1: ',last,': ',cline(last:last)\n frange: if(last.lt.len(cline) .and. cline(last:last).eq.'-') then\n last=last-1\n! upper limit must be negative\n call gparix('Upper index limit (as negative): ',&\n cline,last,i2,-i1,'?Set fix coeff')\n if(i2.lt.0) then\n! a negative value, its positive value must be >=i1\n i2=-i2\n if(i2.lt.i1) then\n i2=i1\n write(kou,*)'Illegal range, setting fixed just: ',i1\n elseif(i2.ge.size(firstash%coeffstate)) then\n i2=size(firstash%coeffstate)-1\n endif\n elseif(i1.ge.size(firstash%coeffstate)) then\n! coefficients have indices 0 to size(firstash%coeffstate)-1\n i2=size(firstash%coeffstate)-1\n write(kou,*)'Setting all coefficients fixed after ',i1\n else\n! any other value ignored\n i2=i1\n write(kou,*)'Not understood, setting fixed just: ',i1\n endif\n else\n i2=i1\n endif frange\n! possible loop if i2>i1\n j4=i1\n! write(*,*)'pmon2: ',i1,j4\n3720 continue\n xxy=firstash%coeffvalues(j4)*firstash%coeffscale(j4)\n if(i1.eq.i2) then\n! A single coefficient, when fixing a single coefficinet ask for value\n call gparrdx('Fix value: ',cline,last,xxx,xxy,&\n '?Set fix coeff')\n if(buperr.ne.0) goto 100\n! set new value\n call change_optcoeff(firstash%coeffindex(j4),xxx)\n if(gx%bmperr.ne.0) goto 100\n firstash%coeffvalues(j4)=one\n firstash%coeffscale(j4)=xxx\n firstash%coeffstart(j4)=xxx\n else\n call get_value_of_constant_index(firstash%coeffindex(j4),xxx)\n endif\n! set as fixed without changing any min/max values (first time)\n! write(*,*)'pmon3: ',xxx,firstash%coeffstate(j4)\n if(firstash%coeffstate(j4).gt.13) then\n write(kou,*)'Coefficient state wrong, set to 1'\n firstash%coeffstate(j4)=1\n nvcoeff=nvcoeff-1\n elseif(firstash%coeffstate(j4).ge.10) then\n firstash%coeffstate(j4)=max(1,firstash%coeffstate(j4)-10)\n nvcoeff=nvcoeff-1\n elseif(xxx.ne.zero) then\n! mark that the coefficient is fixed and nonzero \n firstash%coeffstate(j4)=1\n else\n! firstash%coeffstate(j4)=0\n! Fixed zero parameters are not listed\n firstash%coeffstate(j4)=-1\n endif\n if(i2.gt.j4) then\n j4=j4+1\n goto 3720\n endif\n write(kou,3730)nvcoeff\n3730 format('Number of variable coefficients are now ',i3)\n!------------------------- \n case(24) ! SET SYSTEM_VARIABLE\n write(kou,3733)\n3733 format('Variable 2 is frequency of stability checks during step/map')\n call gparidx('System variable: ',cline,last,ll,0,&\n '?Set system variable')\n! if(ll.gt.0 .and. ll.le.10) then\n if(ll.eq.2) then\n! sysparam(2) used during STEP/MAP often to check if equilibrium is stable\n call gparidx('System variable value: ',cline,last,j4,0,&\n '?Set system variable')\n globaldata%sysparam(ll)=j4\n else\n write(*,*)'No other variable can be changed'\n endif\n!------------------------- \n case(25) ! SET INITIAL_T_AND_P start values?, NOT CONDITIONS!!\n write(kou,3750)ceq%tpval\n3750 format(/'NOTE: these are only local values, not conditions',&\n 2(1pe12.4)/)\n call gparrdx('New value of T: ',cline,last,xxx,1.0D3,&\n 'Set initial TP')\n if(buperr.ne.0) goto 100\n ceq%tpval(1)=xxx\n call gparrdx('New value of P: ',cline,last,xxx,1.0D5,&\n '?Set initial TP')\n if(buperr.ne.0) goto 100\n ceq%tpval(2)=xxx\n!------------------------- \n!CCI\n case(26) ! SET LINEAR_SYSTEM\n!------------ Splitsolver?\n indexSplitsolver = default_splitsolver\n call gparidx('Would you allow the splitting of the linear system? (1=Y; 0=N) : ',&\n cline,last, indexSplitsolver,0,'?Set LINEAR_SYSTEM')\n if((indexSplitsolver.eq.0).or.(indexSplitsolver.eq.1)) then\n ceq%splitsolver = indexSplitsolver\n else\n ceq%splitsolver = default_splitsolver\n endif\n!------------ Pre-conditioner?\n indexPrecond = default_precondsolver\n call gparidx('Would you enable the use of a Jacobi preconditioner? (1=Y; 0=N) : ',&\n cline,last, indexPrecond,0,'?Set LINEAR_SYSTEM')\n if((indexPrecond.eq.0).or.(indexPrecond.eq.1)) then\n ceq%precondsolver = indexPrecond\n else\n ceq%precondsolver = default_precondsolver\n endif\n!------------ Scale the change of phase amount?\n typeOfChange = default_typechangephaseamount\n call gparidx('How do scale all changes in phase amount with total number of atom ? (2=max, 1=sum; 0=one) : ',&\n cline,last, typeOfChange,0,'?Set LINEAR_SYSTEM')\n if((typeOfChange.eq.0).or.(typeOfChange.eq.1).or.(typeOfChange.eq.2)) then\n ceq%type_change_phase_amount = typeOfChange\n else\n ceq%type_change_phase_amount = default_typechangephaseamount\n endif\n!CCI\n!------------------------- \n case(27) ! SET GRID_GENERATOR\n continue\n END SELECT set\n!=================================================================\n! ENTER with subcommand for element, species etc\n! ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',&\n! 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',&\n! 'CONSTITUTION ','EXPERIMENT ','QUIT ',&\n! 'EQUILIBRIUM ','SYMBOL ','OPTIMIZE_COEFF ',&\n! 'COPY_OF_EQUILIB ','COMMENT ','MANY_EQUILIBRIA ',&\n! 'MATERIAL ','PLOT_DATA ','GNUPLOT_TERMINAL',&\n! ' ',' ',' ']\n CASE(4)\n! disable continue assessment optimization (not reelevant)\n! iexit=0\n! iexit(2)=1\n kom2=submenu(cbas(kom),cline,last,center,ncent,11,'?TOPHLP')\n enter: SELECT CASE(kom2)\n CASE DEFAULT\n write(kou,*)'Enter subcommand error'\n!---------------------------------------------------------------\n! maybe change order of questions, maybe check name exits etc ....\n CASE(1) ! enter TPFUN symbol (constants, functions, tables)\n call gparcx('TPfun name: ',cline,last,1,name1,' ','?Enter TPfun')\n if(buperr.ne.0) goto 990\n! if(badsymname(name1)) then\n if(.not.proper_symbol_name(name1,0)) then\n write(kou,*)'Bad symbol name'\n goto 990\n endif\n! check if already entered, \n call find_tpsymbol(name1,idef,xxx)\n if(gx%bmperr.ne.0) then\n! new symbol, can be function, constant or table (??)\n gx%bmperr=0\n call gparcdx('Function, constant or table? ',cline,last,1,name2,&\n 'FUNCTION ','?Enter TPfun')\n if(buperr.ne.0) goto 990\n call capson(name2)\n if(compare_abbrev(name2,'FUNCTION ')) then\n! this call just read the function\n call enter_tpfun_interactivly(cline,last,funstring,jp)\n if(gx%bmperr.ne.0) goto 990\n! here the function is stored\n lrot=0\n! call store_tpfun(name1,funstring,lrot,.FALSE.)\n! last argument -1 means not reading from TDB file\n call store_tpfun(name1,funstring,lrot,-1)\n if(gx%bmperr.ne.0) goto 990\n elseif(compare_abbrev(name2,'CONSTANT ')) then\n! Enter a numeric constant\n call gparrdx('Value: ',cline,last,xxx,zero,'?Enter TPfun')\n call store_tpconstant(name1,xxx)\n elseif(compare_abbrev(name2,'TABLE ')) then\n write(kou,*)'Tables are not implemented yet'\n else\n write(kou,*)'No such type of symbol'\n endif\n else\n! symbol already exist, idef=0 function, =1 constant, =2 oprimizing coefficient\n if(idef.eq.0) then\n write(kou,*)'Use AMEND to change existing TP function'\n elseif(idef.eq.2) then\n write(kou,*)'You cannot change values of optimizing ',&\n 'coefficients this way'\n else\n! Values of constants can be changed here\n call gparrdx('New value: ',cline,last,xxy,xxx,'?Enter TPfun')\n if(buperr.ne.0) goto 990\n call capson(name1)\n call store_tpconstant(name1,xxy)\n! we must evaluate all TPFUNS in all equilibria to be sure value propagates!\n endif\n endif\n!---------------------------------------------------------------\n case(2) ! enter element\n if(.not.allowenter(1)) then\n gx%bmperr=4125\n goto 990\n endif\n call gparcx('Element symbol: ',cline,last,1,elsym,' ',&\n '?Enter element')\n if(buperr.ne.0) goto 990\n call capson(elsym)\n if(.not.(elsym(1:1).ge.'A' .and. elsym(1:1).le.'Z')) then\n write(*,*)'An element symbol must start with a letter A-Z'\n goto 100\n endif\n call gparcdx('Element full name: ',cline,last,1,name1,elsym,&\n '?Enter element')\n call gparcdx('Element reference phase: ',cline,last,1,&\n name2,'SER ','?Enter element')\n call gparrdx('Element mass (g/mol): ',cline,last,mass,one,&\n '?Enter element')\n if(buperr.ne.0) goto 990\n call gparrdx('Element H298-H0: ',cline,last,h298,zero,&\n '?Enter element')\n if(buperr.ne.0) goto 990\n call gparrdx('Element S298: ',cline,last,s298,one,'?Enter element')\n if(buperr.ne.0) goto 990\n! call enter_element(elsym,name1,name2,mass,h298,s298)\n call store_element(elsym,name1,name2,mass,h298,s298)\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n case(3) ! enter species\n! Allow entering species even if there are phases entered\n! needed for the MQMQA model\n! if(.not.allowenter(1)) then\n! gx%bmperr=4125\n! goto 990\n! endif\n!>>> There may be problems with MQMQA quads such as Fe,Mn/SI1/4O,Al2/3O\n call gparcx('Species symbol: ',cline,last,1,name1,' ',&\n '?Enter species')\n! check if it is an MQMQA quad\n name2=name1\n call capson(name2)\n iz=index(name2,'/')\n if(iz.gt.0 .and. &\n (name2(iz+1:iz+1).ge.'A' .and. name2(iz+1:iz+1).le.'Z')) then\n! A MQMQA species has a letter after the /\n! In MQMQA species, the two sublattices indicated by /\n! but we musr also separate species in same, for example: Fe,Mn/Si1/4O,Al2/3O\n mqmqass=' '\n call gparcx('MQMQA specification: ',cline,last,5,&\n mqmqass,' ','?Enter MQMQA species')\n! typically mqmqass is Na/Cl 6.0 6.0 2.4 (last values the FNN/SNN ratio\n! or Mg,Na/Cl 6.00 3.00 3.00 etc. as in Solgsmax DAT files\n! check species used before quad numbers must already be entered!\n! mqmqanend should be negative at first call\n write(*,575)trim(name1),trim(mqmqass),mqmqanend\n575 format('Call mqmqa_species: \"',a,'\" \"',a,'\" ',i5)\n call mqmqa_species(name1,mqmqass,mqmqanend)\n else\n! A species with no / or an ionic / followed by + - or number\n call gparcx('Species stoichiometry: ',cline,last,1,name2,' ',&\n '?Enter species')\n call decode_stoik(name2,noelx,ellist,stoik)\n if(gx%bmperr.ne.0) goto 990\n! all species must be entered\n call enter_species(name1,noelx,ellist,stoik)\n endif\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n case(4) ! enter phase\n if(.not.allowenter(2)) then\n gx%bmperr=4125\n goto 990\n endif\n call enterphase(cline,last)\n!---------------------------------------------------------------\n case(5) ! enter parameter only if there are phases\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'You must enter a phase before'\n goto 100\n endif\n! the last 0 means enter\n call enter_parameter_interactivly(cline,last,0)\n! Strange things may happen when entering parameters interactively \n! This was due to an error in tpfun package ... not yet fixed ... ??\n call change_optcoeff(-1,zero)\n do j4=1,notpf()\n call eval_tpfun(j4,ceq%tpval,val,ceq%eq_tpres)\n if(gx%bmperr.gt.0) goto 990\n enddo\n call change_optcoeff(-1,zero)\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n case(6) ! enter bibliography\n call enter_bibliography_interactivly(cline,last,0,j4)\n if(gx%bmperr.ne.0) goto 990\n write(kou,*)'Bibliography number is ',j4\n!---------------------------------------------------------------\n case(7) ! enter constitution\n call ask_phase_constitution(cline,last,iph,ics,lokcs,ceq)\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n case(8) ! enter experiment\n! almost the same as set_condition ...\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'You have no data!'\n goto 100\n endif\n! enter_experiments is in models/gtp3D ...\n call enter_experiment(cline,last,ceq)\n!---------------------------------------------------------------\n case(9) ! enter QUIT\n goto 100\n!---------------------------------------------------------------\n case(10) ! enter equilibrium is always allowed if there are phases\n if(.not.allowenter(3)) then\n write(kou,*)'You must have entered your system first'\n goto 100\n endif\n! generate a default names line EQ_x ehere x is eqfree\n call geneqname(quest)\n call gparcdx('Name: ',cline,last,1,text,quest,'?Enter equilibrium')\n if(buperr.ne.0) goto 100\n call enter_equilibrium(text,ieq)\n if(gx%bmperr.ne.0) goto 990\n! by default also select this equilibrium\n write(kou,303)ieq,trim(text)\n303 format('Equilibrium number is ',i3,', name: ',a)\n call gparcdx('Select this equilibrium: ',cline,last,1,ch1,'Y',&\n '?Enter equilibrium')\n if(yeschk(ch1)) then\n call selecteq(ieq,ceq)\n! COPY current values of entered symbols from first equilibrium\n ceq%svfunres=firsteq%svfunres\n endif\n! write(*,*)'pmon: ',ceq%eqno,ieq\n!---------------------------------------------------------------\n case(11) ! enter symbol (for state variables expressions)\n! several questions asked inside this call\n call enter_svfun(cline,last,ceq)\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n! enter optimizing coefficients called A00 to A99 (or whatever set as max)\n case(12)\n if(.not.allocated(firstash%coeffstate)) then\n call gparidx('Number of coefficients: ',cline,last,i1,100,&\n '?Enter coeffs')\n if(buperr.ne.0) goto 100\n i1=i1-1\n if(i1.lt.1) then\n write(*,*)'You must have at least 1 coefficient'\n goto 100\n elseif(i1.gt.99) then\n write(*,*)'You cannot have more than 100 coefficient'\n goto 100\n endif\n allocate(firstash%coeffvalues(0:i1))\n allocate(firstash%coeffrsd(0:i1))\n allocate(firstash%coeffscale(0:i1))\n allocate(firstash%coeffstart(0:i1))\n allocate(firstash%coeffmin(0:i1))\n allocate(firstash%coeffmax(0:i1))\n allocate(firstash%coeffindex(0:i1))\n allocate(firstash%coeffstate(0:i1))\n! coeffvalues should be of the order of one\n firstash%coeffvalues=one\n firstash%coeffrsd=zero\n firstash%coeffscale=zero\n firstash%coeffstart=zero\n firstash%coeffmin=zero\n firstash%coeffmax=zero\n firstash%coeffindex=0\n firstash%coeffstate=0\n! create the corresponding TP constants for coeffvalues\n call enter_optvars(j4)\n call makeoptvname(name1,i1)\n write(kou,556)name1(1:3),i1\n556 format(/'Coefficients entered with symbols A00 to ',a/&\n 'Note that indices are from 0 to ',i2)\n do i2=0,i1\n firstash%coeffindex(i2)=j4+i2\n enddo\n firstash%status=ibset(firstash%status,AHCOEF)\n else\n write(kou,553)size(firstash%coeffstate)\n553 format('You have already ',i3,' optimizing coefficients entered')\n endif\n call gparidx('Size of workspace: ',cline,last,lwam,2500,&\n '?Enter coeffs')\n! if(lwam.gt.2000) lwam=2000\n if(allocated(wam)) then\n deallocate(wam)\n deallocate(iwam)\n endif\n! write(*,551)firstash%status\n!551 format('Assessment status word: ',z8)\n!---------------------------------------------------------------\n! enter copy_of equilibrium (for test!)\n case(13)\n! Check if there is any phases, otherwise not allowed\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'Not allowed unless you have data!'\n goto 100\n endif\n call gparcx('Name of new equilibrium: ',cline,last,1,text,' ',&\n '?Enter copyof')\n if(buperr.ne.0) goto 100\n if(text(1:1).eq.' ') then\n write(*,*)'You must specify a unique name'\n goto 100\n endif\n call copy_equilibrium(neweq,text,ceq)\n! write(*,*)'Back from copy equilibrium'\n if(gx%bmperr.ne.0) goto 990\n write(kou,*)'New equilibrium no: ',neweq%eqno\n!---------------------------------------------------------------\n! enter COMMENT for current equilibrium\n case(14)\n write(*,*)'Current equilibrium name: ',ceq%eqname\n call gparcx('One line text: ',cline,last,5,text,' ',&\n '?Enter comment')\n ceq%comment=text\n!---------------------------------------------------------------\n! enter MANY_EQUILIBRIA\n! The plotdataunit array should be zero at first call, then the unit is opened\n! (if there are any plot_data commands). It will remain open until\n! a set range command is given\n case(15)\n! write(*,*)'Working dir: ',trim(workingdir)\n call enter_many_equil(cline,last,plotdataunit)\n if(gx%bmperr.ne.0) goto 990\n!---------------------------------------------------------------\n! enter MATERIAL\n! ask for database, then major element, mass/mole fraction of elements\n! read the database; jump possibly to SCHEIL/STEP calculation \n! or simply ask for T and calculate equilibrium; \n case(16)\n call enter_material(cline,last,nv,xknown,ceq)\n if(gx%bmperr.ne.0) goto 990\n xxy=firsteq%tpval(1)\n call gparrdx('Temperature ',cline,last,xxx,xxy,'?Enter material')\n! set T and P\n cline='P=1E5 T='\n i1=len_trim(cline)+1\n call wrinum(cline,i1,10,0,xxx)\n i1=0\n call set_condition(cline,i1,ceq)\n! calculate the equilibrium\n call calceq2(1,ceq)\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n goto 990\n endif\n!---------------------------------------------------------------\n! enter PLOT DATA\n! the file ocmanyi.plt with unit plotdataunit(i) must already be open!\n! it is opened in the enter_many_equilibria if there is a plot_data command\n case(17)\n call gparidx('Dataset number:',cline,last,i1,1,'?Enter plot data')\n! here only the normal plotdata units 1 to 9 are legal\n if(i1.gt.0 .and. i1.lt.10) then\n if(plotdataunit(i1).lt.10) then\n write(kou,*)'No plotdata file for this dataset'\n goto 100\n endif\n call gparrdx('X coordinate:',cline,last,xxx,zero,&\n '?Enter plot data')\n call gparrdx('Y coordinate:',cline,last,xxy,one,&\n '?Enter plot data')\n call gparidx('Symbol:',cline,last,i2,1,&\n '?Enter plot data')\n write(plotdataunit(i1),171)i1,xxx,xxy,i2\n171 format(i3,2(1pe14.6),i5,' have a nice day')\n else\n write(kou,*)'No plotdata file for dataset ',i1\n endif\n!---------------------------------------------------------------\n! ENTER GNUPLOT_TERMINAL\n case(18)\n write(kou,172)graphopt%gnutermax\n172 format('GNUPLOT terminals are:',i2/&\n 4x,'Name',5x,'> command',6x,'GNUPLOT options')\n write(kou,173)(i2,graphopt%gnutermid(i2),&\n trim(graphopt%gnuterminal(i2)),i2=1,graphopt%gnutermax)\n173 format(i2,2x,a,' > set terminal ',a)\n write(kou,174)\n174 format('Change (exact match required) or enter a new GNUPLOT termial')\n call gparcx('Terminal id (8 chars):',cline,last,1,text,' ',&\n '?Enter GNUTERM')\n call capson(text)\n if(text(1:1).eq.' ') goto 100\n do i1=1,graphopt%gnutermax\n if(text(1:8).eq.graphopt%gnutermid(i1)) then\n string=graphopt%gnuterminal(i1)\n write(*,*)'Modifying terminal ',graphopt%gnutermid(i1)\n goto 176\n endif\n enddo\n! gnutermid not found, a new terminal\n call gparcdx('You want to enter a new terminal \"'//trim(text)//'\"?',&\n cline,last,1,ch1,'Y','?Enter GNUTERM')\n if(ch1.ne.'Y') then\n write(*,*)'Please try again'; goto 100\n endif\n if(graphopt%gnutermax.ge.8) then\n write(kou,*)'There can max be 8 terminals'\n goto 100\n endif\n i1=graphopt%gnutermax+1\n graphopt%gnutermax=i1\n string=' '\n! enter a new set terminal id and definition\n176 continue\n graphopt%gnutermid(i1)=text(1:8)\n call gparcx('Text after set terminal (see GNUPLOT manual):',&\n cline,last,5,text,string,'?Enter GNUTERM')\n graphopt%gnuterminal(i1)=text\n if(i1.ne.1) then\n! SCREEN has no file extention\n call gparcx('File extention:',cline,last,1,text,' ',&\n '?Enter GNUTERM')\n graphopt%filext(i1)=text(1:4)\n endif\n write(*,179)i1,graphopt%gnutermid(i1),trim(graphopt%gnuterminal(i1)),&\n trim(graphopt%filext(i1))\n179 format('New terminal definition for plot '/&\n i2,2x,a,'set terminal ',a/4x,'with file extention: ',a)\n!----------------------------------------------------------------\n! enter unused\n case(19)\n write(*,*)'Not implemeneted yet'\n!----------------------------------------------------------------\n! enter unused\n case(20)\n!----------------------------------------------------------------\n! enter unused\n case(21)\n END SELECT enter\n!=================================================================\n! exit\n CASE(5)\n call gparcdx('Are you sure?',cline,last,1,ch1,'N','?Exit')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n if(logfil.gt.0) then\n write(logfil,*)'set interactive'\n endif\n call openlogfile(' ',' ',-1)\n stop 'Ha en bra dag'\n endif\n!=================================================================\n! list with subcommands\n! ['DATA ','SHORT ','PHASE ',&\n! 'STATE_VARIABLES ','BIBLIOGRAPHY ','MODEL_PARAM_ID ',&\n! 'AXIS ','TPFUN_SYMBOLS ','QUIT ',&\n! 'PARAMETER ','EQUILIBRIA ','RESULTS ',&\n! 'CONDITIONS ','SYMBOLS ','LINE_EQUILIBRIA ',&\n! 'OPTIMIZATION ','MODEL_PARAM_VAL ','ERROR_MESSAGE ',&\n! ,ACTIVE_EQUILIBR ','ELEMENTS ',' ',&\n! , ',' ',' ']\n! SHOW is main cammand 25\n CASE(6,25) ! LIST and SHOW\n if(kom.eq.25) then\n! SHOW is the same as LIST STATE_VARIABLES including also CALC SYMBOL !!\n kom2=4\n else\n! default for LIST is RESULT, number 12\n kom2=submenu(cbas(kom),cline,last,clist,nclist,12,'?TOPHLP')\n if(kom2.le.0) goto 100\n endif\n lut=optionsset%lut\n! write(*,*)'PMON: show xliqni should come here ... YES ',kom,kom2\n list: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'LIST FORMAT subcommand error'\n goto 100\n!-----------------------------------------------------------\n case(1) ! list data, not dependent on equilibrium!!\n! NOTE output file for SCREEN can be set by /output=\n! LIST DATA SCREEN/TDB/MACRO/LaTeX\n! it is also possible to give SAVE TDB \n! character (len=16), dimension(nlform) :: llform=&\n! ['SCREEN ',' ','MACRO ',&\n! ' ',' ',' ']\n if(globaldata%encrypted.ne.0) then\n write(kou,*)'Illegal for encrypted databases'\n goto 100\n endif\n kom3=submenu('Output format for data?',cline,last,llform,nlform,1,&\n '?TOPHLP')\n! write(*,*)'LIST DATA output format',kom3\n if(kom3.eq.1) then\n! list on screen\n call list_many_formats(cline,last,kom3,kou)\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,*)bmperrmess(gx%bmperr)\n elseif(gx%bmperr.ne.0) then\n write(kou,*)'Error code ',gx%bmperr\n endif\n elseif(kom3.eq.3) then\n write(*,*)'Output in MACRO format not yet implemented'\n else\n! TDB format does not work here, use SAVE\n write(*,*)'Use SAVE to list with other formats than SCREEN'\n! ztyp=-1\n! call gparfilex('File name: ',cline,last,1,filename,text,ztyp,&\n! '?Save TDB')\n! kl=max(index(filename,'.dat '),index(filename,'.TDB '))\n! if(kl.le.0) then\n! kl=len_trim(filename)+1\n! if(kl.eq.1) then\n! write(*,*)'Too short file name'\n! goto 100\n! endif\n! filename(kl:)='.DAT '\n! endif\n! call list_TDB_format(filename)\n! else\n! if(tdbfile(1:1).ne.' ') &\n! write(kou,*)'Database file: ',trim(tdbfile)\n! endif\n! else\n! write(kou,*)'Unknown format'\n endif\n!-----------------------------------------------------------\n case(2) ! list short with status bits\n if(kom2.eq.20) then\n ch1='C'\n else\n! note D is a hidden option including the status bits\n call gparcdx('Option (A/C/M/P)',cline,last,1,ch1,chshort,&\n '?List short')\n call capson(ch1)\n endif\n write(lut,6022)ceq%eqname,globaldata%rgasuser,&\n globaldata%pnorm,globaldata%status,ceq%status\n6022 format('Equilibrium name',9x,'Gas constant Pressure norm',&\n 5x,'Status Global Equilib'/&\n 1x,a,1pe12.4,2x,1pe12.4,10x,z8,2x,z8)\n!....................................................................\n! options are A=all phases; P=some phases; C=components; M=phase models\n if(ch1.eq.'A') then\n! A all\n chshort='A'\n call list_all_elements(lut)\n call list_all_species(lut)\n call list_all_phases(lut,ceq)\n!....................................................................\n elseif(ch1.eq.'D') then\n! just the phases\n! P phases sorted: stable/ unstable in driving force order/ dormant the same\n chshort='P'\n call list_sorted_phases(lut,1,ceq)\n if(btest(ceq%status,EQFAIL)) write(lut,6305)'above'\n!....................................................................\n elseif(ch1.eq.'P') then\n! just the phases without status bits\n! P phases sorted: stable/ unstable in driving force order/ dormant the same\n chshort='P'\n call list_sorted_phases(lut,0,ceq)\n if(btest(ceq%status,EQFAIL)) write(lut,6305)'above'\n elseif(ch1.eq.'C') then\n!....................................................................\n! global values and the chemical potentials\n chshort='C'\n write(kou,*)\n call list_global_results(lut,ceq)\n! write(lut,6303)'Some component data ....................'\n write(lut,6303)'Some data for components ...............'\n j4=1\n if(listresopt.ge.4 .and. listresopt.le.7) then\n j4=2\n endif\n call list_components_result(lut,j4,ceq)\n!....................................................................\n elseif(ch1.eq.'M') then\n! list models for all phases\n do iph=1,noph()\n call list_phase_model(iph,1,lut,' ',ceq)\n enddo\n!....................................................................\n else\n write(kou,*)'Only option A, C, M and P implemented'\n endif\n!-----------------------------------------------------------\n case(3) ! list phase subcommands\n call gparcx('Phase name: ',cline,last,1,name1,' ','?List phase')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n kom3=submenu('List what for phase?',cline,last,clph,nclph,2,&\n '?TOPHLP')\n listphase: SELECT CASE(kom3)\n!...............................................................\n CASE DEFAULT\n write(kou,*)'list phase subcommand error'\n!...............................................................\n CASE(1) ! list phase data\n call list_phase_data(iph,' ',lut)\n!...............................................................\n! list phase constitution\n case(2) ! list phase constitution\n! call list_phase_results(iph,ics,mode,kou,firsteq)\n write(lut,6051)version,ceq%eqno,ceq%eqname\n6051 format(/'OC version',a,' equilibrium: ',i3,', ',&\n a,3x,a4,'.',a2,'.',a2)\n mode=110\n once=.TRUE.\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Last equilibrium calculation failed'\n goto 990\n endif\n!...............................................................\n case(3) ! list phase model (including disordered fractions)\n write(kou,6070)'For ',ceq%eqno,ceq%eqname\n6070 format(a,'equilibrium: ',i3,', ',a)\n call list_phase_model(iph,ics,lut,' ',ceq)\n END SELECT listphase\n!------------------------------\n! THIS IS ALSO THE SHOW command and list model-parameter-value case(17) of LIST\n! SHOW STATE VARIABLE VALUE\n case(4,17) ! list state_variable or model_parameter_value, or SHOW\n!6099 continue\n if(btest(ceq%status,EQNOEQCAL) .or. btest(ceq%status,EQFAIL)) then\n write(lut,6101)\n6101 format(' *** Warning,',&\n 'equilibrium not calculated, values are probably wrong')\n elseif(btest(ceq%status,EQINCON)) then\n write(lut,6102)\n6102 format(' *** Warning, values can be inconsistent with',&\n ' current conditions')\n endif\n once=.TRUE.\n! LOOP here for list state_variables or model_parameter_values or SHOW\n6105 continue\n! write(*,*)'At label 6105: ',last,' \"',trim(cline),'\"',kom,kom2\n! NOTE: 4th argument is 5 because otherwise a \",\" will terminate reading cline\n! and state variables like x(fcc,cr) will not work.\n if(kom.eq.25) then\n! SHOW: this execute the SHOW command\n! write(*,*)'PMON: show xliqni should come here ... YES '\n call gparcx('Property: ',cline,last,5,line,' ','?Show property')\n else\n! the command is LIST STATE_VARIABLES\n if(kom2.eq.4) then\n call gparcx('State variable: ',cline,last,5,line,' ',&\n '?List state variables')\n else\n! the command is LIST MODEL_PARAMETER_VALUE \n if(once) then\n write(kou,*)'Remember always to specify the phase!'\n once=.FALSE.\n endif\n call gparcx('Parameter ident: ',cline,last,5,line,' ',&\n '?List model parameter val')\n endif\n endif\n! if line empty return to command level\n j4=1\n if(eolch(line,j4)) goto 100\n j4=index(line,',')\n if(j4.gt.0) then\n! check if there is a , before a ( as that is not allowed. There are\n! state variables like x(fcc,cr) ... (this is not a strong test ...)\n ll=index(line,'(')\n if(ll.le.0 .or. ll.gt.j4) then\n write(*,*)'Please use a space as separator',&\n ' except within ( ) as in x(liq,cr) !'\n goto 100\n endif\n endif\n! model is just used to return texts\n model=' '\n! we should extract the text from last up to first space and save rest in cline\n j4=index(line,' ')\n name1=line(1:j4)\n call capson(name1)\n! dot derivatives not allowed explicitly, must be entered as symbols\n if(index(name1,'.').gt.0) then\n write(kou,*)'You must enter dot derivatives as symbols!'\n goto 100\n endif\n! note gparc etc increment last before looking for answer, keep space in cline\n cline=line(j4:)\n last=1\n! if(index(name1,'*').gt.0) then\n! allow also DGM(#) to generate many values ...\n if(index(name1,'*').gt.0 .or. index(name1,'DGM(#)').gt.0) then\n! generate many values\n! i1 values are resturned in yarr with dimension maxconst. \n! longstring are the state variable symbols for the values ...\n call get_many_svar(name1,yarr,maxconst,i1,longstring,ceq)\n if(gx%bmperr.eq.0) then\n! not a nice output, we should include the state variables FIX!!\n write(lut,6106)i1,longstring(1:len_trim(longstring))\n6106 Format('Listing of ',i3,' state variables:'/a)\n write(lut,6107)(yarr(i2),i2=1,i1)\n6107 format('Values: ',5(1pe14.6)/(8x,5(1pe14.6)))\n if(index(name1,'*,').gt.0) write(*,6121)trim(name1)\n6121 format(' *** Note that for unstable phases ',a,&\n ' is not shown or listed as zero')\n endif\n else\n! the value of a state variable, symbol? or model parameter variable is returned\n! STRANGE the symbol xliqni is accepted in get_state_var_value ???\n! write(*,*)'pmon show: call get_state_var_value',' :',trim(name1)\n! get_state_var_value is in gtp3F.F90\n call get_state_var_value(name1,xxx,model,ceq)\n! write(*,*)'pmon back from get_state_var_value',xxx,' :',trim(model)\n! write(*,*)'PMON: show xliqni should come here 6 ... ',gx%bmperr\n if(gx%bmperr.eq.0) then\n write(lut,6108)trim(model),xxx\n6108 format(1x,a,'=',1PE15.7)\n else\n gx%bmperr=0\n! write(*,*)'PMON: show xliqni should come here ... NO!!!'\n! If error then try to calculate a symbol ...\n! below copied from calculate symbol, first calculate all symbols ignore errors\n! calculate all symbols ignoring errors (note dot derivatives not calculated)\n call meq_evaluate_all_svfun(-1,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n call capson(line)\n! call find_svfun(name1,istv,ceq)\n! write(*,*)'PMON: calling find_svfun again ...'\n call find_svfun(name1,istv)\n if(gx%bmperr.ne.0) goto 990\n mode=1\n actual_arg=' '\n xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq)\n! write(*,*)'pmon error: calling meq_evaluate_svfun',istv,xxx\n if(gx%bmperr.ne.0) goto 990\n write(kou,2047)trim(name1),xxx\n! this format statement elsewhere\n!2047 format(a,'= ',1pe16.8)\n endif\n endif\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(lut,*)bmperrmess(gx%bmperr)\n elseif(gx%bmperr.ne.0) then\n write(lut,*)'Error code ',gx%bmperr\n endif\n gx%bmperr=0\n! try to pick up more properties etc from cline if not empty\n if(.not.eolch(cline,last)) then\n! there are more symbols, state variables or model_parameters in cline\n last=last-1\n goto 6105\n elseif(kom.ne.25) then\n! for list state_variables and list model_parameter_value ask for more\n goto 6105\n endif\n!-----------------------------------------------------------\n case(5) ! list data bibliography\n call gparcdx('Bibliographic id:',cline,last,1,name1,'ALL',&\n '?List biblio')\n if(name1.eq.'ALL ') name1=' '\n call list_bibliography(name1,lut)\n!-----------------------------------------------------------\n case(6) ! list model_parameter_identifiers\n call list_defined_properties(lut)\n!-----------------------------------------------------------\n case(7) ! list axis\n if(noofaxis.le.0) then\n write(kou,*)'No axis set'\n goto 100\n endif\n write(lut,6131)\n6131 format(4x,'Axis variable',12x,'Min',9x,'Max',9x,'Max increment')\n!6131 format(4x,'Axis variable',12x,'Start',7x,'Final',7x,'Increment')\n do iax=1,noofaxis\n jp=1\n call get_one_condition(jp,text,axarr(iax)%seqz,ceq)\n if(gx%bmperr.ne.0) then\n write(kou,*)'PMON: Condition sequential index: ',&\n iax,axarr(iax)%seqz\n goto 990\n endif\n! we just want the expression, remove the value including the = sign\n jp=index(text,'=')\n text(jp:)=' '\n! write(kou,6132)iax,axvar(iax),(axval(j4,iax),j4=1,3)\n write(lut,6132)iax,text(1:24),&\n axarr(iax)%axmin,axarr(iax)%axmax,axarr(iax)%axinc\n6132 format(i2,2x,a,3(1pe12.4))\n enddo\n!-----------------------------------------------------------\n case(8) ! list tpfun symbol\n call gparcdx('name: ',cline,last,5,name1,'*','?List TPfun')\n lrot=0\n iel=index(name1,'*') \n if(iel.gt.1) name1(iel:)=' '\n if(name1(1:1).ne.'*') then\n6140 continue\n call find_tpfun_by_name(name1,lrot)\n! write(*,*)'cui: ',lrot,iel,gx%bmperr\n if(gx%bmperr.ne.0) then\n if(iel.eq.0) goto 990\n gx%bmperr=0\n else\n longstring=' '\n write(longstring,6142)lrot\n6142 format(i5)\n jp=len_trim(longstring)+2\n call list_tpfun(lrot,0,longstring(jp:))\n call wrice2(lut,0,12,78,1,longstring)\n if(iel.gt.1) goto 6140\n endif\n else\n call list_all_funs(lut)\n endif\n!------------------------------------------------------------\n case(9) ! list quit\n!------------------------------------------------------------\n case(10) ! list parameter for a phase (just one). Last 1 means list\n call enter_parameter_interactivly(cline,last,1)\n!-----------------------------------------------------------\n case(11,19) ! list EQUILIBRIA and list ACTIVE_EQUILIBRIA (not result)\n! if 19 then skip equilibria with zero weight\n nv=noeq()\n! skip if there is just one equilibrium kom=6=LIST; kom2=19=ACTIVE-EQUIL\n! write(*,*)'PMON: ',kom,kom2,nv\n if(kom2.eq.19 .and. nv.eq.1) goto 100\n write(lut,6212)\n6212 format('Number Name',25x,'T Weight Comment & phases')\n jp=0\n do iel=1,nv\n if(associated(ceq,eqlista(iel))) then\n name1='**'\n else\n name1=' '\n endif\n! write(*,*)'PMON: ',kom2,iel,eqlista(iel)%weight,jp\n! j4=len_trim(eqlista(iel)%comment)\n! write(*,*)'PMON eqlista: ',len_trim(eqlista(iel)%comment),&\n! eqlista(iel)%weight\n text=eqlista(iel)%comment\n jz=len_trim(text)\n if(jz.lt.20) then\n! if there is space add names of stable phases\n if(jz.gt.0) then\n text(jz+1:)=' & '; jz=jz+4\n else\n jz=1\n endif\n do iz=1,nooftup()\n i2=phasetuple(iz)%lokvares\n if(eqlista(iel)%phase_varres(i2)%phstate.gt.0) then\n if(eqlista(iel)%phase_varres(i2)%phstate.eq.2) then\n! prefix any FIX phase with *\n text(jz:jz)='*'; jz=jz+1\n endif\n call get_phasetup_name(iz,text(jz:))\n! text is limited to 72 characters and anyway only 32 are written\n jz=min(len_trim(text)+2,40)\n endif\n enddo\n! write(*,*)'PMON phases: ',trim(text)\n endif\n if(eqlista(iel)%weight.gt.zero) then\n! always list equilibria with weight>0\n write(lut,6203)iel,name1(1:2),eqlista(iel)%eqname,&\n eqlista(iel)%tpval(1),eqlista(iel)%weight,trim(text)\n6203 format(i4,1x,a2,1x,a,1x,F8.2,1x,F5.2,1x,a)\n elseif(iel.eq.1 .or. kom2.eq.11) then\n! for kom2=11 list all equilibria without including weight\n! NOTE all equilibria outside \"range\" (default and step/map) has weight= -1.0\n write(lut,6202)iel,name1(1:2),eqlista(iel)%eqname,&\n eqlista(iel)%tpval(1),trim(text)\n6202 format(i4,1x,a2,1x,a,1x,F8.2,7x,a)\n elseif(eqlista(iel)%weight.eq.zero) then\n jp=jp+1\n endif\n! if(j4.gt.1) then\n! write(lut,6204)eqlista(iel)%comment(1:j4)\n!6204 format(12x,a)\n! endif\n enddo\n if(kom2.eq.19 .and. jp.gt.0) &\n write(lut,'(/\"Number of equilibria with zero weight: \",i4)')jp\n!------------------------------\n case(12) ! LIST RESULTS (maybe also LIST ESTIMATED_ACCURA?)\n! skip if no calculation made\n if(btest(globaldata%status,GSNOPHASE)) then\n write(kou,*)'No results as no data'\n goto 100\n elseif(btest(ceq%status,EQGRIDCAL)) then\n write(kou,*)' *** Last calculation was not a full equilibrium'\n endif\n call gparidx('Results output mode: ',cline,last,&\n listresopt,lrodef,'?List results')\n if(buperr.ne.0) then\n write(kou,*)'No such mode, using default'\n buperr=0\n listresopt=lrodef\n endif\n! CCI extending the number of listing options\n! if(listresopt.gt.0 .and. listresopt.le.9) then\n! if(listresopt.gt.0 .and. listresopt.le.11) then\n if(listresopt.gt.0 .and. listresopt.le.12) then\n lrodef=listresopt\n endif\n! CCI end \n call date_and_time(optres,name1)\n write(lut,6051)version,ceq%eqno,ceq%eqname,&\n optres(1:4),optres(5:6),optres(7:8)\n! write comment line if any\n if(len_trim(ceq%comment).gt.0) then\n write(lut,6308)trim(ceq%comment)\n6308 format(3x,a)\n endif\n if(btest(ceq%status,EQFAIL)) then\n write(lut,6305)'below'\n6305 format(/' *** The results ',a,&\n ' are not a valid equilibrium as last calculation failed'/)\n! elseif(btest(globaldata%status,GSNOEQCAL)) then\n elseif(btest(ceq%status,EQNOEQCAL)) then\n write(lut,6307)'below'\n6307 format(/' *** The results listed ',a,' does not represent',&\n ' a calculated equilibrium'/)\n elseif(btest(ceq%status,EQINCON)) then\n write(lut,6306)'below'\n6306 format(/' *** The results listed ',a,' may be inconsistent',&\n ' with the current conditions'/)\n endif\n write(lut,6302)'Conditions .............................'\n6302 format(a,20('.'),':')\n6303 format(/a,20('.'),':')\n call list_conditions(lut,ceq)\n write(lut,6303)'Some global data, reference state SER ..'\n call list_global_results(lut,ceq)\n if(btest(ceq%status,EQNOEQCAL)) then\n write(*,6277)ceq%status\n6277 format(' *** No results as no equilibrium calculated! ',z8)\n goto 6363\n endif\n! write(lut,6303)'Some component data ....................'\n write(lut,6303)'Some data for components ...............'\n j4=1\n if(listresopt.ge.4 .and. listresopt.le.7) then\n! j4=2 means mass fractions\n j4=2\n endif\n call list_components_result(lut,j4,ceq)\n! Phase output starts with newline\n! write(lut,6304,advance='no')'Some Phase data ........................'\n write(lut,6304,advance='no')'Some data for phases ...................'\n6304 format(/a,20('.'),':')\n if(listresopt.le.1) then\n! 1: stable phases with mole fractions in value order \n mode=1000\n elseif(listresopt.eq.2) then\n! 2: stable phases with mole fractions and constitution in value order\n mode=1010\n elseif(listresopt.eq.3) then\n! 3: stable phases with mole fractions and constitution in alphabetical order\n mode=1110\n elseif(listresopt.eq.4) then\n! 4: stable phases with mass fractions in value order\n mode=1001\n elseif(listresopt.eq.5) then\n! 5: stable phases with mass fractions in alphabetical order\n mode=1101\n elseif(listresopt.eq.6) then\n! 6: stable phases with mass fractions and constitution in value order\n mode=1011\n elseif(listresopt.eq.7) then\n! 7: all phases with mass fractions in value order\n mode=1\n elseif(listresopt.eq.8) then\n! 9: all phases with mole fractions in alphabetical order\n mode=110\n elseif(listresopt.eq.9) then\n! 9: all phases with mole fractions an constitutions in value order\n mode=10\n elseif(listresopt.eq.10) then\n! CCI\n! 10: stable phases with constituent fractions time FU of hase in value order\n! SOLGASMIX type output\n mode=10000\n elseif(listresopt.eq.11) then\n! 11: stable phases with constituent fractions time FU of hase in value order\n mode=10010\n! CCI end \n elseif(listresopt.eq.12) then\n! 12: just one line per phase, no compositions\n mode=10020\n else\n! all phase with with mole fractions\n mode=0\n endif\n ics=1\n once=.TRUE.\n do iph=1,noph()\n ics=0\n6310 continue\n ics=ics+1\n! moved to gtp3C\n! if(listresopt.ge.4 .and. listresopt.le.7) then\n! use phase amount in mass\n! write(lut,6308)'Mass '\n!6308 format('Name Status ',a,' Volume',&\n! ' Form.U At/FU DGM X/W:')\n! ' Form.U At/FU DGM Frac:')\n! else\n! use phase amount in mole\n! write(lut,6308)'Moles '\n! endif\n call list_phase_results(iph,ics,mode,lut,once,ceq)\n if(gx%bmperr.ne.0) then\n! if error take next phase\n gx%bmperr=0\n else\n! else take next composition set\n goto 6310\n endif\n enddo\n! list experiments if any\n6363 continue\n if(associated(ceq%lastexperiment)) then\n write(lut,491)ceq%weight\n!491 format(/'Weight ',F6.2)\n491 format('Weight ',F6.2)\n! list all experiments ........................................\n call meq_list_experiments(lut,ceq)\n write(lut,*)\n! else\n! write(*,*)'No experiments found'\n endif\n if(btest(ceq%status,EQNOEQCAL)) goto 100\n! list if anyting should be calculated or listed separately (not their values)\n if(allocated(ceq%eqextra)) then\n write(lut,492)ceq%eqextra(1)(1:len_trim(ceq%eqextra(1))),&\n ceq%eqextra(2)(1:len_trim(ceq%eqextra(2)))\n492 format('Calculate: ',a/'List: ',a)\n! else\n! write(*,*)'No extra lines'\n endif\n! make sure phases with positive DGM listed\n call list_phases_with_positive_dgm(mode,lut,ceq)\n if(btest(ceq%status,EQFAIL)) then\n write(lut,6305)'above'\n elseif(btest(ceq%status,EQNOEQCAL)) then\n write(lut,6307)'above'\n elseif(btest(ceq%status,EQINCON)) then\n write(lut,6306)'above'\n endif\n!------------------------------\n case(13) ! list conditions\n write(kou,6070)'Conditions for ',ceq%eqno,ceq%eqname\n call list_conditions(lut,ceq)\n!------------------------------\n case(14) ! list symbols (state variable functions, not TP funs)\n call list_all_svfun(lut,ceq)\n!------------------------------\n! list line_equilibria, (line-equilibria) of calculated and stored equilibria\n case(15)\n! temporary listing of all stored equilibria as test\n! IDEA: Add question for symbols and state variables to be listed!!\n! Add a heading to make spece for more dara\n! ceq #; Next; T; axis value; 0-n user symbols; \n! 9999 9999 20000.00 +1.2345E+00 1.2345E+00 1.2345E+00 1.2345E+00 1.2345E+00\n call list_stored_equilibria(lut,axarr,maptop)\n!------------------------------\n! list optimization, several suboptions\n! character (len=16), dimension(noptopt) :: optopt=&\n! ['SHORT ','LONG ','COEFFICIENTS ',&\n! 'GRAPHICS ','DEBUG ','MACRO ',&\n! 'EXPERIMENTS ','CORRELATION_MTRX','MQMQA_QUAD ']\n case(16)\n if(.not.allocated(firstash%coeffstate)) then\n write(kou,*)'No listing as no optimizing parameters'\n goto 100\n endif\n call date_and_time(optres,name1)\n kom2=submenu('List ',cline,last,optopt,noptopt,1,'?TOPHLP')\n! allow output file\n lut=optionsset%lut\n! if errs not allocated no optimization made\n if(allocated(errs)) then\n! trying to avoid segmentation fault when errs destryed by PLOT with APPEND\n if(size(errs).ne.mexp) then\n write(*,*)'Allocation error of \"errs\"',size(errs),mexp\n! deallocate(errs)\n! write(*,*)'Deallocated errs'\n write(*,*)' **** Warning, datastructure corrupted, save what you can'\n goto 100\n endif\n write(lut,600)optres(1:4),optres(5:6),optres(7:8),&\n name1(1:2),name1(3:4),err0(3)\n600 format(/'Optimization results at ',a4,'.',a2,'.',a2,&\n ':',a2,'h',a2,', normalized sum of error: ',1pe12.4)\n else\n write(*,*)'No current optimization'\n endif\n listopt: SELECT CASE(kom2)\n!..........................................................\n case DEFAULT\n write(kou,*)'No such option'\n!...........................................................\n! list optimization short\n case(1) ! short\n! if(updatemexp) then\n! write(*,*)'You must OPTIMIZE first'\n! goto 100\n! endif\n! write(kou,*)'Still no current optimization'\n if(allocated(errs)) then\n if(size(errs).eq.mexp) then\n! in matsmin\n call listoptshort(lut,mexp,nvcoeff,errs)\n else\n! After PLOT ... with APPEND of experimental data \"errs\" seems destroyed?? \n write(kou,*)'Allocation error: ',mexp,size(errs)\n deallocate(errs)\n endif\n endif\n! in gtp3C\n call listoptcoeff(mexp,err0,.FALSE.,lut)\n!...........................................................\n! list optimization long\n case(2) ! long\n write(*,*)'Not implemented yet'\n!...........................................................\n! list optimization coefficients\n case(3) ! coefficient values\n if(mexp.eq.mexpdone .and. nvcoeff.eq.nvcoeffdone) then\n call listoptcoeff(mexp,err0,.TRUE.,lut)\n else\n call listoptcoeff(mexp,err0,.FALSE.,lut)\n endif\n!...........................................................\n! list optimization graphics, plot calculated vs experiment values\n case(4) ! graphics\n write(*,*)'Not implemented yet'\n!...........................................................\n! list optimization debug ??\n case(5) ! debug\n if(nvcoeff.ne.nvcoeffdone .or. mexp.ne.mexpdone) then\n write(*,*)'No optimization done with current set of ',&\n 'coefficients or experiments'\n goto 100\n elseif(.not.allocated(fjac)) then\n write(*,*)'No optimization done'\n goto 100\n endif \n write(*,*)'Listing the Jacobian: ',nvcoeff,mexp\n! iflag=2\n! call fdjac2(mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam)\n! write(*,*)'fjac: ',nvcoeff,mexp,iflag\n do i2=1,mexp\n write(*,563)(fjac(i2,ll),ll=1,nvcoeff)\n enddo\n if(allocated(cov1)) then\n write(*,*)'The covariance matrix Jac^T * Jac: '\n do i2=1,nvcoeff\n write(*,563)(cov1(i2,ll),ll=1,nvcoeff)\n enddo\n endif\n!...........................................................\n! list optimization macro: create macro file with all experiments\n case(6) ! MACRO include experiments\n write(*,*)'Not implemented yet'\n!...........................................................\n! list optimization experiments\n case(7) ! experiments with weight>0\n if(allocated(errs)) then\n call listoptshort(lut,mexp,nvcoeff,errs)\n else\n write(kou,*)'No current optimization'\n endif\n!...........................................................\n! list optimization correlation matrix\n case(8) ! unused\n if(nvcoeff.eq.nvcoeffdone .and. allocated(cormat)) then\n write(kou,*)'Correlation matrix is (symmetric):'\n do i2=1,nvcoeff\n write(kou,563)(cormat(i2,j2),j2=1,i2)\n enddo\n write(kou,*)'Covariance matrix is (symmetric): '\n do i2=1,nvcoeff\n write(kou,563)(cov1(i2,j2),j2=1,i2)\n enddo\n else\n write(*,*)'No correlation matrix calculated'\n endif\n!...........................................................\n! list optimization RSD (according to OC and TC)\n case(9)\n write(kou,3998)\n3998 format(/'Relative Standard Deviation (RSD) values according',&\n ' to OC and TC'/'Variable OC TC')\n i2=0\n do i1=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(i1).ge.10) then\n i2=i2+1\n write(*,'(i7,2(1pe12.4))')i2,&\n sqrt(abs(cov1(i2,i2))),&\n sqrt(abs(tccovar(i2,i2)))\n endif\n enddo\n write(kou,3999)sqrt(err0(3))\n3999 format('The difference is the square root of the normalized',&\n ' sum or errors: ',1pe12.4)\n end SELECT listopt\n!------------------------------\n! list model_parameter_values, part of case(4)\n! case(17)\n! write(*,*)'Not implemented yet'\n!------------------------------\n! list error message\n case(18)\n i2=4204\n call gparidx('Error code: ',cline,last,i1,i2,'?List error msg')\n if(i1.ge.4000 .and. i1.le.nooferm) then\n write(kou,4999)i1,bmperrmess(i1)\n4999 format('The error code ',i4,', means: '/a)\n else\n write(kou,*)'Not a standard OC error message'\n endif\n!------------------------------\n! list ?? nonzero_equilibria/active-equil merged with list equilibra, case 11\n! case(19)\n! write(*,*)'Not implemented yet'\n!------------------------------\n! list elements\n case(20)\n call list_all_elements(kou)\n!------------------------------\n! list Excell CSV file, code copied from PLOT\n case(21)\n if(noofaxis.gt.1 .or. .not.associated(maptop)) then\n write(kou,*)'You must give a STEP command before list excell_csv'\n goto 100\n endif\n wildcard=.FALSE.\n iax=1\n jp=1\n call get_one_condition(jp,text,axarr(iax)%seqz,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'PMON Error getting axis condition from index: ',&\n iax,axarr(iax)%seqz\n goto 990\n endif\n! we just want the expression, remove the value including the = sign\n jp=index(text,'=')\n text(jp:)=' '\n axplotdef(1)=text\n if(maptop%tieline_inplane.eq.1) then\n! if tie-lines in the plane is 1 (.e. YES) and calculating axis was x(A)\n! then plot axis should be x(*,cu) \n jp=index(text,'(')\n if(jp.gt.0) then \n text=text(1:jp)//'*,'//text(jp+1:)\n endif\n endif\n! default for second axis always NP(*)\n axplotdef(2)='NP(*)'\n! the 4th argument to gparc means the following:\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n iax=1\n call gparcdx('Independent variable',&\n cline,last,7,axplot(iax),axplotdef(iax),'?List excell CSV')\n! dependent variables, can be wildcard\n iax=2\n call gparcdx('Dependent values',&\n cline,last,7,axplot(iax),axplotdef(iax),'?List excell CSV')\n if(buperr.ne.0) goto 990\n if(index(axplot(iax),'*').gt.0 .or. index(axplot(iax),'#').gt.0) then\n wildcard=.TRUE.\n endif\n if(index(axplot(iax),'*').gt.0) then\n! generate many values\n! the values are returned in yarr with dimension maxconst. \n! longstring are the state variable symbols for the values ...\n call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq)\n if(gx%bmperr.ne.0) then\n! if error go back to command level\n write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr\n goto 100\n endif\n elseif(index(axplot(iax),'#').gt.0) then\n! generate many values including for metastable phases\n! the values are returned in yarr with dimension maxconst. \n! longstring are the state variable symbols for the values ...\n call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq)\n if(gx%bmperr.ne.0) then\n! if error go back to command level\n write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr\n goto 100\n endif\n else\n! the value of a state variable or model parameter variable is returned\n! STRANGE the symbol xliqni is accepted in get_state_var_value ???\n call get_state_var_value(axplot(iax),xxx,model,ceq)\n if(gx%bmperr.ne.0) then\n! if error check if it is a complicated symbol like CP=H.T\n gx%bmperr=0\n! If error then try to calculate a symbol ...\n call capson(axplot(iax))\n call find_svfun(axplot(iax),istv)\n if(gx%bmperr.ne.0) then\n write(kou,*)'Illegal axis variable, error: ',gx%bmperr\n goto 100\n endif\n endif\n endif\n! output file, NOTE if /APPEND the file already open!\n if(optionsset%lut.ne.kou) then\n write(*,*)'Appended on CSV files not implemented yet',&\n optionsset%lut\n close(optionsset%lut); optionsset%lut=0\n! goto 1234\n endif\n if(buperr.ne.0) buperr=0\n! What does -5 as argument mean?? Well, open for write!!\n ztyp=-5\n call gparfilex('Output file: ',cline,last,1,plotfile,' ',ztyp,&\n '?List excell CSV')\n! make sure there is a file name\n if(len_trim(plotfile).le.0) then\n plotfile=' '\n if(buperr.ne.0) then\n! write(*,*)'PMON buperr: ',buperr\n buperr=0\n endif\n write(*,*)'Output on screen'\n else\n jp=index(plotfile,'.')\n if(jp.le.0) then\n jp=len_trim(plotfile)\n plotfile(jp+1:)='.csv'\n endif\n write(*,*)'Output will be on: ',trim(plotfile)\n endif\n if(plotfile(1:2).eq.'./') then\n! save in macro directory if iumaclevl>0, else in current working directory\n if(iumaclevl.gt.0) then\n! we are executing a macro, skip the ./\n aline=plotfile(3:)\n plotfile=trim(macropath(iumaclevl))//aline\n else\n! running interactivly prefix with working directory (default?)\n aline=plotfile(2:)\n plotfile=trim(workingdir)//aline\n endif\n! trouble passing on ling file names ....\n! write(*,*)'PMON working directory: ',trim(workingdir)\n! write(*,*)'Saving on file: ',trim(plotfile)\n endif\n1234 continue\n! use the graphics record to transfer data ...\n graphopt%pltax(1)=axplot(1)\n graphopt%pltax(2)=axplot(2)\n graphopt%filename=plotfile\n! this command only for tabulating STEP commands\n graphopt%status=ibset(graphopt%status,GRCSVTABLE)\n graphopt%status=ibclr(graphopt%status,GRISOPLETH)\n! added ceq in the call to make it possible to handle change of reference states\n! if(buperr.ne.0) buperr=0\n call ocplot2(jp,maptop,axarr,graphopt,version,ceq)\n graphopt%status=ibclr(graphopt%status,GRCSVTABLE)\n if(gx%bmperr.ne.0) goto 990\n write(*,*)'CSV output saved on file: ',trim(plotfile)\n! write(*,*)'Not implemented yet'\n!-------------------------------------------------------------------\n! list MQMQA_SPECIAL\n! character (len=16), dimension(mqmqacc) :: mqmqalist=&\n! ['QUADS ','ASYMMETRIES ','DEBUG ',&\n! 'EXCESS ','AMEND_VARKAPPA ',' ']\n case(22)\n! allow output file\n! lut=optionsset%lut\n! if errs not allocated no optimization made\n! if(allocated(errs)) then\n! trying to avoid segmentation fault when errs destryed by PLOT with APPEND\n! if(size(errs).ne.mexp) then\n! write(*,*)'Allocation error of \"errs\"',size(errs),mexp\n! deallocate(errs)\n! write(*,*)'Deallocated errs'\n call gparcx('Phase name: ',cline,last,1,name1,' ','?List phase')\n if(buperr.ne.0) goto 990\n! special to debug read database\n if(name1.eq.'DEBUG') then\n mqmqtdb=.true.\n goto 100\n endif\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n! A stupid way to find lokvares ... (or lokcs, I have forgooten which)\n if(.not.allocated(mqmqa_data%contyp)) then\n! if this not allocated there is no MQMQA data\n write(*,*)'No data for MQMQA phases'\n exit main\n endif\n lokcs=1\n do while(ceq%phase_varres(lokcs)%phlink.ne.iph)\n lokcs=lokcs+1\n enddo\n! write(*,*)'lokcs: ',lokcs,lokph,iph\n!\n kom2=submenu('MQMQA special?',&\n cline,last,mqmqalist,mqmqacc,3,'?TOPHLP')\n!..........................................................\n mqmqa: select case(kom2)\n case DEFAULT\n write(kou,*)'No such option'\n!...........................................................\n! list quads, this is independent of the phase\n case(1) ! Quads\n jquad=0\n qlista: do i1=1,nosp()\n call get_species_location(i1,loksp,name1)\n if(gx%bmperr.ne.0) goto 990\n if(index(name1,'-Q').le.0) cycle qlista\n! this is a species that is a quad\n jquad=jquad+1\n call get_species_component_data(loksp,i2,iphl,stoik,xxx,xxy,ceq)\n if(gx%bmperr.ne.0) goto 990\n do j4=1,i2\n! pick up element symbols\n call get_element_data(iphl(j4),ellist(j4),name2,&\n dummy,mass,h298,s298)\n enddo\n write(kou,1680)i1,loksp,name1,&\n (ellist(j4),stoik(j4),j4=1,i2)\n1680 format(i3,i4,1x,a,1x,4(a2,F8.6,1x))\n! this is in quad alphabetical order, not in alphabetical order of quad elements\n call mqmqa_quadbonds(jquad,quadbonds)\n if(i2.eq.2) then\n write(kou,1681)(quadbonds(j4),j4=1,3)\n else\n write(kou,1681)(quadbonds(j4),j4=1,i2)\n endif\n1681 format(26x,'bonds: ',4(F10.6,1x))\n! max length 8+25+4*11=33+44=77\n enddo qlista\n!\n if(jquad.eq.0) write(kou,*)'No MQMQA quads found'\n!\n!\n! maybe include listing of mqmqa_data%constoi(1..4,index)\n!...........................................................\n! list Asymmetries\n! note: tersys, xquad, compvar are not linked from the phase!!!\n case(2)\n! copied from gtp3XQ listconst\n! list element names, numbers and quad indices, i1 set to number of quads\n call list_quads(i1)\n!\n! tersys is global data\n ts: if(allocated(tersys)) then\n write(*,3101)size(tersys)\n!3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',&\n! /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code')\n do iz=1,size(tersys)\n write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n tersys(iz)%isasym,tersys(iz)%asymm\n!3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a)\n enddo\n write(*,3301)\n!3301 format('Number in T/0 column is actual asymmetric cation'/)\n else\n write(kou,*)'No ternary asymmetry data allocated'\n endif ts\n!\n! listing of fraction in alphbetical order\n write(kou,4123)mqmqa_data%nquad,&\n (ceq%phase_varres(lokcs)%yfr(i1),i1=1,mqmqa_data%nquad)\n!4123 format('Fractions ',i2,' in species OC alphabetical order:',/&\n! (12F6.3))\n! mqmqaf defined globally\n anoq: if(.not.allocated(ceq%phase_varres(lokcs)%mqmqaf%xquad)) then\n write(*,*)'Quads not allocated'\n else\n write(kou,4122)mqmqa_data%nquad,&\n (ceq%phase_varres(lokcs)%mqmqaf%xquad(i1),i1=1,mqmqa_data%nquad)\n!4122 format('Fractions ',i2,' in Quad order: ',/(12F6.3))\n\n write(kou,4124)mqmqa_data%nquad,mqmqa_data%ncat\n!4124 format(/'The ',i3,' quads for ',i2,' cations are arranged ',&\n! 'in order of the n cations:'/&\n! 'Quad ',9x,'1 2 ... n | n+1 n+2 ... 2n-1 | 2n .. | n(n+1)/2'/&\n! 'Cation',9x,'1 1 ... 1 | 2 2 ... 2 | 3 .. | n'/&\n! 'Cation',9x,'1 2 ... n | 2 3 ... n | 3 .. | n')\n write(kou,4126)mqmqa_data%quad2compvar\n!4126 format('quad2compvar: ',21(1x,i2))\n write(kou,4127)mqmqa_data%emquad*(mqmqa_data%emquad-1),&\n mqmqa_data%emquad\n4127 format('Number of varkappa_ij asymmetry variables, n*(n-1)/2: ',i3/&\n 'em2quad: ',21(1x,i2))\n! just a blank line\n write(kou,*)\n write(kou,308)'Fractions in OC order ',&\n (i2,i2=1,mqmqa_data%nquad)\n write(kou,308)'Fractions in Quad order ',&\n (mqmqa_data%con2quad(i2),i2=1,mqmqa_data%nquad)\n!308 format(a,15i3)\n!\n write(kou,410)newXupdate\n!410 format(/'List of compvar, the binary asymmetric composition',&\n! ' variables, last update:',i5/&\n! ' seq cat_i cat_j varkappa_ij varkappa_ji xi_ij xi_ji')\n! calculate varkappaij and varkappaji correcting for all ternaries\n mqmqavar=>ceq%phase_varres(lokcs)\n call calcasymvar(mqmqavar)\n j4=0\n acat1: do i1=1,mqmqa_data%ncat-1\n acat2: do i2=i1+1,mqmqa_data%ncat\n j4=j4+1\n write(kou,412)j4,i1,i2,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ij,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%vk_ji,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ij,&\n ceq%phase_varres(lokcs)%mqmqaf%compvar(j4)%xi_ji\n!412 format(i5,2i6,3x,4(1PE12.4))\n enddo acat2\n enddo acat1\n endif anoq\n!\n write(kou,444)'Values of y_i/k: ',&\n (ceq%phase_varres(lokcs)%mqmqaf%y_ik(i1),i1=1,mqmqa_data%ncat)\n!444 format(/a,(10f7.4))\n write(kou,*)\n! an empty line before extended information\n! NOTE THIS IS PART OF REDUNDANT COMMAND LIST MQ AMEND_VARKAPPA\n! call gparcdx('Details on varkappa?',cline,last,1,ch1,'N',&\n! '?Varkappa')\n! if(ch1.ne.'N') then\n mqmqavar=>ceq%phase_varres(lokcs)\n call varkappadefs(mqmqavar)\n! endif\n! repeat the asymmetries\n! if(allocated(tersys)) then\n! write(*,3101)size(tersys)\n! do iz=1,size(tersys)\n! write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n! tersys(iz)%isasym,tersys(iz)%asymm\n! enddo\n! write(*,3301)\n! list again element names, numbers and quad indices\n! call list_quads(i1)\n! else\n! write(kou,*)'No ternary asymmetry data allocated'\n! endif\n!\n!...........................................................\n! list DEBUG for implementation of asymmetric models\n case(3)\n! list the constituents of the phase in the order they have in constitlink\n! THIS IS AN EMERGY SUBROUTINE IN gtp3XQ NOT CONFORMING WITH THE STRUCTURE\n call listconst(iph)\n!\n! check consistency of some data in mqma_data!!\n! some also in gtp_mqmqa_var!!\n write(*,1687)mqmqa_data%nconst,mqmqa_data%nquad,&\n mqmqa_data%ncon1,mqmqa_data%ncat,&\n mqmqa_data%ncon2,mqmqa_data%nan,&\n mqmqa_data%npair,mqmqa_data%lcat\n1687 format(/'Values of some duplicate global data:',&\n 'Number of quads: ',2i4/&\n 'Number of cations: ',2i4/&\n 'Number of anions: ',2i4/&\n 'Number of pairs: ',i4/&\n 'Value of cation*(cation+1)/2: ',i4/)\n!\n i2=0\n write(*,1688)\n1688 format('Debug settings:'/'0 no debug'/'1 debug asymmetry'/&\n '2 debug some more'/&\n '3 debug reading TDB'/&\n '4 debug parameter calculation'/&\n '5 debug partial derivative calculation')\n call gparidx('Set mqmqa debug?',cline,last,i1,i2,'?MQMQA debug')\n mqmqdebug=.false.\n mqmqdebug2=.false.\n mqmqtdb=.false.\n mqmqxcess=.false.\n mqmqder=.false.\n if(i1.eq.1) then\n! asymmetry debug\n mqmqdebug=.true.\n elseif(i1.eq.2) then\n mqmqdebug2=.true.\n elseif(i1.eq.3) then\n! tdb reading debug\n mqmqtdb=.true.\n elseif(i1.eq.4) then\n! calculation debug\n mqmqxcess=.true.\n elseif(i1.eq.5) then\n! partial derivative debug\n mqmqder=.true.\n endif\n!\n!...........................................................\n! list excess tree\n case(4)\n call get_phase_record(iph,lokph)\n call listpartree(lokph)\n\n!...........................................................\n! list mqmqa AMEND_VARKAPPA\n case(5)\n!\n! CODE BELOW REPLACED by new code around line 1374 AMEND PHASE ... ASYMMETRY\n! that code around line 1288\n!\n! list element names, numbers and quad indices, i1 set to number of quads\n write(*,*)'USE AMEND PHASE ... ASYMMETRY instead'\n goto 100\n!\n call list_quads(i1)\n! tersys is defined globally\n ts2: if(allocated(tersys)) then\n write(*,3101)size(tersys)\n!3101 format(/'Listing of the ',i3,' ternary systems and their asymmetries',&\n! /' i seq cat1 cat2 cat3 T/0 T/0 T/0 asymmetry code')\n do iz=1,size(tersys)\n write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n tersys(iz)%isasym,tersys(iz)%asymm\n!3201 format(i3,i5,2x,3(1x,i4),5x,3i4,5x,a)\n enddo\n! ************************* this code redundant *************************\n write(*,3301)\n else\n write(kou,*)'No ternary asymmetry data allocated'\n endif ts2\n if(size(tersys).gt.1) then\n write(*,*)'Implemented only for a single ternary'\n goto 100\n else\n call gparidx('Specify varkappa index:',cline,last,iz,1,&\n '?List MQMQA varkappa modification')\n! iz=1\n endif\n! ************************* this code redundant *************************\n write(*,3401)\n3401 format('Give 1, 2 or 3 for cat1, cat2 or cat3, 0 if no asymmetry')\n call gparidx('Specify Toop cation index:',cline,last,i2,0,&\n '?List MQMQA varkappa modification')\n! In the general case we must check if the Toop constituent is in the ternary\n! but if we have just one skip it at present\n! As we have just 3 constituents, i2 must be 1, 2 or 3\n! remove any previous Toop element\n asymter=1\n write(*,*)'THIS CODE REPLACED BY AMEND PHASE ... ASYMMETRY '\n! that code around line 1288\n if(asymter.le.0 .or. asymter.gt.size(tersys)) then\n write(*,*)'No such ternary'\n goto 100\n endif\n! ************************* this code redundant *************************\n! new_asymmetry='KKK'\n! tersys is set later inside varkappa1 .... keep for the moment\n! tersys(iz)%asymm='KKK'\n! if(i2.eq.0) then\n! write(*,*)'Restoring symmetric ternary'\n! elseif(i2.eq.1) then\n! Binary 1-2 has 3 as Toop, binary 1-3 has 2 as Toop, binary 2-3 has 1 as Toop\n! THIS IS A MESS suck\n! new_asymmetry(1:1)='T'\n! tersys(iz)%isasym(1)=1; tersys(iz)%asymm(1:1)='T'\n! elseif(i2.eq.2) then\n! new_asymmetry(2:2)='T'\n! tersys(iz)%isasym(2)=2; tersys(iz)%asymm(2:2)='T'\n! elseif(i2.eq.3) then\n! new_asymmetry(3:3)='T'\n! tersys(iz)%isasym(3)=3; tersys(iz)%asymm(3:3)='T'\n! else\n! write(kou,*)'Use 1, 2 or 3. No change of asymmetry'\n! goto 990\n! endif\n iz=asymter\n write(*,3201)iz,tersys(iz)%seq,(tersys(iz)%el(j4),j4=1,3),&\n tersys(iz)%isasym,tersys(iz)%asymm\n! Now modify the ivk, jvk and kvk arrays .....\n write(*,*)'THIS CODE REPLACED BY AMEND PHASE ... ASYMMETRY '\n! that code around line 1288\n write(*,*)'Now modify the ivk, jvk and kvk arrays .....'\n! type(gtp_phase_varres), pointer :: phres\n! phres is the pointer to the phase_varres record of mqmqa phase\n! call varkappa1(iz,phres)\n! TYPE(gtp_phase_varres), pointer :: parres\n parres=>ceq%phase_varres(lokcs)\n if(allocated(parres%mqmqaf%compvar)) then\n! make sure the varkappa are updated\n! deafult is 0, to update set box%lastupdate to -1\n parres%mqmqaf%compvar(iz)%lastupdate=-1\n write(kou,*)'BUG Asymmetry update works only for first cation'\n! this code is redundant <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n! call varkappa1(iz,parres,asymter,new_asymmetry)\n! write(kou,*)'Asymmetry updated'\n else\n write(kou,*)'This phase has no asymmetry records'\n endif\n!\n! THE CODE ABOVE REPLACED around line 1374 by AMEND PHASE ... ASYMMETRY\n!\n!...........................................................\n! \n case(6)\n write(kou,*)'Not implemented yet'\n \n end SELECT mqmqa\n!------------------------------ end list mqmqa_specials\n! LIST ESTIMATE_ACCURACY. Additional calculations are made\n! Eventually included in case(12) ???\n case(23) \n if(btest(ceq%status,EQNOEQCAL) .or. btest(ceq%status,EQFAIL)) then\n write(kou,*)'You must calculate an equilibrium first'\n goto 100\n endif\n xxy=5.0\n call gparrdx('Estimated uncertainty in conditions (%): ',&\n cline,last,xxx,xxy,'?List confidence interval')\n i1=optionsset%lut\n if(i1.eq.0) i1=kou\n call calc_conf_interval(i1,xxx,ceq)\n if(gx%bmperr.ne.0) then\n ceq%status=ibset(ceq%status,EQFAIL)\n goto 990\n endif\n!------------------------------\n! list WORKING_DIR\n case(24)\n write(kou,1685)trim(workingdir)\n1685 format('Current working directory is: ',a)\n!------------------------------\n! list ??\n case(25)\n write(kou,*)'Not implemented yet'\n!------------------------------\n! list ??\n case(26)\n write(kou,*)'Not implemented yet'\n!------------------------------\n! list ??\n case(27)\n write(kou,*)'Not implemented yet'\n end SELECT list\n!=================================================================\n! quit\n case(7)\n if(cline(1:1).eq.'q') then\n call gparcdx('Are you sure?',cline,last,1,ch1,'N','?Quit')\n else\n! upper case Q will quit without question\n ch1='y'\n endif\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n if(logfil.gt.0) then\n write(logfil,*)'set interactive'\n endif\n call openlogfile(' ',' ',-1)\n stop 'Have a nice day'\n endif\n!=================================================================\n! READ subcommand\n! ['UNFORMATTED ','TDB ','QUIT ',&\n! 'DIRECT ','XTDB ','SELECTED_PHASES ']\n case(8)\n! disable continue optimization\n! iexit=0\n! iexit(2)=1\n if(noel().ne.0) then\n write(kou,*)'You already have data, read destroys your current data'\n write(kou,*)'You must give a NEW Y command to remove data first'\n goto 100\n! else\n! all records must be removed and init_gtp is called. This is fragile ...\n! call new_gtp\n! if(gx%bmperr.ne.0) goto 990\n! write(kou,*)'All previous data deleted'\n! endif\n endif\n kom2=submenu(cbas(kom),cline,last,cread,ncread,2,'?TOPHLP')\n read: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n if(cline(len_trim(cline):len_trim(cline)).ne.'?') then\n! This avoids error messages when ? is typed\n write(kou,*)'Read subcommand error: ',trim(cline)\n endif\n!-----------------------------------------------------------\n case(1) ! read unformatted file created by SAVE\n if(ocufile(1:1).ne.' ') then\n text=ocufile\n call gparcdx('File name: ',cline,last,1,ocufile,text,&\n '?Read unformatted')\n else\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=2\n call gparfilex('File name: ',cline,last,1,ocufile,' ',ztyp,&\n '?Read unformatted')\n endif\n call gtpread(ocufile,text)\n if(gx%bmperr.ne.0) then\n ocufile=' '; goto 990\n endif\n! This is written by the gtpread subroutine\n! kl=len_trim(text)\n! if(kl.gt.1) then\n! write(kou,8110)text(1:kl)\n! endif\n!8110 format(/'Savefile text: ',a/)\n! if there is an assessment record set nvcoeff ...\n if(allocated(firstash%coeffvalues)) then\n nvcoeff=0\n kl=size(firstash%coeffvalues)-1\n do j4=0,kl\n if(firstash%coeffstate(j4).ge.10) then\n nvcoeff=nvcoeff+1\n endif\n enddo\n write(kou,3730)nvcoeff\n else\n write(*,*)'No coefficients allocated'\n endif\n if(allocated(firstash%eqlista)) then\n write(*,*)'There are experimental data'\n endif\n!---------------------------------------------------------\n case(2,7) ! read TDB and read ENCRYPTED\n! indicate if the database is encrypted!\n if(kom2.eq.7) then\n globaldata%encrypted=1\n else\n globaldata%encrypted=0\n endif\n! write(*,*)'PM glovaldata%encrypted: ',globaldata%encrypted\n if(tdbfile(1:1).ne.' ') then\n! set previous tdbfil as default\n text=tdbfile\n call gparcdx('File name: ',cline,last,1,tdbfile,text,'?Read TDB')\n else\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=1\n call gparfilex('File name: ',cline,last,1,tdbfile,' ',ztyp,&\n '?Read TDB')\n endif\n! if tdbfle starts with \"ocbase/\" replace that with content of ocbase!!\n! write(*,*)'PMON tdbfile: ',trim(tdbfile)\n! check for replacement of OCBASE probably redundant now ...\n name1=tdbfile(1:7)\n call capson(name1)\n if(name1(1:7).eq.'OCBASE/' .or. name1(1:8).eq.'OCBASE\\ ') then\n tdbfile=trim(ocbase)//tdbfile(7:)\n write(*,*)'database file: ',trim(tdbfile)\n endif\n! this call checks the file exists and returns the elements\n! it also lists the DATABASE_INFO text\n! call checkdb2(tdbfile,'.tdb',jp,ellist)\n call checkdb2(tdbfile,'.tdb',jp,elbase)\n if(gx%bmperr.ne.0) then\n write(kou,*)'No database with this name'\n tdbfile=' '\n goto 990\n elseif(jp.eq.0) then\n write(kou,*)'No elements in the database'\n tdbfile=' '\n goto 100\n elseif(jp.lt.0) then\n! encrypted databases return jp=-1, we do not know number of elements ...\n write(kou,*)'Cannot list elements in encrypted databases'\n j4=20\n goto 8207\n endif\n! write(kou,8203)jp,(ellist(kl),kl=1,jp)\n j4=jp\n write(kou,8203)jp,(elbase(kl),kl=1,j4)\n8203 format('Database has ',i2,' elements: ',18(a,1x)/(1x,28(1x,a)))\n ellist=' '\n write(kou,8205)\n8205 format('Give the elements to select, finish with empty line')\n8207 continue\n jp=1\n selection='Select elements /all/:'\n8210 continue\n call gparcx(selection,cline,last,1,ellist(jp),' ','?Read TDB')\n if(jp.eq.1 .and. cline(1:4).eq.'all ') then\n! this is if someone actually types \"all\". If he types \"ALL\" that will be AL\n jp=0\n elseif(cline(1:1).eq.'q' .or. cline(1:1).eq.'Q' .or.&\n cline(1:4).eq.'NONE') then\n! if user regets selection he can quit\n write(*,*)'Quitting, nothing selected'\n goto 100\n elseif(ellist(jp).ne.' ') then\n call capson(ellist(jp))\n jp=jp+1\n if(jp.gt.size(ellist)) then\n write(kou,*)'Max number of elements selected: ',size(ellist)\n else\n ll=last\n! Check if element exist, unless encrypted ...\n if(globaldata%encrypted.eq.0) then\n elcheck: do j5=1,j4\n if(ellist(jp-1).eq.elbase(j5)) exit elcheck\n enddo elcheck\n! if we come here with j4>j5 then ellist(jp) is not in elbase(1..j4)\n if(j5.gt.j4) then\n jp=jp-1\n write(kou,'(a,i3,1x,a)')' *** WARNING: No such element:',&\n jp,ellist(jp)\n endif\n endif\n if(eolch(cline,last)) then\n! if empty line list current selection and prompt for more\n write(*,8220)jp-1,(ellist(iel),iel=1,jp-1)\n else\n! we must reset position in cline if there is more ...\n last=ll\n endif\n selection='Select elements /no more/:'\n goto 8210\n endif\n else\n jp=jp-1\n endif\n if(jp.eq.0) then\n write(kou,*)'All elements selected'\n else\n write(*,8220)jp,(ellist(iel),iel=1,jp)\n8220 format('Selected ',i2,' elements: ',20(a,1x))\n endif\n call readtdb(tdbfile,jp,ellist)\n if(gx%bmperr.ne.0) then\n! inside readtdb any \"buperr\" will be set as gx%bmperr\n write(kou,*)'There were errors reading the TDB file', gx%bmperr\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,*)bmperrmess(gx%bmperr)\n endif\n write(kou,*)'Please correct these before continuing'\n! ignore any type ahead\n last=len(cline)\n call gparcdx('Do you want to continue anyway?',&\n cline,last,1,ch1,'N','?Read TDB error')\n if(ch1.ne.'Y') then\n stop 'Good luck fixing the TDB file'\n endif\n endif\n! also list the bibliography\n write(kou,*)\n call list_bibliography(' ',kou)\n write(kou,*)\n if(firsteq%multiuse.ne.0) then\n write(*,8221)\n8221 format(/' *** There were warnings from reading the database'/&\n ' *** If you run a macro file please scroll back and check!'/)\n endif\n!-----------------------------------------------------------\n!8300 continue\n case(3) ! read quit\n goto 100\n!-----------------------------------------------------------\n case(4) ! read direct\n write(*,*)'Read direct not implemented yet'\n!-----------------------------------------------------------\n! read the new XTDB format for Calphad databases\n case(5) ! read XTDB \n if(xtdbfile(1:1).ne.' ') then\n text=xtdbfile\n write(*,*)'debug; ',trim(text)\n call gparcdx('File name: ',cline,last,1,xtdbfile,text,'?Read XTDB')\n else\n! THESE TYPES ARE USED ALSO IN METLIB4\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, 8=LOG\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=6\n call gparfilex('File name: ',cline,last,1,xtdbfile,' ',ztyp,&\n '?Read XTDB')\n endif\n if(xtdbfile(1:1).eq.' ') goto 100\n! this call checks the file exists and returns the elements\n! It is in gtp3EY and can handle the j5 then ellist(jp) is not in elbase(1..j4)\n if(j5.gt.j4) then\n jp=jp-1\n write(kou,'(a,i3,1x,a)')'No such element: ',jp,ellist(jp)\n endif\n if(eolch(cline,last)) then\n! if empty line list current selection and prompt for more\n write(*,8220)jp-1,(ellist(iel),iel=1,jp-1)\n else\n! we must reset position in cline if there is more ...\n last=ll\n endif\n selection='Select elements /no more/:'\n goto 8219\n endif\n else\n jp=jp-1\n endif\n if(jp.eq.0) then\n write(kou,*)'All elements selected'\n else\n write(*,8220)jp,(ellist(iel),iel=1,jp)\n!8220 format('Selected ',i2,' elements: ',20(a,1x))\n endif\n! SPECIAL SELECT_PHASES\n! ask for phses to be selected, max 100, seltdbph global variable\n allocate(seltdbph(100))\n j4=0\n selection='Select phase(s) /all/:'\n selph: do while (.TRUE.)\n call gparcdx(selection,&\n cline,last,1,line,' ','?Read select phase')\n if(line(1:1).eq.' ') exit selph\n selection='Select more phase(s):'\n! There is at least one phase name in line\n j2=1\n phname: do while(.not.eolch(line,j2))\n j4=j4+1\n if(j4.gt.100) then\n write(*,*)'Max 100 phases can be selected'\n exit selph\n endif\n j2=j2-1\n! getext increments i2 by 1 at each call. A space or , between each name\n! write(*,*)'pmon 1:',trim(line),j2,j4\n call getext(line,j2,1,seltdbph(j4),' ',i1)\n call capson(seltdbph(j4))\n! write(*,*)'pmon 2:',seltdbph(j4),i1\n enddo phname\n enddo selph\n! nselph is a global variabel\n nselph=j4\n if(nselph.gt.0) then\n write(*,*)nselph,' phase abbreviations specified '\n else\n write(*,*)'No phase specified, all will be read'\n endif\n! do j2=1,j4,3\n! write(*,'(a,1x,a,1x,a)')(trim(seltdbph(j2+i1)),i1=0,2)\n! enddo\n! Finally read the TDB file\n! if seltdbph is allocated only those phase will be inlcuded\n call readtdb(tdbfile,jp,ellist)\n deallocate(seltdbph)\n if(gx%bmperr.ne.0) then\n! inside readtdb any \"buperr\" will be set as gx%bmperr\n write(kou,*)'There were errors reading the TDB file', gx%bmperr\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,*)bmperrmess(gx%bmperr)\n endif\n write(kou,*)'Please correct these before continuing'\n! ignore any type ahead\n last=len(cline)\n call gparcdx('Do you want to continue anyway?',&\n cline,last,1,ch1,'N','?Read TDB error')\n if(ch1.ne.'Y') then\n stop 'Good luck fixing the TDB file'\n endif\n endif\n! also list the bibliography\n write(kou,*)\n call list_bibliography(' ',kou)\n write(kou,*)\n if(firsteq%multiuse.ne.0) then\n write(*,8221)\n!8221 format(/' *** There were warnings from reading the database'/&\n! ' *** If you run a macro file please scroll back and check!'/)\n endif\n! case(7) ! read ENCRYPTED\n! part of read TDB \n case(8) ! read ?\n write(*,*)'Not implemented yet'\n case(9) ! read ?\n write(*,*)'Not implemented yet'\n end SELECT read\n!=================================================================\n! SAVE in various formats (NOT MACRO and LATEX, use LIST DATA)\n! It is a bit inconsistent as one READ TDB but not SAVE TDB ...\n! ['TDB ',' ','QUIT ',&\n! 'DIRECT ','UNFORMATTED ','XTDB ']\n CASE(9)\n! default is 3, unformatted\n kom2=submenu(cbas(kom),cline,last,csave,ncsave,1,'?TOPHLP')\n if(kom2.le.0 .or. kom2.gt.ncsave) goto 100\n!\n call date_and_time(optres,name1)\n! optres(1:8) is year+month+day, name1(1:4) is hour and minutes\n model=' '//optres(1:4)//'.'//optres(5:6)//'.'//optres(7:8)//&\n ' '//name1(1:2)//'h'//name1(3:4)//' '\n save: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'save subcommand error'\n!-----------------------------------------------------------\n case(1) ! save TDB, same as list data TDB\n! format 1 is TDB, see list data ...\n if(globaldata%encrypted.ne.0) then\n write(kou,*)'Illegal for encrypted databases'\n goto 100\n endif\n! gparfilex next to last argument is negative if \n ztyp=-1\n call gparfilex('File name: ',cline,last,1,filename,text,ztyp,&\n '?Save TDB')\n! Bosse do not understand ???\n kl=max(index(filename,'.dat '),index(filename,'.TDB '))\n if(kl.le.0) then\n kl=len_trim(filename)+1\n if(kl.eq.1) then\n write(*,*)'Too short file name'\n goto 100\n endif\n! Bosse do not understand ???\n! filename(kl:)='.DAT '\n endif\n! inside list_TDB_format\n! write(*,*)'PMON calling list_TDB_formats'\n call list_TDB_format(filename)\n! write(*,*)'PMON back from list_TDB_formats'\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,*)bmperrmess(gx%bmperr)\n elseif(gx%bmperr.ne.0) then\n write(kou,*)'Error code ',gx%bmperr\n endif\n!-----------------------------------------------------------\n case(2) ! used to be SOLGAS no longer available\n continue\n!-----------------------------------------------------------\n case(3) ! save quit, do nothing\n continue\n!-----------------------------------------------------------\n case(4) ! save DIRECT\n write(*,*)'Not implemented'\n goto 100\n! probably never to be implemented, save UNFORMATTED can include STEP/MAP\n if(ocdfile(1:1).ne.' ') then\n text=ocdfile\n call gparcdx('File name: ',cline,last,1,ocdfile,text,'?Save direct')\n else\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=-4\n call gparfilex('File name: ',cline,last,1,ocdfile,' ',ztyp,&\n '?Save direct')\n endif\n jp=0\n kl=index(ocdfile(2:),'.')+1\n if(kl.le.0) then\n jp=len_trim(ocdfile)\n elseif(ocdfile(kl+1:kl+1).eq.' ') then\n! just ending a filename with . not accepted as extention\n jp=kl\n endif\n if(kl.le.1 .and. jp.le.0) then\n write(kou,*)'Missing file name, nothing saved'\n goto 100\n endif\n if(jp.gt.0) ocdfile(jp+1:)='.OCD '\n text='M '//model\n call gtpsave(ocdfile,text)\n!-----------------------------------------------------------\n case(5) ! save unformatted\n132 continue\n! save unformatted after step/map not recommended as equilibria\n! unless equilibria with _MAPLINE and _MAPNODE not deleted\n! Reading an unformatted file with these prevents any new new STEP/MAP\n call findeq('_MAPLINE_1 ',ieq)\n if(gx%bmperr.eq.0) then\n write(kou,*)'Please use DELETE STEP_MAP before unformatted save'\n goto 100\n else\n! there are no map/step equilibria, OK to save\n gx%bmperr=0\n endif\n!\n if(ocufile(1:1).ne.' ') then\n text=ocufile\n call gparcdx('File name: ',cline,last,1,ocufile,text,&\n '?Save unformatted')\n else\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=-2\n call gparfilex('File name: ',cline,last,1,ocufile,' ',ztyp,&\n '?Save unformatted')\n endif\n jp=0\n! ignore first letter as in macro files a file name may start with ./\n kl=index(ocufile(2:),'.')+1\n if(kl.le.1) then\n jp=len_trim(ocufile)\n elseif(ocufile(kl+1:kl+1).eq.' ') then\n! just ending a filename with . not accepted as extention\n jp=kl\n endif\n if(kl.le.1 .and. jp.le.0) then\n write(kou,*)'Missing file name, nothing saved'\n goto 100\n endif\n! I have no way to handle the extention to upper case ... inside C routine\n! if(jp.gt.0) ocufile(jp+1:)='.ocu '\n if(jp.gt.0) ocufile(jp+1:)='.OCU '\n inquire(file=ocufile,exist=logok)\n if(logok) then\n call gparcdx('File exists, overwrite?',cline,last,1,ch1,'N',&\n '?Save overwite')\n if(ch1.ne.'Y') then\n write(*,133)\n133 format('Please use another file name')\n ocufile=' '\n goto 132\n endif\n write(*,134)trim(ocufile)\n134 format(/'Overwriting previous results on ',a)\n endif\n text='U '//model\n call gtpsave(ocufile,text)\n!-----------------------------------------------------------\n case(6) ! SAVE XTDB\n! write(kou,*)'PMON: XTDB format still fragile'\n if(globaldata%encrypted.ne.0) then\n write(kou,*)'Illegal for encrypted databases'\n goto 100\n endif\n! is there any data?\n if(noph().le.0) then\n write(kou,*)'There is no data to save'\n goto 100\n endif\n! Ask for file name\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=-6\n call gparfilex('File name: ',cline,last,1,xtdbfile,' ',ztyp,&\n '?Save XTDB')\n!\n zext='XTDB'\n! this subrouine is in gtp3EX.F90\n call write_xtdbformat(xtdbfile,zext)\n if(gx%bmperr.ne.0) goto 990\n end SELECT save\n!=================================================================\n! help ... just list the commands\n case(10)\n call q3helpx(cline,last,cbas,ncbas)\n goto 100\n!=================================================================\n! subcommands to INFORMATION ... very little implemented\n! ['ELEMENTS ','SPECIES ','PHASES ',&\n! 'QUIT-INFO ','COMPOSITION_SET ','EQUILIBRIUM ',&\n! 'HELP_SYSTEM ','CONDITIONS ','DATABASES ',&\n! 'CHANGES ','PHASE_DIAGRAM ','PROPERTY_DIAGRAM',&\n! 'STATE_VARIABLES ',' ',' ']\n case(11)\n! kom2=submenu(cbas(kom),cline,last,cinf,ninf,10,'?TOPHLP')\n! initial default is CHANGES\n iz=10\n! return here until quit\n207 continue\n kom2=submenu('Topic?',cline,last,cinf,ninf,iz,'?TOPHLP')\n! change default to quit\n iz=4\n information: select case(kom2)\n!-------------------------------------------------------\n CASE DEFAULT\n write(*,*)'Information subcommand error'\n!--------------------------------------------------------\n! INFO elements\n case(1)\n write(kou,210)\n210 format('The elements are those from the periodic chart.'/&\n 'Normally the components are the same as the elemets but',&\n ' the user',/'can define any orthogonal set of species as',&\n ' components.')\n call q4help('Info elements',jp)\n!--------------------------------------------------------\n! info species\n case(2)\n write(kou,211)\n211 format('Species are molecular like aggregates of elements with',&\n ' fixed stoichiometry.',/'The elements are the simplest',&\n ' species.'/'The constituents of a phase are a subset of',&\n ' the species.')\n call q4help('Info species',jp)\n!--------------------------------------------------------\n! info phases\n case(3)\n call q4help('Info phases',jp)\n!--------------------------------------------------------\n! quit, we must exit to top level here !!\n case(4)\n goto 100\n!--------------------------------------------------------\n! info composition set\n case(5)\n call q4help('Info compset',jp)\n!--------------------------------------------------------\n! info equilibrium\n case(6)\n call q4help('Info equilibrium',jp)\n!--------------------------------------------------------\n! INFO help system\n case(7) ! none\n call q4help('Info helpsystem',jp)\n!--------------------------------------------------------\n! INFO conditions\n case(8) ! none\n call q4help('Info conditions',jp)\n!--------------------------------------------------------\n! INFO databases\n case(9) ! none\n call q4help('Info databases',jp)\n!--------------------------------------------------------\n! changes\n case(10)\n write(kou,'(a/)')'Writing from \"OCHOME/changes.txt\"'\n open(31,file=trim(OCHOME)//'/changes.txt ',access='sequential',&\n err=990,iostat=buperr)\n changes: do while(.TRUE.)\n do i1=1,40\n read(31,17,end=244,err=990)line\n write(kou,17)trim(line)\n17 format(a)\n enddo\n write(kou,*)'Press return to continue, q to quit'\n read(kiu,17)ch1\n if(ch1.eq.'q' .or. ch1.eq.'Q') exit changes\n enddo changes\n244 close(31)\n!--------------------------------------------------------\n! INFO phase diagram\n case(11) ! none\n call q4help('Info phasediagram',jp)\n!--------------------------------------------------------\n! INFO property diagram\n case(12) ! none\n call q4help('Info propertydiagram',jp)\n!--------------------------------------------------------\n! INFO statevariables\n case(13) ! none\n call q4help('Info statevariables',jp)\n!--------------------------------------------------------\n! INFO \n case(14) ! none\n! call q4help('Info ',jp)\n!--------------------------------------------------------\n! INFO \n case(15) ! none\n! call q4help('Info ',jp)\n end select information\n goto 207\n!=================================================================\n! back / goto, return to calling (main) program\n case(12)\n write(*,*)'Welcome back!'\n return\n!=================================================================\n! NEW command, same as reinitiate\n case(13) ! NEW\n! one must deallocate everyting explicitly to use memory again\n call gparcdx('All data will be removed, are you sure?',cline,last,&\n 1,ch1,'N','?New')\n if(ch1.ne.'Y') then\n write(kou,*)'*** NO CHANGE, upper case Y needed for NEW'\n goto 100\n endif\n! remove global check during map\n mapglobalcheck=0\n stepspecial=.FALSE.\n!------remove assessment data\n! write(*,*)'No segmentation fault 1'\n if(allocated(firstash%eqlista)) then\n write(*,*)'Assessment data removed, not deallocated: memory leak'\n endif\n! write(*,*)'No segmentation fault 2'\n if(allocated(firstash%eqlista)) deallocate(firstash%eqlista)\n deallocate(firstash)\n! write(*,*)'No segmentation fault 3, deallocate errs '\n if(mexp.gt.0) deallocate(errs)\n mexp=0\n updatemexp=.true.\n nvcoeff=0\n! initiate the limit on number of equilibria saved during step/map\n totalsavedceq=0\n! iexit=0\n! iexit(2)=1\n! write(*,*)'No Segmentation fault 4'\n!----- deleting map results ...\n! write(*,*)'PM Deleting map results'\n if(associated(maptopsave)) then\n! this is necessary only if no plot of last step/map made ...\n write(kou,*)'We link to maptopsave'\n maptop%plotlink=>maptopsave\n nullify(maptopsave)\n endif\n seqxyz=0\n! write(*,*)'Calling delete_mapresults'\n call delete_mapresults(maptop)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error deleting map results! Report this error with macro!'\n stop\n endif\n! write(*,*)'Back from delete_mapresults'\n nullify(maptop)\n nullify(mapnode)\n nullify(maptopsave)\n seqxyz=0\n!----- deallocate local axis records\n do jp=1,noofaxis\n if(allocated(axarr(jp)%axcond)) deallocate(axarr(jp)%axcond)\n! deallocate(axarr(jp)%indices)\n! deallocate(axarr(jp)%coeffs)\n enddo\n noofaxis=0\n! remove some more defaults ...\n defcp=1\n! deallocate does not work on pointers!!!\n nullify(starteqs(1)%p1)\n noofstarteq=0\n!\n! this routine fragile, inside new_gtp init_gtp is called\n! write(*,*)'No segmentation fault 7, calling new_gtp'\n call new_gtp\n if(gx%bmperr.ne.0) then\n write(*,*)'Error deleting data! Report this error with macro!'\n stop\n endif\n write(kou,*)'All data removed, reinitiating'\n call init_gtp(intv,dblv)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error initiating! Report this error with macro!'\n stop\n endif\n! write(kou,*)'Workspaces initiated'\n! ceq=>firsteq\n goto 20\n!=================================================================\n! macro begin\n case(14) ! file name is asked inside macbeg\n call macbeg(cline,last,logok)\n if(buperr.ne.0 .or. gx%bmperr.ne.0) goto 990\n!=================================================================\n! about\n case(15)\n write(kou,15010)version,linkdate\n15010 format(/'This is OpenCalphad (OC), a free software for ',&\n 'thermodynamic calculations as described in:'/&\n 'B Sundman, U R Kattner, M Palumbo and S G Fries, ',&\n 'Int Mat and Manu Innov (2015) 4:1; '/&\n 'B Sundman, X-G Lu and H Ohtani, Comp Mat Sci, Vol 101 ',&\n '(2015) 127-137'/'B Sundman, N Dupin and B Hallstedt, ',&\n 'Calphad, Vol 75 (2021) 102330'//&\n 'It is available for download at http://www.opencalphad.org or'/&\n 'the sundmanbo/opencalphad repository at https://www.github.com'//&\n 'This software is protected by the GNU General Public License'/&\n 'either version 2 of the license, or any later version.'/&\n 'You may use freely and distribute copies as long as you provide ',&\n 'the source code'/'and use the GNU GPL license also for your own',&\n ' additions and modifications.'//&\n 'The software is provided \"as is\" without any warranty of any ',&\n 'kind, either'/'expressed or implied. ',&\n 'The full license text is provided with the software'/&\n 'or can be obtained from the Free Software Foundation ',&\n 'http://www.fsf.org'//&\n 'Copyright 2011-2022, Bo Sundman, Gif sur Yvette, France.'/&\n 'Contact person Bo Sundman, bo.sundman@gmail.com'/&\n 'This version ',a,' was compiled ',a/)\n!=================================================================\n! debug subcommands\n case(16)\n kom2=submenu(cbas(kom),cline,last,cdebug,ncdebug,1,'?TOPHLP')\n debug: SELECT CASE (kom2)\n!------------------------------\n CASE DEFAULT\n write(kou,*)'Debug subcommand error ',kom2\n!------------------------------\n! debug free lists\n CASE(1)\n write(*,*)'Check components masses'\n call compmassbug(ceq)\n! write(*,*)'Calculating equilibrium record size'\n! kom3=ceqsize(ceq)\n! write(kou,*)'Current equilibrium record memory use: ',kom3\n! list all tuples\n write(kou,1617)\n1617 format('Phase tuples content:'/&\n 'Tuple lokph compset ixphase lokvares nextcs phase name',&\n ' disfra vareslink')\n do jp=1,nooftup()\n call get_phasetup_name(jp,name1)\n! this is a check that %ihaseix and lokvares are correct\n! if(phasetuple(jp)%compset.eq.1) then\n! call get_phase_compset(jp,1,lokph,lokcs)\n! else\n! call get_phase_compset(phasetuple(jp)%ixphase,&\n! phasetuple(jp)%compset,lokph,lokcs)\n! endif\n! write(kou,16020)jp,phasetuple(jp),name1,lokph,lokcs\n write(kou,16020)jp,phasetuple(jp),name1,&\n ceq%phase_varres(phasetuple(jp)%lokvares)%disfra%varreslink\n16020 format(i3,': ',2i7,2i9,i6,3x,a,2x,i6)\n enddo\n call list_free_lists(kou)\n write(*,*)'Testing tupix converter'\n16100 continue\n call gparidx('phase index',cline,last,i1,0,'none')\n if(i1.gt.0) then\n call gparidx('composition set',cline,last,i2,1,'none')\n write(*,*)'Tuple index: ',gettupix(i1,i2)\n if(gx%bmperr.eq.0) goto 16100\n goto 990\n endif\n!------------------------------\n! debug stop_on_error\n CASE(2)\n if(stop_on_error) then\n stop_on_error=.FALSE.\n write(kou,*)'No longer stop on error'\n else\n write(kou,*)'Macro will stop if error'\n stop_on_error=.true.\n endif\n!------------------------------\n! debug parameter structure\n case(3) ! advanced listing of data structure\n! open file\n! negative is for write, 0 read without filter, -100 write without filter\n write(*,*)'PMON: DEBUG case 3'\n ztyp=-7\n call gparfilex('Output file',cline,last,1,string,' ',ztyp,&\n '?Debug parameter')\n if(string(1:1).eq.' ') then\n string='parameter_output.DAT'\n write(kou,*)' *** No file name given, will use: ',trim(string)\n endif\n! slen=len_trim(string)\n! add extention .dat if to extenstion provided\n! if(index(string,'.').le.0) then\n! string(slen+1:)='.DAT '\n! endif\n! close any previous output file \n close(21)\n open(21,file=string,access='sequential',status='unknown',&\n err=990, iostat=buperr)\n lut=21\n! select phase\n phlistloop: do while(name1(1:1).ne.' ')\n call gparcx('Phase: ',cline,last,1,name1,' ',&\n '?Set Advanced')\n if(name1(1:1).eq.' ') exit phlistloop\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) then\n write(*,*)'No such phase; ',trim(name1)\n exit phlistloop\n endif\n call get_phase_record(iph,lokph)\n! list parameter structure\n call debug_phaseparameters(lokph,lut,ceq)\n! another phase\n enddo phlistloop\n write(lut,*)'Closing file'\n write(kou,*)'Closing file ',trim(string)\n close(lut)\n!----------------------------------\n! debug species\n case(4)\n do i1=1,nosp()\n call get_species_location(i1,loksp,name1)\n if(gx%bmperr.ne.0) goto 990\n call get_species_component_data(loksp,i2,iphl,stoik,xxx,&\n xxy,ceq)\n if(gx%bmperr.ne.0) goto 990\n write(kou,1670)i1,loksp,name1,xxx,xxy,(iphl(j4),stoik(j4),j4=1,i2)\n1670 format(2i4,1x,a12,1x,2F6.2,2x,10(i3,1x,F7.4))\n enddo\n!---------------------------------\n! debug tpfun\n case(5)\n call gparidx('Function index:',cline,last,ll,-1,'?Debug TPfun')\n call list_tpfun_details(ll)\n!---------------------------------\n! debug browser\n case(6)\n! testing using HTML helpfile with \"anchors\" like \n! related to a question or command\n! and the the help utility will search for a specific label as below\n! NOTE in the LaTeX file \\usepackage{hyperref}\n! and in the text \\hypertarget{selectname}\n! using \"path/browser\" \"file://path/helpfile#label\" should position\n! the html window at label!!\n! the label \"selectname\" is in the html file ...\n call gparcdx('File name: ',cline,last,5,model,&\n './manual\\html\\ochelp.html#selectelement ','?Debug browser')\n! browser='\"C:\\Program Files\\Mozilla firefox\\firefox.exe\" '\n! this browser can be opened without \"\"\n browser='C:\\PROGRA~1\\INTERN~1\\iexplore.exe '\n! it works to open the ochelp.html on the first page\n! string=trim(browser)//&\n! ' -file ./manual/html/ochelp.html'\n! write(*,'(a)')trim(string)\n! gnu fortran ...\n! call system(...)\n! call execute_command_line(string)\n! now the complicated one ...\n string=trim(browser)//&\n ' \"file://C:\\Users\\bosse\\documents\\oc\\oc\\src\\'//&\n trim(model(3:))//'\"'\n write(*,'(a)')trim(string)\n call execute_command_line(string)\n! This command works in a Windows terminal window:\n! \"C:\\program files\\Mozilla firefox\\firefox.exe\" \n! \"file://c:\\users\\bosse\\documents\\oc\\oc\\src\\manual\\html\\ochelp.html#selectelement\"\n! but problems using as command ...\n! This works also:\n!c:\\Program Files\\internet explorer\\iexplore.exe\" \"file://c:\\users\\bosse\\documents\\oc\\oc\\src\\manual\\html\\ochelp.html#selectelement\"\n! maybe possible to access by directory names with only 8 bytes ...\n!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux\n!\n!> call gparcd('File name: ',cline,last,5,model,&\n!> '/home/bosse/OC/OC5-20/manual/ochelp.html#selectelement ',q1help)\n! this browser can be opened without \"\"\n!> browser='/usr/bin/firefox '\n!> string=trim(browser)//' \"file:'//trim(model(1:))//'\"'\n!> write(*,'(a)')trim(string)\n! This command works in a Linux terminal window:\n! /usr/bin/firefox -file /home/bosse/OC/OC5-20/manual/ochelp.html\n! it does not work to add #selectelement at the end (no such file name)\n! This work in Linux terminal window:\n! /usr/bin/firefox \"file:/home/bosse/.../manual/ochelp.html#selectelement\"\n!\n!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux!linux\n!---------------------------------\n! debug trace\n case(7)\n call gparcdx('Read TDB debug?',cline,last,1,ch1,'Y','?Debug dbcheck')\n if(ch1.eq.'Y') then\n dbcheck=.TRUE.\n else\n dbcheck=.FALSE.\n endif\n call gparcdx('HTML help?',cline,last,1,ch1,'Y','?Debug trace')\n if(ch1.eq.'Y') then\n helptrace=.TRUE.\n else\n helptrace=.FALSE.\n endif\n call gparcdx('plotting?',cline,last,1,ch1,'N','?Debug plot')\n if(ch1.eq.'Y') then\n plottrace=.TRUE.\n else\n plottrace=.FALSE.\n endif\n!..................................\n! debug symbol value\n case(8)\n! this allows a command \"debug symbol value\" which will test if symbol\n! has the specified value (+/- 10^(-6). \n! Should be useful in the test macros ...\n! 4th argument 2 means terminate at \" \", ignore any ,\n call gparcx('Symbol: ',cline,last,2,name1,' ','?Debug symbol value')\n call gparrx('Value: ',cline,last,xxy,zero,'?Debug symbol value')\n call capson(name1)\n! code below copied from SHOW command\n model=' '\n call get_state_var_value(name1,xxx,model,ceq)\n if(gx%bmperr.ne.0) then\n gx%bmperr=0\n! If error then try to calculate a symbol ...\n! below copied from calculate symbol, first calculate all symbols ignore errors\n! calculate all symbols ignoring errors (note dot derivatives not calculated)\n call meq_evaluate_all_svfun(-1,ceq)\n if(gx%bmperr.ne.0) gx%bmperr=0\n call capson(line)\n call find_svfun(name1,istv)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error finding symbol'\n stop\n endif\n mode=1\n actual_arg=' '\n xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error calculating symbol'\n stop\n endif\n write(kou,2047)trim(name1),xxx\n endif\n! test for NaN, a NaN is never equal to itself\n! if(xxx /= xxx) then\n if(xxx .ne. xxx) then\n write(kou,*)'Calculated value of ',trim(name1),' is NaN'\n stop\n endif\n xxz=1.0D-6\n if(abs(xxy).gt.1.0d0) xxz=xxz*abs(xxy)\n if(abs(xxx-xxy).gt.xxz) then\n write(kou,'(a,2(1pe12.4))')'Symbol value outside limit!',xxx,xxy\n stop\n else\n write(kou,*)'Testing symbol ',trim(name1),' value OK ++++++++'\n endif\n!..................................\n! debug map_startpoints commented away\n! debug ender MQMQA species\n case(9)\n! nullify(starteqs(1)%p1)\n! starteqs(1)%p1=>ceq\n! call auto_startpoints(maptop,noofaxis,axarr,seqxyz,starteqs)\n! if(gx%bmperr.ne.0) goto 990\n!..................................\n! debug grid. This calculates grid for phases one by one and check\n case(10)\n call check_all_phases(0,ceq)\n!..................................\n! DEBUG Kohler/Toop and MQMQA_QUADS constituent test\n case(11)\n! specifying which sublattice each element belong to\n! jp=0\n! mqmqa: do while(.true.)\n! call gparcdx('MQMQA quadrupoles: ',&\n! cline,last,5,aline,' ','?Debug MQMQA')\n! if(aline(1:1).eq.' ') exit mqmqa\n! call mqmqa_constituents(aline,const,jp)\n! jp=1\n! enddo mqmqa\n! if(gx%bmperr.ne.0) goto 990\n! finished by an empty line, then replace species by endmembers\n! call mqmqa_rearrange(const)\n!..................................\n! add list ternary extrapolation methods\n write(kou,1682)\n1682 format(/'Data for ternary extrapolation methods')\n call list_ternary_extrapol_data(kou)\n write(kou,'(\"no more\")')\n!\n if(.not.allocated(mqmqa_data%contyp)) then\n write(*,*)'No MQMQA data entered'\n goto 100\n endif\n call gparcx('Phase name: ',cline,last,1,name1,'LIQUID ',&\n '?Debug mqmqa')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n write(*,*)'Constituents in sublattices: ',&\n mqmqa_data%ncon1,mqmqa_data%ncon2\n do jp=1,mqmqa_data%nconst\n call get_constituent_name(iph,jp,name2,xxx)\n if(gx%bmperr.ne.0) goto 990\n write(*,12)jp,(mqmqa_data%contyp(kl,jp),kl=1,10),&\n (mqmqa_data%constoi(kl,jp),kl=1,4),trim(name2)\n12 format('Quad ',i3,1x,4i3,1x,i3,1x,5i3,1x,4F6.2,1x,a)\n enddo\n!........................\n case(12) ! test bombmatta for mapping\n nullify(starteqs(1)%P1)\n starteqs(1)%P1=>ceq\n call bombmatta(maptop,noofaxis,axarr,seqxyz,starteqs)\n END SELECT debug\n!=================================================================\n! select command\n case(17)\n kom2=submenu(cbas(kom),cline,last,cselect,nselect,1,'?TOPHLP')\n selct: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'Select subcommand error'\n goto 100\n!-----------------------------------------------------------\n CASE(1) ! select equilibrium\n if(ceq%eqno.lt.noeq()) then\n name1='NEXT'\n else\n name1='DEFAULT'\n endif\n call gparcdx('Give name or number?',cline,last,1,text,&\n name1,'?Select equilibrium')\n if(buperr.ne.0) goto 990\n! if the user types \"next\" in lower case or an abbrev it does not work\n call capson(text)\n if(compare_abbrev(text,'NEXT ')) then\n i1=ceq%eqno+1\n call selecteq(i1,ceq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=i1\n elseif(compare_abbrev(text,'PREVIOUS ')) then\n i1=max(ceq%eqno-1,1)\n call selecteq(i1,ceq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=i1\n elseif(compare_abbrev(text,'LAST ')) then\n i1=noeq()\n call selecteq(i1,ceq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=i1\n elseif(compare_abbrev(text,'FIRST ')) then\n i1=1\n call selecteq(i1,ceq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=i1\n else\n! check if number\n j4=1\n call getint(text,j4,i1)\n if(buperr.ne.0) then\n buperr=0\n! findeq accepts PREVIOUS and FIRST (same as DEFAULT)\n ieq=ceq%eqno\n call findeq(text,ieq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=ieq\n ceq=>eqlista(ieq)\n else\n call selecteq(i1,ceq)\n if(gx%bmperr.ne.0) goto 990\n neqdef=i1\n endif\n endif\n write(kou,'(a,i4,\", name: \",a)')'Current equilibrium no: ',&\n ceq%eqno,ceq%eqname\n!-----------------------------------------------------------\n CASE(2) ! select minimizer\n write(kou,*)'Sorry, only one available: ',minimizers(2)\n write(kou,*)'Selected minimizer: ',minimizers(minimizer)\n!-----------------------------------------------------------\n case(3) ! select graphics\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n case(4) ! select language, at present only 1 English and 2 French\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n case(5) ! select optimizer\n write(kou,845)optimizers(optimizer)\n write(kou,844)optimizers\n844 format('Available optimizers: '/,(2x,a,2x,a,2x,a))\n845 format('Current optimizer is: '/,2x,a)\n call gparcdx('Do you want to use LMDIF?',cline,last,1,ch1,'Y',&\n '?Select optimizer')\n if(ch1.eq.'Y') then\n optimizer=1\n else\n write(*,*)'Sorry VA05AD is no longer available'\n endif\n write(kou,*)'You have selected ',optimizers(optimizer)\n!-----------------------------------------------------------\n case(6)\n goto 100\n END SELECT selct\n!=================================================================\n! DELETE not much implemented ...\n! ['ELEMENTS ','SPECIES ','PHASE ',&\n! 'QUIT ','COMPOSITION_SET ','EQUILIBRIUM ',&\n! 'STEP_MAP_RESULTS',' ',' ']\n CASE(18)\n! disable continue optimization\n! iexit=0\n! iexit(2)=1\n kom2=submenu(cbas(kom),cline,last,crej,nrej,6,'?TOPHLP')\n delete: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'Delete subcommand error'\n goto 100\n!-----------------------------------------------------------\n! delete element\n case(1)\n write(kou,18010)\n18010 format(' *** Warning, this command will delete the data for the',&\n ' element, species or'/' phase specified and the data cannot',&\n ' be recovered unless read again from'/' file. If you',&\n ' only want to temporarily remove some data use QUIT'/&\n ' from this command and then SET STATUS'/)\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n! delete species\n case(2)\n write(kou,18010)\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n! delete phase\n case(3)\n write(kou,18010)\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n! quit\n case(4)\n goto 100\n!-----------------------------------------------------------\n! delete composition set, always that with higest number\n case(5)\n call gparcx('Phase name: ',cline,last,1,name1,' ','?Delete phase')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n call remove_composition_set(iph,.FALSE.)\n if(gx%bmperr.ne.0) goto 990\n!-----------------------------------------------------------\n! delete equilibria\n case(6)\n call gparcx('Equilibrium name or abbr.:',cline,last,1,name1,' ',&\n '?Delete equilibrium')\n if(buperr.ne.0) goto 990\n call delete_equilibria(name1,ceq)\n if(gx%bmperr.ne.0) goto 990\n!-----------------------------------------------------------\n! delete step_map_results\n case(7)\n if(associated(maptopsave)) then\n! this is necessary only if no plot of last step/map made ...\n maptop%plotlink=>maptopsave\n nullify(maptopsave)\n write(*,*)'maptopsave nullified'\n endif\n seqxyz=0\n! this does not delete _mapnode and _mapline equilibria ???\n call delete_mapresults(maptop)\n! remove any results from step and map\n! if(associated(maptop)) then\n! write(*,*)'maptop nullified: ',maptop%next%seqx\n! maptop%next%seqx=0\n! maptop%next%seqy=0\n! maptop%seqx=0\n! maptop%seqy=0\n! nullify(maptop)\n! endif\n nullify(maptop)\n nullify(mapnode)\n nullify(maptopsave)\n!----- deallocate local axis records\n do jp=1,noofaxis\n if(allocated(axarr(jp)%axcond)) deallocate(axarr(jp)%axcond)\n enddo\n noofaxis=0\n! remove some more defaults ...\n defcp=1\n! deallocate does not work on pointers!!!\n nullify(starteqs(1)%p1)\n noofstarteq=0\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n!-----------------------------------------------------------\n!\n case(8)\n continue\n!-----------------------------------------------------------\n!\n case(9)\n continue\n end SELECT delete\n!=================================================================\n! STEP, must be tested if compatible with assessments\n! ['NORMAL ','SEPARATE ','QUIT ',&\n! 'CONDITIONAL ','TZERO ','LIQUID_EET ',&\n! 'SHEIL_GULLIVER ','PARAEQUILIBRIUM ','FAST ']\n case(19)\n! disable continue optimization\n! iexit=0\n! iexit(2)=1\n if(noofaxis.ne.1) then\n write(kou,*)'You must set exactly one independent axis variable',&\n ' for a step calculation.'\n goto 100\n endif\n ll=degrees_of_freedom(ceq)\n if(ll.ne.0) then\n write(*,*)'Degrees of freedom not zero',ll\n goto 100\n endif\n! forget any previous step special\n stepspecial=.FALSE.\n! IMPORTANT I have changed the order between option and reinitiate!!\n kom2=submenu('Step options?',cline,last,cstepop,nstepop,1,'?TOPHLP')\n! skip here for step quit and other cases not implemented: case(3 and 4)\n if(kom2.eq.3 .or. kom2.eq.4) goto 100\n! check if there are previous results\n if(associated(maptop)) then\n write(kou,833)\n833 format('There are previous results from step or map')\n call gparcdx('Delete them?',cline,last,1,ch1,'Y','?Step old data')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n! there should be a more careful deallocation to free memory\n call delete_mapresults(maptop)\n! deallocate(maptop%saveceq)\n nullify(maptop)\n nullify(maptopsave)\n write(kou,*)'Previous results removed'\n! This is to keep trace of total number of saved equilibria\n totalsavedceq=0\n! delete equilibria associated with STEP/MAP\n call delete_equilibria('_MAP*',ceq)\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n else\n! for step separate it seems difficult to have correct seqx !!\n! seqxyz(1)=maptop%next%seqx\n seqxyz(1)=max(maptop%next%seqx,maptop%previous%seqx,maptop%seqx)\n seqxyz(2)=maptop%seqy\n! list maptop for debugging\n! write(*,*)'PM maptop node: ',trim(maptop%nodeceq%eqname)\n! maptopcheck=>maptop%next\n! do while(.not.associated(maptopcheck,maptop))\n! write(*,*)'PM: maptop node: ',trim(maptopcheck%nodeceq%eqname)\n! maptopcheck=>maptopcheck%next\n! if(.not.associated(maptopcheck%previous%next,maptopcheck)) then\n! write(*,*)'PM next and previous does not agree'\n! endif\n! enddo\n! if(associated(maptop%plotlink)) then\n! write(*,*)'PM plotlink: ',trim(maptop%plotlink%nodeceq%eqname)\n! endif\n! end debugging\n maptopsave=>maptop\n nullify(maptop)\n write(*,'(a,2i4)')'Previous results kept',seqxyz\n endif\n endif\n! indicate to graphics that we have a step calculation\n graphopt%noofcalcax=1\n step: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'No such step option'\n!-----------------------------------------------------------\n! STEP NORMAL\n case(1)\n! maptop is returned as main map/step record for results\n! noofaxis is current number of axis, axarr is array with axis data\n! starteq is start, equilibria, if empty set it to ceq\n if(noofstarteq.eq.0) then\n noofstarteq=1\n starteqs(1)%p1=>ceq\n endif\n if(associated(maptop)) then\n! can one have several STEP commands YES!\n write(*,*)'Deleting previous step/map results missing'\n goto 100\n endif\n! seqzyz are initial values for creating equilibria for lines and nodes\n call map_setup(maptop,noofaxis,axarr,seqxyz,starteqs)\n! mark that interactive listing of conditions and results may be inconsistent\n ceq%status=ibset(ceq%status,EQINCON)\n if(.not.associated(maptop)) then\n! if one has errors in map_setup maptop may not be initiated, if one\n! has saved previous calculations in maptopsave restore those\n if(associated(maptopsave)) then\n write(kou,*)'Restoring previous map results'\n maptop=>maptopsave\n nullify(maptopsave)\n endif\n elseif(associated(maptopsave)) then\n! THIS ERROR WITH LOST CALCULATONS MAY BE THERE FOR STEP SEPERATE AND MAP\n! write(*,*)'PM linking previous results'\n write(kou,'(a)')'Link set to previous step/map results.'\n maptop%plotlink=>maptopsave\n endif\n! debugging: last maptop/line used\n! write(*,'(a,2i4)')'PMON: sexy 1:',maptop%next%seqx,maptop%seqy\n! remove start equilibria\n nullify(starteqs(1)%p1)\n noofstarteq=0\n if(gx%bmperr.ne.0) goto 990\n!-----------------------------------------------------------\n! STEP SEPARATE\n case(2) ! calculate for each entered phase separately (one by one)\n! starteqs(1)%p1=>ceq\n! noofstarteq=1\n! it will always use the current equilibrium\n! can one have several STEP commands??\n stepspecial(1)=.TRUE.\n if(associated(maptop)) then\n write(*,*)'Deleting previous step/map results missing'\n goto 100\n endif\n call step_separate(maptop,noofaxis,axarr,seqxyz,ceq)\n! mark that interactive listing of conditions and results may be inconsistent\n ceq%status=ibset(ceq%status,EQINCON)\n if(.not.associated(maptop)) then\n! if one has errors in map_setup maptop may not be initiated, if one\n! has saved previous calculations in maptopsave restore those\n if(associated(maptopsave)) then\n write(kou,*)'Restoring previous map results'\n! maptop=>maptopsave\n maptop%plotlink=>maptopsave\n nullify(maptopsave)\n endif\n elseif(associated(maptopsave)) then\n write(kou,'(a)')'Link set to previous map/step results'\n maptop%plotlink=>maptopsave\n endif\n! set default yaxis as GM(*)\n if(axplotdef(2)(1:1).eq.' ') then\n axplotdef(2)='GM(*)'\n endif\n! update maptop%seqx to maptop%prvious%seqx+1 to allow more maptop records\n maptop%seqx=maptop%previous%seqx+1\n! write(*,'(a,4i4)')'PMON: separate seqx:',maptop%next%seqx,&\n! maptop%seqx,maptop%previous%seqx,maptop%seqy\n! remove start equilibria\n nullify(starteqs(1)%p1)\n noofstarteq=0\n stepspecial(1)=.TRUE.\n!-----------------------------------------------------------\n! STEP QUIT, note quitting already above\n case(3)\n!-----------------------------------------------------------\n! STEP CONDITIONAL (NOT for Scheil-Gulliver), note quitting already above\n case(4)\n write(kou,*)'Not implemented yet'\n!-----------------------------------------------------------\n! STEP TZERO plotlink\n case(5)\n write(kou,871)\n871 format('For this command you must already have used',&\n ' \"calculate tzero\"'/&\n 'for the two phases you will specify below and you must',&\n ' have specified an axis'/&\n 'with the composition of the fast diffusing element.')\n call gparcx('Have you done all that?',cline,last,1,&\n name1,'NO','?Step Tzero')\n call capson(name1)\n if(name1(1:1).ne.'Y') goto 100\n call gparcx('First phase name: ',cline,last,1,name1,' ',&\n '?Step Tzero')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n if(ics.ne.1) then\n write(*,*)'You must use first composition set'\n goto 100\n endif\n call gparcx('Second phase name: ',cline,last,1,name2,' ',&\n '?Step Tzero')\n call find_phase_by_name(name2,iph2,ics)\n if(gx%bmperr.ne.0) goto 990\n if(ics.ne.1) then\n write(*,*)'You must use first composition set'\n goto 100\n endif\n! normally T is the first condition\n j2=1\n call gparidx('Release condition number',cline,last,tzcond,j2,&\n '?Step Tzero')\n! Delete previous step/map results\n if(associated(maptop)) then\n write(kou,*)'Previous map/step results will be deleted'\n call delete_mapresults(maptop)\n endif\n nullify(maptop)\n nullify(maptopsave)\n! step tzero\n stepspecial(3)=.TRUE.\n! This is to keep trace of total number of saved equilibria\n totalsavedceq=0\n! initiate indexing nodes and lines\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n! call tzero(iph,iph2,tzcond,xxx,ceq)\n call step_tzero(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq)\n if(gx%bmperr.ne.0) goto 990\n! sum the points calculated\n jp=maptop%linehead(1)%number_of_equilibria+&\n maptop%linehead(2)%number_of_equilibria\n write(kou,'(a,i5,a)')'Calculated ',jp,' points along the tzero line'\n!-----------------------------------------------------------\n! STEP LIQUID_EET, not yet implemented\n case(6)\n write(kou,*)'Not implemented yet'\n goto 100\n write(kou,879)\n879 format('For this command you must already have',&\n ' \"calculatd liquid_EET\"'/&\n 'for the phases you specify below and you must',&\n ' have selected an axis condion')\n call gparcx('Have you done all that?',cline,last,1,&\n name1,'NO','?Step liquid_eet')\n call capson(name1)\n if(name1(1:1).ne.'Y') goto 100\n call gparcx('The liquid phase name: ',cline,last,1,name1,' ',&\n '?Step liquid_eet')\n if(buperr.ne.0) goto 990\n call find_phase_by_name(name1,iph,ics)\n if(gx%bmperr.ne.0) goto 990\n if(ics.ne.1) then\n write(*,*)'You must use first composition set'\n goto 100\n endif\n call gparcx('The solid phase name: ',cline,last,1,name2,' ',&\n '?Step liquid_eet')\n call find_phase_by_name(name2,iph2,ics)\n if(gx%bmperr.ne.0) goto 990\n if(ics.ne.1) then\n write(*,*)'You must use first composition set'\n goto 100\n endif\n! normally T is the first condition\n j2=1\n call gparidx('Release condition number',cline,last,tzcond,j2,&\n '?Step liquid_eet')\n! Delete previous step/map results\n if(associated(maptop)) then\n write(kou,*)'Previous map/step results will be deleted'\n call delete_mapresults(maptop)\n endif\n nullify(maptop)\n nullify(maptopsave)\n! step EET\n stepspecial(5)=.TRUE.\n! This is to keep trace of total number of saved equilibria\n totalsavedceq=0\n! initiate indexing nodes and lines\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n! call step_tzero(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq)\n call step_eet(maptop,noofaxis,axarr,seqxyz,iph,iph2,tzcond,ceq)\n if(gx%bmperr.ne.0) goto 990\n! sum the points calculated\n jp=maptop%linehead(1)%number_of_equilibria+&\n maptop%linehead(2)%number_of_equilibria\n write(kou,'(a,i5,a)')'Calculated ',jp,' points along the EET line'\n!-----------------------------------------------------------\n! STEP SCHEIL_GULLIVER and STEP FAST\n case(7,9)\n write(kou,872)\n872 format('Before this command you must have set an alloy composition',&\n ' and calculated'/&\n 'an equilibrium in the liquid and have set an axis with T',&\n ' as variable.')\n call gparcx('Have you done all that?',cline,last,1,&\n name1,'NO','?Step Scheil')\n call capson(name1)\n if(name1(1:1).ne.'Y') goto 100\n! Delete previous step/map results\n if(associated(maptop)) then\n write(kou,*)'Previous map/step results will be deleted'\n call delete_mapresults(maptop)\n endif\n write(kou,873)\n873 format('The simulation will decrease T and change the liquid',&\n ' composition depending'/&\n 'on the solids formed until there is no liquid stable.')\n nullify(maptop)\n nullify(maptopsave)\n! This is to keep trace of total number of saved equilibria\n totalsavedceq=0\n! initiate indexing nodes and lines\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n! step scheil\n stepspecial(2)=.TRUE.\n if(kom2.eq.9) then\n! ask for fast diffusing elements in Scheil simulation\n nv=1\n fast=' '\n line='A fast diffusing element: '\n fastel: do while(.TRUE.)\n call gparcx(trim(line),cline,last,1,elsym,' ','?Step Scheil')\n if(elsym(1:1).ne.' ') then\n call capson(elsym)\n call find_element_by_name(elsym,iel)\n if(gx%bmperr.ne.0) goto 990\n fast(nv)=elsym\n nv=nv+1\n if(nv.gt.3) exit fastel\n line='Another fast diffusing element: '\n else\n exit fastel\n endif\n enddo fastel\n call step_scheil2(maptop,noofaxis,axarr,seqxyz,fast,ceq)\n else\n! step scheil with no fast diffusiing elements\n call step_scheil(maptop,noofaxis,axarr,seqxyz,ceq)\n endif\n if(gx%bmperr.ne.0) goto 990\n! sum the points calculated\n! write(*,*)'Finished Scheil simulation'\n! jp=maptop%linehead(1)%number_of_equilibria+&\n! maptop%linehead(2)%number_of_equilibria\n! write(kou,'(a,i5,a)')'Calculated ',jp,' points for the simulation'\n!-----------------------------------------------------------\n! STEP PARAEQUILIBRIUM\n case(8)\n write(kou,874)\n874 format('Before this command you must have set an alloy composition',&\n ' and calculated',/&\n 'and suspended all phases except the two involved and',&\n ' you should have'/&\n 'calculated a paraequilibrium')\n call gparcx('Have you done all that?',cline,last,1,&\n name1,'NO','?Step paraeq')\n call capson(name1)\n if(name1(1:1).ne.'Y') goto 100\n if(dummy(1:1).ne.' ') dummy=name2\n call gparcdx('Matrix phase ',cline,last,1,name2,dummy,'?Step paraeq')\n call find_phasetuple_by_name(name2,tupix(1))\n if(gx%bmperr.ne.0) goto 990\n if(dummy(1:1).ne.' ') dummy=name3\n call gparcdx('Growing phase ',cline,last,1,name3,dummy,'?Step paraeq')\n call find_phasetuple_by_name(name3,tupix(2))\n if(gx%bmperr.ne.0) goto 990\n dummy=name3\n call gparcdx('Fast diffusing element',cline,last,1,&\n elsym,parael,'?Step paraeq')\n call find_element_by_name(elsym,icond)\n parael=elsym\n write(kou,875)trim(name1)\n875 format('The simulation will vary the axis variable and calulate',&\n ' compositions'/'of the two phases which have the same',&\n ' chemical potential of ',a)\n! Delete previous step/map results\n if(associated(maptop)) then\n write(kou,*)'Previous map/step results will be deleted'\n call delete_mapresults(maptop)\n endif\n nullify(maptop)\n nullify(maptopsave)\n! This is to keep trace of the total number of saved equilibria\n totalsavedceq=0\n! initiate indexing nodes and lines\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n! set default plot axis\n axplotdef(1)='W(*,'//trim(parael)//') '\n! one can calculate paraequilibria diagrams at constant T\n! axplotdef(2)='T '\n! step paraequil\n stepspecial(4)=.TRUE.\n call step_paraequil(maptop,noofaxis,axarr,seqxyz,tupix,icond,ceq)\n if(gx%bmperr.ne.0) goto 990\n! sum the points calculated\n! jp=maptop%linehead(1)%number_of_equilibria+&\n! maptop%linehead(2)%number_of_equilibria\n write(kou,'(a,2i5,a)')'Paraequilibrium points: ',totalsavedceq\n!-----------------------------------------------------------\n! STEP FAST part of STEP SCHEIL\n! case(9)\n! write(kou,*)'Not implemented yet'\n end SELECT step\n!=================================================================\n! MAP, must be tested if compatible with assessments\n case(20)\n! maybe disable continue optimization ??\n if(noofaxis.lt.2) then\n write(kou,*)'You must set two axis with independent variables'\n goto 100\n endif\n if(noofaxis.gt.3) then\n write(kou,*)'More than 3 axis not implemented yet'\n goto 100\n endif\n! tzeroline=.FALSE.\n! separate=.FALSE.\n stepspecial=.FALSE.\n! indicate to graphics we have calculated with 2 axis\n graphopt%noofcalcax=noofaxis\n write(kou,20014)\n20014 format('The map command is fragile, please send problematic diagrams',&\n ' to the',/'OC development team'/)\n! when setting logfile the maptop became associated !! \n! write(*,*)'PMON maptop bug 3?',associated(maptop)\n if(associated(maptop)) then\n write(kou,833)\n call gparcdx('Reinitiate?',cline,last,1,ch1,'Y','?Map old data')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n call delete_mapresults(maptop)\n! deallocate(maptop%saveceq)\n nullify(maptop)\n nullify(maptopsave)\n! This is to keep trace of total number of saved equilibria\n totalsavedceq=0\n! this removes all previous equilibria associated with STEP/MAP commands\n! already done by delete_mapresults\n! call delete_equilibria('_MAP*',ceq)\n! if(gx%bmperr.ne.0) then\n! write(kou,*)'Error removing old MAP equilibria'\n! goto 990\n! endif\n! initiate indexing nodes and lines\n seqxyz=0\n! remove all graphopt settings\n call reset_plotoptions(graphopt,plotfile,textlabel)\n axplotdef=' '\n else\n! start indexing new nodes/lines from previous \n! write(*,*)'mapnode: ',maptop%seqx,maptop%previous%seqx,&\n! maptop%next%seqx\n seqxyz(1)=maptop%next%seqx\n seqxyz(2)=maptop%seqy\n! seqxyz(3) can be used for something else ...\n maptopsave=>maptop\n nullify(maptop)\n! write(*,*)'seqxyz: ',seqxyz\n endif\n! this should never be done ! It destroys the possibility to find old nodes\n! call delete_equilibria('_MAP*',ceq)\n endif\n! maptop is returned as main map/step record for results\n! noofaxis is current number of axis, axarr is array with axis data\n! starteq is start equilibria, if empty set it to ceq\n! if(.not.associated(starteq)) then\n if(noofstarteq.eq.0) then\n noofstarteq=1\n starteqs(1)%p1=>ceq\n endif\n ceq=>starteqs(1)%p1\n ll=degrees_of_freedom(ceq)\n if(ll.ne.0) then\n write(*,*)'Degrees of freedom not zero ',ll\n goto 100\n endif\n! maptop is first nullified inside map_setup, then alloctated to return result\n call map_setup(maptop,noofaxis,axarr,seqxyz,starteqs)\n if(gx%bmperr.ne.0) then\n write(kou,*)'Error return from MAP: ',gx%bmperr\n gx%bmperr=0\n! else\n! write(*,*)'Map command finished without error'\n endif\n if(.not.associated(maptop)) then\n! if one has errors in map_setup maptop may not be initiated, if one\n! has saved previous calculations in maptopsave restore those\n if(associated(maptopsave)) then\n write(kou,*)'Restoring previous map results'\n maptop=>maptopsave\n nullify(maptopsave)\n endif\n elseif(associated(maptopsave)) then\n write(kou,'(a)')'Link set to previous map results'\n maptop%plotlink=>maptopsave\n nullify(maptopsave)\n endif\n! remove start equilibria\n noofstarteq=0\n nullify(starteqs(1)%p1)\n! mark that interactive listing of conditions and results may be inconsistent\n ceq%status=ibset(ceq%status,EQINCON)\n if(gx%bmperr.ne.0) goto 990\n! end of MAP command\n!=================================================================\n! PLOT COMMAND with many options and EXTRA\n! Always specify the axis first when giving this command, default is previous!!\n! loop with subcommands comes after\n case(21)\n if(.not.associated(maptop)) then\n write(kou,*)'You must give a STEP or MAP command before PLOT'\n goto 100\n endif\n wildcard=.FALSE.\n! values of stepspecial ...\n! write(*,*)'stepspecial: ',stepspecial\n pltaxdef: do iax=1,2\n plotdefault: if(axplotdef(iax)(1:1).eq.' ') then\n! If there is no previous plot axis variable, propose one\n iaxval: if(iax.eq.1 .and. stepspecial(2)) then\n! Scheil, PFL (Phase Fraction Liquid) is a special function\n if(iax.eq.1) text='PFL'\n elseif(iax.le.noofaxis) then\n! extract the actual axis condition used for calculation\n jp=1\n call get_one_condition(jp,text,axarr(iax)%seqz,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Error getting axis condition from index: ',&\n iax,axarr(iax)%seqz\n goto 990\n endif\n jp=index(text,'=')\n text(jp:)=' '\n if(.not.(text(1:2).eq.'MU' .or. text(1:2).eq.'AC' .or.&\n text(1:4).eq.'LNAC')) then\n if(maptop%tieline_inplane.eq.1) then\n! if tie-lines in the plane is 1 (.e. YES) and calculating axis was x(cu)\n! then plot axis should be x(*,cu) \n jp=index(text,'(')\n if(jp.gt.0) then \n text=text(1:jp)//'*,'//text(jp+1:)\n endif\n endif\n! do not modify axis variables MU(C), AC(C), LNAC(C) !!!\n endif\n else\n! this the vertical axis of a STEP calculation, most often T as axis 1\n! maybe change default for iax=1 also. Most frequent vertical axis is NP(*)\n if(iax.eq.2) text='NP(*)'\n if(stepspecial(1)) then\n! step separate, default vertical axis is GM, horizontal fraction\n if(iax.eq.2) text='GM(*)'\n elseif(stepspecial(2)) then\n! Scheil, PFL (Phase Fraction Liquid) or PFS are special plot functions\n if(iax.eq.1) text='PFL'\n if(iax.eq.2) text='T'\n elseif(stepspecial(3)) then\n! Tzero, fraction vs T\n if(iax.eq.2) text='w(c)'\n elseif(stepspecial(4)) then\n! Paraequilibrium, fraction vs T\n if(iax.eq.2) text='T'\n elseif(stepspecial(5)) then\n! step liquid_eet\n if(iax.eq.2) text='T'\n endif\n nullify(maptop%plotlink)\n endif iaxval\n axplotdef(iax)=text\n endif plotdefault\n! the 4th argument to gparc means the following:\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n!------------------------------------------------------------------------\n! Here the user specifies his axis for plotting\n21000 continue\n if(iax.eq.1) then\n call gparcdx('Horizontal axis variable',&\n cline,last,7,axplot(iax),axplotdef(iax),'?Plot command')\n! Note \"7\" means that a \",\" inside x(liq,fe) will not return just \"x(liq\"\n else\n call gparcdx('Vertical axis variable',&\n cline,last,7,axplot(iax),axplotdef(iax),'?Plot command')\n endif\n if(buperr.ne.0) goto 990\n! extract a possible scaling factor like 0.001*GM(*)\n jp=1\n call getrel(axplot(iax),jp,xxx)\n if(buperr.eq.0) then\n! there is a numerical factor\n graphopt%scalefact(iax)=xxx\n! a number must be followed by a *\n if(axplot(iax)(jp:jp).ne.'*') then\n write(*,*)'Scaling factor must be followed by *'\n goto 990\n else\n! Fortran allows overlapping strings in assignments\n axplot(iax)=axplot(iax)(jp+1:)\n endif\n else\n! no scaling factor, graphopt%scalfactor(iax) already unity\n buperr=0\n endif\n if(index(axplot(iax),'*').gt.0 .or. index(axplot(iax),'#').gt.0) then\n! if(wildcard) then\n! write(*,*)'Wildcards allowed for one axis only'\n! goto 21000\n! else\n wildcard=.TRUE.\n! endif\n endif\n if(axplotdef(iax).ne.axplot(iax)) then\n! if new axis variable then reset default plot options\n! plot ranges and their defaults\n call reset_plotoptions(graphopt,plotfile,textlabel)\n! check that axis variable is a correct state variable or symbol\n! Most code copied from show variable (case(4,17) around line 3273)\n! Avoid capson of axplot(iax) for possible other problems later\n name1=axplot(iax)\n call capson(name1)\n if(name1(1:4).eq.'PFL ' .or. name1(1:4).eq.'PFS ') then\n! this is a special function allowed in Scheil simulations for phase frac liq\n if(.not.stepspecial(2)) then\n write(*,*)'The PFL and PFS functions are allowed only for Scheil simulations'\n goto 100\n endif\n elseif(index(axplot(iax),'*').gt.0) then\n! generate many values\n! the values are returned in yarr with dimension maxconst. \n! longstring are the state variable symbols for the values ...\n call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq)\n if(gx%bmperr.ne.0) then\n! if error go back to command level\n write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr\n goto 100\n! else\n! write(*,*)'pmon test value: ',yarr(1)\n endif\n elseif(index(axplot(iax),'#').gt.0) then\n! generate many values including for metastable phases\n! the values are returned in yarr with dimension maxconst. \n! longstring are the state variable symbols for the values ...\n call get_many_svar(axplot(iax),yarr,maxconst,i1,longstring,ceq)\n if(gx%bmperr.ne.0) then\n! if error go back to command level\n write(kou,*)'Illegal axis variable! Error code: ',gx%bmperr\n goto 100\n! else\n! write(*,*)'pmon test value: ',yarr(1)\n endif\n else\n! the value of a state variable or model parameter variable is returned\n! STRANGE the symbol xliqni is accepted in get_state_var_value ???\n call get_state_var_value(axplot(iax),xxx,model,ceq)\n if(gx%bmperr.ne.0) then\n! if error check if it is a complicated symbol like CP=H.T\n gx%bmperr=0\n! If error then try to calculate a symbol ...\n call capson(axplot(iax))\n! call find_svfun(axplot(iax),istv,ceq)\n call find_svfun(axplot(iax),istv)\n if(gx%bmperr.ne.0) then\n write(kou,*)'Illegal axis variable, error: ',gx%bmperr\n goto 100\n endif\n endif\n endif\n endif\n! remember most recent axis as default (and to avoid reset)\n axplotdef(iax)=axplot(iax)\n enddo pltaxdef\n! first argument is the number of plot axis, always 2 at present\n jp=2\n if(associated(maptopsave)) then\n write(kou,'(a)')'Link set to maptopsave'\n maptop%plotlink=>maptopsave\n endif\n! restore default graphopt%linetype\n! graphopt%linetype=1\n!-----------------------------------------------------------\n! PLOT subcommands, default is PLOT, NONE does not work ...\n! subcommands to PLOT OPTIONS/ GRAPHICS OPTIONS\n! THIS IS A MESS, should be reorganized in levels\n! character (len=16), dimension(nplt) :: cplot=&\n! ['RENDER ','SCALE_RANGES ','FONT ',&\n! 'AXIS_LABELS ',' ','TITLE ',&\n! 'GRAPHICS_FORMAT ','OUTPUT_FILE ',' ',&\n! 'QUIT ','POSITION_OF_KEYS','APPEND ',&\n! 'TEXT_LABEL ',' ','EXTRA ']\n!-------------------\n! return here after each sub or subsub command\n21100 continue\n if(graphopt%gnutermsel.lt.1 .or. &\n graphopt%gnutermsel.gt.graphopt%gnutermax) then\n write(kou,*)'No such graphics terminal: ',graphopt%gnutermsel\n elseif(graphopt%gnutermsel.ne.1) then\n write(kou,2910)trim(graphopt%gnutermid(graphopt%gnutermsel)),&\n trim(plotfile),trim(graphopt%filext(graphopt%gnutermsel))\n2910 format(/'Graphics output as ',a,' on file: ',a,'.',a)\n endif\n write(kou,21112)\n21112 format(/'Note: give only one option per line!')\n kom2=submenu('Plot options?',cline,last,cplot,nplt,1,'?TOPHLP')\n plotoption: SELECT CASE(kom2)\n!-----------------------------------------------------------\n CASE DEFAULT\n write(kou,*)'No such plot option'\n!-----------------------------------------------------------\n! PLOT RENDER no more options to plot ...\n case(1)\n!2190 continue\n! use the graphics record to transfer data ...\n! write(*,*)'PMON render plot',associated(maptop%plotlink)\n graphopt%pltax(1)=axplot(1)\n graphopt%pltax(2)=axplot(2)\n if(graphopt%gibbstriangle) then\n! if gibbstriangle make sure min is 0\n graphopt%plotmin(1)=zero\n graphopt%dfltmin(1)=zero\n graphopt%plotmin(2)=zero\n graphopt%dfltmin(2)=zero\n if(graphopt%rangedefaults(1).ne.0 .or. &\n graphopt%rangedefaults(2).ne.0) then\n! if gibbstriangle and scaling make sure xmax and ymax are the same\n xxx=min(graphopt%plotmax(1),graphopt%plotmax(2))\n graphopt%plotmax(1)=xxx\n graphopt%dfltmax(1)=xxx\n graphopt%plotmax(2)=xxx\n graphopt%dfltmax(2)=xxx\n endif\n endif\n graphopt%filename=' '\n graphopt%filename=plotfile\n! write(*,*)'PMON6 tieline_inplane: ',maptop%tieline_inplane,&\n! graphopt%status\n if(maptop%tieline_inplane.lt.0) then\n! set the isopleth bit\n if(index(graphopt%pltax(1),'*').eq.0 .and. &\n index(graphopt%pltax(1),'*').eq.0) then\n graphopt%status=ibset(graphopt%status,GRISOPLETH)\n! write(*,*)'PMON6 isopleth: ',graphopt%status,grisopleth\n else\n! Probably meaningless to plot fractions ... but who knows?\n graphopt%status=ibclr(graphopt%status,GRISOPLETH)\n! write(*,*)'PMON6 not isopleth: ',graphopt%status,grisopleth\n endif\n else\n! for step and tie-lines in plane clear the bit\n graphopt%status=ibclr(graphopt%status,GRISOPLETH)\n endif\n! write(*,*)'PMON call ocplot2: ',graphopt%status,grisopleth\n! added ceq in the call to make it possible to handle change of reference states\n call ocplot2(jp,maptop,axarr,graphopt,version,ceq)\n if(gx%bmperr.ne.0) goto 990\n! write(*,*)'Plot saved on file: ',trim(plotfile)\n! always restore default plot file name and plot option to screem\n if(graphopt%gnutermsel.ne.1) &\n write(kou,*)'Restoring plot device to screen'\n graphopt%gnutermsel=1\n plotfile='ocgnu'\n graphopt%filename=plotfile\n!-----------------------------------------------------------\n! PLOT SCALE_RANGE of either X or Y\n case(2)\n call gparcdx('For X or Y axis? ',cline,last,1,ch1,'Y','?Plot limits')\n if(ch1.eq.'X' .or. ch1.eq.'x') then\n! if(graphopt%axistype(1).eq.1) then\n! write(kou,*)'The x axis set to linear'\n! graphopt%axistype(1)=0\n! else\n! graphopt%axistype(1)=1\n! endif\n goto 21120\n elseif(ch1.eq.'Y' .or. ch1.eq.'y') then\n! if(graphopt%axistype(2).eq.1) then\n! write(kou,*)'The y axis set to linear'\n! graphopt%axistype(2)=0\n! else\n! graphopt%axistype(2)=1\n! endif\n goto 21130\n else\n write(kou,*)'Please answer X or Y'\n endif\n goto 21100\n!............................................ user limits X axis (1)\n21120 continue\n call gparcdx('Default limits',cline,last,1,ch1,'N','?Plot limits')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n graphopt%rangedefaults(1)=0\n else\n graphopt%rangedefaults(1)=1\n twice=.FALSE.\n21104 continue\n call gparrdx('Low limit',cline,last,xxx,graphopt%dfltmin(1),&\n '?Plot limits')\n if(graphopt%gibbstriangle .and. xxx.ne.zero) then\n write(*,*)'Lower limit of a Gibbs triangle plot must be zero'\n goto 21100\n endif\n graphopt%plotmin(1)=xxx\n graphopt%dfltmin(1)=xxx\n once=.TRUE.\n21105 continue\n call gparrdx('High limit',cline,last,xxx,&\n graphopt%dfltmax(1),'?Plot limits')\n if(xxx.le.graphopt%plotmin(1)) then\n if(once) then\n write(kou,*)'Think before typing'\n once=.FALSE.\n elseif(twice) then\n write(kou,*)'Back to command level'\n goto 100\n else\n write(kou,*)'Please give the low limit again!'\n twice=.TRUE.\n goto 21104\n endif\n write(kou,21106)graphopt%plotmin(1)\n21106 format('High limit must be higher than low: ',1pe14.6)\n goto 21105\n endif\n graphopt%plotmax(1)=xxx\n graphopt%dfltmax(1)=xxx\n endif\n goto 21100\n!---------------------------------------------- user limits Y axis (2)\n21130 continue\n call gparcdx('Default limits',cline,last,1,ch1,'N','?Plot limits')\n if(ch1.eq.'Y' .or. ch1.eq.'y') then\n graphopt%rangedefaults(2)=0\n else\n graphopt%rangedefaults(2)=1\n twice=.FALSE.\n21107 continue\n call gparrdx('Low limit',cline,last,xxx,graphopt%dfltmin(2),&\n '?Plot limits')\n if(graphopt%gibbstriangle .and. xxx.ne.zero) then\n write(*,*)'Lower limit of a Gibbs triangle plot must be zero'\n goto 21100\n endif\n graphopt%plotmin(2)=xxx\n graphopt%dfltmin(2)=xxx\n once=.TRUE.\n21108 continue\n call gparrdx('High limit',cline,last,xxx,&\n graphopt%dfltmax(2),'?Plot limits')\n if(xxx.le.graphopt%plotmin(2)) then\n if(once) then\n write(*,*)'Think before typing'\n once=.FALSE.\n elseif(twice) then\n write(kou,*)'Back to command level'\n goto 100\n else\n write(kou,*)'Please give the low limit again!'\n twice=.TRUE.\n goto 21107\n endif\n write(kou,21106)graphopt%plotmin(2)\n goto 21108\n endif\n graphopt%plotmax(2)=xxx\n graphopt%dfltmax(2)=xxx\n endif\n goto 21100\n!-----------------------------------------------------------\n! PLOT unused select FONT\n case(3)\n call gparcdx('Font (check what your GNUPLOT has): ',&\n cline,last,1,name1,graphopt%font,'?Plot font')\n graphopt%font=name1\n! font size ignored but it is better to have the question now ...\n call gparidx('Font size: ',cline,last,iz,16,'?Plot font')\n write(*,*)'Size is ignored at present ...'\n! write(*,*)'Font is now: ',graphopt%font\n! we have to change \"font\" in all terminals and key\n allgnu: do i1=1,graphopt%gnutermax\n iz=index(graphopt%gnuterminal(i1),'\"')\n if(iz.le.0) cycle allgnu\n i2=index(graphopt%gnuterminal(i1)(iz:),',')\n name1=graphopt%gnuterminal(i1)(iz+i2-1:)\n graphopt%gnuterminal(i1)(iz+1:)=graphopt%font\n i2=len_trim(graphopt%gnuterminal(i1))\n graphopt%gnuterminal(i1)(i2+1:)=name1\n! write(*,'(a,i2,2x,a)')'pmon: ',i1,trim(graphopt%gnuterminal(i1))\n enddo allgnu\n iz=index(graphopt%labelkey,'\"')\n if(iz.gt.0) then\n i2=index(graphopt%labelkey(iz:),',')\n name1=graphopt%labelkey(iz+i2-1:)\n graphopt%labelkey(iz+1:)=graphopt%font\n i2=len_trim(graphopt%labelkey)\n graphopt%labelkey(i2+1:)=name1\n! write(*,*)'pmon key: ',trim(graphopt%labelkey)\n endif\n goto 21100\n!-----------------------------------------------------------\n! PLOT AXIS_LABELS\n case(4)\n call gparcdx('For X or Y axis? ',cline,last,1,ch1,'X',&\n '?Plot axis labels')\n if(ch1.eq.'X' .or. ch1.eq.'x') then\n call gparcdx('Axis label: ',cline,last,5,&\n graphopt%plotlabels(2),axplot(1),'?Plot axis labels')\n! remember that plotlabel(1) is the title\n graphopt%labeldefaults(2)=len(graphopt%plotlabels(2))\n elseif(ch1.eq.'Y' .or. ch1.eq.'y') then\n call gparcdx('Axis label: ',cline,last,5,&\n graphopt%plotlabels(3),axplot(2),'?Plot axis labels')\n! remember that plotlabel(1) is the title\n graphopt%labeldefaults(3)=len(graphopt%plotlabels(3))\n else\n write(kou,*)'Please answer X or Y'\n endif\n goto 21100\n!-----------------------------------------------------------\n! PLOT unused\n case(5)\n!-----------------------------------------------------------\n! PLOT TITLE\n case(6)\n call gparcdx('Plot title',cline,last,5,line,'DEFAULT','?Plot title')\n if(line(1:8).eq.'DEFAULT ') then\n graphopt%labeldefaults(1)=0\n else\n graphopt%plotlabels(1)=line\n graphopt%labeldefaults(1)=len_trim(graphopt%plotlabels(1))\n endif\n goto 21100\n!-----------------------------------------------------------\n! PLOT GRAPHICS_FORMAT and PLOT OUTPUT_FILE\n! when setting graphics format always also ask for plot file\n case(7,8)\n! write(*,*)'P6 kom2: ',kom2\n if(kom2.eq.7) then\n! subroutine TOPHLP forces return with ? in position cline(1:1)\n29130 continue\n call gparidx('Graphics format index:',cline,last,grunit,1,&\n '?Plot formats')\n if(cline(1:1).eq.'?' .or. &\n grunit.lt.1 .or. grunit.gt.graphopt%gnutermax) then\n write(kou,29133)\n29133 format('Avalable graphics formats are:')\n write(kou,29135)(i1,graphopt%gnutermid(i1),&\n i1=1,graphopt%gnutermax)\n29135 format(i3,2x,a)\n goto 29130\n endif\n graphopt%gnutermsel=grunit\n write(kou,*)'Graphics format set to: ',graphopt%gnutermid(grunit)\n endif\n!-----------------------------------------------------------\n! PLOT OUTPUT_FILE, always asked when changing graphics terminal type\n21140 continue\n! default extension: 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT, 8=LOG\n! negative is for write, 0 read without filter, -100 write without filter\n! DO NOT USE tinyfiledialog here ...\n write(*,*)'To use file the browser give just a <'\n call gparcdx('Plot file',cline,last,1,plotfile,'ocgnu','?Plot file')\n! to avoid confusion abot use of > and <\n if(plotfile(1:1).eq.'<' .or. plotfile(1:1).eq.'>') then\n! use the file browser\n ztyp=-5\n call gparfilex('File name: ',cline,last,1,plotfile,' ',ztyp,&\n '?Plot file')\n! make sure there is a plt extention\n jp=index(plotfile,'.')\n if(jp.le.0) then\n jp=len_trim(plotfile)\n plotfile(jp+1:)='.plt'\n endif\n write(*,*)'Output will be on: ',trim(plotfile)\n endif\n once=.false.\n if(plotfile(1:2).eq.'./') then\n! save in macro directory if iumaclevl>0, else in current working directory\n! write(*,*)'PMON1: ',trim(plotfile),len_trim(plotfile)\n! write(*,*)'PMON2: ',trim(macropath(iumaclevl)),&\n! len_trim(macropath(iumaclevl)),iumaclevl\n if(iumaclevl.gt.0) then\n! we are executing a macro, skip the ./\n aline=plotfile(3:)\n plotfile=trim(macropath(iumaclevl))//aline\n else\n! running interactivly prefix with working directory (default?)\n aline=plotfile(2:)\n plotfile=trim(workingdir)//aline\n endif\n! trouble passing on ling file names ....\n! write(*,*)'PMON3: ',trim(aline)\n write(*,*)'PMON working directory: ',trim(workingdir)\n write(*,*)'Saving on file: ',trim(plotfile)\n once=.true.\n endif\n if(plotfile(1:6).ne.'ocgnu ') then\n if(index(plotfile,'.').le.0) then\n if(graphopt%gnutermsel.ne.1) then\n filename=trim(plotfile)//'.'//&\n graphopt%filext(graphopt%gnutermsel)\n else\n! just changing name of the GNUPLOT command file\n filename=trim(plotfile)//'.plt '\n plotfile=filename\n endif\n endif\n! filename=trim(plotfile)//'.plt '\n inquire(file=filename,exist=logok)\n if(logok) then\n call gparcdx('File exists, overwrite?',&\n cline,last,1,ch1,'N','PLOT file')\n if(.not.(ch1.eq.'Y' .or. ch1.eq.'y')) then\n write(*,133)\n plotfile=' '\n goto 21140\n endif\n write(*,134)trim(filename)\n once=.true.\n endif\n endif\n! if(.not.once) write(*,'('P134)trim(filename)\n! I am not sure how to inform user where the plot file is saved ....\n goto 21100\n!-----------------------------------------------------------\n! PLOT unused\n case(9)\n!-----------------------------------------------------------\n! PLOT QUIT\n case(10)\n! just return to command level\n!-----------------------------------------------------------\n! PLOT position of line labels (position_of_keys)\n case(11)\n write(kou,21200)\n21200 format('Key to lines can be positioned: '/&\n 'top/bottom left/center/right inside/outside on/off')\n call gparcdx('Position?',cline,last,5,line,'top right','?Plot keys')\n! iz=min(index(line,',')-1,len_trim(line))\n graphopt%labelkey=trim(line)\n! call gparcdx('Font,size: ',cline,last,5,line,'arial,12',&\n! '?Plot keys')\n if(line(1:3).ne.'off') then\n call gparidx('Size: ',cline,last,iz,12,'?Plot keys')\n graphopt%labelkey=trim(graphopt%labelkey)//' font \"'&\n //trim(graphopt%font)//','\n ll=len_trim(graphopt%labelkey)+1\n write(graphopt%labelkey(ll:),'(i2,a)')iz,'\"'\n endif\n write(*,*)'GNUPLOT will use: set key ',trim(graphopt%labelkey)\n goto 21100\n!-----------------------------------------------------------\n! PLOT APPEND a gnuplot file or csv file\n case(12)\n write(kou,*)'Give a file name with graphics in GNUPLOT or csv format'\n! append plot file, specifying extension PLT\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n! if(len_trim(graphopt%appendfile).gt.1) then\n! text=trim(graphopt%appendfile)\n! ztyp=5\n! call gparfilex('File name',cline,last,1,filename,text,ztyp,&\n! '?Plot append')\n! else\n ztyp=5\n call gparfilex('File name',cline,last,1,filename,' ',ztyp,&\n '?Plot append')\n! endif\n! check file exits, convert csv to plt, and add .plt if necessary ...\n jp=max(index(filename,'.csv '),index(filename,'.CSV '))\n write(*,*)'Full file name: ',trim(filename)\n if(jp.gt.0) then\n! the csv file must be converted to a plt file ------------- csv special begin\n! default separator in FactSage is \";\"\n ch1=';'\n call gparcdx('Separating character (, ; or ?)',cline,last,&\n 1,ch1,';','?CSV separator')\n write(*,21205)trim(filename)\n21205 format(/'Converting csv file: ',a,' to csvappend.plt')\n open(23,file=filename,status='old',access='sequential',err=21300)\n! First column is x-axis, the remaining columns are y-axis\n! write(*,*)'Converting CSV file to GNUPLOT file: csvappend.plt'\n! create a new file for the GNUPLOT, overwrite any old\n open(31,file='csvappend.plt',status='unknown',access='sequential',&\n err=21300)\n! write header\n! 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\n! 0.02;0.027281;7.84E-05;0.33126;0.0028241;0.62185;0.016708\n! \"N(LI)\",\"Y(LIQUID,..-Q02)\",\"Y(LIQUID,..-Q04)\",\"Y(LIQUID,..-Q06)\",\"Y(LIQUID,..-Q01)\",\"Y(LIQUID,..-Q05)\",\"Y(LIQUID,..-Q03)\"\n! 2.00000E-01, 2.31701E-02, 3.51556E-02, 5.35191E-01, 1.20145E-02, 1.72251E-01, 2.22218E-01\n read(23,21210,end=21300)string\n21210 format(a)\n call date_and_time(optres,name1)\n write(31,21220)trim(filename),optres(1:4),optres(5:6),&\n optres(7:8),name1(1:2),name1(3:4),trim(string)\n21220 format('# Converted by OC from csv file: ',a/&\n '# ',a4,'-',a2,'-',a2,2x,a2,'h',a2/&\n '# ',a//&\n 'set terminal wxt size 840,700 font \"Arial,16\"'/&\n 'set title \"OpenCalphad CSV\" '/&\n 'set origin 0.0, 0.0'/&\n 'set size 1.0, 1.0'//&\n '$OCCSV2502000 << EOD')\n! on the second line to the last one are values to be plotted as symbols\n read(23,21210,end=21250)string\n! write(*,*)'Read line 2: ',trim(string)\n ioc=1; ip=1; jp=1\n commas: do while(.true.)\n! ch1 should be the separating character\n ip=index(string(ip:),ch1)\n if(ip.le.0) exit commas\n! replace ch1 by a space\n string(jp+ip-1:jp+ip-1)=' '\n ioc=ioc+1\n ip=jp+ip+1\n jp=ip\n! write(*,*)'CSV commas: ',ip,jp,ioc\n enddo commas\n! there are ioc values to be plotted\n! write(*,*)'written line 1: ',trim(string),ioc\n do while(.true.)\n! add a space at the end of line ... GNUPLOT need that\n write(31,'(a,\" \")')trim(string)\n ip=1; jp=1\n! we have to replace ch1 with a space on every line ....\n read(23,21210,end=21250)string\n! write(*,*)'Read line n: ',trim(string)\n tty17: do while(ip.gt.0)\n jp=ip\n ip=index(string(ip:),ch1)\n if(ip.eq.0) exit tty17\n ip=jp+ip-1\n string(ip:ip)=' '\n! write(*,*)'Loop ip: ',ip\n enddo tty17\n! write(*,'(a,\" \")')'written line n: ',trim(string)\n enddo\n! end of file\n! we have read the whole csv file, close the PLT file\n21250 continue\n close(23)\n! add the GNUPLOT ending\n write(31,21260)ioc\n21260 format('EOD'//&\n 'plot for [i=2:',i3,&\n '] $OCCSV2502000 using 1:i with points pt (i-1) notitle'/)\n close(31)\n! set the newly created PLT file as appendfile\n filename='csvappend.plt'\n endif\n!------------------------ end csv special\n jp=index(filename,'.plt ')\n if(jp.le.0) then\n jp=len_trim(filename)\n filename(jp+1:)='.plt'\n endif\n! test file exists by opening and closing it\n open(23,file=filename,status='old',access='sequential',err=21300)\n close(23)\n graphopt%appendfile=filename\n goto 21100\n! error opening file, remove any previous appended file\n21300 continue\n if(graphopt%appendfile(1:1).ne.' ') then\n write(*,21304)trim(graphopt%appendfile)\n21304 format('Error, removing append file: ',a)\n else\n write(kou,*)'No such file name: ',trim(filename)\n endif\n graphopt%appendfile=' '\n goto 21100\n!-----------------------------------------------------------\n! PLOT TEXT anywhere on plot\n case(13)\n labelp=>graphopt%firsttextlabel\n if(associated(labelp)) then\n call gparcdx('Modify existing text?',cline,last,1,ch1,'NO',&\n '?Plot texts')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n jp=0\n do while(associated(labelp))\n jp=jp+1\n write(kou,2310)jp,labelp%xpos,labelp%ypos,&\n labelp%textfontscale,labelp%angle,&\n trim(labelp%textline)\n2310 format(i3,2(1pe12.4),2x,0pF5.2,2x,i4,5x,a)\n labelp=>labelp%nexttextlabel\n enddo\n call gparidx('Which text index?',cline,last,kl,1,'?Plot texts')\n if(kl.lt.1 .or. kl.gt.jp) then\n write(*,*)'No such text label'\n goto 21100\n endif\n labelp=>graphopt%firsttextlabel\n do jp=2,kl\n labelp=>labelp%nexttextlabel\n enddo\n call gparcdx('New text: ',cline,last,5,text,&\n labelp%textline,'?Plot texts')\n labelp%textline=trim(text)\n call gparrdx('New X position: ',cline,last,xxx,&\n labelp%xpos,'?Plot texts')\n call gparrdx('New Y position: ',cline,last,xxy,&\n labelp%ypos,'?Plot texts')\n call gparrdx('New Fontscale: ',cline,last,&\n textfontscale,labelp%textfontscale,'?Plot texts')\n if(textfontscale.lt.0.2) textfontscale=0.2\n call gparidx('New angle (degrees): ',cline,last,j4,&\n labelp%angle,'?Plot texts')\n if(buperr.ne.0) then\n write(*,*)'Error reading coordinates'; buperr=0; goto 21100\n endif\n labelp%xpos=xxx\n labelp%ypos=xxy\n labelp%textfontscale=textfontscale\n labelp%angle=j4\n! ask for more options\n goto 21100\n endif\n endif\n! input a new label\n call gparrdx('X position: ',cline,last,xxx,zero,'?Plot texts')\n call gparrdx('Y position: ',cline,last,xxy,zero,'?Plot texts')\n call gparrdx('Fontscale: ',cline,last,textfontscale,0.8D0,&\n '?Plot texts')\n if(textfontscale.le.0.2) textfontscale=0.2\n call gparidx('Angle (degree): ',cline,last,j4,0,'?Plot texts')\n if(buperr.ne.0) then\n write(*,*)'Error reading coordinates'; buperr=0; goto 21100\n endif\n line=' '\n if(noofaxis.eq.2) then\n! Calculate the equilibria at the specific point\n write(kou,22100)\n22100 format(' *** Note: the positioning of the text will use the ',&\n 'axis variables for which',/11x,'the diagram was calculated',&\n ' even if you plot with other variables!')\n call gparcdx('Do you want to calculate the equilibrium? ',&\n cline,last,1,ch1,'Y','?Plot texts')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n! Check if plotted diagram (axplot) has same axis as calculated (axarr)??\n! Or better, calculate using the plot axis ...\n line=' '\n call calc_diagram_point(axarr,axplot,xxx,xxy,line,ceq)\n if(gx%bmperr.ne.0) then\n write(*,*)'Calculation failed ',gx%bmperr\n gx%bmperr=0\n line='Sorry calculation failed'\n endif\n! when implemented add the stable phase names to \"line\" as default for text\n endif\n endif\n! There is no gparcd which allows editing the existing text ... use emacs!!\n text=' '\n call gparcdx('Text: ',cline,last,5,text,line,'?Plot texts')\n if(text(1:1).eq.' ') then\n write(*,*)'Label ignored'\n goto 21100\n endif\n! I know one should never allocate pointers but this is the only way ???\n allocate(textlabel)\n textlabel%xpos=xxx\n textlabel%ypos=xxy\n textlabel%textfontscale=textfontscale\n textlabel%angle=j4\n textlabel%textline=trim(text)\n if(associated(graphopt%firsttextlabel)) then\n textlabel%nexttextlabel=>graphopt%firsttextlabel\n! write(*,*)trim(graphopt%firsttextlabel%textline)\n else\n nullify(textlabel%nexttextlabel)\n endif\n graphopt%firsttextlabel=>textlabel\n! the record is now linked from graphopt, nullify the pointer ...\n! (some memory lost ...)\n nullify(textlabel)\n! also clean the cline character otherwise labels may be overwritten\n cline=' '\n last=len(cline)\n goto 21100\n!---------------------------------------------------------\n! PLOT unused\n case(14)\n!---------------------------------------------------------\n! PLOT EXTRA, subsubcommand\n case(15)\n! subsubcommands to PLOT (may not be updated!!)\n! character (len=16), dimension(nplt2) :: cplot2=&\n! ['COLOR ','LOGSCALE ','RATIOS_XY ',&\n! 'LINE_TYPE ','MANIPULATE_LINES','PAUSE_OPTION ',&\n! 'LOWER_LEFT_TEXT ','TIE_LINES ','GIBBS_TRIANGLE ',&\n! 'QUIT ','SPAWN ','NO_HEADING ',&\n! 'AXIS_FACTOR ','GRID ',' ',&\n! ' ',' ',' ']\n!-------------------------------------------------------------------\n! default set to GIBBS-TRIANGLE\n kom3=submenu('Extra options?',cline,last,cplot2,nplt2,9,'?TOPHLP')\n plotextra: SELECT CASE(kom3)\n case default\n! this is typically when using a ? or ??\n write(*,*)'No such extra option'\n cline=' '\n last=len(cline)\n goto 21100\n!...............................................\n! PLOT EXTRA axis_factor for example to plot kJ or GPa instead of J and Pa\n case(13)\n call gparcdx('Which axis?',cline,last,1,ch1,'Y',&\n '?Plot extra factor')\n call capson(ch1)\n if(ch1.eq.'Y' .or. ch1.eq.'X') then\n call gparrdx('Factor?',cline,last,xxx,1.0D-3,&\n '?Plot extra factor')\n if(ch1.eq.'X') graphopt%scalefact(1)=abs(xxx)\n if(ch1.eq.'Y') graphopt%scalefact(2)=abs(xxx)\n! write(*,*)'PMON: ',graphopt%scalefact(1),graphopt%scalefact(2)\n else\n write(*,*)'No such axis'\n endif\n goto 21100\n!...............................\n! PLOT EXTRA COLOR ... and some more things ...\n case(1)\n! monovariant and tielinecolor declared in smp2.F90\n call gparcdx('Monovariant color ',cline,last,1,&\n name1,monovariant,'?Plot color')\n call capson(name1)\n do kl=1,6\n if(name1(kl:kl).lt.'0' .or. name1(kl:kl).gt.'9') then\n if(name1(kl:kl).lt.'A' .or. name1(kl:kl).gt.'F') then\n write(*,*)'The color must be a hexadecimal value',&\n ' between 000000 (black) and FFFFFF (white)'\n goto 21100\n endif\n endif\n enddo\n monovariant=name1(1:6)\n call gparcdx('Tie-line color ',cline,last,1,&\n name1,tielinecolor,'?Plot font')\n call capson(name1)\n do kl=1,6\n if(name1(kl:kl).lt.'0' .or. name1(kl:kl).gt.'9') then\n if(name1(kl:kl).lt.'A' .or. name1(kl:kl).gt.'F') then\n write(*,*)'Wrong color, must be between 000000 and FFFFFF'\n goto 21100\n endif\n endif\n enddo\n tielinecolor=name1(1:6)\n goto 21100\n!...............................................\n! PLOT EXTRA Gibbs triangle\n case(9)\n chz='Y'\n if(graphopt%gibbstriangle) chz='N'\n call gparcdx('A Gibbs triangle diagram?',cline,last,5,ch1,chz,&\n 'PLOT Gibbs triangle')\n if(ch1.eq.'y' .or. ch1.eq.'Y') then\n graphopt%gibbstriangle=.TRUE.\n write(*,22500)\n22500 format('The Gibbs triangle layout courtesy of',&\n ' Catalina Pineda Heresi at RUB, Germany')\n else\n graphopt%gibbstriangle=.FALSE.\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA GRID\n case(14)\n call gparcdx('Plot grid?',cline,last,1,ch1,'Y',&\n '?Plot extra factor')\n call capson(ch1)\n if(ch1.eq.'Y') then\n graphopt%setgrid=1\n else\n graphopt%setgrid=0\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA LINE_TYPE\n case(4)\n j4=last\n if(eolch(cline,j4)) then\n! write this only if the lime is empty\n write(*,22300)\n22300 format('Default 1 restore normal line types:',/&\n ' 0 means dashed lines,'/,' 1 means full line',/&\n '>1 means symbol at each calculated point')\n endif\n call gparidx('Line type?',cline,last,iz,1,'?Plot line symbols')\n if(iz.eq.0) then\n! this means dashed lines and possibly symbols if already set ..\n graphopt%linetype=0\n elseif(iz.gt.1) then\n! graphopt%linetype=iz\n! this means symboles and possibly dashed lines if already set\n graphopt%linewp=iz\n else\n! this means full lines and no symbols\n graphopt%linewp=1\n graphopt%linetype=1\n endif\n! write(*,*)'Only partially implemented'\n goto 21100\n!...............................................\n! PLOT EXTRA LOGSCALE\n case(2)\n call gparcdx('For x or y axis (or NONE)? ',cline,last,1,ch1,'y',&\n '?Plot logax')\n if(ch1.eq.'x') then\n if(graphopt%axistype(1).eq.1) then\n write(kou,*)'The x axis set to linear'\n graphopt%axistype(1)=0\n else\n graphopt%axistype(1)=1\n! set range to defaults when changing to LOG \n graphopt%rangedefaults(1)=0\n endif\n elseif(ch1.eq.'y') then\n if(graphopt%axistype(2).eq.1) then\n write(kou,*)'The y axis set to linear'\n graphopt%axistype(2)=0\n else\n graphopt%axistype(2)=1\n! set range to defaults when changing to LOG \n graphopt%rangedefaults(2)=0\n endif\n else\n write(kou,*)'Both axis set to be linear'\n graphopt%axistype(1)=0\n graphopt%axistype(2)=0\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA text in lower left corner\n case(7)\n call gparcx('Text in lower left corner?',cline,last,1,text,' ',&\n '?Extra lower-left-corner')\n graphopt%lowerleftcorner=text\n goto 21100\n!...............................................\n! PLOT EXTRA MANIPULATE LINE COLORS\n case(5)\n write(kou,22400)\n22400 format('OC uses GNUPLOT and it is possible to edit',&\n ' the file \"ocgnu.plt\" file'/&\n 'generated by OC to use extensive facilities',&\n ' provided by GNUPLOT.'/&\n 'Only a few of them is provided here.'/&\n 'OC has 10 different colors to identify the lines plotted.',&\n ' Line 11 or'/' higher will repeat these colors. With',&\n ' this command you can select'/' one of these 10 colors',&\n ' to be used for the first line plotted.')\n call gparidx('The color index should be on the first line?',&\n cline,last,flc,1,'?Plot manipulate colors')\n if(flc.lt.1 .or. flc.gt.10) then\n write(*,*)'Number must be between 1 and 10'\n else\n graphopt%linett=flc\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA remove headings\n case(12)\n call gparcdx('Remove headings?',cline,last,1,ch1,'N',&\n '?Plot no heading')\n if(ch1.ne.'N') then\n write(*,*)'No title set!',ch1\n graphopt%status=ibset(graphopt%status,GRNOTITLE)\n else\n graphopt%status=ibclr(graphopt%status,GRNOTITLE)\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA PAUSE_OPTIONS uselss??\n case(6)\n write(kou,*)'Specify option after pause !'\n call gparcx('GNUPLOT pause option?',cline,last,5,text,' ',&\n '?Plot pause')\n if(len_trim(text).eq.0) then\n write(kou,*)'Warning, plot will exit directly!'\n! text='-1'\n endif\n graphopt%plotend='pause '//text\n goto 21100\n!...............................................\n! PLOT EXTRA QUIT\n case(10)\n goto 21100\n!...............................................\n! PLOT EXTRA RATIOS\n case(3)\n call gparrdx('X-axis plot ratio',cline,last,xxx,graphopt%xsize,&\n '?Plot ratios')\n if(xxx.le.0.1) then\n write(*,*)'Ratio set to 0.1'\n xxx=0.1D0\n endif\n graphopt%xsize=xxx\n call gparrdx('Y-axis plot ratio',cline,last,xxx,graphopt%ysize,&\n 'PLOT ratios')\n if(xxx.le.0.1) then\n write(*,*)'Ratio set to 0.1'\n xxx=0.1D0\n endif\n graphopt%ysize=xxx\n goto 21100\n!...............................................\n! PLOT EXTRA spawn plot\n case(11)\n call gparcdx('Spawn plot?',cline,last,1,ch1,'N','?Plot extra')\n if(ch1.eq.'Y') then\n graphopt%status=ibset(graphopt%status,GRKEEP)\n else\n graphopt%status=ibclr(graphopt%status,GRKEEP)\n endif\n goto 21100\n!...............................................\n! PLOT EXTRA Tie-line plot increment\n case(8)\n call gparidx('Tie-line plot increment?',cline,last,kl,3,&\n '?Plot tieline')\n if(kl.lt.0) kl=0\n graphopt%tielines=kl\n goto 21100\n!...............................................\n! PLOT EXTRA unused\n case(15)\n goto 21100\n!...............................................\n! PLOT EXTRA unused\n case(16)\n goto 21100\n!...............................................\n! PLOT EXTRA unused\n case(17)\n goto 21100\n!...............................................\n! PLOT EXTRA unused\n case(18)\n goto 21100\n!-----------------------------------------------------------\n end select plotextra\n goto 21100\n!-----------------------------------------------------------\n end SELECT plotoption\n!=================================================================\n! HPCALC\n case(22)\n call hpcalc\n buperr=0\n!=================================================================\n! FIN, do not ask if sure, the French always know what they do ...\n case(23)\n if(logfil.gt.0) then\n write(logfil,*)'set interactive'\n endif\n call openlogfile(' ',' ',-1)\n stop 'Au revoir'\n!=================================================================\n! OPTIMIZE and CONTINUE. Current optimizer is optimizers(optimizer)\n case(24)\n call gparidx('Number of iterations: ',cline,last,i1,nopt1,&\n '?Optimize')\n if(buperr.ne.0) goto 100\n nopt1=i1\n nopt=i1\n! write(*,606)'dead 1',mexp,nvcoeff,iexit\n606 format(a,10i4)\n! some optimizers have no CONTINUE\n! if(optimizer.eq.1) iexit(4)=0\n! continue: if(mexp.gt.0 .and. iexit(4).eq.2) then\n! iexit(4) from previous optimize allows continue with same Jacobian\n! call gparcd('Continue with same Jacobian? ',cline,last,1,&\n! ch1,'Y',q1help)\n! if(ch1.eq.'Y') then\n! ient=1\n! goto 987\n! endif\n! endif continue\n! Initiate arrays when new optimization\n! ient=0\n if(.not.allocated(firstash%eqlista)) then\n write(kou,*)'There are no equilibria with experiments!'\n goto 100\n endif\n! write(*,*)'dead 2A',mexp,nvcoeff\n! if(allocated(www)) then\n! write(*,*)'Deallocating www: ',size(www),www(1)\n! deallocate(www)\n! endif\n! write(*,*)'dead 2B',mexp,nvcoeff\n if(allocated(coefs)) deallocate(coefs)\n! write(*,*)'dead 2C',mexp,nvcoeff\n if(allocated(errs)) deallocate(errs)\n! write(*,*)'dead 3',mexp,nvcoeff\n! size of errors array, sum experiments for all equilibria\n mexp=0\n do i1=1,size(firstash%eqlista)\n! skip equilibria with zero weight\n if(firstash%eqlista(i1)%p1%weight.eq.zero) cycle\n if(associated(firstash%eqlista(i1)%p1%lastexperiment)) then\n i2=firstash%eqlista(i1)%p1%lastexperiment%seqz\n mexp=mexp+i2\n else\n write(*,*)'No experiment in equilibrium ',i1\n endif\n enddo\n! write(*,*)'Number of experiments: ',mexp\n allocate(errs(mexp))\n updatemexp=.false.\n! copy the variable coefficients to coefs\n if(nvcoeff.le.0) then\n write(*,*)'No coefficients to optimize'\n nvcoeff=0\n else\n i2=0\n allocate(coefs(nvcoeff))\n do i1=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(i1).ge.10) then\n i2=i2+1\n if(i2.gt.nvcoeff) then\n write(kou,*)'More variable coefficients than expected',&\n i2,nvcoeff\n goto 100\n endif\n coefs(i2)=firstash%coeffvalues(i1)\n! coefs(i2)=firstash%coeffvalues(i1)*firstash%scale(i1)\n! We do not have to bother about the associtated TP variable, it will\n! be set by the calfun routine to coefs*firstashscale\n! call change_optcoeff(firstash%coeffindex(i1),&\n! firstash%coeffvalues(i1))\n! firstash%coeffvalues(i1))\n if(gx%bmperr.ne.0) then\n write(*,*)'Error finding coefficient TP fun'\n goto 100\n endif\n endif\n enddo\n if(i2.lt.nvcoeff) then\n write(kou,*)'Internal error for variable coefficients',&\n i2,nvcoeff\n goto 100\n endif\n endif\n! JUMP HERE IF CONTINUE optimization ... NOT YET implemented\n987 continue\n! mexp Number of experiments\n! nvcoeff Number of coefficients to be optimized\n! errs Array with differences with experiments and calculated values\n! coefs Array with coefficients\n if(mexp.le.0 .or. nvcoeff.le.0) then\n write(kou,569)mexp,nvcoeff\n569 format('Cannot optimize with zero experiments or coefficients',2i5)\n goto 100\n endif\n firstash%lwam=lwam\n write(*,558)mexp,nvcoeff,mexp*nvcoeff+5*nvcoeff+mexp,lwam\n558 format(/'*************************************************************'/&\n '>>> Start of optimization using LMDIF'/&\n '>>> with ',i4,' experiments and ',i3,' coefficients.',/&\n '>>> Workspace needed ',i6,', out of allocated ',i6/&\n '*************************************************************')\n!\n j4=nopt\n if(.not.allocated(iwam)) then\n! value of lwam set by user\n allocate(iwam(lwam))\n allocate(wam(lwam))\n endif\n if(allocated(fjac)) deallocate(fjac)\n! fjac is used to calculate the Jacobian and other things\n! err0(1) is set to the sum of errors squared for the initial values of coefs\n573 format(a,6(1pe12.4))\n allocate(fjac(mexp,nvcoeff))\n! write(*,'(a,10(1pe12.4))')'lmdif1: ',(coefs(iz),iz=1,nvcoeff)\n!->->->->->-> HERE THE OPTIMIZATION IS MADE <-<-<-<-<-<-\n! nfev set to number of iterations\n! write(*,*)'LMDIF dimensions: ',mexp,nvcoeff,lwam\n call lmdif1(calfun,mexp,nvcoeff,coefs,errs,optacc,nopt,nfev,&\n iwam,wam,lwam,fjac,err0)\n! call lmdif1(mexp,nvcoeff,coefs,errs,optacc,nopt,nfev,&\n! iwam,wam,lwam,fjac,err0)\n!->->->->->-> HERE THE OPTIMIZATION IS MADE <-<-<-<-<-<-\n mexpdone=mexp\n nvcoeffdone=nvcoeff\n! on return nopt is set to a message but \n! first copy the coefs to coeffvalues ...\n! write(*,573)'Coeffs ut: ',(coefs(j2),j2=1,nvcoeff)\n i2=0\n do i1=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(i1).ge.10) then\n i2=i2+1\n firstash%coeffvalues(i1)=coefs(i2)\n! write(*,555)'final: ',i1,i2,&\n! firstash%coeffvalues(i1)*firstash%coeffscale(i1),&\n! coefs(i2),firstash%coeffscale(i1)\n!555 format(a,2i3,3(1pe12.4))\n endif\n enddo\n! then calculate final sum of errots\n xxx=zero\n do i2=1,mexp\n xxx=xxx+errs(i2)**2\n enddo\n! this is the final sum of errors squared\n err0(2)=xxx\n if(mexp-nvcoeff.gt.0) then\n! should I add or subract 1??\n err0(3)=xxx/real(mexp-nvcoeff)\n else\n! when equal number of experiment and coefficients\n err0(3)=1.0D30\n endif\n! The top nvcoeff*nvcoeff submatrix of fjac is R^T * R\n! write(*,*)'The unsymmetric R^T*R submatrix returned from lmfif1:'\n! do i2=1,nvcoeff\n! write(*,563)(fjac(j2,i2),j2=1,nvcoeff)\n! enddo\n! read(*,'(a)')ch1\n! cormat will be the CORRELATION MATRIX if optimization successful\n! otherwise it will not be allocated\n if(allocated(cormat)) then\n deallocate(cormat)\n deallocate(tccovar)\n endif\n!--------------- begin calculate correlation matrix and RSD\n! zero the relative standard deviations (RSD)\n firstash%coeffrsd=zero\n if(j4.gt.0 .and. nopt.gt.0 .and. nopt.le.6) then\n! if there is a result calculate the Jacobian in fjac\n! mexp,nvcoeff,coeffs,errs are same as in the call to lmdif1\n! This will overwrite the fjac returned from the call to lmdif1\n! write(*,*)'Calculating the Jacobian: '\n! allocate array to extract calculated values of experiments\n if(allocated(calcexp)) deallocate(calcexp)\n allocate(calcexp(mexp))\n iflag=2\n! penulitima argument zero means use machine precision to calculate derivative\n! call fdjac2(mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam)\n call fdjac2(calfun,mexp,nvcoeff,coefs,errs,fjac,mexp,iflag,zero,wam)\n! debug output ...\n! write(*,*)'pmon: fjac: ',nvcoeff,mexp,iflag\n! do i2=1,mexp\n! write(*,563)(fjac(i2,ll),ll=1,nvcoeff)\n! enddo\n563 format(6(1pe12.4))\n! write(*,*)'End listing of Jacobian fjac calculated by fdjac2'\n! read(*,'(a)')ch1\n! Next calculate M = (fjac)^T (fjac); ( ^T means transponat)\n if(allocated(cov1)) deallocate(cov1)\n! the cov1 is symmetric and should have these dimensions:\n allocate(cov1(nvcoeff,nvcoeff))\n cov1=zero\n do i2=1,nvcoeff\n do j2=1,nvcoeff\n xxx=zero\n do ll=1,mexp\n xxx=xxx+fjac(ll,i2)*fjac(ll,j2)\n! write(*,564)'xxx: ',i2,j2,ll,xxx\n564 format(a,3i5,1pe12.4)\n enddo\n! this matrix is symmetric ... which index first ???\n cov1(j2,i2)=xxx\n! cov1(i2,j2)=xxx\n enddo\n enddo\n! write(*,*)'M = (Jac)^T (Jac); (^T means transponat)',nvcoeff\n! do i2=1,nvcoeff\n! write(*,563)(cov1(i2,ll),ll=1,nvcoeff)\n! enddo\n! invert cov1 using LAPACK+BLAS via Lukas routine ...\n if(nvcoeff.gt.1) then\n! cormat deallocated above, dimension is cormat(nvcoeff,nvcoeff) !!\n allocate(cormat(nvcoeff,nvcoeff))\n allocate(tccovar(nvcoeff,nvcoeff))\n! symmetric? call mdinv(nvcoeff,nvcoeff+1,cov1,cormat,nvcoeff,iflag)\n! NOTE: cov1 and cormat should both have dimension cov1(nvcoeff,nvcoeff)\n call mdinv(nvcoeff,cov1,cormat,nvcoeff,iflag)\n! invert unsymmetrical matrix\n if(iflag.eq.0) then\n write(*,*)'Failed invert matrix=Jac^T*Jac',iflag\n endif\n! RSD depend on scaling factor of coefficient\n! write(*,*)'PMON norm.error and covariant matrix: ',err0(3)\n! do i1=1,nvcoeff\n! write(*,'(6(1pe12.4))')(cormat(i1,i2),i2=1,nvcoeff)\n! enddo\n! all elements in the covariance matrix should be multiplied with err0(3)\n tccovar=cormat\n do i1=1,nvcoeff\n do i2=1,nvcoeff\n! I get exactly the same RSD as TC if I ignore the normalized error !!\n! but according to theory it should be multiplied with the normalized error\n cormat(i1,i2)=err0(3)*cormat(i1,i2)\n enddo\n enddo\n! divide all values with the square root of the diagonal elements\n! save covarance matrix n cov1\n cov1=cormat\n do i1=1,nvcoeff\n do i2=1,nvcoeff\n xxx=sqrt(abs(cov1(i1,i1)*cov1(i2,i2)))\n cormat(i1,i2)=cormat(i1,i2)/xxx\n enddo\n enddo\n! write(*,*)'Correlation after dividing with sqrt(abs(c_ii*c_jj))'\n! do i1=1,nvcoeff\n! write(*,'(6(1pe12.4))')(cormat(i1,i2),i2=1,nvcoeff)\n! enddo\n elseif(abs(cov1(1,1)).gt.1.0D-38) then\n! cov1 is just a single value\n allocate(cormat(1,1))\n allocate(tccovar(1,1))\n! cormat(1,1)=one\n! IF THERE IS A SINGLE VARIABLE ITS CORRELATION MATRIX MUST BE UNITY\n cormat(1,1)=one\n tccovar(1,1)=one\n else\n write(*,*)'Correlation matrix singular'\n endif\n endif\n! write the correlation matrix this is still very uncertain ,,,\n! if(allocated(cormat)) then\n! if(nvcoeff.gt.0) then\n! write(*,*)'Correlation matrix (symmetric):'\n! do i2=1,nvcoeff\n! write(kou,'(8(1pe10.2))')(cormat(i2,j2),j2=1,nvcoeff)\n! enddo\n! endif\n! endif\n! zero all RSD values\n firstash%coeffrsd=zero\n if(allocated(cormat) .and. allocated(cov1)) then\n! calculate the RSD (Relative Standard Deviation) for each parameter\n! the last calculated values of the experiments in calcexp\n! write(*,*)'The sum of all calculated equilibria,',&\n! ' very different magnitudes ...'\n xxx=zero\n do i2=1,mexp\n! the calculated value is stored in calcexp by fdjac if calcexp is allocated!\n xxx=xxx+calcexp(i2)\n! write(*,766)i2,calcexp(i2),xxx\n766 format('pmon: Calculated value',i4,2(1pe12.4))\n enddo\n! ll=max(1,mexp-nvcoeff)\n! This value may be negative!\n! xxy=xxx/real(ll)\n! the difference between the calculated and experimental value is errs(1:mexp)\n! err0(2) is sum of all errors squared \n! xxx=err0(2)/real(ll) ... this is err0(3)\n! I am not sure about this ...\n i2=0\n do i1=0,size(firstash%coeffstate)-1\n if(firstash%coeffstate(i1).ge.10) then\n! this is an optimized parameter, they are indexed starting from zero!!\n i2=i2+1\n! But in cormat they are indexed from 1 .. nvcoeff\n! firstash%coeffrsd(i1)=sqrt(abs(cormat(i2,i2))*xxx)/xxy\n! write(*,'(a,3(1pe12.4))')'RSD: ',cov1(i2,i2),xxx,xxy\n! firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2))*xxx)/xxy)\n! we have already multiplied all terms in covariance matrix with err0(3)\n! firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2))*err0(3)\n firstash%coeffrsd(i1)=abs(sqrt(abs(cov1(i2,i2))))\n endif\n enddo\n endif\n! deallocate calcexp to avoid storing these values when running LMDIF\n if(allocated(calcexp)) deallocate(calcexp)\n!--------------- end calculate correlation matrix and RSD\n! some nice output .....\n write(kou,5020)\n if(j4.eq.0) then\n write(*,*)'Dry run with zero iterations'\n elseif(nopt.eq.0) then\n write(kou,5000)nopt\n5000 format(/'*** No optimization due to improper input parameters',i3)\n elseif(nopt.eq.1) then\n write(kou,5001)nopt,optacc\n5001 format(/'LMDIF return code ',i2/&\n 'Relative error for sum of squares is within ',1pe10.2)\n elseif(nopt.eq.2) then\n write(kou,5002)nopt,optacc\n5002 format(/'LMDIF return code ',i2/&\n 'Relative error of parameters is within ',1pe10.2)\n elseif(nopt.eq.3) then\n write(kou,5003)nopt\n5003 format(/'LMDIF return code ',i2,': successful optimization')\n elseif(nopt.eq.4) then\n write(kou,5004)nopt\n5004 format(/'*** LMDIF return code ',i2/&\n 'Sum of squares does not decrease')\n elseif(nopt.eq.5) then\n write(kou,5005)nopt,nfev\n5005 format(/'*** LMDIF return code ',i2/&\n 'Maximum calls of function ',i5,' exceeded')\n elseif(nopt.eq.6) then\n write(kou,5006)nopt,optacc\n5006 format(/'*** LMDIF return code ',i2/&\n 'Cannot reduce error, requested accuracy ',1pe10.2,' too small')\n! '*** Cannot reduce error, requested accuracy 123456789. too small\n elseif(nopt.eq.6) then\n write(kou,5007)nopt,optacc\n5007 format(/'*** LMDIF return code ',i2/&\n 'Cannot improve result, requested accuracy ',1pe10.2,' too small')\n else\n write(kou,5008)nopt\n5008 format('*** LMDIF return code ',i7/&\n 'Unknown code, see LMDIF documentation.')\n endif\n write(kou,5010)nfev,err0\n5010 format(/'Iterations ',i4,', sum of errors changed from ',&\n 1pe14.6,' to ',1pe14.6/17x,'Normalized sum of errors:',20x,1pe14.6)\n write(kou,5020)\n5020 format(/78('*'))\n! finally list the coefficient values\n call listoptcoeff(mexp,err0,.FALSE.,lut)\n! end of call to LMDIF\n!=================================================================\n! SHOW is immpemented as a special case of LIST STATE_VARIABLES\n! CASE(25)\n! write(kou,*)'Not implemented yet'\n!=================================================================\n! not used\n CASE(26)\n continue\n write(kou,*)'Not implemented yet'\n!=================================================================\n! unused\n CASE(27)\n write(kou,*)'Not implemented yet'\n!=================================================================\n! unused\n CASE(28)\n write(kou,*)'Not implemented yet'\n!=================================================================\n! unused\n CASE(29)\n write(kou,*)'Not implemented yet'\n!=================================================================\n! unused\n CASE(30)\n write(kou,*)'Not implemented yet'\n!=================================================================\n!\n END SELECT main\n! command executed, prompt for another command unless error code\n if(gx%bmperr.eq.0) goto 100\n!============================================================\n! handling errors\n990 continue\n write(kou,991)gx%bmperr,buperr,kiu\n991 format(/'Error codes: ',3i6)\n if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then\n write(kou,992)trim(bmperrmess(gx%bmperr))\n992 format('Message: ',a/)\n else\n write(kou,*)'No defined error message, maybe I/O error'\n endif\n! if(kiu.ne.kiud) then\n if(stop_on_error) then\n! error running a macro, terminate macro and return interactive\n write(*,*)'Error running MACRO file, return to interactive mode?'\n if(iox(8).eq.0) then\n! iox(8) is nonzero if one has set \"no stop on @&\"\n! in such a case ignore any error\n read(*,993)ch1\n993 format(a)\n if(ch1.eq.' ') then\n call macend(cline,last,logok) \n kiu=kiud\n else\n write(*,*)'Continue on your own risk '\n endif\n endif\n endif\n! if(stop_on_error) then\n! turn off macro but remain inside software\n! if(kiu.ne.kiud) then\n! call macend(cline,last,logok) \n! write(kou,*)'Stop_on_error set, press return to finish program'\n! read(kiu,17)ch1\n! stop\n! endif\n gx%bmperr=0; buperr=0\n goto 100\n!\n end subroutine oc_command_monitor\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\bergin{verbatim}\n integer function submenu(query,cline,last,ccomnd,ncomnd,kdef,menutarget)\n! general subcommand decoder\n! query is the prompt\n! cline and last is user input and position\n! ccomnd is the menu and ncomnd number of menu entries\n! kdef is the default (to be added to query)\n! implicit double precision (a-h,o-z)\n implicit none\n character cline*(*),ccomnd(*)*(*),query*(*),menutarget*(*)\n integer last,kdef,ncomnd\n!\\end{verbatim}\n! external q2help\n character defansw*16,query1*64,text*256\n integer kom2,lend,lenq\n logical once\n lenq=len_trim(query)\n if(query(lenq:lenq).eq.'?') then\n query1=query(1:lenq)\n else\n query1=query(1:lenq)//' what?'\n lenq=lenq+6\n endif\n once=.true.\n! this is to force loading of q2help on MacOS (did not help)\n! write(*,*)'In submenu target:',trim(menutarget),' \"',trim(cline),'\"',last\n submenu=0\n! if cline(last:last) is \",\" skip one character\n! write(kou,*)'submenu 1: ',query(1:lenq),last,trim(cline),kdef\n if(last+2.lt.len(cline)) then\n if(cline(last:last).eq.',') last=last+1\n else\n! write(*,*)'Submenu input too long: \"',trim(cline),'\"',last\n last=len(cline)-2\n endif\n if(cline(last:last+2).eq.' ? ' .or. cline(last:last+1).eq.'? ') then\n! This handles help for things like \"set ?\"\n! if cline is just \"?\" just display menu but reset last to 1\n! in order to provide help also specific for the command\n call q3helpx(cline,last,ccomnd,ncomnd)\n last=len(cline)\n goto 1000\n endif\n100 continue\n! write(*,*)'submenu command input'\n if(kdef.lt.1 .or. kdef.gt.ncomnd) then\n! no default answer\n if(eolch(cline,last)) then\n! empty line, note fourth argument 5 copes whole of cline into text\n! the hypertext is the submenu prompt, last argument set to mark TOPHLP!\n call gparcx(query1(1:lenq),cline,last,5,text,' ','?TOPHLP')\n if(buperr.ne.0) goto 1000\n! write(*,*)'At the TOP LEVEL no default: ',trim(text),last\n cline=text\n else\n cline=cline(last:)\n endif\n else\n! there is a default answer\n! this eolch skips spaces. If only spaces it returns TRUE\n if(eolch(cline,last)) then\n! there is no user input passed to this subroutine, write the question\n defansw=ccomnd(kdef)\n lend=len_trim(defansw)+1\n333 continue\n! this is submenu command input\n! note fourth argument 5 copes whole of cline into text\n! the queary is the hypertarget, last argument to indicate TOPHLP\n! if user answers a single ? retutn here, if ?? use webrowser\n call gparcdx(query1(1:lenq),cline,last,5,text,defansw,'?TOPHLP')\n if(buperr.ne.0) goto 1000\n! write(*,*)'submenu input 3: ',trim(text),last\n if(text(1:1).eq.'?') then\n if(text(2:2).ne.'?') then\n! if we have just a ? here we should display the menue\n! write(*,*)'TOP LEVEL default: ',trim(text),last\n call q3helpx(' * ',last,ccomnd,ncomnd)\n last=len(cline)\n! note that two ?? should have been taken care of inside gparcdx\n endif\n goto 333\n endif\n cline=text\n else\n! if first character is , take default answer\n! write(*,102)'submenu 7: ',last,trim(cline)\n102 format(a,i5,'\"',a,'\"')\n if(cline(last:last).eq.',') then\n! a , means accept default answer\n submenu=kdef\n goto 1000\n else\n defansw=ccomnd(kdef)\n lend=len_trim(defansw)+1\n! note fourth argument 5 copes whole of cline into text\n! gparcd skips one character, backspace last, it does not matter if it is ,\n last=last-1\n! in this case there is no user input in this call\n call gparcdx(query1(1:lenq),cline,last,5,text,defansw,'?TOPHLP')\n if(buperr.ne.0) goto 1000\n cline=text\n! cline=cline(last:)\n! write(*,*)'sumbemu: ',trim(cline),last\n! added 20190207 because \"enter gamma ac(a)/x(a); gave segmentation fault\n! but that was not the error, the error was missing =\n! once=.false.\n endif\n endif\n endif\n!\n! write(*,102)'submenu 9: ',last,trim(cline)\n kom2=ncomp(cline,ccomnd,ncomnd,last)\n if(kom2.le.0) then\n if(once) then\n if(cline(1:1).ne.'?') once=.false.\n if(kom2.lt.0) write(kou,*)'Ambiguous answer, please try again'\n write(kou,*)'Possible answers are:'\n last=1\n cline=' *'\n! call nghelp(cline,last,ccomnd,ncomnd)\n call q3helpx(cline,last,ccomnd,ncomnd)\n last=len(cline)\n goto 100\n else\n write(kou,*)'Answer not understood, returning to upper level'\n goto 1000\n endif\n else\n submenu=kom2\n if(helprec%level.lt.maxhelplevel) then\n helprec%level=helprec%level+1\n helprec%cpath(helprec%level)=ccomnd(kom2)\n else\n write(*,*)'Warning, exceeded helprec%level limit 2'\n endif\n endif\n! write(*,102)'submenu last: ',last,trim(cline)\n1000 continue\n return\n end function submenu\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\begin{verbatim}\n subroutine ocmon_set_options(useroption,afo,optionsset)\n implicit none\n character*(*) useroption\n integer afo\n TYPE(ocoptions) :: optionsset\n!\\end{verbatim}\n integer next,kom,slen,errno,jj,ztyp\n character option*64,string*64,dummy*128,date*8,time*10\n integer, parameter :: nopt=9\n character (len=16), dimension(nopt) :: copt=&\n ['OUTPUT ','ALL ','FORCE ',&\n 'VERBOSE ','SILENT ','APPEND ',&\n ' ',' ',' ']\n! copy \"option\" to a local string as it may be just a single character!!\n option=' '\n option=useroption\n! /? will list options\n afo=0\n if(option(1:2).eq.'? ') then\n write(kou,10)\n10 format('Available options (preceded by /) are:')\n next=1\n dummy=' * '\n call q3helpx(dummy,next,copt,nopt)\n! write(*,*)'Back from q3help'\n afo=1\n goto 1000\n endif\n kom=ncomp(option,copt,nopt,next)\n if(kom.le.0) then\n write(kou,*)'Unknown option ignored: ',option(1:len_trim(option))\n goto 1000\n else\n select case(kom)\n case default\n write(kou,*)'Option not implemented: ',option(1:len_trim(option))\n write(kou,10)\n next=1\n dummy=' * '\n call q3helpx(dummy,next,copt,nopt)\n afo=1\n!-----------------------------------\n case(1) ! /output means open a file and ovewrite any previous content\n! write(*,*)'Option not implemented: ',option(1:len_trim(option))\n! next argument after = must be a file name\n! 6 means extension DAT\n! jj=next+1\n! if(eolch(option,jj)) then\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=-7\n call gparfilex('Output file',option,next,1,string,' ',ztyp,&\n '?Command options')\n if(string(1:1).eq.' ') then\n string='ocoutput.DAT'\n write(kou,*)' *** No file name given, will use: ',trim(string)\n endif\n slen=len_trim(string)\n! else\n! call getext(option,next,2,string,' ',slen)\n! endif\n! add extention .dat if to extenstion provided\n if(index(string,'.').le.0) then\n string(slen+1:)='.DAT '\n endif\n! close any previous output file \n close(21)\n open(21,file=string,access='sequential',status='unknown',&\n err=900, iostat=errno)\n optionsset%lut=21\n! write a header\n call date_and_time(date,time)\n232 format(/'%%%%%%%%%% OC output ',a,a4,'-',a2,'-',a2,2x,a2,'h',a2)\n write(21,232)'written: ',date(1:4),date(5:6),date(7:8),&\n time(1:2),time(3:4)\n write(kou,231)'Output',trim(string)\n!-----------------------------------\n case(2) ! /all ??\n write(*,*)'Option not implemented: ',trim(option)\n!-----------------------------------\n case(3) ! /force\n write(*,*)'Option not implemented: ',trim(option)\n!-----------------------------------\n case(4) ! /verbose\n globaldata%status=ibset(globaldata%status,GSVERBOSE)\n write(kou,*)'VERBOSE option set ... but not really implemented'\n!-----------------------------------\n case(5) ! /silent\n globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n globaldata%status=ibset(globaldata%status,GSSILENT)\n!-----------------------------------\n case(6) ! /APPEND, open file and write at end\n! write(*,*)'Option not implemented: ',option(1:len_trim(option))\n! next argument after = must be a file name\n! jj=next\n! if(eolch(option,jj)) then\n! default extension (1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT, 6=XTDB, 7=DAT\n! negative is for write, 0 read without filter, -100 write without filter\n ztyp=-7\n call gparfilex('Append to file:',option,next,&\n 1,string,' ',ztyp,'?Command options')\n if(string(1:1).eq.' ') then\n string='ocappend.DAT'\n write(kou,*)' *** No file name given, will use: ',trim(string)\n endif\n! else\n! call getext(option,next,2,string,' ',slen)\n! endif\n! add extention .dat if to extension provided\n slen=len_trim(string)\n if(index(string,'.').le.0) then\n string(slen+1:)='.DAT '\n endif\n! close any previous output file (should not be necessary)\n close(21)\n open(21,file=string,access='sequential',status='unknown',&\n err=900, iostat=errno)\n optionsset%lut=21\n! read until end-of-file\n200 continue\n read(21,210,end=220)dummy\n210 format(a)\n goto 200\n! write not allowed after finding EOF, we must backspace\n220 continue\n backspace(21)\n! write a header\n call date_and_time(date,time)\n write(21,232)'appended: ',date(1:4),date(5:6),date(7:8),&\n time(1:2),time(3:4)\n write(kou,231)'Append',trim(string)\n231 format(a,' on file: ',a)\n!-----------------------------------\n case(7) ! \n continue\n!-----------------------------------\n case(8) ! \n continue\n!-----------------------------------\n case(9) ! \n continue\n end select\n endif\n goto 1000\n! errors\n900 continue\n write(kou,*)'Failed to open output file, error cofe=',errno\n goto 1000\n1000 continue\n return\n end subroutine ocmon_set_options\n \n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\begin{verbatim}\n subroutine ocmon_reset_options(optionsset)\n implicit none\n TYPE(ocoptions) :: optionsset\n! TYPE(ocoptions), pointer :: optionsset\n!\\end{verbatim}\n if(btest(globaldata%status,GSVERBOSE)) then\n! reset verbose option\n if(.not.btest(globaldata%status,GSSETVERB)) then\n! if user has SET VERBOSE do not resest VERBOSE\n globaldata%status=ibclr(globaldata%status,GSVERBOSE)\n endif\n endif\n! reset output unit option\n if(optionsset%lut.ne.kou) then\n close(optionsset%lut)\n optionsset%lut=kou\n write(kou,\"(a,i4)\")'Output unit reset to screen: ',kou\n endif\n!1000 continue\n return\n end subroutine ocmon_reset_options\n\n!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\nEND MODULE cmon1oc\n\n" }, { "path": "src/utilities/GETKEY/M_getkey.F90", "content": "!=======================================================================--------\n!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()\n!=======================================================================--------\n! These routines are available for general use. I ask that you send me\n! interesting alterations that are available for public use; and that you\n! include a note indicating the original author -- John S. Urban\n! Last updated May 5th, 2009\n!=======================================================================--------\n!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()\n!=======================================================================--------\n! make Fortran/C interface for C routine getkey(3C)\nmodule M_getkey\n use iso_c_binding\n implicit none\n public\n interface\n character function getkex() bind(c, name='getkeyC')\n use iso_c_binding\n implicit none\n character(kind=c_char) :: getkey\n end function getkex\n end interface\nend module M_getkey\n!=======================================================================--------\n!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()\n!=======================================================================--------\n!-------------------------------------------------------------------------------\n\n" }, { "path": "src/utilities/GETKEY/Makefile", "content": "OBJS=getkey.o bintxt.o \nEXE=tin\n\nall: $(EXE)\n\ngetkey.o:\n# uncomment the appropriate line below\n# for MAC\n#\tgcc -c -DBSD getkey.c\n# for Linux\n#\tgcc -c -DLinux getkey.c\n# for other UNIX systems\n#\tgcc -c -DG77 getkey.c\n# for CYGWIN on Windows\n#\tgcc -c -DCYGWIN getkey.c\n\tgfortran -c M_getkey.F90\n\nbintxt.o:\n\tgfortran -c bintxt.F90\n\n$(EXE): $(OBJS) \n#\tgfortran -o $(EXE) testbintxt2.F90 bintxt.o getkey.o\n" }, { "path": "src/utilities/GETKEY/getkey.c", "content": "/*\n * @(#) Driver for reading a character from keyboard in raw I/O mode\n */\n#include \n#include \n#include \n#include \n#include \n\n/*--------------------------*/\n#ifdef BSD\n#include \n#else\n/*--------------------------*/\n#ifdef Linux\n#define G77\n#endif\n\n#ifdef CYGWIN\n#define G77\n#endif\n\n#ifdef G77\n#include \n#else\n#include \n#endif\n/* modified to sys/termios.h above */\n/*--------------------------*/\n#endif\n\n#include \n\n/*V13 #include */\n/*V13 #include */\n/******************************************************************************/\n/* return the next key typed in hot (raw I/O) mode. */\nchar getkeyC(void) {\n#ifdef BSD\n struct sgttyb oldtty, newtty;\n char c;\n\n ioctl(0, TIOCGETP, &oldtty);\n\n newtty = oldtty;\n newtty.sg_flags = RAW;\n\n ioctl(0, TIOCSETP, &newtty);\n\n read(0, &c, 1);\n\n ioctl(0, TIOCSETP, &oldtty);\n#else\n struct termio oldtty, newtty;\n/*V13 struct termios oldtty, newtty; */\n char c;\n\n ioctl(0, TCGETA, &oldtty);\n/*V13 \ttcgetattr(0, &oldtty); */\n\n newtty = oldtty;\n newtty.c_iflag = BRKINT | IXON | ISTRIP;\n newtty.c_lflag = 0;\n newtty.c_cc[VEOF] = 1;\n\n ioctl(0, TCSETA, &newtty);\n/*V13 \ttcsetattr(0, TCSANOW, &newtty); */\n\n read(0, &c, 1);\n\n ioctl(0, TCSETA, &oldtty);\n/*V13 \ttcsetattr(0, TCSANOW, &oldtty); */\n#endif\n /* fprintf(stderr,\"C:c=%c\\n\",c); */\n\t/* fflush(stdout); */\n return(c);\n}\n/******************************************************************************/\n/* Commonly, a C routine called name_ can be called from Fortran as name; plus less-common ones */\nint getkey4f_(void) { return(getkeyC()); }\nint _getkey4f(void) { return(getkeyC()); }\nint getkey4f(void) { return(getkeyC()); }\nint GETKEY4F(void) { return(getkeyC()); }\n\n\n/* http://www.urbanjost.altervista.org/LIBRARY/libCLI/Getkey/getkey.html */\n" }, { "path": "src/utilities/TINYFILEDIALOGS/Makefile", "content": "OBJS=tinyfiledialogs.o tinyopen.o ftinyopen.o\nEXE=gopen\n\nall: $(EXE)\n\ntinyfiledialogs.o:\n\tgcc -c tinyfiledialogs.c\n\ntinyopen.o:\n\tgcc -c tinyopen.c\n\nftinyopen.o:\n\tgfortran -c ftinyopen.F90\n\n$(EXE): $(OBJS)\n\tgfortran -o $(EXE) main.F90 ftinyopen.o tinyopen.o tinyfiledialogs.o\n\nclean: \n\trm *.o *.exe\n" }, { "path": "src/utilities/TINYFILEDIALOGS/compile_and_link", "content": "gcc -c tinyfiledialogs.c\ngcc -c tinyopen.c\n\ngfortran -o fopen main.F90 tinyopen.o tinyfiledialogs.c -lcomdlg32 -lole32\n\n" }, { "path": "src/utilities/TINYFILEDIALOGS/ftinyopen.F90", "content": "module ftinyopen\n use iso_c_binding\n implicit none\n\n! A C function that returns a string need a pointer to the array of single char \n type (c_ptr) :: C_String_ptr\n! This is the Fortran equivalent to a string of single char\n character (len=1, kind=c_char), dimension(:), pointer :: filchar => null()\n\n!\\begin{verbatim}\n! Interface to a C routine which opens a window for browsing a file to open\n interface\n function tinyopen(typ) bind(c, name=\"tinyopen\")\n use iso_c_binding\n implicit none\n integer(c_int), value :: typ\n type (C_Ptr) :: tinyopen\n end function tinyopen\n end interface\n!\\end{verbatim}\n\ncontains\n\n!\\begin{verbatim}\n subroutine getfilename(typ,filename)\n! Fortran routine to call a C routine to browse for a file name\n! typ if default extension:\n! 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=PLT ,6=XTDB, 7=DAT, 8=LOG\n character (len=*) :: filename\n integer typ\n!\\end{verbatim}\n integer jj\n! the current directory can be found by \n! character directory*128\n! call getcwd(directory)\n! specify a name of a file type:\n! write(*,*)'In ftinyopen ',typ\n! 1=TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT, 8=LOG\n C_String_ptr = tinyopen(typ)\n! convert C pointer to Fortran pointer\n call c_f_pointer(C_String_ptr,filchar,[256])\n filename=' '\n if(associated(filchar)) then\n! convert the array of single characters to a Fortran character\n jj=1\n do while(filchar(jj).ne.c_null_char)\n filename(jj:jj)=filchar(jj)\n jj=jj+1\n enddo\n endif\n! write(*,*)'ftinyopen getfilename: ',trim(filename),typ\n1000 continue\n return\n end subroutine getfilename\n\nend module ftinyopen\n\n\n" }, { "path": "src/utilities/TINYFILEDIALOGS/tinyfiledialogs.c", "content": "/*_________\n / \\ tinyfiledialogs.c v3.6.4 [Sep 14, 2020] zlib licence\n |tiny file| Unique code file created [November 9, 2014]\n | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com\n \\____ ___/ http://tinyfiledialogs.sourceforge.net\n \\| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd\n ____________________________________________\n | |\n | email: tinyfiledialogs at ysengrin.com |\n |____________________________________________|\n _________________________________________________________________________________\n | |\n | the windows only wchar_t UTF-16 prototypes are at the bottom of the header file |\n |_________________________________________________________________________________|\n _________________________________________________________\n | |\n | on windows: - since v3.6 char is UTF-8 by default |\n | - if you want MBCS set tinyfd_winUtf8 to 0 |\n | - functions like fopen expect MBCS |\n |_________________________________________________________|\n\nIf you like tinyfiledialogs, please upvote my stackoverflow answer\nhttps://stackoverflow.com/a/47651444\n\ntiny file dialogs (cross-platform C C++)\nInputBox PasswordBox MessageBox ColorPicker\nOpenFileDialog SaveFileDialog SelectFolderDialog\nNative dialog library for WINDOWS MAC OSX GTK+ QT CONSOLE & more\nSSH supported via automatic switch to console mode or X11 forwarding\n\none C file + a header (add them to your C or C++ project) with 8 functions:\n- beep\n- notify popup (tray)\n- message & question\n- input & password\n- save file\n- open file(s)\n- select folder\n- color picker\n\nComplements OpenGL Vulkan GLFW GLUT GLUI VTK SFML TGUI\nSDL Ogre Unity3d ION OpenCV CEGUI MathGL GLM CPW GLOW\nOpen3D IMGUI MyGUI GLT NGL STB & GUI less programs\n\nNO INIT\nNO MAIN LOOP\nNO LINKING\nNO INCLUDE\n\nThe dialogs can be forced into console mode\n\nWindows (XP to 10) ASCII MBCS UTF-8 UTF-16\n- native code & vbs create the graphic dialogs\n- enhanced console mode can use dialog.exe from\nhttp://andrear.altervista.org/home/cdialog.php\n- basic console input\n\nUnix (command line calls) ASCII UTF-8\n- applescript, kdialog, zenity\n- python (2 or 3) + tkinter + python-dbus (optional)\n- dialog (opens a console if needed)\n- basic console input\nThe same executable can run across desktops & distributions\n\nC89/C18 & C++98/C++20 compliant: tested with C & C++ compilers\nVisualStudio MinGW-gcc GCC Clang TinyCC OpenWatcom-v2 BorlandC SunCC ZapCC\non Windows Mac Linux Bsd Solaris Minix Raspbian\nusing Gnome Kde Enlightenment Mate Cinnamon Budgie Unity Lxde Lxqt Xfce\nWindowMaker IceWm Cde Jds OpenBox Awesome Jwm Xdm Cwm\n\nBindings for LUA and C# dll, Haskell, Fortran\nIncluded in LWJGL(java), Rust, Allegrobasic\n\nThanks for contributions, bug corrections & thorough testing to:\n- Don Heyse http://ldglite.sf.net for bug corrections & thorough testing!\n- Paul Rouget\n\n- License -\n\nThis software is provided 'as-is', without any express or implied\nwarranty. In no event will the authors be held liable for any damages\narising from the use of this software.\n\nPermission is granted to anyone to use this software for any purpose,\nincluding commercial applications, and to alter it and redistribute it\nfreely, subject to the following restrictions:\n\n1. The origin of this software must not be misrepresented; you must not\nclaim that you wrote the original software. If you use this software\nin a product, an acknowledgment in the product documentation would be\nappreciated but is not required.\n2. Altered source versions must be plainly marked as such, and must not be\nmisrepresented as being the original software.\n3. This notice may not be removed or altered from any source distribution.\n*/\n\n\n#ifndef __sun\n#define _POSIX_C_SOURCE 2 /* to accept POSIX 2 in old ANSI C standards */\n#endif\n\n#include \n#include \n#include \n#include \n#include \n\n#ifdef _WIN32\n #ifdef __BORLANDC__\n #define _getch getch\n #endif\n #ifndef _WIN32_WINNT\n #define _WIN32_WINNT 0x0500\n #endif\n #ifndef TINYFD_NOLIB\n #include \n #include \n #include \n #endif\n #include \n #include \n #define TINYFD_NOCCSUNICODE\n #define SLASH \"\\\\\"\n#else\n #include \n #include \n #include /* on old systems try instead */\n #include \n #include \n #include /* on old systems try instead */\n #define SLASH \"/\"\n#endif /* _WIN32 */\n\n#include \"tinyfiledialogs.h\"\n\n#define MAX_PATH_OR_CMD 1024 /* _MAX_PATH or MAX_PATH */\n\n#ifndef MAX_MULTIPLE_FILES\n#define MAX_MULTIPLE_FILES 1024\n#endif\n#define LOW_MULTIPLE_FILES 32\n\nchar const tinyfd_version[8] = \"3.6.4\";\n\n/******************************************************************************************************/\n/**************************************** UTF-8 on Windows ********************************************/\n/******************************************************************************************************/\n#ifdef _WIN32\n/* if you want to use UTF-8 ( instead of the UTF-16/wchar_t functions at the end of tinyfiledialogs.h )\nMake sure your code is really prepared for UTF-8 (on windows, functions like fopen() expect MBCS and not UTF-8) */\nint tinyfd_winUtf8 = 1; /* on windows char strings can be 1:UTF-8(default) or 0:MBCS */\n/* for MBCS change this to 0, here or in your code */\n#endif\n/******************************************************************************************************/\n/******************************************************************************************************/\n/******************************************************************************************************/\n\nint tinyfd_verbose = 0 ; /* on unix: prints the command line calls */\nint tinyfd_silent = 1 ; /* 1 (default) or 0 : on unix, hide errors and warnings from called dialogs*/\nstatic int const tinyfd_allowCursesDialogs = 0 ; /* 0 (default) or 1 : curses dialogs are difficult to use, on windows they are only ascii*/\n\n#if defined(TINYFD_NOLIB) && defined(_WIN32)\nint tinyfd_forceConsole = 1 ;\n#else\nint tinyfd_forceConsole = 0 ; /* 0 (default) or 1 */\n#endif\n/* for unix & windows: 0 (graphic mode) or 1 (console mode).\n0: try to use a graphic solution, if it fails then it uses console mode.\n1: forces all dialogs into console mode even when the X server is present,\n if the package dialog (and a console is present) or dialog.exe is installed.\n on windows it only make sense for console applications */\n\nchar tinyfd_response[1024];\n/* if you pass \"tinyfd_query\" as aTitle,\nthe functions will not display the dialogs\nbut and return 0 for console mode, 1 for graphic mode.\ntinyfd_response is then filled with the retain solution.\npossible values for tinyfd_response are (all lowercase)\nfor graphic mode:\n windows_wchar windows\n applescript kdialog zenity zenity3 matedialog qarma\n python2-tkinter python3-tkinter python-dbus perl-dbus\n gxmessage gmessage xmessage xdialog gdialog\nfor console mode:\n dialog whiptail basicinput no_solution */\n\n#if defined(TINYFD_NOLIB) && defined(_WIN32)\nstatic int gWarningDisplayed = 1 ;\n#else\nstatic int gWarningDisplayed = 0 ;\n#endif\n\nstatic char const gTitle[]=\"missing software! (we will try basic console input)\";\n\n#ifdef _WIN32\nchar const tinyfd_needs[] = \"\\\n ___________\\n\\\n/ \\\\ \\n\\\n| tiny file |\\n\\\n| dialogs |\\n\\\n\\\\_____ ____/\\n\\\n \\\\|\\\n\\ntiny file dialogs on Windows needs:\\\n\\n a graphic display\\\n\\nor dialog.exe (enhanced console mode)\\\n\\nor a console for basic input\";\n#else\nchar const tinyfd_needs[] = \"\\\n ___________\\n\\\n/ \\\\ \\n\\\n| tiny file |\\n\\\n| dialogs |\\n\\\n\\\\_____ ____/\\n\\\n \\\\|\\\n\\ntiny file dialogs on UNIX needs:\\\n\\n applescript\\\n\\nor kdialog\\\n\\nor zenity (or matedialog or qarma)\\\n\\nor python (2 or 3)\\\n\\n + tkinter + python-dbus (optional)\\\n\\nor dialog (opens console if needed)\\\n\\nor xterm + bash\\\n\\n (opens console for basic input)\\\n\\nor existing console for basic input\";\n#endif\n\n#ifdef _MSC_VER\n#pragma warning(disable:4996) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */\n#pragma warning(disable:4100) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */\n#pragma warning(disable:4706) /* allows usage of strncpy, strcpy, strcat, sprintf, fopen */\n#endif\n\nchar * getCurDir(void)\n{\n\tstatic char lCurDir [MAX_PATH_OR_CMD];\n\treturn getcwd(lCurDir, sizeof(lCurDir));\n}\n\nstatic char * getPathWithoutFinalSlash(\n char * aoDestination, /* make sure it is allocated, use _MAX_PATH */\n char const * aSource) /* aoDestination and aSource can be the same */\n{\n char const * lTmp ;\n if ( aSource )\n {\n lTmp = strrchr(aSource, '/');\n if (!lTmp)\n {\n lTmp = strrchr(aSource, '\\\\');\n }\n if (lTmp)\n {\n strncpy(aoDestination, aSource, lTmp - aSource );\n aoDestination[lTmp - aSource] = '\\0';\n }\n else\n {\n * aoDestination = '\\0';\n }\n }\n else\n {\n * aoDestination = '\\0';\n }\n return aoDestination;\n}\n\n\nstatic char * getLastName(\n char * aoDestination, /* make sure it is allocated */\n char const * aSource)\n{\n /* copy the last name after '/' or '\\' */\n char const * lTmp ;\n if ( aSource )\n {\n lTmp = strrchr(aSource, '/');\n if (!lTmp)\n {\n lTmp = strrchr(aSource, '\\\\');\n }\n if (lTmp)\n {\n strcpy(aoDestination, lTmp + 1);\n }\n else\n {\n strcpy(aoDestination, aSource);\n }\n }\n else\n {\n * aoDestination = '\\0';\n }\n return aoDestination;\n}\n\n\nstatic void ensureFinalSlash( char * aioString )\n{\n if ( aioString && strlen( aioString ) )\n {\n char * lastcar = aioString + strlen( aioString ) - 1 ;\n if ( strncmp( lastcar , SLASH , 1 ) )\n {\n strcat( lastcar , SLASH ) ;\n }\n }\n}\n\n\nstatic void Hex2RGB( char const aHexRGB [8] ,\n unsigned char aoResultRGB [3] )\n{\n char lColorChannel [8] ;\n if ( aoResultRGB )\n {\n if ( aHexRGB )\n {\n strcpy(lColorChannel, aHexRGB ) ;\n aoResultRGB[2] = (unsigned char)strtoul(lColorChannel+5,NULL,16);\n lColorChannel[5] = '\\0';\n aoResultRGB[1] = (unsigned char)strtoul(lColorChannel+3,NULL,16);\n lColorChannel[3] = '\\0';\n aoResultRGB[0] = (unsigned char)strtoul(lColorChannel+1,NULL,16);\n/* printf(\"%d %d %d\\n\", aoResultRGB[0], aoResultRGB[1], aoResultRGB[2]); */\n }\n else\n {\n aoResultRGB[0]=0;\n aoResultRGB[1]=0;\n aoResultRGB[2]=0;\n }\n }\n}\n\nstatic void RGB2Hex( unsigned char const aRGB [3] ,\n char aoResultHexRGB [8] )\n{\n if ( aoResultHexRGB )\n {\n if ( aRGB )\n {\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n sprintf(aoResultHexRGB, \"#%02hhx%02hhx%02hhx\", aRGB[0], aRGB[1], aRGB[2]);\n#else\n sprintf(aoResultHexRGB, \"#%02hx%02hx%02hx\", aRGB[0], aRGB[1], aRGB[2]);\n#endif\n /*printf(\"aoResultHexRGB %s\\n\", aoResultHexRGB);*/\n }\n else\n {\n aoResultHexRGB[0]=0;\n aoResultHexRGB[1]=0;\n aoResultHexRGB[2]=0;\n }\n }\n}\n\n\nstatic void replaceSubStr( char const * aSource ,\n char const * aOldSubStr ,\n char const * aNewSubStr ,\n char * aoDestination )\n{\n char const * pOccurence ;\n char const * p ;\n char const * lNewSubStr = \"\" ;\n size_t lOldSubLen = strlen( aOldSubStr ) ;\n\n if ( ! aSource )\n {\n * aoDestination = '\\0' ;\n return ;\n }\n if ( ! aOldSubStr )\n {\n strcpy( aoDestination , aSource ) ;\n return ;\n }\n if ( aNewSubStr )\n {\n lNewSubStr = aNewSubStr ;\n }\n p = aSource ;\n * aoDestination = '\\0' ;\n while ( ( pOccurence = strstr( p , aOldSubStr ) ) != NULL )\n {\n strncat( aoDestination , p , pOccurence - p ) ;\n strcat( aoDestination , lNewSubStr ) ;\n p = pOccurence + lOldSubLen ;\n }\n strcat( aoDestination , p ) ;\n}\n\n\nstatic int filenameValid( char const * aFileNameWithoutPath )\n{\n if ( ! aFileNameWithoutPath\n || ! strlen(aFileNameWithoutPath)\n || strpbrk(aFileNameWithoutPath , \"\\\\/:*?\\\"<>|\") )\n {\n return 0 ;\n }\n return 1 ;\n}\n\n#ifndef _WIN32\n\nstatic int fileExists( char const * aFilePathAndName )\n{\n FILE * lIn ;\n if ( ! aFilePathAndName || ! strlen(aFilePathAndName) )\n {\n return 0 ;\n }\n lIn = fopen( aFilePathAndName , \"r\" ) ;\n if ( ! lIn )\n {\n return 0 ;\n }\n fclose( lIn ) ;\n return 1 ;\n}\n\n#elif defined(TINYFD_NOLIB)\n\nstatic int fileExists( char const * aFilePathAndName )\n{\n FILE * lIn ;\n if ( ! aFilePathAndName || ! strlen(aFilePathAndName) )\n {\n return 0 ;\n }\n\n if ( tinyfd_winUtf8 )\n return 1; /* we cannot test */\n\n lIn = fopen( aFilePathAndName , \"r\" ) ;\n if ( ! lIn )\n {\n return 0 ;\n }\n fclose( lIn ) ;\n return 1 ;\n}\n\n#endif\n\n\nstatic void wipefile(char const * aFilename)\n{\n int i;\n struct stat st;\n FILE * lIn;\n\n if (stat(aFilename, &st) == 0)\n {\n if ((lIn = fopen(aFilename, \"w\")))\n {\n for (i = 0; i < st.st_size; i++)\n {\n fputc('A', lIn);\n }\n }\n fclose(lIn);\n }\n}\n\n\n#ifdef _WIN32\n\n/* windows only (not for wchar_t): you can set char to 1:utf-8(default) or 0:MBCS */\nvoid tinyfd_setWinUtf8(int aIsUtf8) /* made to be used from C# to modify the global variable tinyfd_winUtf8 */\n{\n\ttinyfd_winUtf8 = aIsUtf8;\n}\n\n\nstatic int replaceChr( char * aString ,\n char aOldChr ,\n char aNewChr )\n{\n char * p ;\n int lRes = 0 ;\n\n if ( ! aString )\n {\n return 0 ;\n }\n\n if ( aOldChr == aNewChr )\n {\n return 0 ;\n }\n\n p = aString ;\n while ( (p = strchr( p , aOldChr )) )\n {\n * p = aNewChr ;\n p ++ ;\n lRes = 1 ;\n }\n return lRes ;\n}\n\n\n#if !defined(WC_ERR_INVALID_CHARS)\n/* undefined prior to Vista, so not yet in MINGW header file */\n#define WC_ERR_INVALID_CHARS 0x00000080\n#endif\n\nstatic int sizeUtf16From8(char const * aUtf8string)\n{\n\treturn MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS,\n\t\taUtf8string, -1, NULL, 0);\n}\n\n\nstatic int sizeUtf16FromMbcs(char const * aMbcsString)\n{\n\treturn MultiByteToWideChar(CP_ACP, MB_ERR_INVALID_CHARS,\n\t\taMbcsString, -1, NULL, 0);\n}\n\n\nstatic int sizeUtf8(wchar_t const * aUtf16string)\n{\n\treturn WideCharToMultiByte(CP_UTF8, WC_ERR_INVALID_CHARS,\n\t\taUtf16string, -1, NULL, 0, NULL, NULL);\n}\n\n\nstatic int sizeMbcs(wchar_t const * aMbcsString)\n{\n\tint lRes = WideCharToMultiByte(CP_ACP, 0,\n\t\taMbcsString, -1, NULL, 0, NULL, NULL);\n\t/* DWORD licic = GetLastError(); */\n\treturn lRes;\n}\n\n\nwchar_t * tinyfd_utf8to16(char const * aUtf8string)\n{\n\tstatic wchar_t * lUtf16string = NULL;\n\tint lSize;\n\n\tfree(lUtf16string);\n\tif (!aUtf8string) {lUtf16string = NULL; return NULL;}\n\tlSize = sizeUtf16From8(aUtf8string);\n\tlUtf16string = (wchar_t *)malloc(lSize * sizeof(wchar_t));\n\tlSize = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS,\n\t\taUtf8string, -1, lUtf16string, lSize);\n\tif (lSize == 0)\n\t{\n\t\tfree(lUtf16string);\n\t\tlUtf16string = NULL;\n\t}\n\treturn lUtf16string;\n}\n\n\nstatic char * utf16toMbcs(wchar_t const * aUtf16string)\n{\n\tstatic char * lMbcsString = NULL;\n\tint lSize;\n\n\tfree(lMbcsString);\n\tif (!aUtf16string) { lMbcsString = NULL; return NULL; }\n\tlSize = sizeMbcs(aUtf16string);\n\tlMbcsString = (char *)malloc(lSize);\n\tlSize = WideCharToMultiByte(CP_ACP, 0,\n\t\taUtf16string, -1, lMbcsString, lSize, NULL, NULL);\n\tif (lSize == 0)\n\t{\n\t\tfree(lMbcsString);\n\t\tlMbcsString = NULL;\n\t}\n\treturn lMbcsString;\n}\n\n\nchar * tinyfd_utf8toMbcs(char const * aUtf8string)\n{\n\twchar_t const * lUtf16string;\n\tlUtf16string = tinyfd_utf8to16(aUtf8string);\n\treturn utf16toMbcs(lUtf16string);\n}\n\nstatic wchar_t * mbcsTo16(char const * aMbcsString)\n{\n\tstatic wchar_t * lMbcsString = NULL;\n\tint lSize;\n\n\tfree(lMbcsString);\n\tif (!aMbcsString) { lMbcsString = NULL; return NULL; }\n\tlSize = sizeUtf16FromMbcs(aMbcsString);\n\tlMbcsString = (wchar_t *)malloc(lSize * sizeof(wchar_t));\n\tlSize = MultiByteToWideChar(CP_ACP, 0,\n\t\taMbcsString, -1, lMbcsString, lSize);\n\tif (lSize == 0)\n\t{\n\t\tfree(lMbcsString);\n\t\tlMbcsString = NULL;\n\t}\n\treturn lMbcsString;\n}\n\n\nchar * tinyfd_utf16to8(wchar_t const * aUtf16string)\n{\n\tstatic char * lUtf8string = NULL;\n\tint lSize;\n\n\tfree(lUtf8string);\n\tif (!aUtf16string) { lUtf8string = NULL; return NULL; }\n\tlSize = sizeUtf8(aUtf16string);\n\tlUtf8string = (char *)malloc(lSize);\n\tlSize = WideCharToMultiByte(CP_UTF8, WC_ERR_INVALID_CHARS,\n\t\taUtf16string, -1, lUtf8string, lSize, NULL, NULL);\n\tif (lSize == 0)\n\t{\n\t\tfree(lUtf8string);\n\t\tlUtf8string = NULL;\n\t}\n\treturn lUtf8string;\n}\n\n\nchar * mbcsTo8(char const * aMbcsString)\n{\n\twchar_t const * lUtf16string;\n\tlUtf16string = mbcsTo16(aMbcsString);\n\treturn tinyfd_utf16to8(lUtf16string);\n}\n\n\n#ifdef TINYFD_NOLIB\n\nstatic int dirExists(char const * aDirPath)\n{\n struct stat lInfo;\n\n if (!aDirPath || !strlen(aDirPath))\n return 0;\n if (stat(aDirPath, &lInfo) != 0)\n return 0;\n else if ( tinyfd_winUtf8 )\n return 1; /* we cannot test */\n else if (lInfo.st_mode & S_IFDIR)\n return 1;\n else\n return 0;\n}\n\n\nvoid tinyfd_beep(void)\n{\n printf(\"\\a\");\n}\n\n#else /* ndef TINYFD_NOLIB */\n\nvoid tinyfd_beep(void)\n{\n Beep(440,300);\n}\n\n\nstatic void wipefileW(wchar_t const * aFilename)\n{\n int i;\n struct _stat st;\n FILE * lIn;\n\n if (_wstat(aFilename, &st) == 0)\n {\n if ((lIn = _wfopen(aFilename, L\"w\")))\n {\n for (i = 0; i < st.st_size; i++)\n {\n fputc('A', lIn);\n }\n }\n fclose(lIn);\n }\n}\n\n\nstatic wchar_t * getPathWithoutFinalSlashW(\n wchar_t * aoDestination, /* make sure it is allocated, use _MAX_PATH */\n wchar_t const * aSource) /* aoDestination and aSource can be the same */\n{\n wchar_t const * lTmp;\n if (aSource)\n {\n lTmp = wcsrchr(aSource, L'/');\n if (!lTmp)\n {\n lTmp = wcsrchr(aSource, L'\\\\');\n }\n if (lTmp)\n {\n wcsncpy(aoDestination, aSource, lTmp - aSource);\n aoDestination[lTmp - aSource] = L'\\0';\n }\n else\n {\n *aoDestination = L'\\0';\n }\n }\n else\n {\n *aoDestination = L'\\0';\n }\n return aoDestination;\n}\n\n\nstatic wchar_t * getLastNameW(\n wchar_t * aoDestination, /* make sure it is allocated */\n wchar_t const * aSource)\n{\n /* copy the last name after '/' or '\\' */\n wchar_t const * lTmp;\n if (aSource)\n {\n lTmp = wcsrchr(aSource, L'/');\n if (!lTmp)\n {\n lTmp = wcsrchr(aSource, L'\\\\');\n }\n if (lTmp)\n {\n wcscpy(aoDestination, lTmp + 1);\n }\n else\n {\n wcscpy(aoDestination, aSource);\n }\n }\n else\n {\n *aoDestination = L'\\0';\n }\n return aoDestination;\n}\n\n\nstatic void Hex2RGBW(wchar_t const aHexRGB[8],\n unsigned char aoResultRGB[3])\n{\n wchar_t lColorChannel[8];\n if (aoResultRGB)\n {\n if (aHexRGB)\n {\n wcscpy(lColorChannel, aHexRGB);\n aoResultRGB[2] = (unsigned char)wcstoul(lColorChannel + 5, NULL, 16);\n lColorChannel[5] = '\\0';\n aoResultRGB[1] = (unsigned char)wcstoul(lColorChannel + 3, NULL, 16);\n lColorChannel[3] = '\\0';\n aoResultRGB[0] = (unsigned char)wcstoul(lColorChannel + 1, NULL, 16);\n /* printf(\"%d %d %d\\n\", aoResultRGB[0], aoResultRGB[1], aoResultRGB[2]); */\n }\n else\n {\n aoResultRGB[0] = 0;\n aoResultRGB[1] = 0;\n aoResultRGB[2] = 0;\n }\n }\n}\n\n\nstatic void RGB2HexW(\n unsigned char const aRGB[3],\n wchar_t aoResultHexRGB[8])\n{\n if (aoResultHexRGB)\n {\n if (aRGB)\n {\n /* wprintf(L\"aoResultHexRGB %s\\n\", aoResultHexRGB); */\n swprintf(aoResultHexRGB,\n\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n 8,\n#endif\n\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n\t\t\t\t\t\t\t\tL\"#%02hhx%02hhx%02hhx\", aRGB[0], aRGB[1], aRGB[2]);\n#else\n\t\t\t\t\t\t\t\tL\"#%02hx%02hx%02hx\", aRGB[0], aRGB[1], aRGB[2]);\n#endif\n }\n else\n {\n aoResultHexRGB[0] = 0;\n aoResultHexRGB[1] = 0;\n aoResultHexRGB[2] = 0;\n }\n }\n}\n\n\nstatic int dirExists(char const * aDirPath)\n{\n struct _stat lInfo;\n wchar_t * lTmpWChar;\n int lStatRet;\n\t\tint lDirLen;\n\n\t\tif (!aDirPath)\n\t\t\treturn 0;\n\t\tlDirLen = strlen(aDirPath);\n\t\tif (!lDirLen)\n\t\t\treturn 1;\n\t\tif ( (lDirLen == 2) && (aDirPath[1] == ':') )\n\t\t\treturn 1;\n\n if (tinyfd_winUtf8)\n {\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDirPath);\n lStatRet = _wstat(lTmpWChar, &lInfo);\n if (lStatRet != 0)\n return 0;\n else if (lInfo.st_mode & S_IFDIR)\n return 1;\n else\n return 0;\n }\n else if (_stat(aDirPath, &lInfo) != 0)\n return 0;\n else if (lInfo.st_mode & S_IFDIR)\n return 1;\n else\n return 0;\n}\n\n\nstatic int fileExists(char const * aFilePathAndName)\n{\n struct _stat lInfo;\n wchar_t * lTmpWChar;\n int lStatRet;\n FILE * lIn;\n\n if (!aFilePathAndName || !strlen(aFilePathAndName))\n {\n return 0;\n }\n\n if (tinyfd_winUtf8)\n {\n\t\t\tlTmpWChar = tinyfd_utf8to16(aFilePathAndName);\n lStatRet = _wstat(lTmpWChar, &lInfo);\n if (lStatRet != 0)\n return 0;\n else if (lInfo.st_mode & _S_IFREG)\n return 1;\n else\n return 0;\n }\n else\n {\n lIn = fopen(aFilePathAndName, \"r\");\n if (!lIn)\n {\n return 0;\n }\n fclose(lIn);\n return 1;\n }\n}\n\nstatic int replaceWchar(wchar_t * aString,\n\twchar_t aOldChr,\n\twchar_t aNewChr)\n{\n\twchar_t * p;\n\tint lRes = 0;\n\n\tif (!aString)\n\t{\n\t\treturn 0;\n\t}\n\n\tif (aOldChr == aNewChr)\n\t{\n\t\treturn 0;\n\t}\n\n\tp = aString;\n\twhile ((p = wcsrchr(p, aOldChr)))\n\t{\n\t\t*p = aNewChr;\n#ifdef TINYFD_NOCCSUNICODE\n\t\tp++;\n#endif\n\t\tp++;\n\t\tlRes = 1;\n\t}\n\treturn lRes;\n}\n\n#endif /* TINYFD_NOLIB */\n#endif /* _WIN32 */\n\n/* source and destination can be the same or ovelap*/\nstatic char * ensureFilesExist(char * aDestination,\n char const * aSourcePathsAndNames)\n{\n char * lDestination = aDestination;\n char const * p;\n char const * p2;\n size_t lLen;\n\n if (!aSourcePathsAndNames)\n {\n return NULL;\n }\n lLen = strlen(aSourcePathsAndNames);\n if (!lLen)\n {\n return NULL;\n }\n\n p = aSourcePathsAndNames;\n while ((p2 = strchr(p, '|')) != NULL)\n {\n lLen = p2 - p;\n memmove(lDestination, p, lLen);\n lDestination[lLen] = '\\0';\n if (fileExists(lDestination))\n {\n lDestination += lLen;\n *lDestination = '|';\n lDestination++;\n }\n p = p2 + 1;\n }\n if (fileExists(p))\n {\n lLen = strlen(p);\n memmove(lDestination, p, lLen);\n lDestination[lLen] = '\\0';\n }\n else\n {\n *(lDestination - 1) = '\\0';\n }\n return aDestination;\n}\n\n#ifdef _WIN32\n#ifndef TINYFD_NOLIB\n\nstatic int __stdcall EnumThreadWndProc(HWND hwnd, LPARAM lParam)\n{\n wchar_t lTitleName[MAX_PATH];\n GetWindowTextW(hwnd, lTitleName, MAX_PATH);\n /* wprintf(L\"lTitleName %ls \\n\", lTitleName); */\n if (wcscmp(L\"tinyfiledialogsTopWindow\", lTitleName) == 0)\n {\n SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE);\n return 0;\n }\n return 1;\n}\n\n\nstatic void hiddenConsoleW(wchar_t const * aString, wchar_t const * aDialogTitle, int aInFront)\n{\n STARTUPINFOW StartupInfo;\n PROCESS_INFORMATION ProcessInfo;\n\n if (!aString || !wcslen(aString) ) return;\n\n memset(&StartupInfo, 0, sizeof(StartupInfo));\n StartupInfo.cb = sizeof(STARTUPINFOW);\n StartupInfo.dwFlags = STARTF_USESHOWWINDOW;\n StartupInfo.wShowWindow = SW_HIDE;\n\n if (!CreateProcessW(NULL, (LPWSTR)aString, NULL, NULL, FALSE,\n CREATE_NEW_CONSOLE, NULL, NULL,\n &StartupInfo, &ProcessInfo))\n {\n return; /* GetLastError(); */\n }\n\n WaitForInputIdle(ProcessInfo.hProcess, INFINITE);\n if (aInFront)\n {\n while (EnumWindows(EnumThreadWndProc, (LPARAM)NULL)) {}\n SetWindowTextW(GetForegroundWindow(), aDialogTitle);\n }\n WaitForSingleObject(ProcessInfo.hProcess, INFINITE);\n CloseHandle(ProcessInfo.hThread);\n CloseHandle(ProcessInfo.hProcess);\n}\n\n\nint tinyfd_messageBoxW(\n wchar_t const * aTitle, /* NULL or \"\" */\n wchar_t const * aMessage, /* NULL or \"\" may contain \\n and \\t */\n wchar_t const * aDialogType, /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n wchar_t const * aIconType, /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n int lBoxReturnValue;\n UINT aCode;\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return 1; }\n\n if (aIconType && !wcscmp(L\"warning\", aIconType))\n {\n aCode = MB_ICONWARNING;\n }\n else if (aIconType && !wcscmp(L\"error\", aIconType))\n {\n aCode = MB_ICONERROR;\n }\n else if (aIconType && !wcscmp(L\"question\", aIconType))\n {\n aCode = MB_ICONQUESTION;\n }\n else\n {\n aCode = MB_ICONINFORMATION;\n }\n\n if (aDialogType && !wcscmp(L\"okcancel\", aDialogType))\n {\n aCode += MB_OKCANCEL;\n if (!aDefaultButton)\n {\n aCode += MB_DEFBUTTON2;\n }\n }\n else if (aDialogType && !wcscmp(L\"yesno\", aDialogType))\n {\n aCode += MB_YESNO;\n if (!aDefaultButton)\n {\n aCode += MB_DEFBUTTON2;\n }\n }\n else\n {\n aCode += MB_OK;\n }\n\n aCode += MB_TOPMOST;\n\n lBoxReturnValue = MessageBoxW(GetForegroundWindow(), aMessage, aTitle, aCode);\n if (((aDialogType\n && wcscmp(L\"okcancel\", aDialogType)\n && wcscmp(L\"yesno\", aDialogType)))\n || (lBoxReturnValue == IDOK)\n || (lBoxReturnValue == IDYES))\n {\n return 1;\n }\n else\n {\n return 0;\n }\n}\n\n\nstatic int messageBoxWinGui8(\n char const * aTitle, /* NULL or \"\" */\n char const * aMessage, /* NULL or \"\" may contain \\n and \\t */\n char const * aDialogType, /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n char const * aIconType, /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n int lIntRetVal;\n wchar_t lTitle [128] = L\"\";\n\t\twchar_t * lMessage = NULL;\n\t\twchar_t lDialogType [16] = L\"\";\n\t\twchar_t lIconType [16] = L\"\";\n\t\twchar_t * lTmpWChar;\n\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aMessage)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aMessage);\n\t\t\tlMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t));\n\t\t\twcscpy(lMessage, lTmpWChar);\n\t\t}\n\t\tif (aDialogType)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDialogType);\n\t\t\twcscpy(lDialogType, lTmpWChar);\n\t\t}\n\t\tif (aIconType)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aIconType);\n\t\t\twcscpy(lIconType, lTmpWChar);\n\t\t}\n\n lIntRetVal = tinyfd_messageBoxW(lTitle, lMessage,lDialogType, lIconType, aDefaultButton );\n\n\t\tfree(lMessage);\n\n return lIntRetVal ;\n}\n\n\n/* return has only meaning for tinyfd_query */\nint tinyfd_notifyPopupW(\n wchar_t const * aTitle, /* NULL or L\"\" */\n wchar_t const * aMessage, /* NULL or L\"\" may contain \\n \\t */\n wchar_t const * aIconType) /* L\"info\" L\"warning\" L\"error\" */\n{\n wchar_t * lDialogString;\n size_t lTitleLen;\n size_t lMessageLen;\n size_t lDialogStringLen;\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return 1; }\n\n lTitleLen = aTitle ? wcslen(aTitle) : 0;\n lMessageLen = aMessage ? wcslen(aMessage) : 0;\n lDialogStringLen = 3 * MAX_PATH_OR_CMD + lTitleLen + lMessageLen;\n lDialogString = (wchar_t *)malloc(2 * lDialogStringLen);\n\n wcscpy(lDialogString, L\"powershell.exe -command \\\"\\\nfunction Show-BalloonTip {\\\n[cmdletbinding()] \\\nparam( \\\n[string]$Title = ' ', \\\n[string]$Message = ' ', \\\n[ValidateSet('info', 'warning', 'error')] \\\n[string]$IconType = 'info');\\\n[system.Reflection.Assembly]::LoadWithPartialName('System.Windows.Forms') | Out-Null ; \\\n$balloon = New-Object System.Windows.Forms.NotifyIcon ; \\\n$path = Get-Process -id $pid | Select-Object -ExpandProperty Path ; \\\n$icon = [System.Drawing.Icon]::ExtractAssociatedIcon($path) ;\");\n\n wcscat(lDialogString, L\"\\\n$balloon.Icon = $icon ; \\\n$balloon.BalloonTipIcon = $IconType ; \\\n$balloon.BalloonTipText = $Message ; \\\n$balloon.BalloonTipTitle = $Title ; \\\n$balloon.Text = 'lalala' ; \\\n$balloon.Visible = $true ; \\\n$balloon.ShowBalloonTip(5000)};\\\nShow-BalloonTip\");\n\n if (aTitle && wcslen(aTitle))\n {\n wcscat(lDialogString, L\" -Title '\");\n wcscat(lDialogString, aTitle);\n wcscat(lDialogString, L\"'\");\n }\n if (aMessage && wcslen(aMessage))\n {\n wcscat(lDialogString, L\" -Message '\");\n wcscat(lDialogString, aMessage);\n wcscat(lDialogString, L\"'\");\n }\n if (aMessage && wcslen(aIconType))\n {\n wcscat(lDialogString, L\" -IconType '\");\n wcscat(lDialogString, aIconType);\n wcscat(lDialogString, L\"'\");\n }\n wcscat(lDialogString, L\"\\\"\");\n\n /* wprintf ( L\"lDialogString: %ls\\n\" , lDialogString ) ; */\n\n hiddenConsoleW(lDialogString, aTitle, 0);\n free(lDialogString);\n return 1;\n}\n\n\nstatic int notifyWinGui(\n char const * aTitle, /* NULL or \"\" */\n char const * aMessage, /* NULL or \"\" may NOT contain \\n nor \\t */\n char const * aIconType)\n{\n wchar_t lTitle [128] = L\"\";\n\t\twchar_t * lMessage = NULL;\n\t\twchar_t lIconType[16] = L\"\";\n\t\twchar_t * lTmpWChar;\n\n if (tinyfd_winUtf8)\n {\n\t\t\tif (aTitle)\n\t\t\t{\n\t\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t\t}\n\t\t\tif (aMessage)\n\t\t\t{\n\t\t\t\tlTmpWChar = tinyfd_utf8to16(aMessage);\n\t\t\t\tlMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t));\n\t\t\t\twcscpy(lMessage, lTmpWChar);\n\t\t\t}\n\t\t\tif (aIconType)\n\t\t\t{\n\t\t\t\tlTmpWChar = tinyfd_utf8to16(aIconType);\n\t\t\t\twcscpy(lIconType, lTmpWChar);\n\t\t\t}\n }\n else\n {\n\t\t\tif (aTitle)\n\t\t\t{\n\t\t\t\tlTmpWChar = mbcsTo16(aTitle);\n\t\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t\t}\n\t\t\tif (aMessage)\n\t\t\t{\n\t\t\t\tlTmpWChar = mbcsTo16(aMessage);\n\t\t\t\tlMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t));\n\t\t\t\twcscpy(lMessage, lTmpWChar);\n\t\t\t}\n\t\t\tif (aIconType)\n\t\t\t{\n\t\t\t\tlTmpWChar = mbcsTo16(aIconType);\n\t\t\t\twcscpy(lIconType, lTmpWChar);\n\t\t\t}\n }\n\n tinyfd_notifyPopupW( lTitle, lMessage, lIconType);\n\n\t\tfree(lMessage);\n\n\t\treturn 1;\n}\n\n\nwchar_t * tinyfd_inputBoxW(\n wchar_t const * aTitle, /* NULL or L\"\" */\n wchar_t const * aMessage, /* NULL or L\"\" may NOT contain \\n nor \\t */\n wchar_t const * aDefaultInput) /* L\"\" , if NULL it's a passwordBox */\n{\n static wchar_t lBuff[MAX_PATH_OR_CMD];\n wchar_t * lDialogString;\n FILE * lIn;\n FILE * lFile;\n int lResult;\n size_t lTitleLen;\n size_t lMessageLen;\n size_t lDialogStringLen;\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return (wchar_t *)1; }\n\n lTitleLen = aTitle ? wcslen(aTitle) : 0 ;\n lMessageLen = aMessage ? wcslen(aMessage) : 0 ;\n lDialogStringLen = 3 * MAX_PATH_OR_CMD + lTitleLen + lMessageLen;\n lDialogString = (wchar_t *)malloc(2 * lDialogStringLen);\n\n if (aDefaultInput)\n {\n\t\t\tswprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n L\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.vbs\", _wgetenv(L\"USERPROFILE\"));\n }\n else\n {\n swprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n L\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.hta\", _wgetenv(L\"USERPROFILE\"));\n }\n lIn = _wfopen(lDialogString, L\"w\");\n if (!lIn)\n {\n free(lDialogString);\n return NULL;\n }\n\n if ( aDefaultInput )\n {\n wcscpy(lDialogString, L\"Dim result:result=InputBox(\\\"\");\n if (aMessage && wcslen(aMessage))\n {\n\t\t\t\t\twcscpy(lBuff, aMessage);\n\t\t\t\t\treplaceWchar(lBuff, L'\\n', L' ');\n\t\t\t\t\twcscat(lDialogString, lBuff);\n }\n wcscat(lDialogString, L\"\\\",\\\"tinyfiledialogsTopWindow\\\",\\\"\");\n if (aDefaultInput && wcslen(aDefaultInput))\n {\n\t\t\t\t\twcscpy(lBuff, aDefaultInput);\n\t\t\t\t\treplaceWchar(lBuff, L'\\n', L' ');\n\t\t\t\t\twcscat(lDialogString, lBuff);\n }\n wcscat(lDialogString, L\"\\\"):If IsEmpty(result) then:WScript.Echo 0\");\n wcscat(lDialogString, L\":Else: WScript.Echo \\\"1\\\" & result : End If\");\n }\n else\n {\n wcscpy(lDialogString, L\"\\n\\\n\\n\\\n\\n\\\n\");\n\n wcscat(lDialogString, L\"tinyfiledialogsTopWindow\");\n wcscat(lDialogString, L\"\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n\\n\\\n
\\n\");\n\n wcscat(lDialogString, aMessage ? aMessage : L\"\");\n\n wcscat(lDialogString, L\"\\n\\\n\\n\\\n\\n\\\n\\n\\\n
\\n\\\n

\\n\\\n\\n\\\n
\\n\\\n
\\n\");\n\n wcscat(lDialogString, L\"\\n\\\n\\n\\\n\\n\\\n\\n\\\n
\\n\\\n
\\n\\\n
\\n\\\n\\n\\\n\\n\\\n\" ) ;\n }\n fputws(lDialogString, lIn);\n fclose(lIn);\n\n if (aDefaultInput)\n {\n swprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n L\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\",_wgetenv(L\"USERPROFILE\"));\n\n#ifdef TINYFD_NOCCSUNICODE\n\t\t\t\tlFile = _wfopen(lDialogString, L\"w\");\n\t\t\t\tfputc(0xFF, lFile);\n\t\t\t\tfputc(0xFE, lFile);\n#else\n\t\t\t\tlFile = _wfopen(lDialogString, L\"wt, ccs=UNICODE\"); /*or ccs=UTF-16LE*/\n#endif\n\t\t\t\tfclose(lFile);\n\n wcscpy(lDialogString, L\"cmd.exe /c cscript.exe //U //Nologo \");\n wcscat(lDialogString, L\"\\\"%USERPROFILE%\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.vbs\\\" \");\n wcscat(lDialogString, L\">> \\\"%USERPROFILE%\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\\\"\");\n }\n else\n {\n wcscpy(lDialogString,\n L\"cmd.exe /c mshta.exe \\\"%USERPROFILE%\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.hta\\\"\");\n }\n\n /* wprintf ( \"lDialogString: %ls\\n\" , lDialogString ) ; */\n\n hiddenConsoleW(lDialogString, aTitle, 1);\n\n swprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n\t\t\t\tL\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\", _wgetenv(L\"USERPROFILE\"));\n\t\t/* wprintf(L\"lDialogString: %ls\\n\", lDialogString); */\n#ifdef TINYFD_NOCCSUNICODE\n\t\tif (!(lIn = _wfopen(lDialogString, L\"r\")))\n#else\n\t\tif (!(lIn = _wfopen(lDialogString, L\"rt, ccs=UNICODE\"))) /*or ccs=UTF-16LE*/\n#endif\n\t\t{\n _wremove(lDialogString);\n free(lDialogString);\n return NULL;\n }\n\n\t\tmemset(lBuff, 0, MAX_PATH_OR_CMD * sizeof(wchar_t) );\n\n#ifdef TINYFD_NOCCSUNICODE\n\t\tfgets((char *)lBuff, 2*MAX_PATH_OR_CMD, lIn);\n#else\n\t\tfgetws(lBuff, MAX_PATH_OR_CMD, lIn);\n#endif\n\t\tfclose(lIn);\n\t\twipefileW(lDialogString);\n\t\t_wremove(lDialogString);\n\n\t\tif (aDefaultInput)\n\t\t{\n\t\t\tswprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n L\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.vbs\",\n _wgetenv(L\"USERPROFILE\"));\n }\n else\n {\n swprintf(lDialogString,\n#if !defined(__BORLANDC__) && !defined(__TINYC__) && !(defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR))\n lDialogStringLen,\n#endif\n L\"%ls\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.hta\",\n _wgetenv(L\"USERPROFILE\"));\n }\n _wremove(lDialogString);\n free(lDialogString);\n /* wprintf( L\"lBuff: %ls\\n\" , lBuff ) ; */\n#ifdef TINYFD_NOCCSUNICODE\n\t\tlResult = !wcsncmp(lBuff+1, L\"1\", 1);\n#else\n\t\tlResult = !wcsncmp(lBuff, L\"1\", 1);\n#endif\n\n /* printf( \"lResult: %d \\n\" , lResult ) ; */\n if (!lResult)\n {\n return NULL ;\n }\n\n /* wprintf( \"lBuff+1: %ls\\n\" , lBuff+1 ) ; */\n\n#ifdef TINYFD_NOCCSUNICODE\n\t\tif (aDefaultInput)\n\t\t{\n\t\t\tlDialogStringLen = wcslen(lBuff) ;\n\t\t\tlBuff[lDialogStringLen - 1] = L'\\0';\n\t\t\tlBuff[lDialogStringLen - 2] = L'\\0';\n\t\t}\n\t\treturn lBuff + 2;\n#else\n\t\tif (aDefaultInput) lBuff[wcslen(lBuff) - 1] = L'\\0';\n\t\treturn lBuff + 1;\n#endif\n}\n\n\nstatic int inputBoxWinGui(\n char * aoBuff,\n char const * aTitle, /* NULL or \"\" */\n char const * aMessage, /* NULL or \"\" may NOT contain \\n nor \\t */\n char const * aDefaultInput) /* \"\" , if NULL it's a passwordBox */\n{\n wchar_t lTitle [128] = L\"\";\n\twchar_t * lMessage = NULL;\n\twchar_t lDefaultInput[MAX_PATH_OR_CMD] = L\"\";\n wchar_t * lTmpWChar;\n char * lTmpChar;\n\n if (tinyfd_winUtf8)\n {\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aMessage)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aMessage);\n\t\t\tlMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t));\n\t\t\twcscpy(lMessage, lTmpWChar);\n\t\t}\n\t\tif (aDefaultInput)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDefaultInput);\n\t\t\twcscpy(lDefaultInput, lTmpWChar);\n\t\t}\n\t}\n else\n {\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = mbcsTo16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aMessage)\n\t\t{\n\t\t\tlTmpWChar = mbcsTo16(aMessage);\n\t\t\tlMessage = malloc((wcslen(lTmpWChar) + 1)* sizeof(wchar_t));\n\t\t\twcscpy(lMessage, lTmpWChar);\n\t\t}\n\t\tif (aDefaultInput)\n\t\t{\n\t\t\tlTmpWChar = mbcsTo16(aDefaultInput);\n\t\t\twcscpy(lDefaultInput, lTmpWChar);\n\t\t}\n }\n\n lTmpWChar = tinyfd_inputBoxW( lTitle, lMessage, lDefaultInput);\n\n\tfree(lMessage);\n\n if (!lTmpWChar)\n {\n\t\taoBuff[0] = '\\0';\n return 0;\n }\n\n if (tinyfd_winUtf8)\n {\n\t\tlTmpChar = tinyfd_utf16to8(lTmpWChar);\n }\n else\n {\n lTmpChar = utf16toMbcs(lTmpWChar);\n }\n strcpy(aoBuff, lTmpChar);\n\n return 1;\n}\n\n\nwchar_t * tinyfd_saveFileDialogW(\n wchar_t const * aTitle, /* NULL or \"\" */\n wchar_t const * aDefaultPathAndFile, /* NULL or \"\" */\n int aNumOfFilterPatterns, /* 0 */\n wchar_t const * const * aFilterPatterns, /* NULL or {\"*.jpg\",\"*.png\"} */\n wchar_t const * aSingleFilterDescription) /* NULL or \"image files\" */\n{\n static wchar_t lBuff[MAX_PATH_OR_CMD];\n wchar_t lDirname[MAX_PATH_OR_CMD];\n wchar_t lDialogString[MAX_PATH_OR_CMD];\n wchar_t lFilterPatterns[MAX_PATH_OR_CMD] = L\"\";\n wchar_t * p;\n wchar_t * lRetval;\n\t\twchar_t const * ldefExt = NULL;\n\t\tint i;\n HRESULT lHResult;\n OPENFILENAMEW ofn = {0};\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return (wchar_t *)1; }\n\n lHResult = CoInitializeEx(NULL, 0);\n\n getPathWithoutFinalSlashW(lDirname, aDefaultPathAndFile);\n getLastNameW(lBuff, aDefaultPathAndFile);\n\n if (aNumOfFilterPatterns > 0)\n {\n\t\t\tldefExt = aFilterPatterns[0];\n\n if (aSingleFilterDescription && wcslen(aSingleFilterDescription))\n {\n wcscpy(lFilterPatterns, aSingleFilterDescription);\n wcscat(lFilterPatterns, L\"\\n\");\n }\n wcscat(lFilterPatterns, aFilterPatterns[0]);\n for (i = 1; i < aNumOfFilterPatterns; i++)\n {\n wcscat(lFilterPatterns, L\";\");\n wcscat(lFilterPatterns, aFilterPatterns[i]);\n }\n wcscat(lFilterPatterns, L\"\\n\");\n if (!(aSingleFilterDescription && wcslen(aSingleFilterDescription)))\n {\n wcscpy(lDialogString, lFilterPatterns);\n wcscat(lFilterPatterns, lDialogString);\n }\n wcscat(lFilterPatterns, L\"All Files\\n*.*\\n\");\n p = lFilterPatterns;\n while ((p = wcschr(p, L'\\n')) != NULL)\n {\n *p = L'\\0';\n p++;\n }\n }\n\n ofn.lStructSize = sizeof(OPENFILENAMEW);\n ofn.hwndOwner = GetForegroundWindow();\n ofn.hInstance = 0;\n ofn.lpstrFilter = wcslen(lFilterPatterns) ? lFilterPatterns : NULL;\n ofn.lpstrCustomFilter = NULL;\n ofn.nMaxCustFilter = 0;\n ofn.nFilterIndex = 1;\n ofn.lpstrFile = lBuff;\n\n ofn.nMaxFile = MAX_PATH_OR_CMD;\n ofn.lpstrFileTitle = NULL;\n ofn.nMaxFileTitle = MAX_PATH_OR_CMD/2;\n ofn.lpstrInitialDir = wcslen(lDirname) ? lDirname : NULL;\n ofn.lpstrTitle = aTitle && wcslen(aTitle) ? aTitle : NULL;\n ofn.Flags = OFN_OVERWRITEPROMPT | OFN_NOCHANGEDIR | OFN_PATHMUSTEXIST ;\n ofn.nFileOffset = 0;\n ofn.nFileExtension = 0;\n\t\tofn.lpstrDefExt = ldefExt;\n ofn.lCustData = 0L;\n ofn.lpfnHook = NULL;\n ofn.lpTemplateName = NULL;\n\n if (GetSaveFileNameW(&ofn) == 0)\n {\n lRetval = NULL;\n }\n else\n {\n lRetval = lBuff;\n }\n\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n CoUninitialize();\n }\n return lRetval;\n}\n\n\nstatic char * saveFileDialogWinGui8(\n char * aoBuff,\n char const * aTitle, /* NULL or \"\" */\n char const * aDefaultPathAndFile, /* NULL or \"\" */\n int aNumOfFilterPatterns, /* 0 */\n char const * const * aFilterPatterns, /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription) /* NULL or \"image files\" */\n{\n wchar_t lTitle [128] = L\"\";\n wchar_t lDefaultPathAndFile [MAX_PATH_OR_CMD] = L\"\";\n wchar_t lSingleFilterDescription [128] = L\"\";\n wchar_t * * lFilterPatterns;\n wchar_t * lTmpWChar;\n char * lTmpChar;\n int i ;\n\n lFilterPatterns = (wchar_t **) malloc(aNumOfFilterPatterns*sizeof(wchar_t *));\n for (i = 0; i < aNumOfFilterPatterns; i++)\n {\n\t\t\tlTmpWChar = tinyfd_utf8to16(aFilterPatterns[i]);\n\t\t\tlFilterPatterns[i] = (wchar_t *)malloc( (wcslen(lTmpWChar)+1) * sizeof(wchar_t *));\n\t\t\twcscpy(lFilterPatterns[i], lTmpWChar);\n\t\t}\n\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\n\t\tif (aDefaultPathAndFile)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDefaultPathAndFile);\n\t\t\twcscpy(lDefaultPathAndFile, lTmpWChar);\n\t\t}\n\n\t\tif (aSingleFilterDescription)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aSingleFilterDescription);\n\t\t\twcscpy(lSingleFilterDescription, lTmpWChar);\n\t\t}\n\n lTmpWChar = tinyfd_saveFileDialogW(\n lTitle,\n lDefaultPathAndFile,\n aNumOfFilterPatterns,\n (wchar_t const** ) /*stupid cast for gcc*/\n lFilterPatterns,\n lSingleFilterDescription);\n\n for (i = 0; i < aNumOfFilterPatterns; i++)\n {\n free(lFilterPatterns[i]);\n }\n free(lFilterPatterns);\n\n if (!lTmpWChar)\n {\n return NULL;\n }\n\n\t\tlTmpChar = tinyfd_utf16to8(lTmpWChar);\n strcpy(aoBuff, lTmpChar);\n\t\t(void) tinyfd_utf16to8(NULL);\n\n return aoBuff;\n}\n\n\nwchar_t * tinyfd_openFileDialogW(\n wchar_t const * aTitle, /* NULL or \"\" */\n wchar_t const * aDefaultPathAndFile, /* NULL or \"\" */\n int aNumOfFilterPatterns, /* 0 */\n wchar_t const * const * aFilterPatterns, /* NULL or {\"*.jpg\",\"*.png\"} */\n wchar_t const * aSingleFilterDescription, /* NULL or \"image files\" */\n int aAllowMultipleSelects) /* 0 or 1 ; -1 to free allocated memory and return */\n{\n size_t lLengths[MAX_MULTIPLE_FILES];\n wchar_t lDirname[MAX_PATH_OR_CMD];\n wchar_t lFilterPatterns[MAX_PATH_OR_CMD] = L\"\";\n wchar_t lDialogString[MAX_PATH_OR_CMD];\n wchar_t * lPointers[MAX_MULTIPLE_FILES+1];\n wchar_t * p;\n int i, j;\n\t\tsize_t lBuffLen, lFullBuffLen;\n HRESULT lHResult;\n OPENFILENAMEW ofn = { 0 };\n\t\tstatic wchar_t * lBuff = NULL;\n\n\t\tfree(lBuff);\n\t\tlBuff = NULL;\n\t\tif (aAllowMultipleSelects < 0) return (wchar_t *)0;\n\n\t\tif (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return (wchar_t *)1; }\n\n\t\tif (aAllowMultipleSelects)\n\t\t{\n\t\t\tlFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\tlBuff = (wchar_t*)(malloc(lFullBuffLen * sizeof(wchar_t)));\n\t\t\tif (!lBuff)\n\t\t\t{\n\t\t\t\tlFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\t\tlBuff = (wchar_t*)( malloc( lFullBuffLen * sizeof(wchar_t)));\n\t\t\t}\n\t\t}\n\t\telse\n\t\t{\n\t\t\tlFullBuffLen = MAX_PATH_OR_CMD + 1;\n\t\t\tlBuff = (wchar_t*)(malloc(lFullBuffLen * sizeof(wchar_t)));\n\t\t}\n\t\tif (!lBuff) return NULL;\n\n lHResult = CoInitializeEx(NULL, 0);\n\n getPathWithoutFinalSlashW(lDirname, aDefaultPathAndFile);\n getLastNameW(lBuff, aDefaultPathAndFile);\n\n if (aNumOfFilterPatterns > 0)\n {\n if (aSingleFilterDescription && wcslen(aSingleFilterDescription))\n {\n wcscpy(lFilterPatterns, aSingleFilterDescription);\n wcscat(lFilterPatterns, L\"\\n\");\n }\n wcscat(lFilterPatterns, aFilterPatterns[0]);\n for (i = 1; i < aNumOfFilterPatterns; i++)\n {\n wcscat(lFilterPatterns, L\";\");\n wcscat(lFilterPatterns, aFilterPatterns[i]);\n }\n wcscat(lFilterPatterns, L\"\\n\");\n if (!(aSingleFilterDescription && wcslen(aSingleFilterDescription)))\n {\n wcscpy(lDialogString, lFilterPatterns);\n wcscat(lFilterPatterns, lDialogString);\n }\n wcscat(lFilterPatterns, L\"All Files\\n*.*\\n\");\n p = lFilterPatterns;\n while ((p = wcschr(p, L'\\n')) != NULL)\n {\n *p = L'\\0';\n p++;\n }\n }\n\n ofn.lStructSize = sizeof(OPENFILENAME);\n ofn.hwndOwner = GetForegroundWindow();\n ofn.hInstance = 0;\n ofn.lpstrFilter = wcslen(lFilterPatterns) ? lFilterPatterns : NULL;\n ofn.lpstrCustomFilter = NULL;\n ofn.nMaxCustFilter = 0;\n ofn.nFilterIndex = 1;\n ofn.lpstrFile = lBuff;\n\t\tofn.nMaxFile = lFullBuffLen;\n ofn.lpstrFileTitle = NULL;\n ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2;\n ofn.lpstrInitialDir = wcslen(lDirname) ? lDirname : NULL;\n ofn.lpstrTitle = aTitle && wcslen(aTitle) ? aTitle : NULL;\n ofn.Flags = OFN_EXPLORER | OFN_NOCHANGEDIR | OFN_PATHMUSTEXIST | OFN_FILEMUSTEXIST;\n ofn.nFileOffset = 0;\n ofn.nFileExtension = 0;\n ofn.lpstrDefExt = NULL;\n ofn.lCustData = 0L;\n ofn.lpfnHook = NULL;\n ofn.lpTemplateName = NULL;\n\n if (aAllowMultipleSelects)\n {\n ofn.Flags |= OFN_ALLOWMULTISELECT;\n }\n\n if (GetOpenFileNameW(&ofn) == 0)\n {\n\t\t\tfree(lBuff);\n\t\t\tlBuff = NULL;\n }\n else\n {\n lBuffLen = wcslen(lBuff);\n lPointers[0] = lBuff + lBuffLen + 1;\n if (aAllowMultipleSelects && (lPointers[0][0] != L'\\0'))\n\t\t\t\t{\n i = 0;\n do\n {\n lLengths[i] = wcslen(lPointers[i]);\n lPointers[i + 1] = lPointers[i] + lLengths[i] + 1;\n i++;\n\t\t\t\t\t\t} while (lPointers[i][0] != L'\\0' && i < MAX_MULTIPLE_FILES );\n\t\t\t\t\t\tif (i > MAX_MULTIPLE_FILES)\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tfree(lBuff);\n\t\t\t\t\t\t\tlBuff = NULL;\n\t\t\t\t\t\t}\n\t\t\t\t\t\telse\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\ti--;\n\t\t\t\t\t\t\tp = lBuff + lFullBuffLen - 1;\n\t\t\t\t\t\t\t*p = L'\\0';\n\t\t\t\t\t\t\tfor (j = i; j >= 0; j--)\n\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\tp -= lLengths[j];\n\t\t\t\t\t\t\t\tmemmove(p, lPointers[j], lLengths[j] * sizeof(wchar_t));\n\t\t\t\t\t\t\t\tp--;\n\t\t\t\t\t\t\t\t*p = L'\\\\';\n\t\t\t\t\t\t\t\tp -= lBuffLen;\n\t\t\t\t\t\t\t\tmemmove(p, lBuff, lBuffLen*sizeof(wchar_t));\n\t\t\t\t\t\t\t\tp--;\n\t\t\t\t\t\t\t\t*p = L'|';\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\tp++;\n\t\t\t\t\t\t\twcscpy(lBuff, p);\n\t\t\t\t\t\t\tlBuffLen = wcslen(lBuff);\n\t\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tif (lBuff) lBuff = (wchar_t*)(realloc(lBuff, (lBuffLen + 1) * sizeof(wchar_t)));\n }\n\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n CoUninitialize();\n }\n\t\treturn lBuff;\n}\n\n\nstatic char * openFileDialogWinGui8(\n char const * aTitle, /* NULL or \"\" */\n char const * aDefaultPathAndFile, /* NULL or \"\" */\n int aNumOfFilterPatterns, /* 0 */\n char const * const * aFilterPatterns, /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription, /* NULL or \"image files\" */\n int aAllowMultipleSelects) /* 0 or 1 */\n{\n wchar_t lTitle[128] = L\"\";\n\t\twchar_t lDefaultPathAndFile[MAX_PATH_OR_CMD] = L\"\";\n wchar_t lSingleFilterDescription[128] = L\"\";\n wchar_t * * lFilterPatterns;\n\t\twchar_t * lTmpWChar;\n\t\tchar * lTmpChar;\n\t\tint i;\n\n lFilterPatterns = (wchar_t * *) malloc(aNumOfFilterPatterns*sizeof(wchar_t *));\n for (i = 0; i < aNumOfFilterPatterns; i++)\n {\n\t\t\tlTmpWChar = tinyfd_utf8to16(aFilterPatterns[i]);\n\t\t\tlFilterPatterns[i] = (wchar_t *)malloc((wcslen(lTmpWChar)+1)*sizeof(wchar_t *));\n\t\t\twcscpy(lFilterPatterns[i], lTmpWChar);\n }\n\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aDefaultPathAndFile)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDefaultPathAndFile);\n\t\t\twcscpy(lDefaultPathAndFile, lTmpWChar);\n\t\t}\n\t\tif (aSingleFilterDescription)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aSingleFilterDescription);\n\t\t\twcscpy(lSingleFilterDescription, lTmpWChar);\n\t\t}\n\n lTmpWChar = tinyfd_openFileDialogW(\n lTitle,\n lDefaultPathAndFile,\n aNumOfFilterPatterns,\n (wchar_t const**) /*stupid cast for gcc*/\n lFilterPatterns,\n lSingleFilterDescription,\n aAllowMultipleSelects);\n\n for (i = 0; i < aNumOfFilterPatterns; i++)\n {\n free(lFilterPatterns[i]);\n }\n free(lFilterPatterns);\n\n if (!lTmpWChar) return NULL;\n\n\t\tlTmpChar = tinyfd_utf16to8(lTmpWChar);\n\t\t(void) tinyfd_openFileDialogW(NULL,NULL,0,NULL,NULL,-1);\n\n\t\treturn lTmpChar;\n}\n\n\nBOOL CALLBACK BrowseCallbackProc_enum(HWND hWndChild, LPARAM lParam)\n{\n\tchar buf[255];\n\tGetClassNameA(hWndChild, buf, sizeof(buf));\n\tif (strcmp(buf, \"SysTreeView32\") == 0) {\n\t\tHTREEITEM hNode = TreeView_GetSelection(hWndChild);\n\t\tTreeView_EnsureVisible(hWndChild, hNode);\n\t\treturn FALSE;\n\t}\n\treturn TRUE;\n}\n\n\n\nBOOL CALLBACK BrowseCallbackProcW_enum(HWND hWndChild, LPARAM lParam)\n{\n wchar_t buf[255];\n GetClassNameW(hWndChild, buf, sizeof(buf));\n if (wcscmp(buf, L\"SysTreeView32\") == 0) {\n HTREEITEM hNode = TreeView_GetSelection(hWndChild);\n TreeView_EnsureVisible(hWndChild, hNode);\n return FALSE;\n }\n return TRUE;\n}\n\nstatic int __stdcall BrowseCallbackProc(HWND hwnd, UINT uMsg, LPARAM lp, LPARAM pData)\n{\n\tswitch (uMsg) {\n\tcase BFFM_INITIALIZED:\n\t\tSendMessage(hwnd, BFFM_SETSELECTION, TRUE, pData);\n\t\tbreak;\n\tcase BFFM_SELCHANGED:\n\t\tEnumChildWindows(hwnd, BrowseCallbackProc_enum, 0);\n\t}\n\treturn 0;\n}\n\n\nstatic int __stdcall BrowseCallbackProcW(HWND hwnd, UINT uMsg, LPARAM lp, LPARAM pData)\n{\n switch (uMsg) {\n case BFFM_INITIALIZED:\n SendMessage(hwnd, BFFM_SETSELECTIONW, TRUE, (LPARAM)pData);\n break;\n case BFFM_SELCHANGED:\n EnumChildWindows(hwnd, BrowseCallbackProcW_enum, 0);\n }\n return 0;\n}\n\nwchar_t * tinyfd_selectFolderDialogW(\n wchar_t const * aTitle, /* NULL or \"\" */\n wchar_t const * aDefaultPath) /* NULL or \"\" */\n{\n static wchar_t lBuff[MAX_PATH_OR_CMD];\n\t\twchar_t * lRetval;\n\n BROWSEINFOW bInfo;\n LPITEMIDLIST lpItem;\n HRESULT lHResult;\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return (wchar_t *)1; }\n\n lHResult = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED);\n\n bInfo.hwndOwner = GetForegroundWindow();\n bInfo.pidlRoot = NULL;\n bInfo.pszDisplayName = lBuff;\n bInfo.lpszTitle = aTitle && wcslen(aTitle) ? aTitle : NULL;\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n bInfo.ulFlags = BIF_USENEWUI;\n }\n bInfo.lpfn = BrowseCallbackProcW;\n bInfo.lParam = (LPARAM)aDefaultPath;\n bInfo.iImage = -1;\n\n lpItem = SHBrowseForFolderW(&bInfo);\n if (!lpItem)\n\t\t{\n\t\t\tlRetval = NULL;\n\t\t}\n\t\telse\n {\n SHGetPathFromIDListW(lpItem, lBuff);\n\t\t\t\tlRetval = lBuff ;\n }\n\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n CoUninitialize();\n }\n\t\treturn lRetval;\n}\n\n\nstatic char * selectFolderDialogWinGui8(\n char * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPath ) /* NULL or \"\" */\n{\n wchar_t lTitle [128] = L\"\";\n wchar_t lDefaultPath[MAX_PATH_OR_CMD] = L\"\";\n wchar_t * lTmpWChar;\n char * lTmpChar;\n\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aDefaultPath)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDefaultPath);\n\t\t\twcscpy(lDefaultPath, lTmpWChar);\n\t\t}\n\n lTmpWChar = tinyfd_selectFolderDialogW(\n lTitle,\n lDefaultPath);\n\n if (!lTmpWChar)\n {\n return NULL;\n }\n\n\t\tlTmpChar = tinyfd_utf16to8(lTmpWChar);\n strcpy(aoBuff, lTmpChar);\n\n return aoBuff;\n}\n\n\nwchar_t * tinyfd_colorChooserW(\n wchar_t const * aTitle, /* NULL or \"\" */\n wchar_t const * aDefaultHexRGB, /* NULL or \"#FF0000\"*/\n unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */\n unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */\n{\n static wchar_t lResultHexRGB[8];\n CHOOSECOLORW cc;\n COLORREF crCustColors[16];\n unsigned char lDefaultRGB[3];\n int lRet;\n\n HRESULT lHResult;\n\n if (aTitle&&!wcscmp(aTitle, L\"tinyfd_query\")){ strcpy(tinyfd_response, \"windows_wchar\"); return (wchar_t *)1; }\n\n lHResult = CoInitializeEx(NULL, 0);\n\n if ( aDefaultHexRGB )\n {\n Hex2RGBW(aDefaultHexRGB, lDefaultRGB);\n }\n else\n {\n lDefaultRGB[0] = aDefaultRGB[0];\n lDefaultRGB[1] = aDefaultRGB[1];\n lDefaultRGB[2] = aDefaultRGB[2];\n }\n\n /* we can't use aTitle */\n cc.lStructSize = sizeof(CHOOSECOLOR);\n cc.hwndOwner = GetForegroundWindow();\n cc.hInstance = NULL;\n cc.rgbResult = RGB(lDefaultRGB[0], lDefaultRGB[1], lDefaultRGB[2]);\n cc.lpCustColors = crCustColors;\n cc.Flags = CC_RGBINIT | CC_FULLOPEN | CC_ANYCOLOR ;\n cc.lCustData = 0;\n cc.lpfnHook = NULL;\n cc.lpTemplateName = NULL;\n\n lRet = ChooseColorW(&cc);\n\n if (!lRet)\n {\n return NULL;\n }\n\n aoResultRGB[0] = GetRValue(cc.rgbResult);\n aoResultRGB[1] = GetGValue(cc.rgbResult);\n aoResultRGB[2] = GetBValue(cc.rgbResult);\n\n RGB2HexW(aoResultRGB, lResultHexRGB);\n\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n CoUninitialize();\n }\n\n return lResultHexRGB;\n}\n\n\nstatic char * colorChooserWinGui8(\n char const * aTitle, /* NULL or \"\" */\n char const * aDefaultHexRGB, /* NULL or \"#FF0000\"*/\n unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */\n unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */\n{\n static char lResultHexRGB[8];\n\n wchar_t lTitle[128];\n wchar_t lDefaultHexRGB[16];\n wchar_t * lTmpWChar;\n char * lTmpChar;\n\n\t\tif (aTitle)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aTitle);\n\t\t\twcscpy(lTitle, lTmpWChar);\n\t\t}\n\t\tif (aDefaultHexRGB)\n\t\t{\n\t\t\tlTmpWChar = tinyfd_utf8to16(aDefaultHexRGB);\n\t\t\twcscpy(lDefaultHexRGB, lTmpWChar);\n\t\t}\n\n lTmpWChar = tinyfd_colorChooserW(\n lTitle,\n lDefaultHexRGB,\n aDefaultRGB,\n aoResultRGB );\n\n if (!lTmpWChar)\n {\n return NULL;\n }\n\n\t\tlTmpChar = tinyfd_utf16to8(lTmpWChar);\n strcpy(lResultHexRGB, lTmpChar);\n\n return lResultHexRGB;\n}\n\n\nstatic int messageBoxWinGuiA(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n and \\t */\n char const * aDialogType , /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n char const * aIconType , /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n\tint lBoxReturnValue;\n\tUINT aCode ;\n\n if ( aIconType && ! strcmp( \"warning\" , aIconType ) )\n {\n aCode = MB_ICONWARNING ;\n }\n else if ( aIconType && ! strcmp(\"error\", aIconType))\n {\n aCode = MB_ICONERROR ;\n }\n else if ( aIconType && ! strcmp(\"question\", aIconType))\n {\n aCode = MB_ICONQUESTION ;\n }\n else\n {\n aCode = MB_ICONINFORMATION ;\n }\n\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n aCode += MB_OKCANCEL ;\n if ( ! aDefaultButton )\n {\n aCode += MB_DEFBUTTON2 ;\n }\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n aCode += MB_YESNO ;\n if ( ! aDefaultButton )\n {\n aCode += MB_DEFBUTTON2 ;\n }\n }\n else if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n aCode += MB_YESNOCANCEL;\n if (!aDefaultButton)\n {\n aCode += MB_DEFBUTTON3;\n }\n else if (aDefaultButton == 2)\n {\n aCode += MB_DEFBUTTON2;\n }\n }\n else\n {\n aCode += MB_OK ;\n }\n\n aCode += MB_TOPMOST;\n\n lBoxReturnValue = MessageBoxA(GetForegroundWindow(), aMessage, aTitle, aCode);\n\n if (((aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n && (lBoxReturnValue == IDNO)))\n {\n return 2;\n }\n\n if ( ( ( aDialogType\n && strcmp(\"yesnocancel\", aDialogType)\n && strcmp(\"okcancel\", aDialogType)\n && strcmp(\"yesno\", aDialogType)))\n || (lBoxReturnValue == IDOK)\n || (lBoxReturnValue == IDYES) )\n {\n return 1 ;\n }\n else\n {\n return 0 ;\n }\n}\n\n\nstatic char * saveFileDialogWinGuiA(\n\tchar * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription ) /* NULL or \"image files\" */\n{\n char lDirname [MAX_PATH_OR_CMD] ;\n char lDialogString[MAX_PATH_OR_CMD];\n char lFilterPatterns[MAX_PATH_OR_CMD] = \"\";\n int i ;\n char * p;\n char * lRetval;\n HRESULT lHResult;\n\t\tchar const * ldefExt = NULL;\n OPENFILENAMEA ofn = { 0 };\n\n lHResult = CoInitializeEx(NULL,0);\n\n getPathWithoutFinalSlash(lDirname, aDefaultPathAndFile);\n getLastName(aoBuff, aDefaultPathAndFile);\n\n if (aNumOfFilterPatterns > 0)\n {\n\t\t\tldefExt = aFilterPatterns[0];\n\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcpy(lFilterPatterns, aSingleFilterDescription);\n strcat(lFilterPatterns, \"\\n\");\n }\n strcat(lFilterPatterns, aFilterPatterns[0]);\n for (i = 1; i < aNumOfFilterPatterns; i++)\n {\n strcat(lFilterPatterns, \";\");\n strcat(lFilterPatterns, aFilterPatterns[i]);\n }\n strcat(lFilterPatterns, \"\\n\");\n if ( ! (aSingleFilterDescription && strlen(aSingleFilterDescription) ) )\n {\n strcpy(lDialogString, lFilterPatterns);\n strcat(lFilterPatterns, lDialogString);\n }\n strcat(lFilterPatterns, \"All Files\\n*.*\\n\");\n p = lFilterPatterns;\n while ((p = strchr(p, '\\n')) != NULL)\n {\n *p = '\\0';\n p ++ ;\n }\n }\n\n ofn.lStructSize = sizeof(OPENFILENAME) ;\n ofn.hwndOwner = GetForegroundWindow();\n ofn.hInstance = 0 ;\n ofn.lpstrFilter = strlen(lFilterPatterns) ? lFilterPatterns : NULL;\n ofn.lpstrCustomFilter = NULL ;\n ofn.nMaxCustFilter = 0 ;\n ofn.nFilterIndex = 1 ;\n ofn.lpstrFile = aoBuff;\n\n ofn.nMaxFile = MAX_PATH_OR_CMD ;\n ofn.lpstrFileTitle = NULL ;\n ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2;\n ofn.lpstrInitialDir = strlen(lDirname) ? lDirname : NULL;\n ofn.lpstrTitle = aTitle && strlen(aTitle) ? aTitle : NULL;\n ofn.Flags = OFN_OVERWRITEPROMPT | OFN_NOCHANGEDIR ;\n ofn.nFileOffset = 0 ;\n ofn.nFileExtension = 0 ;\n\t\tofn.lpstrDefExt\t\t= ldefExt;\n ofn.lCustData = 0L ;\n ofn.lpfnHook = NULL ;\n ofn.lpTemplateName = NULL ;\n\n if ( GetSaveFileNameA ( & ofn ) == 0 )\n {\n lRetval = NULL ;\n }\n else\n {\n lRetval = aoBuff ;\n }\n\n if (lHResult==S_OK || lHResult==S_FALSE)\n {\n CoUninitialize();\n }\n return lRetval ;\n}\n\n\nstatic char * openFileDialogWinGuiA(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription , /* NULL or \"image files\" */\n int aAllowMultipleSelects ) /* 0 or 1 */\n{\n char lDirname [MAX_PATH_OR_CMD] ;\n char lFilterPatterns[MAX_PATH_OR_CMD] = \"\";\n char lDialogString[MAX_PATH_OR_CMD] ;\n char * lPointers[MAX_MULTIPLE_FILES+1];\n size_t lLengths[MAX_MULTIPLE_FILES];\n int i , j ;\n char * p;\n\t\tsize_t lBuffLen, lFullBuffLen;\n HRESULT lHResult;\n OPENFILENAMEA ofn = {0};\n\t\tstatic char * lBuff = NULL;\n\n\t\tfree(lBuff);\n\t\tlBuff = NULL;\n\t\tif (aAllowMultipleSelects)\n\t\t{\n\t\t\tlFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\tlBuff = (char *)(malloc(lFullBuffLen * sizeof(char)));\n\t\t\tif (!lBuff)\n\t\t\t{\n\t\t\t\tlFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\t\tlBuff = (char *)(malloc(lFullBuffLen * sizeof(char)));\n\t\t\t}\n\t\t}\n\t\telse\n\t\t{\n\t\t\tlFullBuffLen = MAX_PATH_OR_CMD + 1;\n\t\t\tlBuff = (char *)(malloc(lFullBuffLen * sizeof(char)));\n\t\t}\n\t\tif (!lBuff) return NULL;\n\n lHResult = CoInitializeEx(NULL,0);\n\n getPathWithoutFinalSlash(lDirname, aDefaultPathAndFile);\n\t\tgetLastName(lBuff, aDefaultPathAndFile);\n\n if (aNumOfFilterPatterns > 0)\n {\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcpy(lFilterPatterns, aSingleFilterDescription);\n strcat(lFilterPatterns, \"\\n\");\n }\n strcat(lFilterPatterns, aFilterPatterns[0]);\n for (i = 1; i < aNumOfFilterPatterns; i++)\n {\n strcat(lFilterPatterns, \";\");\n strcat(lFilterPatterns, aFilterPatterns[i]);\n }\n strcat(lFilterPatterns, \"\\n\");\n if ( ! (aSingleFilterDescription && strlen(aSingleFilterDescription) ) )\n {\n strcpy(lDialogString, lFilterPatterns);\n strcat(lFilterPatterns, lDialogString);\n }\n strcat(lFilterPatterns, \"All Files\\n*.*\\n\");\n p = lFilterPatterns;\n while ((p = strchr(p, '\\n')) != NULL)\n {\n *p = '\\0';\n p ++ ;\n }\n }\n\n ofn.lStructSize = sizeof( OPENFILENAME ) ;\n ofn.hwndOwner = GetForegroundWindow();\n ofn.hInstance = 0 ;\n ofn.lpstrFilter = strlen(lFilterPatterns) ? lFilterPatterns : NULL;\n ofn.lpstrCustomFilter = NULL ;\n ofn.nMaxCustFilter = 0 ;\n ofn.nFilterIndex = 1 ;\n\t\tofn.lpstrFile = lBuff;\n\t\tofn.nMaxFile = lFullBuffLen;\n ofn.lpstrFileTitle = NULL ;\n ofn.nMaxFileTitle = MAX_PATH_OR_CMD / 2;\n ofn.lpstrInitialDir = strlen(lDirname) ? lDirname : NULL;\n ofn.lpstrTitle = aTitle && strlen(aTitle) ? aTitle : NULL;\n ofn.Flags = OFN_EXPLORER | OFN_NOCHANGEDIR ;\n ofn.nFileOffset = 0 ;\n ofn.nFileExtension = 0 ;\n ofn.lpstrDefExt = NULL ;\n ofn.lCustData = 0L ;\n ofn.lpfnHook = NULL ;\n ofn.lpTemplateName = NULL ;\n\n if ( aAllowMultipleSelects )\n {\n ofn.Flags |= OFN_ALLOWMULTISELECT;\n }\n\n if ( GetOpenFileNameA( & ofn ) == 0 )\n {\n\t\t\tfree(lBuff);\n\t\t\tlBuff = NULL ;\n }\n else\n {\n\t\t\tlBuffLen = strlen(lBuff);\n\t\t\tlPointers[0] = lBuff + lBuffLen + 1;\n if ( aAllowMultipleSelects && (lPointers[0][0] != '\\0') )\n {\n i = 0 ;\n do\n {\n lLengths[i] = strlen(lPointers[i]);\n lPointers[i+1] = lPointers[i] + lLengths[i] + 1 ;\n i ++ ;\n\t\t\t\t\t\t} while (lPointers[i][0] != L'\\0' && i < MAX_MULTIPLE_FILES);\n\t\t\t\t\t\tif (i > MAX_MULTIPLE_FILES)\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tfree(lBuff);\n\t\t\t\t\t\t\tlBuff = NULL;\n\t\t\t\t\t\t}\n\t\t\t\t\t\telse\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\ti--;\n\t\t\t\t\t\t\tp = lBuff + MAX_MULTIPLE_FILES*MAX_PATH_OR_CMD - 1;\n\t\t\t\t\t\t\t*p = '\\0';\n\t\t\t\t\t\t\tfor (j = i; j >= 0; j--)\n\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\tp -= lLengths[j];\n\t\t\t\t\t\t\t\tmemmove(p, lPointers[j], lLengths[j]);\n\t\t\t\t\t\t\t\tp--;\n\t\t\t\t\t\t\t\t*p = '\\\\';\n\t\t\t\t\t\t\t\tp -= lBuffLen;\n\t\t\t\t\t\t\t\tmemmove(p, lBuff, lBuffLen);\n\t\t\t\t\t\t\t\tp--;\n\t\t\t\t\t\t\t\t*p = '|';\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\tp++;\n\t\t\t\t\t\t\tstrcpy(lBuff, p);\n\t\t\t\t\t\t\tlBuffLen = strlen(lBuff);\n\t\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tif (lBuff) lBuff = (char *)(realloc(lBuff, (lBuffLen + 1) * sizeof(char)));\n\t\t}\n\n if (lHResult==S_OK || lHResult==S_FALSE)\n {\n CoUninitialize();\n }\n\t\treturn lBuff;\n}\n\n\nstatic char * selectFolderDialogWinGuiA(\n char * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPath ) /* NULL or \"\" */\n{\n BROWSEINFOA bInfo ;\n LPITEMIDLIST lpItem ;\n HRESULT lHResult ;\n\t\tchar * lRetval = NULL ;\n\n lHResult = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED);\n\n /* we can't use aDefaultPath */\n bInfo.hwndOwner = GetForegroundWindow();\n bInfo.pidlRoot = NULL ;\n bInfo.pszDisplayName = aoBuff ;\n bInfo.lpszTitle = aTitle && strlen(aTitle) ? aTitle : NULL;\n if (lHResult == S_OK || lHResult == S_FALSE)\n {\n bInfo.ulFlags = BIF_USENEWUI;\n }\n bInfo.lpfn = BrowseCallbackProc;\n bInfo.lParam = (LPARAM)aDefaultPath;\n bInfo.iImage = -1 ;\n\n lpItem = SHBrowseForFolderA( & bInfo ) ;\n if ( lpItem )\n {\n SHGetPathFromIDListA( lpItem , aoBuff ) ;\n\t\t\t\tlRetval = aoBuff;\n }\n\n if (lHResult==S_OK || lHResult==S_FALSE)\n {\n CoUninitialize();\n }\n\t\treturn lRetval;\n}\n\n\nstatic char * colorChooserWinGuiA(\n char const * aTitle, /* NULL or \"\" */\n char const * aDefaultHexRGB, /* NULL or \"#FF0000\"*/\n unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */\n unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */\n{\n static char lResultHexRGB[8];\n\n CHOOSECOLORA cc;\n COLORREF crCustColors[16];\n unsigned char lDefaultRGB[3];\n int lRet;\n\n if ( aDefaultHexRGB )\n {\n Hex2RGB(aDefaultHexRGB, lDefaultRGB);\n }\n else\n {\n lDefaultRGB[0]=aDefaultRGB[0];\n lDefaultRGB[1]=aDefaultRGB[1];\n lDefaultRGB[2]=aDefaultRGB[2];\n }\n\n /* we can't use aTitle */\n cc.lStructSize = sizeof( CHOOSECOLOR ) ;\n cc.hwndOwner = GetForegroundWindow();\n cc.hInstance = NULL ;\n cc.rgbResult = RGB(lDefaultRGB[0], lDefaultRGB[1], lDefaultRGB[2]);\n cc.lpCustColors = crCustColors;\n cc.Flags = CC_RGBINIT | CC_FULLOPEN;\n cc.lCustData = 0;\n cc.lpfnHook = NULL;\n cc.lpTemplateName = NULL;\n\n lRet = ChooseColorA(&cc);\n\n if ( ! lRet )\n {\n return NULL;\n }\n\n aoResultRGB[0] = GetRValue(cc.rgbResult);\n aoResultRGB[1] = GetGValue(cc.rgbResult);\n aoResultRGB[2] = GetBValue(cc.rgbResult);\n\n RGB2Hex(aoResultRGB, lResultHexRGB);\n\n return lResultHexRGB;\n}\n\n#endif /* TINYFD_NOLIB */\n\nstatic int dialogPresent(void)\n{\n static int lDialogPresent = -1 ;\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n char const * lString = \"dialog.exe\";\n\t\tif (!tinyfd_allowCursesDialogs) return 0;\n\t\tif (lDialogPresent < 0)\n {\n if (!(lIn = _popen(\"where dialog.exe\",\"r\")))\n {\n lDialogPresent = 0 ;\n return 0 ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n _pclose( lIn ) ;\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n if ( strcmp(lBuff+strlen(lBuff)-strlen(lString),lString) )\n {\n lDialogPresent = 0 ;\n }\n else\n {\n lDialogPresent = 1 ;\n }\n }\n\t\treturn lDialogPresent;\n}\n\n\nstatic int messageBoxWinConsole(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n and \\t */\n char const * aDialogType , /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n char const * aIconType , /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n char lDialogString[MAX_PATH_OR_CMD];\n char lDialogFile[MAX_PATH_OR_CMD];\n FILE * lIn;\n char lBuff [MAX_PATH_OR_CMD] = \"\";\n\n\t\tstrcpy(lDialogString, \"dialog \");\n\t\tif (aTitle && strlen(aTitle))\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( aDialogType && ( !strcmp( \"okcancel\" , aDialogType )\n || !strcmp(\"yesno\", aDialogType) || !strcmp(\"yesnocancel\", aDialogType) ) )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString, \"tab: move focus\") ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n if ( ! aDefaultButton )\n {\n strcat( lDialogString , \"--defaultno \" ) ;\n }\n strcat( lDialogString ,\n \"--yes-label \\\"Ok\\\" --no-label \\\"Cancel\\\" --yesno \" ) ;\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n if ( ! aDefaultButton )\n {\n strcat( lDialogString , \"--defaultno \" ) ;\n }\n strcat( lDialogString , \"--yesno \" ) ;\n }\n else if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n if (!aDefaultButton)\n {\n strcat(lDialogString, \"--defaultno \");\n }\n strcat(lDialogString, \"--menu \");\n }\n else\n {\n strcat( lDialogString , \"--msgbox \" ) ;\n }\n\n strcat( lDialogString , \"\\\"\" ) ;\n if ( aMessage && strlen(aMessage) )\n {\n replaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lBuff ) ;\n strcat(lDialogString, lBuff) ;\n lBuff[0]='\\0';\n }\n strcat(lDialogString, \"\\\" \");\n\n if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n strcat(lDialogString, \"0 60 0 Yes \\\"\\\" No \\\"\\\"\");\n strcat(lDialogString, \"2>>\");\n }\n else\n {\n strcat(lDialogString, \"10 60\");\n strcat(lDialogString, \" && echo 1 > \");\n }\n\n strcpy(lDialogFile, getenv(\"USERPROFILE\"));\n strcat(lDialogFile, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcat(lDialogString, lDialogFile);\n\n /*if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;*/\n system( lDialogString ) ;\n\n if (!(lIn = fopen(lDialogFile, \"r\")))\n {\n remove(lDialogFile);\n return 0 ;\n }\n\t\twhile (fgets(lBuff, sizeof(lBuff), lIn) != NULL)\n {}\n fclose(lIn);\n remove(lDialogFile);\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n\n /* if (tinyfd_verbose) printf(\"lBuff: %s\\n\", lBuff); */\n if ( ! strlen(lBuff) )\n {\n return 0;\n }\n\n if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n if (lBuff[0] == 'Y') return 1;\n else return 2;\n }\n\n return 1;\n}\n\n\nstatic int inputBoxWinConsole(\n char * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may NOT contain \\n nor \\t */\n char const * aDefaultInput ) /* \"\" , if NULL it's a passwordBox */\n{\n char lDialogString[MAX_PATH_OR_CMD];\n char lDialogFile[MAX_PATH_OR_CMD];\n FILE * lIn;\n int lResult;\n\n strcpy(lDialogFile, getenv(\"USERPROFILE\"));\n strcat(lDialogFile, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcpy(lDialogString , \"echo|set /p=1 >\" ) ;\n strcat(lDialogString, lDialogFile);\n strcat( lDialogString , \" & \" ) ;\n\n strcat( lDialogString , \"dialog \" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString, \"tab: move focus\") ;\n if ( ! aDefaultInput )\n {\n strcat(lDialogString, \" (sometimes nothing, no blink nor star, is shown in text field)\") ;\n }\n\n strcat(lDialogString, \"\\\" \") ;\n\n if ( ! aDefaultInput )\n {\n strcat( lDialogString , \"--insecure --passwordbox\" ) ;\n }\n else\n {\n strcat( lDialogString , \"--inputbox\" ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString,\"\\\" 10 60 \") ;\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat(lDialogString, \"\\\"\") ;\n strcat(lDialogString, aDefaultInput) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat(lDialogString, \"2>>\");\n strcpy(lDialogFile, getenv(\"USERPROFILE\"));\n strcat(lDialogFile, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcat(lDialogString, lDialogFile);\n strcat(lDialogString, \" || echo 0 > \");\n strcat(lDialogString, lDialogFile);\n\n /* printf( \"lDialogString: %s\\n\" , lDialogString ) ; */\n system( lDialogString ) ;\n\n if (!(lIn = fopen(lDialogFile, \"r\")))\n {\n remove(lDialogFile);\n\t\t\t\taoBuff[0] = '\\0';\n\t\t\t\treturn 0;\n }\n while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL)\n {}\n fclose(lIn);\n\n wipefile(lDialogFile);\n remove(lDialogFile);\n if ( aoBuff[strlen( aoBuff ) -1] == '\\n' )\n {\n aoBuff[strlen( aoBuff ) -1] = '\\0' ;\n }\n /* printf( \"aoBuff: %s\\n\" , aoBuff ) ; */\n\n /* printf( \"aoBuff: %s len: %lu \\n\" , aoBuff , strlen(aoBuff) ) ; */\n lResult = strncmp( aoBuff , \"1\" , 1) ? 0 : 1 ;\n /* printf( \"lResult: %d \\n\" , lResult ) ; */\n\tif ( ! lResult )\n\t{\n\t\taoBuff[0] = '\\0';\n\t\treturn 0 ;\n\t}\n\t/* printf( \"aoBuff+1: %s\\n\" , aoBuff+1 ) ; */\n\tstrcpy(aoBuff, aoBuff+3);\n\treturn 1;\n}\n\n\nstatic char * saveFileDialogWinConsole(\n char * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile ) /* NULL or \"\" */\n{\n char lDialogString[MAX_PATH_OR_CMD];\n char lPathAndFile[MAX_PATH_OR_CMD] = \"\";\n FILE * lIn;\n\n strcpy( lDialogString , \"dialog \" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n\n strcat( lDialogString , \"--fselect \\\"\" ) ;\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n /* dialog.exe uses unix separators even on windows */\n strcpy(lPathAndFile, aDefaultPathAndFile);\n replaceChr( lPathAndFile , '\\\\' , '/' ) ;\n }\n\n /* dialog.exe needs at least one separator */\n if ( ! strchr(lPathAndFile, '/') )\n {\n strcat(lDialogString, \"./\") ;\n }\n strcat(lDialogString, lPathAndFile) ;\n strcat(lDialogString, \"\\\" 0 60 2>\");\n strcpy(lPathAndFile, getenv(\"USERPROFILE\"));\n strcat(lPathAndFile, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcat(lDialogString, lPathAndFile);\n\n /* printf( \"lDialogString: %s\\n\" , lDialogString ) ; */\n system( lDialogString ) ;\n\n if (!(lIn = fopen(lPathAndFile, \"r\")))\n {\n remove(lPathAndFile);\n return NULL;\n }\n while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL)\n {}\n fclose(lIn);\n remove(lPathAndFile);\n replaceChr( aoBuff , '/' , '\\\\' ) ;\n /* printf( \"aoBuff: %s\\n\" , aoBuff ) ; */\n getLastName(lDialogString,aoBuff);\n if ( ! strlen(lDialogString) )\n {\n return NULL;\n }\n return aoBuff;\n}\n\n\nstatic char * openFileDialogWinConsole(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile ) /* NULL or \"\" */\n{\n char lFilterPatterns[MAX_PATH_OR_CMD] = \"\";\n char lDialogString[MAX_PATH_OR_CMD] ;\n FILE * lIn;\n\n\t\tstatic char aoBuff[MAX_PATH_OR_CMD];\n\n strcpy( lDialogString , \"dialog \" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n\n strcat( lDialogString , \"--fselect \\\"\" ) ;\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n /* dialog.exe uses unix separators even on windows */\n strcpy(lFilterPatterns, aDefaultPathAndFile);\n replaceChr( lFilterPatterns , '\\\\' , '/' ) ;\n }\n\n /* dialog.exe needs at least one separator */\n if ( ! strchr(lFilterPatterns, '/') )\n {\n strcat(lDialogString, \"./\") ;\n }\n strcat(lDialogString, lFilterPatterns) ;\n strcat(lDialogString, \"\\\" 0 60 2>\");\n strcpy(lFilterPatterns, getenv(\"USERPROFILE\"));\n strcat(lFilterPatterns, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcat(lDialogString, lFilterPatterns);\n\n /* printf( \"lDialogString: %s\\n\" , lDialogString ) ; */\n system( lDialogString ) ;\n\n if (!(lIn = fopen(lFilterPatterns, \"r\")))\n {\n remove(lFilterPatterns);\n return NULL;\n }\n while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL)\n {}\n fclose(lIn);\n remove(lFilterPatterns);\n replaceChr( aoBuff , '/' , '\\\\' ) ;\n /* printf( \"aoBuff: %s\\n\" , aoBuff ) ; */\n return aoBuff;\n}\n\n\nstatic char * selectFolderDialogWinConsole(\n char * aoBuff ,\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPath ) /* NULL or \"\" */\n{\n char lDialogString [MAX_PATH_OR_CMD] ;\n char lString [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n\n strcpy( lDialogString , \"dialog \" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n\n strcat( lDialogString , \"--dselect \\\"\" ) ;\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n /* dialog.exe uses unix separators even on windows */\n strcpy(lString, aDefaultPath) ;\n ensureFinalSlash(lString);\n replaceChr( lString , '\\\\' , '/' ) ;\n strcat(lDialogString, lString) ;\n }\n else\n {\n /* dialog.exe needs at least one separator */\n strcat(lDialogString, \"./\") ;\n }\n strcat(lDialogString, \"\\\" 0 60 2>\");\n strcpy(lString, getenv(\"USERPROFILE\"));\n strcat(lString, \"\\\\AppData\\\\Local\\\\Temp\\\\tinyfd.txt\");\n strcat(lDialogString, lString);\n\n /* printf( \"lDialogString: %s\\n\" , lDialogString ) ; */\n system( lDialogString ) ;\n\n if (!(lIn = fopen(lString, \"r\")))\n {\n remove(lString);\n return NULL;\n }\n while (fgets(aoBuff, MAX_PATH_OR_CMD, lIn) != NULL)\n {}\n fclose(lIn);\n remove(lString);\n replaceChr( aoBuff , '/' , '\\\\' ) ;\n /* printf( \"aoBuff: %s\\n\" , aoBuff ) ; */\n return aoBuff;\n}\n\nstatic void writeUtf8( char const * aUtf8String )\n{\n\tunsigned long lNum;\n\tvoid * lConsoleHandle;\n\twchar_t * lTmpWChar;\n\n\tlConsoleHandle = GetStdHandle(STD_OUTPUT_HANDLE);\n\tlTmpWChar = tinyfd_utf8to16(aUtf8String);\n\t(void)WriteConsoleW(lConsoleHandle, lTmpWChar, wcslen(lTmpWChar), &lNum, NULL);\n}\n\n\nint tinyfd_messageBox(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n and \\t */\n char const * aDialogType , /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n char const * aIconType , /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n char lChar ;\n\t\tUINT lOriginalCP;\n\t\tUINT lOriginalOutputCP;\n\n#ifndef TINYFD_NOLIB\n if ((!tinyfd_forceConsole || !(GetConsoleWindow() || dialogPresent()))\n && (!getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\")))\n {\n if (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"windows\"); return 1; }\n if (tinyfd_winUtf8)\n {\n return messageBoxWinGui8(\n aTitle, aMessage, aDialogType, aIconType, aDefaultButton);\n }\n else\n {\n return messageBoxWinGuiA(\n aTitle, aMessage, aDialogType, aIconType, aDefaultButton);\n }\n }\n else\n#endif /* TINYFD_NOLIB */\n if ( dialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return 0;}\n return messageBoxWinConsole(\n aTitle,aMessage,aDialogType,aIconType,aDefaultButton);\n }\n else\n {\n\t\t\tif (!tinyfd_winUtf8)\n\t\t\t{\n\t\t\t\tlOriginalCP = GetConsoleCP();\n\t\t\t\tlOriginalOutputCP = GetConsoleOutputCP();\n\t\t\t\t(void)SetConsoleCP(GetACP());\n\t\t\t\t(void)SetConsoleOutputCP(GetACP());\n\t\t\t}\n\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return 0;}\n if (!gWarningDisplayed && !tinyfd_forceConsole )\n {\n gWarningDisplayed = 1;\n printf(\"\\n\\n%s\\n\", gTitle);\n printf(\"%s\\n\\n\", tinyfd_needs);\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n\t\t\t\t\tprintf(\"\\n\");\n\t\t\t\t\tif (tinyfd_winUtf8) writeUtf8(aTitle);\n\t\t\t\t\telse printf(\"%s\", aTitle);\n\t\t\t\t\tprintf(\"\\n\\n\");\n\t\t\t\t}\n if ( aDialogType && !strcmp(\"yesno\",aDialogType) )\n {\n do\n {\n if ( aMessage && strlen(aMessage) )\n {\n\t\t\t\t\t\t\t\t\tif (tinyfd_winUtf8) writeUtf8(aMessage);\n\t\t\t\t\t\t\t\t\telse printf(\"%s\",aMessage);\n\t\t\t\t\t\t\t\t\tprintf(\"\\n\");\n }\n printf(\"y/n: \");\n lChar = (char) tolower( _getch() ) ;\n printf(\"\\n\\n\");\n }\n while ( lChar != 'y' && lChar != 'n' ) ;\n\t\t\t\t\t\tif (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); }\n return lChar == 'y' ? 1 : 0 ;\n }\n else if ( aDialogType && !strcmp(\"okcancel\",aDialogType) )\n {\n do\n {\n if ( aMessage && strlen(aMessage) )\n {\n\t\t\t\t\t\t\t\t\tif (tinyfd_winUtf8) writeUtf8(aMessage);\n\t\t\t\t\t\t\t\t\telse printf(\"%s\", aMessage);\n\t\t\t\t\t\t\t\t\tprintf(\"\\n\");\n }\n printf(\"[O]kay/[C]ancel: \");\n lChar = (char) tolower( _getch() ) ;\n printf(\"\\n\\n\");\n }\n while ( lChar != 'o' && lChar != 'c' ) ;\n\t\t\t\t\t\tif (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); }\n return lChar == 'o' ? 1 : 0 ;\n }\n else if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n do\n {\n if (aMessage && strlen(aMessage))\n {\n\t\t\t\t\t\t\t\t\tif (tinyfd_winUtf8) writeUtf8(aMessage);\n\t\t\t\t\t\t\t\t\telse printf(\"%s\", aMessage);\n\t\t\t\t\t\t\t\t\tprintf(\"\\n\");\n }\n printf(\"[Y]es/[N]o/[C]ancel: \");\n lChar = (char)tolower(_getch());\n printf(\"\\n\\n\");\n } while (lChar != 'y' && lChar != 'n' && lChar != 'c');\n\t\t\t\t\t\tif (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); }\n return (lChar == 'y') ? 1 : (lChar == 'n') ? 2 : 0 ;\n }\n else\n {\n if ( aMessage && strlen(aMessage) )\n {\n\t\t\t\t\t\t\tif (tinyfd_winUtf8) writeUtf8(aMessage);\n\t\t\t\t\t\t\telse printf(\"%s\", aMessage);\n\t\t\t\t\t\t\tprintf(\"\\n\\n\");\n }\n printf(\"press enter to continue \");\n lChar = (char) _getch() ;\n printf(\"\\n\\n\");\n\t\t\t\t\t\tif (!tinyfd_winUtf8) { (void)SetConsoleCP(lOriginalCP); (void)SetConsoleOutputCP(lOriginalOutputCP); }\n return 1 ;\n }\n\t\t}\n}\n\n\n/* return has only meaning for tinyfd_query */\nint tinyfd_notifyPopup(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n \\t */\n char const * aIconType ) /* \"info\" \"warning\" \"error\" */\n{\n#ifndef TINYFD_NOLIB\n if ((!tinyfd_forceConsole || !(\n GetConsoleWindow() ||\n dialogPresent()))\n && ( !getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\") ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return 1;}\n return notifyWinGui(aTitle, aMessage, aIconType);\n }\n else\n#endif /* TINYFD_NOLIB */\n\t\treturn tinyfd_messageBox(aTitle, aMessage, \"ok\" , aIconType, 0);\n}\n\n\n/* returns NULL on cancel */\nchar * tinyfd_inputBox(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may NOT contain \\n nor \\t */\n char const * aDefaultInput ) /* \"\" , if NULL it's a passwordBox */\n{\n\tstatic char lBuff[MAX_PATH_OR_CMD] = \"\";\n\tchar * lEOF;\n\n\tDWORD mode = 0;\n\tHANDLE hStdin = GetStdHandle(STD_INPUT_HANDLE);\n\n\tunsigned long lNum;\n\tvoid * lConsoleHandle;\n\tchar * lTmpChar;\n\twchar_t lBuffW[1024];\n\n\tUINT lOriginalCP;\n\tUINT lOriginalOutputCP;\n\n\n\t\tif (!aTitle && !aMessage && !aDefaultInput) return lBuff; /* now I can fill lBuff from outside */\n\n#ifndef TINYFD_NOLIB\n mode = 0;\n hStdin = GetStdHandle(STD_INPUT_HANDLE);\n\n if ((!tinyfd_forceConsole || !(\n GetConsoleWindow() ||\n dialogPresent()))\n && ( !getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\") ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return (char *)1;}\n lBuff[0]='\\0';\n\t\t\t\tif (inputBoxWinGui(lBuff, aTitle, aMessage, aDefaultInput)) return lBuff;\n\t\t\t\telse return NULL;\n\t\t}\n else\n#endif /* TINYFD_NOLIB */\n if ( dialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n lBuff[0]='\\0';\n\t\t\t\tif (inputBoxWinConsole(lBuff, aTitle, aMessage, aDefaultInput) ) return lBuff;\n\t\t\t\telse return NULL;\n\t\t}\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return (char *)0;}\n lBuff[0]='\\0';\n if (!gWarningDisplayed && !tinyfd_forceConsole)\n {\n gWarningDisplayed = 1 ;\n printf(\"\\n\\n%s\\n\", gTitle);\n printf(\"%s\\n\\n\", tinyfd_needs);\n }\n\n\t if (!tinyfd_winUtf8)\n\t {\n\t\t lOriginalCP = GetConsoleCP();\n\t\t lOriginalOutputCP = GetConsoleOutputCP();\n\t\t (void)SetConsoleCP(GetACP());\n\t\t (void)SetConsoleOutputCP(GetACP());\n\t }\n\n\t if (aTitle && strlen(aTitle))\n {\n\t\tprintf(\"\\n\");\n\t\tif (tinyfd_winUtf8) writeUtf8(aTitle);\n\t\telse printf(\"%s\", aTitle);\n\t\tprintf(\"\\n\\n\");\n\t }\n if ( aMessage && strlen(aMessage) )\n {\n\t\tif (tinyfd_winUtf8) writeUtf8(aMessage);\n\t\telse printf(\"%s\", aMessage);\n\t\tprintf(\"\\n\");\n }\n printf(\"(ctrl-Z + enter to cancel): \");\n if ( ! aDefaultInput )\n {\n\t\t (void) GetConsoleMode(hStdin, &mode);\n\t\t (void) SetConsoleMode(hStdin, mode & (~ENABLE_ECHO_INPUT));\n }\n\t if (tinyfd_winUtf8)\n\t {\n\t\t \tlConsoleHandle = GetStdHandle(STD_INPUT_HANDLE);\n\t\t\t(void) ReadConsoleW(lConsoleHandle, lBuffW, MAX_PATH_OR_CMD, &lNum, NULL);\n\t\t\tif (!aDefaultInput)\n\t\t\t{\n\t\t\t\t(void)SetConsoleMode(hStdin, mode);\n\t\t\t\tprintf(\"\\n\");\n\t\t\t}\n\t\t\tlBuffW[lNum] = '\\0';\n\t\t\tif (lBuffW[wcslen(lBuffW) - 1] == '\\n') lBuffW[wcslen(lBuffW) - 1] = '\\0';\n\t\t\tif (lBuffW[wcslen(lBuffW) - 1] == '\\r') lBuffW[wcslen(lBuffW) - 1] = '\\0';\n\t\t\tlTmpChar = tinyfd_utf16to8(lBuffW);\n\t\t\tif (lTmpChar)\n\t\t\t{\n\t\t\t\tstrcpy(lBuff, lTmpChar);\n\t\t\t\treturn lBuff;\n\t\t\t}\n\t\t\telse\n\t\t\t\treturn NULL;\n\t }\n\t else\n\t {\n\t\t lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin);\n\t\t if (!aDefaultInput)\n\t\t {\n\t\t\t (void)SetConsoleMode(hStdin, mode);\n\t\t\t printf(\"\\n\");\n\t\t }\n\n\t\t if (!tinyfd_winUtf8)\n\t\t {\n\t\t\t (void)SetConsoleCP(lOriginalCP);\n\t\t\t (void)SetConsoleOutputCP(lOriginalOutputCP);\n\t\t }\n\n\t\t if (!lEOF)\n\t\t {\n\t\t\t return NULL;\n\t\t }\n\t\t printf(\"\\n\");\n\t\t if (strchr(lBuff, 27))\n\t\t {\n\t\t\t return NULL;\n\t\t }\n\t\t if (lBuff[strlen(lBuff) - 1] == '\\n')\n\t\t {\n\t\t\t lBuff[strlen(lBuff) - 1] = '\\0';\n\t\t }\n\t\t return lBuff;\n\t }\n }\n}\n\n\nchar * tinyfd_saveFileDialog(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription ) /* NULL or \"image files\" */\n{\n static char lBuff [MAX_PATH_OR_CMD] ;\n char lString[MAX_PATH_OR_CMD] ;\n char * p ;\n\t\tchar * lPointerInputBox;\n lBuff[0]='\\0';\n#ifndef TINYFD_NOLIB\n if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) )\n && ( !getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\") ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return (char *)1;}\n if (tinyfd_winUtf8)\n {\n p = saveFileDialogWinGui8(lBuff,\n aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription);\n }\n else\n {\n p = saveFileDialogWinGuiA(lBuff,\n aTitle, aDefaultPathAndFile, aNumOfFilterPatterns, aFilterPatterns, aSingleFilterDescription);\n }\n }\n\t\telse\n#endif /* TINYFD_NOLIB */\n\t\tif (dialogPresent())\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"dialog\"); return (char *)0; }\n\t\t\tp = saveFileDialogWinConsole(lBuff, aTitle, aDefaultPathAndFile);\n\t\t}\n\t\telse\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"basicinput\"); return (char *)0; }\n\t\t\tstrcpy(lBuff, \"Save file in \");\n\t\t\tstrcat(lBuff, getCurDir());\n\n\t\t\tlPointerInputBox = tinyfd_inputBox(NULL,NULL,NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\tif (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\tp = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\tif (p) strcpy(lBuff, p); else lBuff[0] = '\\0';\n\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */\n\t\t\tp = lBuff;\n\t\t}\n\n\n if ( ! p || ! strlen( p ) )\n {\n return NULL;\n }\n getPathWithoutFinalSlash( lString , p ) ;\n if ( strlen( lString ) && ! dirExists( lString ) )\n {\n return NULL ;\n }\n getLastName(lString,p);\n if ( ! filenameValid(lString) )\n {\n return NULL;\n }\n return p ;\n}\n\n\n/* in case of multiple files, the separator is | */\nchar * tinyfd_openFileDialog(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription , /* NULL or \"image files\" */\n int aAllowMultipleSelects ) /* 0 or 1 */\n{\n\tchar lString[MAX_PATH_OR_CMD];\n\tchar lBuff[MAX_PATH_OR_CMD];\n\tchar * p;\n\tchar * lPointerInputBox;\n\n#ifndef TINYFD_NOLIB\n if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) )\n && ( !getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\") ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return (char *)1;}\n if (tinyfd_winUtf8)\n {\n p = openFileDialogWinGui8( aTitle, aDefaultPathAndFile, aNumOfFilterPatterns,\n aFilterPatterns, aSingleFilterDescription, aAllowMultipleSelects);\n }\n else\n {\n p = openFileDialogWinGuiA( aTitle, aDefaultPathAndFile, aNumOfFilterPatterns,\n aFilterPatterns, aSingleFilterDescription, aAllowMultipleSelects);\n }\n }\n\t\telse\n#endif /* TINYFD_NOLIB */\n\t\tif (dialogPresent())\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"dialog\"); return (char *)0; }\n\t\t\tp = openFileDialogWinConsole(aTitle, aDefaultPathAndFile);\n\t\t}\n\t\telse\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"basicinput\"); return (char *)0; }\n\t\t\tstrcpy(lBuff, \"Open file from \");\n\t\t\tstrcat(lBuff, getCurDir());\n\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\tif (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\tp = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\tif (p) strcpy(lBuff, p); else lBuff[0] = '\\0';\n\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */\n\t\t\tp = lBuff;\n\t\t}\n\n if ( ! p || ! strlen( p ) )\n {\n return NULL;\n }\n if ( aAllowMultipleSelects && strchr(p, '|') )\n {\n p = ensureFilesExist( (char *) p , p ) ;\n }\n else if ( ! fileExists(p) )\n {\n return NULL ;\n }\n /* printf( \"lBuff3: %s\\n\" , p ) ; */\n return p ;\n}\n\n\nchar * tinyfd_selectFolderDialog(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPath ) /* NULL or \"\" */\n{\n\tstatic char lBuff[MAX_PATH_OR_CMD];\n\tchar * p;\n\tchar * lPointerInputBox;\n\tchar lString[MAX_PATH_OR_CMD];\n\n#ifndef TINYFD_NOLIB\n if ( ( !tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent() ) )\n && ( !getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\") ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return (char *)1;}\n if (tinyfd_winUtf8)\n {\n p = selectFolderDialogWinGui8(lBuff, aTitle, aDefaultPath);\n }\n else\n {\n p = selectFolderDialogWinGuiA(lBuff, aTitle, aDefaultPath);\n }\n }\n\t\telse\n#endif /* TINYFD_NOLIB */\n\t\tif (dialogPresent())\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"dialog\"); return (char *)0; }\n\t\t\tp = selectFolderDialogWinConsole(lBuff, aTitle, aDefaultPath);\n\t\t}\n\t\telse\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"basicinput\"); return (char *)0; }\n\t\t\tstrcpy(lBuff, \"Select folder from \");\n\t\t\tstrcat(lBuff, getCurDir());\n\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\tif (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\tp = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\tif (p) strcpy(lBuff, p); else lBuff[0] = '\\0';\n\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */\n\t\t\tp = lBuff;\n\t\t}\n\n if ( ! p || ! strlen( p ) || ! dirExists( p ) )\n {\n return NULL ;\n }\n return p ;\n}\n\n\n/* returns the hexcolor as a string \"#FF0000\" */\n/* aoResultRGB also contains the result */\n/* aDefaultRGB is used only if aDefaultHexRGB is NULL */\n/* aDefaultRGB and aoResultRGB can be the same array */\nchar * tinyfd_colorChooser(\n char const * aTitle, /* NULL or \"\" */\n char const * aDefaultHexRGB, /* NULL or \"#FF0000\"*/\n unsigned char const aDefaultRGB[3], /* { 0 , 255 , 255 } */\n unsigned char aoResultRGB[3]) /* { 0 , 0 , 0 } */\n{\n\tstatic char lDefaultHexRGB[16];\n int i;\n char * p ;\n\tchar * lPointerInputBox;\n\tchar lString[MAX_PATH_OR_CMD];\n\n\tlDefaultHexRGB[0] = '\\0';\n\n#ifndef TINYFD_NOLIB\n if ( (!tinyfd_forceConsole || !( GetConsoleWindow() || dialogPresent()) )\n && (!getenv(\"SSH_CLIENT\") || getenv(\"DISPLAY\")) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"windows\");return (char *)1;}\n if (tinyfd_winUtf8)\n {\n p = colorChooserWinGui8(\n aTitle, aDefaultHexRGB, aDefaultRGB, aoResultRGB);\n\t\t\t\t\t\tstrcpy(lDefaultHexRGB, p);\n }\n else\n {\n p = colorChooserWinGuiA(\n aTitle, aDefaultHexRGB, aDefaultRGB, aoResultRGB);\n\t\t\t\t\t\tstrcpy(lDefaultHexRGB, p);\n\t\t\t\t}\n\t\t\t\treturn lDefaultHexRGB;\n }\n\t\telse\n#endif /* TINYFD_NOLIB */\n\n\t\tif (dialogPresent())\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"dialog\"); return (char *)0; }\n\t\t}\n\t\telse\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle, \"tinyfd_query\")){ strcpy(tinyfd_response, \"basicinput\"); return (char *)0; }\n\t\t}\n\n\t\tif (aDefaultHexRGB)\n\t\t{\n\t\t\tstrncpy(lDefaultHexRGB, aDefaultHexRGB,7);\n\t\t\tlDefaultHexRGB[7]='\\0';\n\t\t}\n\t\telse\n\t\t{\n\t\t\tRGB2Hex(aDefaultRGB, lDefaultHexRGB);\n\t\t}\n\n\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\tif (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\tp = tinyfd_inputBox(aTitle, \"Enter hex rgb color (i.e. #f5ca20)\", lDefaultHexRGB);\n\n if ( !p || (strlen(p) != 7) || (p[0] != '#') )\n {\n return NULL ;\n }\n for ( i = 1 ; i < 7 ; i ++ )\n {\n if ( ! isxdigit( (int) p[i] ) )\n {\n return NULL ;\n }\n }\n Hex2RGB(p,aoResultRGB);\n\n\t\tstrcpy(lDefaultHexRGB, p);\n\n\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */\n\n\t\treturn lDefaultHexRGB;\n}\n\n\n#else /* unix */\n\nstatic char gPython2Name[16];\nstatic char gPython3Name[16];\nstatic char gPythonName[16];\n\nstatic int isDarwin(void)\n{\n static int lsIsDarwin = -1 ;\n struct utsname lUtsname ;\n if ( lsIsDarwin < 0 )\n {\n lsIsDarwin = !uname(&lUtsname) && !strcmp(lUtsname.sysname,\"Darwin\") ;\n }\n return lsIsDarwin ;\n}\n\n\nstatic int dirExists( char const * aDirPath )\n{\n DIR * lDir ;\n if ( ! aDirPath || ! strlen( aDirPath ) )\n return 0 ;\n lDir = opendir( aDirPath ) ;\n if ( ! lDir )\n {\n return 0 ;\n }\n closedir( lDir ) ;\n return 1 ;\n}\n\n\nstatic int detectPresence( char const * aExecutable )\n{\n char lBuff [MAX_PATH_OR_CMD] ;\n char lTestedString [MAX_PATH_OR_CMD] = \"which \" ;\n FILE * lIn ;\n\n strcat( lTestedString , aExecutable ) ;\n strcat( lTestedString, \" 2>/dev/null \");\n lIn = popen( lTestedString , \"r\" ) ;\n if ( ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n && ( ! strchr( lBuff , ':' ) )\n && ( strncmp(lBuff, \"no \", 3) ) )\n { /* present */\n pclose( lIn ) ;\n if (tinyfd_verbose) printf(\"detectPresence %s %d\\n\", aExecutable, 1);\n return 1 ;\n }\n else\n {\n pclose( lIn ) ;\n if (tinyfd_verbose) printf(\"detectPresence %s %d\\n\", aExecutable, 0);\n return 0 ;\n }\n}\n\n\nstatic char * getVersion( char const * aExecutable ) /*version must be first numeral*/\n{\n\tstatic char lBuff [MAX_PATH_OR_CMD] ;\n\tchar lTestedString [MAX_PATH_OR_CMD] ;\n\tFILE * lIn ;\n\tchar * lTmp ;\n\n strcpy( lTestedString , aExecutable ) ;\n strcat( lTestedString , \" --version\" ) ;\n\n lIn = popen( lTestedString , \"r\" ) ;\n lTmp = fgets( lBuff , sizeof( lBuff ) , lIn ) ;\n pclose( lIn ) ;\n\n\tlTmp += strcspn(lTmp,\"0123456789\");\n\t/* printf(\"lTmp:%s\\n\", lTmp); */\n\treturn lTmp ;\n}\n\n\nstatic int * getMajorMinorPatch( char const * aExecutable )\n{\n\tstatic int lArray [3] ;\n\tchar * lTmp ;\n\n\tlTmp = (char *) getVersion(aExecutable);\n\tlArray[0] = atoi( strtok(lTmp,\" ,.-\") ) ;\n\t/* printf(\"lArray0 %d\\n\", lArray[0]); */\n\tlArray[1] = atoi( strtok(0,\" ,.-\") ) ;\n\t/* printf(\"lArray1 %d\\n\", lArray[1]); */\n\tlArray[2] = atoi( strtok(0,\" ,.-\") ) ;\n\t/* printf(\"lArray2 %d\\n\", lArray[2]); */\n\n\tif ( !lArray[0] && !lArray[1] && !lArray[2] ) return NULL;\n\treturn lArray ;\n}\n\n\nstatic int tryCommand( char const * aCommand )\n{\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n\n lIn = popen( aCommand , \"r\" ) ;\n if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL )\n { /* present */\n pclose( lIn ) ;\n return 1 ;\n }\n else\n {\n pclose( lIn ) ;\n return 0 ;\n }\n\n}\n\n\nstatic int isTerminalRunning(void)\n{\n\tstatic int lIsTerminalRunning = -1 ;\n\tif ( lIsTerminalRunning < 0 )\n\t{\n\t\tlIsTerminalRunning = isatty(1);\n\t\tif (tinyfd_verbose) printf(\"isTerminalRunning %d\\n\", lIsTerminalRunning );\n\t}\n\treturn lIsTerminalRunning;\n}\n\n\nstatic char * dialogNameOnly(void)\n{\n\tstatic char lDialogName[128] = \"*\" ;\n\tif ( lDialogName[0] == '*' )\n\t{\n\t\tif (!tinyfd_allowCursesDialogs)\n\t\t{\n\t\t\tstrcpy(lDialogName , \"\" );\n\t\t}\n\t\telse if ( isDarwin() && * strcpy(lDialogName , \"/opt/local/bin/dialog\" )\n\t\t\t&& detectPresence( lDialogName ) )\n\t\t{}\n\t\telse if ( * strcpy(lDialogName , \"dialog\" )\n\t\t\t&& detectPresence( lDialogName ) )\n\t\t{}\n\t\telse\n\t\t{\n\t\t\tstrcpy(lDialogName , \"\" );\n\t\t}\n\t}\n\treturn lDialogName ;\n}\n\n\nint isDialogVersionBetter09b(void)\n{\n char const * lDialogName ;\n char * lVersion ;\n int lMajor ;\n int lMinor ;\n int lDate ;\n int lResult ;\n char * lMinorP ;\n char * lLetter ;\n char lBuff[128] ;\n\n /*char lTest[128] = \" 0.9b-20031126\" ;*/\n\n lDialogName = dialogNameOnly() ;\n if ( ! strlen(lDialogName) || !(lVersion = (char *) getVersion(lDialogName)) ) return 0 ;\n /*lVersion = lTest ;*/\n /*printf(\"lVersion %s\\n\", lVersion);*/\n strcpy(lBuff,lVersion);\n lMajor = atoi( strtok(lVersion,\" ,.-\") ) ;\n /*printf(\"lMajor %d\\n\", lMajor);*/\n lMinorP = strtok(0,\" ,.-abcdefghijklmnopqrstuvxyz\");\n lMinor = atoi( lMinorP ) ;\n /*printf(\"lMinor %d\\n\", lMinor );*/\n lDate = atoi( strtok(0,\" ,.-\") ) ;\n if (lDate<0) lDate = - lDate;\n /*printf(\"lDate %d\\n\", lDate);*/\n lLetter = lMinorP + strlen(lMinorP) ;\n strcpy(lVersion,lBuff);\n strtok(lLetter,\" ,.-\");\n /*printf(\"lLetter %s\\n\", lLetter);*/\n lResult = (lMajor > 0) || ( ( lMinor == 9 ) && (*lLetter == 'b') && (lDate >= 20031126) );\n /*printf(\"lResult %d\\n\", lResult);*/\n return lResult;\n}\n\n\nstatic int whiptailPresentOnly(void)\n{\n static int lWhiptailPresent = -1 ;\n\t\tif (!tinyfd_allowCursesDialogs) return 0;\n if ( lWhiptailPresent < 0 )\n {\n lWhiptailPresent = detectPresence( \"whiptail\" ) ;\n }\n return lWhiptailPresent ;\n}\n\n\nstatic char * terminalName(void)\n{\n static char lTerminalName[128] = \"*\" ;\n char lShellName[64] = \"*\" ;\n int * lArray;\n\n if ( lTerminalName[0] == '*' )\n {\n if ( detectPresence( \"bash\" ) )\n {\n strcpy(lShellName , \"bash -c \" ) ; /*good for basic input*/\n }\n\t\t\t\telse if ( strlen(dialogNameOnly()) || whiptailPresentOnly() )\n\t\t\t\t{\n\t\t\t\t\t\tstrcpy(lShellName , \"sh -c \" ) ; /*good enough for dialog & whiptail*/\n\t\t\t\t}\n\t\t\t\telse\n\t\t\t\t{\n\t\t\t\t\tstrcpy(lTerminalName , \"\" ) ;\n\t\t\t\t\treturn NULL ;\n\t\t\t\t}\n\n if ( isDarwin() )\n {\n\t\t\t\t\tif ( * strcpy(lTerminalName , \"/opt/X11/bin/xterm\" )\n && detectPresence( lTerminalName ) )\n {\n strcat(lTerminalName , \" -fa 'DejaVu Sans Mono' -fs 10 -title tinyfiledialogs -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else\n {\n strcpy(lTerminalName , \"\" ) ;\n }\n }\n else if ( * strcpy(lTerminalName,\"xterm\") /*good (small without parameters)*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -fa 'DejaVu Sans Mono' -fs 10 -title tinyfiledialogs -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"terminator\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -x \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"lxterminal\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"konsole\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"kterm\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"tilix\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"xfce4-terminal\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -x \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"mate-terminal\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -x \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"Eterm\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"evilvte\") /*good*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else if ( * strcpy(lTerminalName,\"pterm\") /*good (only letters)*/\n && detectPresence(lTerminalName) )\n {\n strcat(lTerminalName , \" -e \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n\t\t\t\telse if ( * strcpy(lTerminalName,\"gnome-terminal\")\n && detectPresence(lTerminalName) && (lArray = getMajorMinorPatch(lTerminalName))\n\t\t\t\t&& ((lArray[0]<3) || (lArray[0]==3 && lArray[1]<=6)) )\n {\n strcat(lTerminalName , \" --disable-factory -x \" ) ;\n strcat(lTerminalName , lShellName ) ;\n }\n else\n {\n strcpy(lTerminalName , \"\" ) ;\n }\n /* bad: koi rxterm guake tilda vala-terminal qterminal\n aterm Terminal terminology sakura lilyterm weston-terminal\n roxterm termit xvt rxvt mrxvt urxvt */\n }\n if ( strlen(lTerminalName) )\n {\n return lTerminalName ;\n }\n else\n {\n return NULL ;\n }\n}\n\n\nstatic char * dialogName(void)\n{\n char * lDialogName ;\n lDialogName = dialogNameOnly( ) ;\n if ( strlen(lDialogName) && ( isTerminalRunning() || terminalName() ) )\n {\n return lDialogName ;\n }\n else\n {\n return NULL ;\n }\n}\n\n\nstatic int whiptailPresent(void)\n{\n int lWhiptailPresent ;\n lWhiptailPresent = whiptailPresentOnly( ) ;\n if ( lWhiptailPresent && ( isTerminalRunning() || terminalName() ) )\n {\n return lWhiptailPresent ;\n }\n else\n {\n return 0 ;\n }\n}\n\n\n\nstatic int graphicMode(void)\n{\n return !( tinyfd_forceConsole && (isTerminalRunning() || terminalName()) )\n && ( getenv(\"DISPLAY\")\n || (isDarwin() && (!getenv(\"SSH_TTY\") || getenv(\"DISPLAY\") ) ) ) ;\n}\n\n\nstatic int pactlPresent(void)\n{\n static int lPactlPresent = -1 ;\n if ( lPactlPresent < 0 )\n {\n lPactlPresent = detectPresence(\"pactl\") ;\n }\n return lPactlPresent ;\n}\n\n\nstatic int speakertestPresent(void)\n{\n static int lSpeakertestPresent = -1 ;\n if ( lSpeakertestPresent < 0 )\n {\n lSpeakertestPresent = detectPresence(\"speaker-test\") ;\n }\n return lSpeakertestPresent ;\n}\n\n\nstatic int beepexePresent(void)\n{\n static int lBeepexePresent = -1 ;\n if ( lBeepexePresent < 0 )\n {\n lBeepexePresent = detectPresence(\"beep.exe\") ;\n }\n return lBeepexePresent ;\n}\n\n\nstatic int xmessagePresent(void)\n{\n static int lXmessagePresent = -1 ;\n if ( lXmessagePresent < 0 )\n {\n lXmessagePresent = detectPresence(\"xmessage\");/*if not tty,not on osxpath*/\n }\n return lXmessagePresent && graphicMode( ) ;\n}\n\n\nstatic int gxmessagePresent(void)\n{\n static int lGxmessagePresent = -1 ;\n if ( lGxmessagePresent < 0 )\n {\n lGxmessagePresent = detectPresence(\"gxmessage\") ;\n }\n return lGxmessagePresent && graphicMode( ) ;\n}\n\n\nstatic int gmessagePresent(void)\n{\n static int lGmessagePresent = -1 ;\n if ( lGmessagePresent < 0 )\n {\n lGmessagePresent = detectPresence(\"gmessage\") ;\n }\n return lGmessagePresent && graphicMode( ) ;\n}\n\n\nstatic int notifysendPresent(void)\n{\n static int lNotifysendPresent = -1 ;\n if ( lNotifysendPresent < 0 )\n {\n lNotifysendPresent = detectPresence(\"notify-send\") ;\n }\n return lNotifysendPresent && graphicMode( ) ;\n}\n\n\nstatic int perlPresent(void)\n{\n static int lPerlPresent = -1 ;\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n\n if ( lPerlPresent < 0 )\n {\n lPerlPresent = detectPresence(\"perl\") ;\n if ( lPerlPresent )\n {\n lIn = popen( \"perl -MNet::DBus -e \\\"Net::DBus->session->get_service('org.freedesktop.Notifications')\\\" 2>&1\" , \"r\" ) ;\n if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL )\n {\n lPerlPresent = 2 ;\n }\n pclose( lIn ) ;\n if (tinyfd_verbose) printf(\"perl-dbus %d\\n\", lPerlPresent);\n }\n }\n return graphicMode() ? lPerlPresent : 0 ;\n}\n\n\nstatic int afplayPresent(void)\n{\n static int lAfplayPresent = -1 ;\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n\n if ( lAfplayPresent < 0 )\n {\n lAfplayPresent = detectPresence(\"afplay\") ;\n if ( lAfplayPresent )\n {\n lIn = popen( \"test -e /System/Library/Sounds/Ping.aiff || echo Ping\" , \"r\" ) ;\n if ( fgets( lBuff , sizeof( lBuff ) , lIn ) == NULL )\n {\n lAfplayPresent = 2 ;\n }\n pclose( lIn ) ;\n if (tinyfd_verbose) printf(\"afplay %d\\n\", lAfplayPresent);\n }\n }\n return graphicMode() ? lAfplayPresent : 0 ;\n}\n\n\nstatic int xdialogPresent(void)\n{\n static int lXdialogPresent = -1 ;\n if ( lXdialogPresent < 0 )\n {\n lXdialogPresent = detectPresence(\"Xdialog\") ;\n }\n return lXdialogPresent && graphicMode( ) ;\n}\n\n\nstatic int gdialogPresent(void)\n{\n static int lGdialoglPresent = -1 ;\n if ( lGdialoglPresent < 0 )\n {\n lGdialoglPresent = detectPresence( \"gdialog\" ) ;\n }\n return lGdialoglPresent && graphicMode( ) ;\n}\n\n\nstatic int osascriptPresent(void)\n{\n static int lOsascriptPresent = -1 ;\n if ( lOsascriptPresent < 0 )\n {\n gWarningDisplayed |= !!getenv(\"SSH_TTY\");\n lOsascriptPresent = detectPresence( \"osascript\" ) ;\n }\n return lOsascriptPresent && graphicMode() && !getenv(\"SSH_TTY\") ;\n}\n\n\nstatic int qarmaPresent(void)\n{\n static int lQarmaPresent = -1 ;\n if ( lQarmaPresent < 0 )\n {\n lQarmaPresent = detectPresence(\"qarma\") ;\n }\n return lQarmaPresent && graphicMode( ) ;\n}\n\n\nstatic int matedialogPresent(void)\n{\n static int lMatedialogPresent = -1 ;\n if ( lMatedialogPresent < 0 )\n {\n lMatedialogPresent = detectPresence(\"matedialog\") ;\n }\n return lMatedialogPresent && graphicMode( ) ;\n}\n\n\nstatic int shellementaryPresent(void)\n{\n static int lShellementaryPresent = -1 ;\n if ( lShellementaryPresent < 0 )\n {\n lShellementaryPresent = 0 ; /*detectPresence(\"shellementary\"); shellementary is not ready yet */\n }\n return lShellementaryPresent && graphicMode( ) ;\n}\n\n\nstatic int zenityPresent(void)\n{\n static int lZenityPresent = -1 ;\n if ( lZenityPresent < 0 )\n {\n lZenityPresent = detectPresence(\"zenity\") ;\n }\n return lZenityPresent && graphicMode( ) ;\n}\n\n\nstatic int zenity3Present(void)\n{\n static int lZenity3Present = -1 ;\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n\t\tint lIntTmp ;\n\n if ( lZenity3Present < 0 )\n {\n lZenity3Present = 0 ;\n if ( zenityPresent() )\n {\n lIn = popen( \"zenity --version\" , \"r\" ) ;\n if ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {\n if ( atoi(lBuff) >= 3 )\n {\n lZenity3Present = 3 ;\n\t\t\t\t\t\t\t\t\t\tlIntTmp = atoi(strtok(lBuff,\".\")+2 ) ;\n\t\t\t\t\t\t\t\t\t\tif ( lIntTmp >= 18 )\n\t\t\t\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\t\t\t\tlZenity3Present = 5 ;\n\t\t\t\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\t\t\t\telse if ( lIntTmp >= 10 )\n\t\t\t\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\t\t\t\tlZenity3Present = 4 ;\n\t\t\t\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\t\t}\n else if ( ( atoi(lBuff) == 2 ) && ( atoi(strtok(lBuff,\".\")+2 ) >= 32 ) )\n {\n lZenity3Present = 2 ;\n }\n if (tinyfd_verbose) printf(\"zenity %d\\n\", lZenity3Present);\n }\n pclose( lIn ) ;\n }\n }\n return graphicMode() ? lZenity3Present : 0 ;\n}\n\n\nstatic int kdialogPresent(void)\n{\n\tstatic int lKdialogPresent = -1 ;\n\tchar lBuff [MAX_PATH_OR_CMD] ;\n\tFILE * lIn ;\n\tchar * lDesktop;\n\n\tif ( lKdialogPresent < 0 )\n\t{\n\t\tif ( zenityPresent() )\n\t\t{\n\t\t\tlDesktop = getenv(\"XDG_SESSION_DESKTOP\");\n\t\t\tif ( !lDesktop || ( strcmp(lDesktop, \"KDE\") && strcmp(lDesktop, \"lxqt\") ) )\n\t\t\t{\n\t\t\t\tlKdialogPresent = 0 ;\n\t\t\t\treturn lKdialogPresent ;\n\t\t\t}\n\t\t}\n\n\t\tlKdialogPresent = detectPresence(\"kdialog\") ;\n\t\tif ( lKdialogPresent && !getenv(\"SSH_TTY\") )\n\t\t{\n\t\t\tlIn = popen( \"kdialog --attach 2>&1\" , \"r\" ) ;\n\t\t\tif ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n\t\t\t{\n\t\t\t\tif ( ! strstr( \"Unknown\" , lBuff ) )\n\t\t\t\t{\n\t\t\t\t\tlKdialogPresent = 2 ;\n\t\t\t\t\tif (tinyfd_verbose) printf(\"kdialog-attach %d\\n\", lKdialogPresent);\n\t\t\t\t}\n\t\t\t}\n\t\t\tpclose( lIn ) ;\n\n\t\t\tif (lKdialogPresent == 2)\n\t\t\t{\n\t\t\t\tlKdialogPresent = 1 ;\n\t\t\t\tlIn = popen( \"kdialog --passivepopup 2>&1\" , \"r\" ) ;\n\t\t\t\tif ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n\t\t\t\t{\n\t\t\t\t\tif ( ! strstr( \"Unknown\" , lBuff ) )\n\t\t\t\t\t{\n\t\t\t\t\t\tlKdialogPresent = 2 ;\n\t\t\t\t\t\tif (tinyfd_verbose) printf(\"kdialog-popup %d\\n\", lKdialogPresent);\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tpclose( lIn ) ;\n\t\t\t}\n\t\t}\n\t}\n\treturn graphicMode() ? lKdialogPresent : 0 ;\n}\n\n\nstatic int osx9orBetter(void)\n{\n static int lOsx9orBetter = -1 ;\n char lBuff [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n int V,v;\n\n if ( lOsx9orBetter < 0 )\n {\n lOsx9orBetter = 0 ;\n lIn = popen( \"osascript -e 'set osver to system version of (system info)'\" , \"r\" ) ;\n if ( ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n && ( 2 == sscanf(lBuff, \"%d.%d\", &V, &v) ) )\n {\n V = V * 100 + v;\n if ( V >= 1009 )\n {\n lOsx9orBetter = 1 ;\n }\n }\n pclose( lIn ) ;\n if (tinyfd_verbose) printf(\"Osx10 = %d, %d = %s\\n\", lOsx9orBetter, V, lBuff) ;\n }\n return lOsx9orBetter ;\n}\n\n\nstatic int python3Present(void)\n{\n static int lPython3Present = -1 ;\n int i;\n\n if ( lPython3Present < 0 )\n {\n lPython3Present = 0 ;\n strcpy(gPython3Name , \"python3\" ) ;\n if ( detectPresence(gPython3Name) ) lPython3Present = 1;\n else\n {\n for ( i = 9 ; i >= 0 ; i -- )\n {\n sprintf( gPython3Name , \"python3.%d\" , i ) ;\n if ( detectPresence(gPython3Name) )\n {\n lPython3Present = 1;\n break;\n }\n }\n }\n if (tinyfd_verbose) printf(\"lPython3Present %d\\n\", lPython3Present) ;\n if (tinyfd_verbose) printf(\"gPython3Name %s\\n\", gPython3Name) ;\n }\n\t\treturn lPython3Present ;\n}\n\n\nstatic int python2Present(void)\n{\n\tstatic int lPython2Present = -1 ;\n\tint i;\n\n\tif ( lPython2Present < 0 )\n\t{\n\t\tlPython2Present = 0 ;\n\t\tstrcpy(gPython2Name , \"python2\" ) ;\n\t\tif ( detectPresence(gPython2Name) ) lPython2Present = 1;\n\t\telse\n\t\t{\n\t\t\tfor ( i = 9 ; i >= 0 ; i -- )\n\t\t\t{\n\t\t\t\tsprintf( gPython2Name , \"python2.%d\" , i ) ;\n\t\t\t\tif ( detectPresence(gPython2Name) )\n\t\t\t\t{\n\t\t\t\t\tlPython2Present = 1;\n\t\t\t\t\tbreak;\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t\tif (tinyfd_verbose) printf(\"lPython2Present %d\\n\", lPython2Present) ;\n\t\tif (tinyfd_verbose) printf(\"gPython2Name %s\\n\", gPython2Name) ;\n\t}\n\treturn lPython2Present ;\n}\n\n\nstatic int tkinter3Present(void)\n{\n static int lTkinter3Present = -1 ;\n char lPythonCommand[256];\n char lPythonParams[128] =\n \"-S -c \\\"try:\\n\\timport tkinter;\\nexcept:\\n\\tprint(0);\\\"\";\n\n if ( lTkinter3Present < 0 )\n {\n lTkinter3Present = 0 ;\n if ( python3Present() )\n {\n sprintf( lPythonCommand , \"%s %s\" , gPython3Name , lPythonParams ) ;\n lTkinter3Present = tryCommand(lPythonCommand) ;\n }\n if (tinyfd_verbose) printf(\"lTkinter3Present %d\\n\", lTkinter3Present) ;\n }\n\t\treturn lTkinter3Present && graphicMode() && !(isDarwin() && getenv(\"SSH_TTY\") );\n}\n\n\nstatic int tkinter2Present(void)\n{\n\tstatic int lTkinter2Present = -1 ;\n\tchar lPythonCommand[256];\n\tchar lPythonParams[128] =\n\t\t\"-S -c \\\"try:\\n\\timport Tkinter;\\nexcept:\\n\\tprint 0;\\\"\";\n\n\tif ( lTkinter2Present < 0 )\n\t{\n\t\tlTkinter2Present = 0 ;\n\t\tif ( python2Present() )\n\t\t{\n\t\t\tsprintf( lPythonCommand , \"%s %s\" , gPython2Name , lPythonParams ) ;\n\t\t\tlTkinter2Present = tryCommand(lPythonCommand) ;\n\t\t}\n\t\tif (tinyfd_verbose) printf(\"lTkinter2Present %d\\n\", lTkinter2Present) ;\n\t}\n\treturn lTkinter2Present && graphicMode() && !(isDarwin() && getenv(\"SSH_TTY\") );\n}\n\n\nstatic int pythonDbusPresent(void)\n{\n static int lDbusPresent = -1 ;\n char lPythonCommand[384];\n char lPythonParams[256] =\n\"-c \\\"try:\\n\\timport dbus;bus=dbus.SessionBus();\\\nnotif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');\\\nnotify=dbus.Interface(notif,'org.freedesktop.Notifications');\\nexcept:\\n\\tprint(0);\\\"\";\n\n if ( lDbusPresent < 0 )\n {\n lDbusPresent = 0 ;\n if ( python2Present() )\n {\n strcpy(gPythonName , gPython2Name ) ;\n sprintf( lPythonCommand , \"%s %s\" , gPythonName , lPythonParams ) ;\n lDbusPresent = tryCommand(lPythonCommand) ;\n }\n\n if ( ! lDbusPresent && python3Present() )\n {\n strcpy(gPythonName , gPython3Name ) ;\n sprintf( lPythonCommand , \"%s %s\" , gPythonName , lPythonParams ) ;\n lDbusPresent = tryCommand(lPythonCommand) ;\n }\n\n if (tinyfd_verbose) printf(\"lDbusPresent %d\\n\", lDbusPresent) ;\n if (tinyfd_verbose) printf(\"gPythonName %s\\n\", gPythonName) ;\n }\n return lDbusPresent && graphicMode() && !(isDarwin() && getenv(\"SSH_TTY\") );\n}\n\n\nstatic void sigHandler(int sig)\n{\n FILE * lIn ;\n if ( ( lIn = popen( \"pactl unload-module module-sine\" , \"r\" ) ) )\n {\n pclose( lIn ) ;\n }\n}\n\nvoid tinyfd_beep(void)\n{\n char lDialogString [256] ;\n FILE * lIn ;\n\n if ( osascriptPresent() )\n {\n if ( afplayPresent() >= 2 )\n {\n strcpy( lDialogString , \"afplay /System/Library/Sounds/Ping.aiff\") ;\n }\n else\n {\n strcpy( lDialogString , \"osascript -e 'tell application \\\"System Events\\\" to beep'\") ;\n }\n }\n else if ( pactlPresent() )\n {\n signal(SIGINT, sigHandler);\n /*strcpy( lDialogString , \"pactl load-module module-sine frequency=440;sleep .3;pactl unload-module module-sine\" ) ;*/\n strcpy( lDialogString , \"thnum=$(pactl load-module module-sine frequency=440);sleep .3;pactl unload-module $thnum\" ) ;\n }\n else if ( speakertestPresent() )\n {\n /*strcpy( lDialogString , \"timeout -k .3 .3 speaker-test --frequency 440 --test sine > /dev/tty\" ) ;*/\n strcpy( lDialogString , \"( speaker-test -t sine -f 440 > /dev/tty )& pid=$!;sleep .3; kill -9 $pid\" ) ;\n }\n else if ( beepexePresent() )\n {\n strcpy( lDialogString , \"beep.exe 440 300\" ) ;\n }\n else\n {\n strcpy( lDialogString , \"printf '\\a' > /dev/tty\" ) ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n\n if ( ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n pclose( lIn ) ;\n }\n\n if ( pactlPresent() )\n {\n signal(SIGINT, SIG_DFL);\n }\n}\n\n\nint tinyfd_messageBox(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n and \\t */\n char const * aDialogType , /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n char const * aIconType , /* \"info\" \"warning\" \"error\" \"question\" */\n int aDefaultButton ) /* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n{\n char lBuff [MAX_PATH_OR_CMD] ;\n char * lDialogString = NULL ;\n char * lpDialogString;\n FILE * lIn ;\n int lWasGraphicDialog = 0 ;\n int lWasXterm = 0 ;\n int lResult ;\n char lChar ;\n struct termios infoOri;\n struct termios info;\n size_t lTitleLen ;\n size_t lMessageLen ;\n\n lBuff[0]='\\0';\n\n lTitleLen = aTitle ? strlen(aTitle) : 0 ;\n lMessageLen = aMessage ? strlen(aMessage) : 0 ;\n if ( !aTitle || strcmp(aTitle,\"tinyfd_query\") )\n {\n lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen );\n }\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return 1;}\n\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'set {vButton} to {button returned} of ( display dialog \\\"\") ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString, \"\\\" \") ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n strcat(lDialogString, \"with icon \") ;\n if ( aIconType && ! strcmp( \"error\" , aIconType ) )\n {\n strcat(lDialogString, \"stop \" ) ;\n }\n else if ( aIconType && ! strcmp( \"warning\" , aIconType ) )\n {\n strcat(lDialogString, \"caution \" ) ;\n }\n else /* question or info */\n {\n strcat(lDialogString, \"note \" ) ;\n }\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n if ( ! aDefaultButton )\n {\n strcat( lDialogString ,\"default button \\\"Cancel\\\" \" ) ;\n }\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n strcat( lDialogString ,\"buttons {\\\"No\\\", \\\"Yes\\\"} \" ) ;\n if (aDefaultButton)\n {\n strcat( lDialogString ,\"default button \\\"Yes\\\" \" ) ;\n }\n else\n {\n strcat( lDialogString ,\"default button \\\"No\\\" \" ) ;\n }\n strcat( lDialogString ,\"cancel button \\\"No\\\"\" ) ;\n }\n else if ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString ,\"buttons {\\\"No\\\", \\\"Yes\\\", \\\"Cancel\\\"} \" ) ;\n switch (aDefaultButton)\n {\n case 1: strcat( lDialogString ,\"default button \\\"Yes\\\" \" ) ; break;\n case 2: strcat( lDialogString ,\"default button \\\"No\\\" \" ) ; break;\n case 0: strcat( lDialogString ,\"default button \\\"Cancel\\\" \" ) ; break;\n }\n strcat( lDialogString ,\"cancel button \\\"Cancel\\\"\" ) ;\n }\n else\n {\n strcat( lDialogString ,\"buttons {\\\"OK\\\"} \" ) ;\n strcat( lDialogString ,\"default button \\\"OK\\\" \" ) ;\n }\n strcat( lDialogString, \")' \") ;\n\n strcat( lDialogString,\n\"-e 'if vButton is \\\"Yes\\\" then' -e 'return 1'\\\n -e 'else if vButton is \\\"OK\\\" then' -e 'return 1'\\\n -e 'else if vButton is \\\"No\\\" then' -e 'return 2'\\\n -e 'else' -e 'return 0' -e 'end if' \" );\n\n strcat( lDialogString, \"-e 'on error number -128' \" ) ;\n strcat( lDialogString, \"-e '0' \" );\n\n strcat( lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return 1;}\n\n strcpy( lDialogString , \"kdialog\" ) ;\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n\n strcat( lDialogString , \" --\" ) ;\n if ( aDialogType && ( ! strcmp( \"okcancel\" , aDialogType )\n || ! strcmp( \"yesno\" , aDialogType ) || ! strcmp( \"yesnocancel\" , aDialogType ) ) )\n {\n if ( aIconType && ( ! strcmp( \"warning\" , aIconType )\n || ! strcmp( \"error\" , aIconType ) ) )\n {\n strcat( lDialogString , \"warning\" ) ;\n }\n if ( ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString , \"yesnocancel\" ) ;\n }\n else\n {\n strcat( lDialogString , \"yesno\" ) ;\n }\n }\n else if ( aIconType && ! strcmp( \"error\" , aIconType ) )\n {\n strcat( lDialogString , \"error\" ) ;\n }\n else if ( aIconType && ! strcmp( \"warning\" , aIconType ) )\n {\n strcat( lDialogString , \"sorry\" ) ;\n }\n else\n {\n strcat( lDialogString , \"msgbox\" ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aMessage )\n {\n strcat( lDialogString , aMessage ) ;\n }\n strcat( lDialogString , \"\\\"\" ) ;\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n strcat( lDialogString ,\n \" --yes-label Ok --no-label Cancel\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n\n if ( ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString , \"; x=$? ;if [ $x = 0 ] ;then echo 1;elif [ $x = 1 ] ;then echo 2;else echo 0;fi\");\n }\n else\n {\n strcat( lDialogString , \";if [ $? = 0 ];then echo 1;else echo 0;fi\");\n }\n }\n else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return 1;}\n strcpy( lDialogString , \"szAnswer=$(zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return 1;}\n strcpy( lDialogString , \"szAnswer=$(matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return 1;}\n strcpy( lDialogString , \"szAnswer=$(shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return 1;}\n strcpy( lDialogString , \"szAnswer=$(qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat(lDialogString, \" --\");\n\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n strcat( lDialogString ,\n \"question --ok-label=Ok --cancel-label=Cancel\" ) ;\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n strcat( lDialogString , \"question\" ) ;\n }\n else if ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString , \"list --column \\\"\\\" --hide-header \\\"Yes\\\" \\\"No\\\"\" ) ;\n }\n else if ( aIconType && ! strcmp( \"error\" , aIconType ) )\n {\n strcat( lDialogString , \"error\" ) ;\n }\n else if ( aIconType && ! strcmp( \"warning\" , aIconType ) )\n {\n strcat( lDialogString , \"warning\" ) ;\n }\n else\n {\n strcat( lDialogString , \"info\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, \" --no-wrap --text=\\\"\") ;\n strcat(lDialogString, aMessage) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( (zenity3Present() >= 3) || (!zenityPresent() && (shellementaryPresent() || qarmaPresent()) ) )\n {\n strcat( lDialogString , \" --icon-name=dialog-\" ) ;\n if ( aIconType && (! strcmp( \"question\" , aIconType )\n || ! strcmp( \"error\" , aIconType )\n || ! strcmp( \"warning\" , aIconType ) ) )\n {\n strcat( lDialogString , aIconType ) ;\n }\n else\n {\n strcat( lDialogString , \"information\" ) ;\n }\n }\n\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n\n if ( ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString ,\n\");if [ $? = 1 ];then echo 0;elif [ $szAnswer = \\\"No\\\" ];then echo 2;else echo 1;fi\");\n }\n else\n {\n strcat( lDialogString , \");if [ $? = 0 ];then echo 1;else echo 0;fi\");\n }\n }\n\t\telse if ( !gxmessagePresent() && !gmessagePresent() && !gdialogPresent() && !xdialogPresent() && tkinter3Present() )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return 1;}\n\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter;from tkinter import messagebox;root=tkinter.Tk();root.withdraw();\");\n\n\t\t\tstrcat( lDialogString ,\"res=messagebox.\" ) ;\n\t\t\tif ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"askokcancel(\" ) ;\n\t\t\t\tif ( aDefaultButton )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"default=messagebox.OK,\" ) ;\n\t\t\t\t}\n\t\t\t\telse\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"default=messagebox.CANCEL,\" ) ;\n\t\t\t\t}\n\t\t\t}\n\t\t\telse if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"askyesno(\" ) ;\n\t\t\t\tif ( aDefaultButton )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"default=messagebox.YES,\" ) ;\n\t\t\t\t}\n\t\t\t\telse\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"default=messagebox.NO,\" ) ;\n\t\t\t\t}\n\t\t\t}\n\t\t\telse if ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"askyesnocancel(\" ) ;\n\t\t\t\tswitch ( aDefaultButton )\n\t\t\t\t{\n\t\t\t\tcase 1: strcat( lDialogString , \"default=messagebox.YES,\" ); break;\n\t\t\t\tcase 2: strcat( lDialogString , \"default=messagebox.NO,\" ); break;\n\t\t\t\tcase 0: strcat( lDialogString , \"default=messagebox.CANCEL,\" ); break;\n\t\t\t\t}\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"showinfo(\" ) ;\n\t\t\t}\n\n\t\t\tstrcat( lDialogString , \"icon='\" ) ;\n\t\t\tif ( aIconType && (! strcmp( \"question\" , aIconType )\n\t\t\t\t|| ! strcmp( \"error\" , aIconType )\n\t\t\t\t|| ! strcmp( \"warning\" , aIconType ) ) )\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , aIconType ) ;\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"info\" ) ;\n\t\t\t}\n\n\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aMessage && strlen(aMessage) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"message='\") ;\n\t\t\t\tlpDialogString = lDialogString + strlen(lDialogString);\n\t\t\t\treplaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n\t\t\t\tstrcat(lDialogString, \"'\") ;\n\t\t\t}\n\n\t\t\tif ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \");\\n\\\nif res is None :\\n\\tprint(0)\\n\\\nelif res is False :\\n\\tprint(2)\\n\\\nelse :\\n\\tprint 1\\n\\\"\" ) ;\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \");\\n\\\nif res is False :\\n\\tprint(0)\\n\\\nelse :\\n\\tprint(1)\\n\\\"\" ) ;\n\t\t\t}\n\t\t}\n\t\telse if ( !gxmessagePresent() && !gmessagePresent() && !gdialogPresent() && !xdialogPresent() && tkinter2Present() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return 1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n\t\t\t\tstrcat( lDialogString , gPython2Name ) ;\n\t\t\t\tif ( ! isTerminalRunning( ) && isDarwin( ) )\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n\n strcat( lDialogString ,\n\" -S -c \\\"import Tkinter,tkMessageBox;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''/usr/bin/osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set \\\nfrontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n\n strcat( lDialogString ,\"res=tkMessageBox.\" ) ;\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n strcat( lDialogString , \"askokcancel(\" ) ;\n if ( aDefaultButton )\n {\n strcat( lDialogString , \"default=tkMessageBox.OK,\" ) ;\n }\n else\n {\n strcat( lDialogString , \"default=tkMessageBox.CANCEL,\" ) ;\n }\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n strcat( lDialogString , \"askyesno(\" ) ;\n if ( aDefaultButton )\n {\n strcat( lDialogString , \"default=tkMessageBox.YES,\" ) ;\n }\n else\n {\n strcat( lDialogString , \"default=tkMessageBox.NO,\" ) ;\n }\n }\n else if ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat( lDialogString , \"askyesnocancel(\" ) ;\n switch ( aDefaultButton )\n {\n case 1: strcat( lDialogString , \"default=tkMessageBox.YES,\" ); break;\n case 2: strcat( lDialogString , \"default=tkMessageBox.NO,\" ); break;\n case 0: strcat( lDialogString , \"default=tkMessageBox.CANCEL,\" ); break;\n }\n }\n else\n {\n strcat( lDialogString , \"showinfo(\" ) ;\n }\n\n strcat( lDialogString , \"icon='\" ) ;\n if ( aIconType && (! strcmp( \"question\" , aIconType )\n || ! strcmp( \"error\" , aIconType )\n || ! strcmp( \"warning\" , aIconType ) ) )\n {\n strcat( lDialogString , aIconType ) ;\n }\n else\n {\n strcat( lDialogString , \"info\" ) ;\n }\n\n strcat(lDialogString, \"',\") ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, \"message='\") ;\n lpDialogString = lDialogString + strlen(lDialogString);\n replaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n strcat(lDialogString, \"'\") ;\n }\n\n if ( aDialogType && ! strcmp( \"yesnocancel\" , aDialogType ) )\n {\n strcat(lDialogString, \");\\n\\\nif res is None :\\n\\tprint 0\\n\\\nelif res is False :\\n\\tprint 2\\n\\\nelse :\\n\\tprint 1\\n\\\"\" ) ;\n }\n else\n {\n strcat(lDialogString, \");\\n\\\nif res is False :\\n\\tprint 0\\n\\\nelse :\\n\\tprint 1\\n\\\"\" ) ;\n }\n }\n else if ( gxmessagePresent() || gmessagePresent() || (!gdialogPresent() && !xdialogPresent() && xmessagePresent()) )\n {\n if ( gxmessagePresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gxmessage\");return 1;}\n strcpy( lDialogString , \"gxmessage\");\n }\n else if ( gmessagePresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gmessage\");return 1;}\n strcpy( lDialogString , \"gmessage\");\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xmessage\");return 1;}\n strcpy( lDialogString , \"xmessage\");\n }\n\n if ( aDialogType && ! strcmp(\"okcancel\" , aDialogType) )\n {\n strcat( lDialogString , \" -buttons Ok:1,Cancel:0\");\n switch ( aDefaultButton )\n {\n case 1: strcat( lDialogString , \" -default Ok\"); break;\n case 0: strcat( lDialogString , \" -default Cancel\"); break;\n }\n }\n else if ( aDialogType && ! strcmp(\"yesno\" , aDialogType) )\n {\n strcat( lDialogString , \" -buttons Yes:1,No:0\");\n switch ( aDefaultButton )\n {\n case 1: strcat( lDialogString , \" -default Yes\"); break;\n case 0: strcat( lDialogString , \" -default No\"); break;\n }\n }\n else if ( aDialogType && ! strcmp(\"yesnocancel\" , aDialogType) )\n {\n strcat( lDialogString , \" -buttons Yes:1,No:2,Cancel:0\");\n switch ( aDefaultButton )\n {\n case 1: strcat( lDialogString , \" -default Yes\"); break;\n case 2: strcat( lDialogString , \" -default No\"); break;\n case 0: strcat( lDialogString , \" -default Cancel\"); break;\n }\n }\n else\n {\n strcat( lDialogString , \" -buttons Ok:1\");\n strcat( lDialogString , \" -default Ok\");\n }\n\n strcat( lDialogString , \" -center \\\"\");\n if ( aMessage && strlen(aMessage) )\n {\n strcat( lDialogString , aMessage ) ;\n }\n strcat(lDialogString, \"\\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat( lDialogString , \" -title \\\"\");\n strcat( lDialogString , aTitle ) ;\n strcat( lDialogString, \"\\\"\" ) ;\n }\n strcat( lDialogString , \" ; echo $? \");\n }\n else if ( xdialogPresent() || gdialogPresent() || dialogName() || whiptailPresent() )\n {\n if ( gdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gdialog\");return 1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(gdialog \" ) ;\n }\n else if ( xdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return 1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(Xdialog \" ) ;\n }\n else if ( dialogName( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return 0;}\n if ( isTerminalRunning( ) )\n {\n strcpy( lDialogString , \"(dialog \" ) ;\n }\n else\n {\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(\" ) ;\n strcat( lDialogString , dialogName() ) ;\n strcat( lDialogString , \" \" ) ;\n }\n }\n else if ( isTerminalRunning( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"whiptail\");return 0;}\n strcpy( lDialogString , \"(whiptail \" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"whiptail\");return 0;}\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(whiptail \" ) ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( !xdialogPresent() && !gdialogPresent() )\n {\n if ( aDialogType && ( !strcmp( \"okcancel\" , aDialogType ) || !strcmp( \"yesno\" , aDialogType )\n || !strcmp( \"yesnocancel\" , aDialogType ) ) )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString, \"tab: move focus\") ;\n strcat(lDialogString, \"\\\" \") ;\n }\n }\n\n if ( aDialogType && ! strcmp( \"okcancel\" , aDialogType ) )\n {\n if ( ! aDefaultButton )\n {\n strcat( lDialogString , \"--defaultno \" ) ;\n }\n strcat( lDialogString ,\n \"--yes-label \\\"Ok\\\" --no-label \\\"Cancel\\\" --yesno \" ) ;\n }\n else if ( aDialogType && ! strcmp( \"yesno\" , aDialogType ) )\n {\n if ( ! aDefaultButton )\n {\n strcat( lDialogString , \"--defaultno \" ) ;\n }\n strcat( lDialogString , \"--yesno \" ) ;\n }\n else if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n if (!aDefaultButton)\n {\n strcat(lDialogString, \"--defaultno \");\n }\n strcat(lDialogString, \"--menu \");\n }\n else\n {\n strcat( lDialogString , \"--msgbox \" ) ;\n\n }\n strcat( lDialogString , \"\\\"\" ) ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString, \"\\\" \");\n\n if ( lWasGraphicDialog )\n {\n if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n strcat(lDialogString,\"0 60 0 Yes \\\"\\\" No \\\"\\\") 2>/tmp/tinyfd.txt;\\\nif [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\\\ntinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes\") ;\n }\n else\n {\n strcat(lDialogString,\n \"10 60 ) 2>&1;if [ $? = 0 ];then echo 1;else echo 0;fi\");\n }\n }\n else\n {\n if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n strcat(lDialogString,\"0 60 0 Yes \\\"\\\" No \\\"\\\" >/dev/tty ) 2>/tmp/tinyfd.txt;\\\n if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\\\n tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes\") ;\n\n if ( lWasXterm )\n {\n strcat(lDialogString,\" >/tmp/tinyfd0.txt';cat /tmp/tinyfd0.txt\");\n }\n else\n {\n strcat(lDialogString, \"; clear >/dev/tty\") ;\n }\n }\n else\n {\n strcat(lDialogString, \"10 60 >/dev/tty) 2>&1;if [ $? = 0 ];\");\n if ( lWasXterm )\n {\n strcat( lDialogString ,\n\"then\\n\\techo 1\\nelse\\n\\techo 0\\nfi >/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt\");\n }\n else\n {\n strcat(lDialogString,\n \"then echo 1;else echo 0;fi;clear >/dev/tty\");\n }\n }\n }\n }\n else if ( !isTerminalRunning() && terminalName() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return 0;}\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'\" ) ;\n if ( !gWarningDisplayed && !tinyfd_forceConsole)\n {\n gWarningDisplayed = 1 ;\n strcat( lDialogString , \"echo \\\"\" ) ;\n strcat( lDialogString, gTitle) ;\n strcat( lDialogString , \"\\\";\" ) ;\n strcat( lDialogString , \"echo \\\"\" ) ;\n strcat( lDialogString, tinyfd_needs) ;\n strcat( lDialogString , \"\\\";echo;echo;\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat( lDialogString , \"echo \\\"\" ) ;\n strcat( lDialogString, aTitle) ;\n strcat( lDialogString , \"\\\";echo;\" ) ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n strcat( lDialogString , \"echo \\\"\" ) ;\n strcat( lDialogString, aMessage) ;\n strcat( lDialogString , \"\\\"; \" ) ;\n }\n if ( aDialogType && !strcmp(\"yesno\",aDialogType) )\n {\n strcat( lDialogString , \"echo -n \\\"y/n: \\\"; \" ) ;\n strcat( lDialogString , \"stty sane -echo;\" ) ;\n strcat( lDialogString ,\n \"answer=$( while ! head -c 1 | grep -i [ny];do true ;done);\");\n strcat( lDialogString ,\n \"if echo \\\"$answer\\\" | grep -iq \\\"^y\\\";then\\n\");\n strcat( lDialogString , \"\\techo 1\\nelse\\n\\techo 0\\nfi\" ) ;\n }\n else if ( aDialogType && !strcmp(\"okcancel\",aDialogType) )\n {\n strcat( lDialogString , \"echo -n \\\"[O]kay/[C]ancel: \\\"; \" ) ;\n strcat( lDialogString , \"stty sane -echo;\" ) ;\n strcat( lDialogString ,\n \"answer=$( while ! head -c 1 | grep -i [oc];do true ;done);\");\n strcat( lDialogString ,\n \"if echo \\\"$answer\\\" | grep -iq \\\"^o\\\";then\\n\");\n strcat( lDialogString , \"\\techo 1\\nelse\\n\\techo 0\\nfi\" ) ;\n }\n else if ( aDialogType && !strcmp(\"yesnocancel\",aDialogType) )\n {\n strcat( lDialogString , \"echo -n \\\"[Y]es/[N]o/[C]ancel: \\\"; \" ) ;\n strcat( lDialogString , \"stty sane -echo;\" ) ;\n strcat( lDialogString ,\n \"answer=$( while ! head -c 1 | grep -i [nyc];do true ;done);\");\n strcat( lDialogString ,\n \"if echo \\\"$answer\\\" | grep -iq \\\"^y\\\";then\\n\\techo 1\\n\");\n strcat( lDialogString , \"elif echo \\\"$answer\\\" | grep -iq \\\"^n\\\";then\\n\\techo 2\\n\" ) ;\n strcat( lDialogString , \"else\\n\\techo 0\\nfi\" ) ;\n }\n else\n {\n strcat(lDialogString , \"echo -n \\\"press enter to continue \\\"; \");\n strcat( lDialogString , \"stty sane -echo;\" ) ;\n strcat( lDialogString ,\n \"answer=$( while ! head -c 1;do true ;done);echo 1\");\n }\n strcat( lDialogString ,\n \" >/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt\");\n }\n else if ( !isTerminalRunning() && pythonDbusPresent() && !strcmp(\"ok\" , aDialogType) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python-dbus\");return 1;}\n strcpy( lDialogString , gPythonName ) ;\n strcat( lDialogString ,\" -c \\\"import dbus;bus=dbus.SessionBus();\");\n strcat( lDialogString ,\"notif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');\" ) ;\n strcat( lDialogString ,\"notify=dbus.Interface(notif,'org.freedesktop.Notifications');\" ) ;\n strcat( lDialogString ,\"notify.Notify('',0,'\" ) ;\n if ( aIconType && strlen(aIconType) )\n {\n strcat( lDialogString , aIconType ) ;\n }\n strcat(lDialogString, \"','\") ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n }\n strcat(lDialogString, \"','\") ;\n if ( aMessage && strlen(aMessage) )\n {\n lpDialogString = lDialogString + strlen(lDialogString);\n replaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n }\n strcat(lDialogString, \"','','',5000)\\\"\") ;\n }\n else if ( !isTerminalRunning() && (perlPresent() >= 2) && !strcmp(\"ok\" , aDialogType) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"perl-dbus\");return 1;}\n\n\t\t\t\tstrcpy( lDialogString , \"perl -e \\\"use Net::DBus;\\\nmy \\\\$sessionBus = Net::DBus->session;\\\nmy \\\\$notificationsService = \\\\$sessionBus->get_service('org.freedesktop.Notifications');\\\nmy \\\\$notificationsObject = \\\\$notificationsService->get_object('/org/freedesktop/Notifications',\\\n'org.freedesktop.Notifications');\");\n\n\t\t\t\tsprintf( lDialogString + strlen(lDialogString),\n\"my \\\\$notificationId;\\\\$notificationId = \\\\$notificationsObject->Notify(shift, 0, '%s', '%s', '%s', [], {}, -1);\\\" \",\n\t\t\t\t\t\t\taIconType?aIconType:\"\", aTitle?aTitle:\"\", aMessage?aMessage:\"\" ) ;\n }\n else if ( !isTerminalRunning() && notifysendPresent() && !strcmp(\"ok\" , aDialogType) )\n {\n\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"notifysend\");return 1;}\n strcpy( lDialogString , \"notify-send\" ) ;\n if ( aIconType && strlen(aIconType) )\n {\n strcat( lDialogString , \" -i '\" ) ;\n strcat( lDialogString , aIconType ) ;\n strcat( lDialogString , \"'\" ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n strcat( lDialogString , \" | \" ) ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n replaceSubStr( aMessage , \"\\n\\t\" , \" | \" , lBuff ) ;\n replaceSubStr( aMessage , \"\\n\" , \" | \" , lBuff ) ;\n replaceSubStr( aMessage , \"\\t\" , \" \" , lBuff ) ;\n strcat(lDialogString, lBuff) ;\n }\n strcat( lDialogString , \"\\\"\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return 0;}\n if ( !gWarningDisplayed && !tinyfd_forceConsole)\n {\n gWarningDisplayed = 1 ;\n printf(\"\\n\\n%s\\n\", gTitle);\n printf(\"%s\\n\\n\", tinyfd_needs);\n }\n if ( aTitle && strlen(aTitle) )\n {\n printf(\"\\n%s\\n\", aTitle);\n }\n\n tcgetattr(0, &infoOri);\n tcgetattr(0, &info);\n info.c_lflag &= ~ICANON;\n info.c_cc[VMIN] = 1;\n info.c_cc[VTIME] = 0;\n tcsetattr(0, TCSANOW, &info);\n if ( aDialogType && !strcmp(\"yesno\",aDialogType) )\n {\n do\n {\n if ( aMessage && strlen(aMessage) )\n {\n printf(\"\\n%s\\n\",aMessage);\n }\n printf(\"y/n: \"); fflush(stdout);\n lChar = tolower( getchar() ) ;\n printf(\"\\n\\n\");\n }\n while ( lChar != 'y' && lChar != 'n' );\n lResult = lChar == 'y' ? 1 : 0 ;\n }\n else if ( aDialogType && !strcmp(\"okcancel\",aDialogType) )\n {\n do\n {\n if ( aMessage && strlen(aMessage) )\n {\n printf(\"\\n%s\\n\",aMessage);\n }\n printf(\"[O]kay/[C]ancel: \"); fflush(stdout);\n lChar = tolower( getchar() ) ;\n printf(\"\\n\\n\");\n }\n while ( lChar != 'o' && lChar != 'c' );\n lResult = lChar == 'o' ? 1 : 0 ;\n }\n else if ( aDialogType && !strcmp(\"yesnocancel\",aDialogType) )\n {\n do\n {\n if ( aMessage && strlen(aMessage) )\n {\n printf(\"\\n%s\\n\",aMessage);\n }\n printf(\"[Y]es/[N]o/[C]ancel: \"); fflush(stdout);\n lChar = tolower( getchar() ) ;\n printf(\"\\n\\n\");\n }\n while ( lChar != 'y' && lChar != 'n' && lChar != 'c' );\n lResult = (lChar == 'y') ? 1 : (lChar == 'n') ? 2 : 0 ;\n }\n else\n {\n if ( aMessage && strlen(aMessage) )\n {\n printf(\"\\n%s\\n\\n\",aMessage);\n }\n printf(\"press enter to continue \"); fflush(stdout);\n getchar() ;\n printf(\"\\n\\n\");\n lResult = 1 ;\n }\n tcsetattr(0, TCSANOW, &infoOri);\n free(lDialogString);\n return lResult ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n free(lDialogString);\n return 0 ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n\n pclose( lIn ) ;\n\n /* printf( \"lBuff: %s len: %lu \\n\" , lBuff , strlen(lBuff) ) ; */\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff1: %s len: %lu \\n\" , lBuff , strlen(lBuff) ) ; */\n\n if (aDialogType && !strcmp(\"yesnocancel\", aDialogType))\n {\n if ( lBuff[0]=='1' )\n {\n if ( !strcmp( lBuff+1 , \"Yes\" )) strcpy(lBuff,\"1\");\n else if ( !strcmp( lBuff+1 , \"No\" )) strcpy(lBuff,\"2\");\n }\n }\n /* printf( \"lBuff2: %s len: %lu \\n\" , lBuff , strlen(lBuff) ) ; */\n\n lResult = !strcmp( lBuff , \"2\" ) ? 2 : !strcmp( lBuff , \"1\" ) ? 1 : 0;\n\n /* printf( \"lResult: %d\\n\" , lResult ) ; */\n free(lDialogString);\n return lResult ;\n}\n\n\n/* return has only meaning for tinyfd_query */\nint tinyfd_notifyPopup(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may contain \\n and \\t */\n char const * aIconType ) /* \"info\" \"warning\" \"error\" */\n{\n char lBuff[MAX_PATH_OR_CMD];\n char * lDialogString = NULL ;\n char * lpDialogString ;\n FILE * lIn ;\n size_t lTitleLen ;\n size_t lMessageLen ;\n\n if ( getenv(\"SSH_TTY\") )\n {\n return tinyfd_messageBox(aTitle, aMessage, \"ok\", aIconType, 0);\n }\n\n lTitleLen = aTitle ? strlen(aTitle) : 0 ;\n lMessageLen = aMessage ? strlen(aMessage) : 0 ;\n if ( !aTitle || strcmp(aTitle,\"tinyfd_query\") )\n {\n lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen );\n }\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return 1;}\n\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'display notification \\\"\") ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString, \" \\\" \") ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat( lDialogString, \"' -e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return 1;}\n strcpy( lDialogString , \"kdialog\" ) ;\n\n if ( aIconType && strlen(aIconType) )\n {\n strcat( lDialogString , \" --icon '\" ) ;\n strcat( lDialogString , aIconType ) ;\n strcat( lDialogString , \"'\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat( lDialogString , \" --title \\\"\" ) ;\n strcat( lDialogString , aTitle ) ;\n strcat( lDialogString , \"\\\"\" ) ;\n }\n\n strcat( lDialogString , \" --passivepopup\" ) ;\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aMessage )\n {\n strcat( lDialogString , aMessage ) ;\n }\n strcat( lDialogString , \" \\\" 5\" ) ;\n }\n else if ( (zenity3Present()>=5) || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n /* zenity 2.32 & 3.14 has the notification but with a bug: it doesnt return from it */\n /* zenity 3.8 show the notification as an alert ok cancel box */\n if ( zenity3Present()>=5 )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return 1;}\n strcpy( lDialogString , \"zenity\" ) ;\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return 1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return 1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return 1;}\n strcpy( lDialogString , \"qarma\" ) ;\n }\n\n strcat( lDialogString , \" --notification\");\n\n if ( aIconType && strlen( aIconType ) )\n {\n strcat( lDialogString , \" --window-icon '\");\n strcat( lDialogString , aIconType ) ;\n strcat( lDialogString , \"'\" ) ;\n }\n\n strcat( lDialogString , \" --text \\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\n\") ;\n }\n if ( aMessage && strlen( aMessage ) )\n {\n strcat( lDialogString , aMessage ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n }\n else if ( perlPresent() >= 2 )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"perl-dbus\");return 1;}\n\n\t\t\t\tstrcpy( lDialogString , \"perl -e \\\"use Net::DBus;\\\nmy \\\\$sessionBus = Net::DBus->session;\\\nmy \\\\$notificationsService = \\\\$sessionBus->get_service('org.freedesktop.Notifications');\\\nmy \\\\$notificationsObject = \\\\$notificationsService->get_object('/org/freedesktop/Notifications',\\\n'org.freedesktop.Notifications');\");\n\n\t\t\t\tsprintf( lDialogString + strlen(lDialogString) ,\n\"my \\\\$notificationId;\\\\$notificationId = \\\\$notificationsObject->Notify(shift, 0, '%s', '%s', '%s', [], {}, -1);\\\" \",\naIconType?aIconType:\"\", aTitle?aTitle:\"\", aMessage?aMessage:\"\" ) ;\n }\n else if ( pythonDbusPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python-dbus\");return 1;}\n strcpy( lDialogString , gPythonName ) ;\n strcat( lDialogString ,\" -c \\\"import dbus;bus=dbus.SessionBus();\");\n strcat( lDialogString ,\"notif=bus.get_object('org.freedesktop.Notifications','/org/freedesktop/Notifications');\" ) ;\n strcat( lDialogString ,\"notify=dbus.Interface(notif,'org.freedesktop.Notifications');\" ) ;\n strcat( lDialogString ,\"notify.Notify('',0,'\" ) ;\n if ( aIconType && strlen(aIconType) )\n {\n strcat( lDialogString , aIconType ) ;\n }\n strcat(lDialogString, \"','\") ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n }\n strcat(lDialogString, \"','\") ;\n if ( aMessage && strlen(aMessage) )\n {\n lpDialogString = lDialogString + strlen(lDialogString);\n replaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n }\n strcat(lDialogString, \"','','',5000)\\\"\") ;\n }\n else if ( notifysendPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"notifysend\");return 1;}\n strcpy( lDialogString , \"notify-send\" ) ;\n if ( aIconType && strlen(aIconType) )\n {\n strcat( lDialogString , \" -i '\" ) ;\n strcat( lDialogString , aIconType ) ;\n strcat( lDialogString , \"'\" ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n strcat( lDialogString , \" | \" ) ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n replaceSubStr( aMessage , \"\\n\\t\" , \" | \" , lBuff ) ;\n replaceSubStr( aMessage , \"\\n\" , \" | \" , lBuff ) ;\n replaceSubStr( aMessage , \"\\t\" , \" \" , lBuff ) ;\n strcat(lDialogString, lBuff) ;\n }\n strcat( lDialogString , \"\\\"\" ) ;\n }\n else\n {\n return tinyfd_messageBox(aTitle, aMessage, \"ok\", aIconType, 0);\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n free(lDialogString);\n return 0 ;\n }\n\n pclose( lIn ) ;\n free(lDialogString);\n return 1;\n}\n\n\n/* returns NULL on cancel */\nchar * tinyfd_inputBox(\n char const * aTitle , /* NULL or \"\" */\n char const * aMessage , /* NULL or \"\" may NOT contain \\n nor \\t */\n char const * aDefaultInput ) /* \"\" , if NULL it's a passwordBox */\n{\n static char lBuff[MAX_PATH_OR_CMD];\n char * lDialogString = NULL;\n char * lpDialogString;\n FILE * lIn ;\n int lResult ;\n int lWasGdialog = 0 ;\n int lWasGraphicDialog = 0 ;\n int lWasXterm = 0 ;\n int lWasBasicXterm = 0 ;\n struct termios oldt ;\n struct termios newt ;\n char * lEOF;\n size_t lTitleLen ;\n size_t lMessageLen ;\n\n\t\tif (!aTitle && !aMessage && !aDefaultInput) return lBuff; /* now I can fill lBuff from outside */\n\n lBuff[0]='\\0';\n\n lTitleLen = aTitle ? strlen(aTitle) : 0 ;\n lMessageLen = aMessage ? strlen(aMessage) : 0 ;\n if ( !aTitle || strcmp(aTitle,\"tinyfd_query\") )\n {\n lDialogString = (char *) malloc( MAX_PATH_OR_CMD + lTitleLen + lMessageLen );\n }\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return (char *)1;}\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'display dialog \\\"\") ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString, \"\\\" \") ;\n strcat(lDialogString, \"default answer \\\"\") ;\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat(lDialogString, aDefaultInput) ;\n }\n strcat(lDialogString, \"\\\" \") ;\n if ( ! aDefaultInput )\n {\n strcat(lDialogString, \"hidden answer true \") ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n strcat(lDialogString, \"with icon note' \") ;\n strcat(lDialogString, \"-e '\\\"1\\\" & text returned of result' \" );\n strcat(lDialogString, \"-e 'on error number -128' \" ) ;\n strcat(lDialogString, \"-e '0' \" );\n strcat(lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat(lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(kdialog\" ) ;\n\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n\n if ( ! aDefaultInput )\n {\n strcat(lDialogString, \" --password \") ;\n }\n else\n {\n strcat(lDialogString, \" --inputbox \") ;\n\n }\n strcat(lDialogString, \"\\\"\") ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage ) ;\n }\n strcat(lDialogString , \"\\\" \\\"\" ) ;\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat(lDialogString, aDefaultInput ) ;\n }\n strcat(lDialogString , \"\\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n strcat( lDialogString ,\n \");if [ $? = 0 ];then echo 1$szAnswer;else echo 0$szAnswer;fi\");\n }\n else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat( lDialogString ,\" --entry\" ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, \" --text=\\\"\") ;\n strcat(lDialogString, aMessage) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat(lDialogString, \" --entry-text=\\\"\") ;\n strcat(lDialogString, aDefaultInput) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n else\n {\n strcat(lDialogString, \" --hide-text\") ;\n }\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n strcat( lDialogString ,\n \");if [ $? = 0 ];then echo 1$szAnswer;else echo 0$szAnswer;fi\");\n }\n else if ( gxmessagePresent() || gmessagePresent() )\n {\n if ( gxmessagePresent() ) {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gxmessage\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(gxmessage -buttons Ok:1,Cancel:0 -center \\\"\");\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gmessage\");return (char *)1;}\n strcpy( lDialogString , \"szAnswer=$(gmessage -buttons Ok:1,Cancel:0 -center \\\"\");\n }\n\n if ( aMessage && strlen(aMessage) )\n {\n strcat( lDialogString , aMessage ) ;\n }\n strcat(lDialogString, \"\\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat( lDialogString , \" -title \\\"\");\n strcat( lDialogString , aTitle ) ;\n strcat(lDialogString, \"\\\" \" ) ;\n }\n strcat(lDialogString, \" -entrytext \\\"\" ) ;\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat( lDialogString , aDefaultInput ) ;\n }\n strcat(lDialogString, \"\\\"\" ) ;\n strcat( lDialogString , \");echo $?$szAnswer\");\n }\n\t\telse if ( !gdialogPresent() && !xdialogPresent() && tkinter3Present( ) )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return (char *)1;}\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter; from tkinter import simpledialog;root=tkinter.Tk();root.withdraw();\");\n\t\t\tstrcat( lDialogString ,\"res=simpledialog.askstring(\" ) ;\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aMessage && strlen(aMessage) )\n\t\t\t{\n\n\t\t\t\tstrcat(lDialogString, \"prompt='\") ;\n\t\t\t\tlpDialogString = lDialogString + strlen(lDialogString);\n\t\t\t\treplaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aDefaultInput )\n\t\t\t{\n\t\t\t\tif ( strlen(aDefaultInput) )\n\t\t\t\t{\n\t\t\t\t\tstrcat(lDialogString, \"initialvalue='\") ;\n\t\t\t\t\tstrcat(lDialogString, aDefaultInput) ;\n\t\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t\t}\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"show='*'\") ;\n\t\t\t}\n\t\t\tstrcat(lDialogString, \");\\nif res is None :\\n\\tprint(0)\");\n\t\t\tstrcat(lDialogString, \"\\nelse :\\n\\tprint('1'+res)\\n\\\"\" ) ;\n\t\t}\n\t\telse if ( !gdialogPresent() && !xdialogPresent() && tkinter2Present( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return (char *)1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n\t\t\t\tstrcat( lDialogString , gPython2Name ) ;\n\t\t\t\tif ( ! isTerminalRunning( ) && isDarwin( ) )\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n\n\t\t\t\tstrcat( lDialogString ,\n\t\t\t\t\t\" -S -c \\\"import Tkinter,tkSimpleDialog;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''/usr/bin/osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set \\\nfrontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n\n strcat( lDialogString ,\"res=tkSimpleDialog.askstring(\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aMessage && strlen(aMessage) )\n {\n\n strcat(lDialogString, \"prompt='\") ;\n lpDialogString = lDialogString + strlen(lDialogString);\n replaceSubStr( aMessage , \"\\n\" , \"\\\\n\" , lpDialogString ) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aDefaultInput )\n {\n if ( strlen(aDefaultInput) )\n {\n strcat(lDialogString, \"initialvalue='\") ;\n strcat(lDialogString, aDefaultInput) ;\n strcat(lDialogString, \"',\") ;\n }\n }\n else\n {\n strcat(lDialogString, \"show='*'\") ;\n }\n strcat(lDialogString, \");\\nif res is None :\\n\\tprint 0\");\n strcat(lDialogString, \"\\nelse :\\n\\tprint '1'+res\\n\\\"\" ) ;\n }\n else if ( gdialogPresent() || xdialogPresent() || dialogName() || whiptailPresent() )\n {\n if ( gdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"gdialog\");return (char *)1;}\n lWasGraphicDialog = 1 ;\n lWasGdialog = 1 ;\n strcpy( lDialogString , \"(gdialog \" ) ;\n }\n else if ( xdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return (char *)1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(Xdialog \" ) ;\n }\n else if ( dialogName( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n if ( isTerminalRunning( ) )\n {\n strcpy( lDialogString , \"(dialog \" ) ;\n }\n else\n {\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(\" ) ;\n strcat( lDialogString , dialogName() ) ;\n strcat( lDialogString , \" \" ) ;\n }\n }\n else if ( isTerminalRunning( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"whiptail\");return (char *)0;}\n strcpy( lDialogString , \"(whiptail \" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"whiptail\");return (char *)0;}\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(whiptail \" ) ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( !xdialogPresent() && !gdialogPresent() )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString, \"tab: move focus\") ;\n if ( ! aDefaultInput && !lWasGdialog )\n {\n strcat(lDialogString, \" (sometimes nothing, no blink nor star, is shown in text field)\") ;\n }\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( aDefaultInput || lWasGdialog )\n {\n strcat( lDialogString , \"--inputbox\" ) ;\n }\n else\n {\n if ( !lWasGraphicDialog && dialogName() && isDialogVersionBetter09b() )\n {\n strcat( lDialogString , \"--insecure \" ) ;\n }\n strcat( lDialogString , \"--passwordbox\" ) ;\n }\n strcat( lDialogString , \" \\\"\" ) ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat(lDialogString, aMessage) ;\n }\n strcat(lDialogString,\"\\\" 10 60 \") ;\n if ( aDefaultInput && strlen(aDefaultInput) )\n {\n strcat(lDialogString, \"\\\"\") ;\n strcat(lDialogString, aDefaultInput) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n if ( lWasGraphicDialog )\n {\n strcat(lDialogString,\") 2>/tmp/tinyfd.txt;\\\n if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\\\n tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes\") ;\n }\n else\n {\n strcat(lDialogString,\">/dev/tty ) 2>/tmp/tinyfd.txt;\\\n if [ $? = 0 ];then tinyfdBool=1;else tinyfdBool=0;fi;\\\n tinyfdRes=$(cat /tmp/tinyfd.txt);echo $tinyfdBool$tinyfdRes\") ;\n\n if ( lWasXterm )\n {\n strcat(lDialogString,\" >/tmp/tinyfd0.txt';cat /tmp/tinyfd0.txt\");\n }\n else\n {\n strcat(lDialogString, \"; clear >/dev/tty\") ;\n }\n }\n }\n else if ( ! isTerminalRunning( ) && terminalName() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return (char *)0;}\n lWasBasicXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'\" ) ;\n if ( !gWarningDisplayed && !tinyfd_forceConsole)\n {\n\t\t\t\t\tgWarningDisplayed = 1 ;\n\t\t\t\t\ttinyfd_messageBox(gTitle,tinyfd_needs,\"ok\",\"warning\",0);\n }\n if ( aTitle && strlen(aTitle) && !tinyfd_forceConsole)\n {\n strcat( lDialogString , \"echo \\\"\" ) ;\n strcat( lDialogString, aTitle) ;\n strcat( lDialogString , \"\\\";echo;\" ) ;\n }\n\n strcat( lDialogString , \"echo \\\"\" ) ;\n if ( aMessage && strlen(aMessage) )\n {\n strcat( lDialogString, aMessage) ;\n }\n strcat( lDialogString , \"\\\";read \" ) ;\n if ( ! aDefaultInput )\n {\n strcat( lDialogString , \"-s \" ) ;\n }\n strcat( lDialogString , \"-p \\\"\" ) ;\n strcat( lDialogString , \"(esc+enter to cancel): \\\" ANSWER \" ) ;\n strcat( lDialogString , \";echo 1$ANSWER >/tmp/tinyfd.txt';\" ) ;\n strcat( lDialogString , \"cat -v /tmp/tinyfd.txt\");\n }\n else if ( !gWarningDisplayed && ! isTerminalRunning( ) && ! terminalName() ) {\n\t\t\tgWarningDisplayed = 1 ;\n\t\t\ttinyfd_messageBox(gTitle,tinyfd_needs,\"ok\",\"warning\",0);\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"no_solution\");return (char *)0;}\n\t\t\tfree(lDialogString);\n\t\t\treturn NULL;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"basicinput\");return (char *)0;}\n if ( !gWarningDisplayed && !tinyfd_forceConsole)\n {\n gWarningDisplayed = 1 ;\n tinyfd_messageBox(gTitle,tinyfd_needs,\"ok\",\"warning\",0);\n }\n if ( aTitle && strlen(aTitle) )\n {\n printf(\"\\n%s\\n\", aTitle);\n }\n if ( aMessage && strlen(aMessage) )\n {\n printf(\"\\n%s\\n\",aMessage);\n }\n printf(\"(esc+enter to cancel): \"); fflush(stdout);\n if ( ! aDefaultInput )\n {\n tcgetattr(STDIN_FILENO, & oldt) ;\n newt = oldt ;\n newt.c_lflag &= ~ECHO ;\n tcsetattr(STDIN_FILENO, TCSANOW, & newt);\n }\n\n lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin);\n /* printf(\"lbuff<%c><%d>\\n\",lBuff[0],lBuff[0]); */\n if ( ! lEOF || (lBuff[0] == '\\0') )\n {\n free(lDialogString);\n return NULL;\n }\n\n if ( lBuff[0] == '\\n' )\n {\n lEOF = fgets(lBuff, MAX_PATH_OR_CMD, stdin);\n /* printf(\"lbuff<%c><%d>\\n\",lBuff[0],lBuff[0]); */\n if ( ! lEOF || (lBuff[0] == '\\0') )\n {\n free(lDialogString);\n return NULL;\n }\n }\n\n if ( ! aDefaultInput )\n {\n tcsetattr(STDIN_FILENO, TCSANOW, & oldt);\n printf(\"\\n\");\n }\n printf(\"\\n\");\n if ( strchr(lBuff,27) )\n {\n free(lDialogString);\n return NULL ;\n }\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n free(lDialogString);\n return lBuff ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n lIn = popen( lDialogString , \"r\" );\n if ( ! lIn )\n {\n if ( fileExists(\"/tmp/tinyfd.txt\") )\n {\n wipefile(\"/tmp/tinyfd.txt\");\n remove(\"/tmp/tinyfd.txt\");\n }\n if ( fileExists(\"/tmp/tinyfd0.txt\") )\n {\n wipefile(\"/tmp/tinyfd0.txt\");\n remove(\"/tmp/tinyfd0.txt\");\n }\n free(lDialogString);\n return NULL ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n\n pclose( lIn ) ;\n\n if ( fileExists(\"/tmp/tinyfd.txt\") )\n {\n wipefile(\"/tmp/tinyfd.txt\");\n remove(\"/tmp/tinyfd.txt\");\n }\n if ( fileExists(\"/tmp/tinyfd0.txt\") )\n {\n wipefile(\"/tmp/tinyfd0.txt\");\n remove(\"/tmp/tinyfd0.txt\");\n }\n\n /* printf( \"len Buff: %lu\\n\" , strlen(lBuff) ) ; */\n /* printf( \"lBuff0: %s\\n\" , lBuff ) ; */\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff1: %s len: %lu \\n\" , lBuff , strlen(lBuff) ) ; */\n if ( lWasBasicXterm )\n {\n if ( strstr(lBuff,\"^[\") ) /* esc was pressed */\n {\n free(lDialogString);\n return NULL ;\n }\n }\n\n lResult = strncmp( lBuff , \"1\" , 1) ? 0 : 1 ;\n /* printf( \"lResult: %d \\n\" , lResult ) ; */\n if ( ! lResult )\n {\n free(lDialogString);\n return NULL ;\n }\n\n /* printf( \"lBuff+1: %s\\n\" , lBuff+1 ) ; */\n free(lDialogString);\n return lBuff+1 ;\n}\n\n\nchar * tinyfd_saveFileDialog(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription ) /* NULL or \"image files\" */\n{\n static char lBuff [MAX_PATH_OR_CMD] ;\n char lDialogString [MAX_PATH_OR_CMD] ;\n char lString [MAX_PATH_OR_CMD] ;\n int i ;\n int lWasGraphicDialog = 0 ;\n int lWasXterm = 0 ;\n char * p ;\n\t\tchar * lPointerInputBox ;\n FILE * lIn ;\n lBuff[0]='\\0';\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return (char *)1;}\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"Finder\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'POSIX path of ( choose file name \" );\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with prompt \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"default location \\\"\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"\\\" \" ) ;\n }\n getLastName( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"default name \\\"\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"\\\" \" ) ;\n }\n strcat( lDialogString , \")' \" ) ;\n strcat(lDialogString, \"-e 'on error number -128' \" ) ;\n strcat(lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return (char *)1;}\n\n strcpy( lDialogString , \"kdialog\" ) ;\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n strcat( lDialogString , \" --getsavefilename \" ) ;\n\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n if ( aDefaultPathAndFile[0] != '/' )\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n strcat(lDialogString, \"\\\"\") ;\n strcat(lDialogString, aDefaultPathAndFile ) ;\n strcat(lDialogString , \"\\\"\" ) ;\n }\n else\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n\n if ( aNumOfFilterPatterns > 0 )\n {\n strcat(lDialogString , \" \\\"\" ) ;\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \" \" ) ;\n }\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , \" | \" ) ;\n strcat( lDialogString , aSingleFilterDescription ) ;\n }\n strcat( lDialogString , \"\\\"\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n }\n else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return (char *)1;}\n strcpy( lDialogString , \"zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat(lDialogString, \" --file-selection --save --confirm-overwrite\" ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n strcat(lDialogString, \" --filename=\\\"\") ;\n strcat(lDialogString, aDefaultPathAndFile) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aNumOfFilterPatterns > 0 )\n {\n strcat( lDialogString , \" --file-filter='\" ) ;\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , aSingleFilterDescription ) ;\n strcat( lDialogString , \" | \" ) ;\n }\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \" \" ) ;\n }\n strcat( lDialogString , \"' --file-filter='All files | *'\" ) ;\n }\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n }\n\t\telse if ( !xdialogPresent() && tkinter3Present( ) )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return (char *)1;}\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();\");\n\t\t\tstrcat( lDialogString , \"res=filedialog.asksaveasfilename(\");\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n\t\t\t{\n\t\t\t\tgetPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n\t\t\t\tif ( strlen(lString) )\n\t\t\t\t{\n\t\t\t\t\tstrcat(lDialogString, \"initialdir='\") ;\n\t\t\t\t\tstrcat(lDialogString, lString ) ;\n\t\t\t\t\tstrcat(lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t\tgetLastName( lString , aDefaultPathAndFile ) ;\n\t\t\t\tif ( strlen(lString) )\n\t\t\t\t{\n\t\t\t\t\tstrcat(lDialogString, \"initialfile='\") ;\n\t\t\t\t\tstrcat(lDialogString, lString ) ;\n\t\t\t\t\tstrcat(lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t}\n\t\t\tif ( ( aNumOfFilterPatterns > 1 )\n\t\t\t\t|| ( (aNumOfFilterPatterns == 1) /* test because poor osx behaviour */\n\t\t\t\t&& ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString , \"filetypes=(\" ) ;\n\t\t\t\tstrcat( lDialogString , \"('\" ) ;\n\t\t\t\tif ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , aSingleFilterDescription ) ;\n\t\t\t\t}\n\t\t\t\tstrcat( lDialogString , \"',(\" ) ;\n\t\t\t\tfor ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"'\" ) ;\n\t\t\t\t\tstrcat( lDialogString , aFilterPatterns [i] ) ;\n\t\t\t\t\tstrcat( lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t\tstrcat( lDialogString , \")),\" ) ;\n\t\t\t\tstrcat( lDialogString , \"('All files','*'))\" ) ;\n\t\t\t}\n\t\t\tstrcat( lDialogString, \");\\nif not isinstance(res, tuple):\\n\\tprint(res)\\n\\\"\" ) ;\n\t\t}\n\t\telse if ( !xdialogPresent() && tkinter2Present( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return (char *)1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n\t\t\t\tstrcat( lDialogString , gPython2Name ) ;\n\t\t\t\tif ( ! isTerminalRunning( ) && isDarwin( ))\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n strcat( lDialogString ,\n\" -S -c \\\"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''/usr/bin/osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set\\\n frontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n\n strcat( lDialogString , \"res=tkFileDialog.asksaveasfilename(\");\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"initialdir='\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"',\" ) ;\n }\n getLastName( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"initialfile='\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"',\" ) ;\n }\n }\n if ( ( aNumOfFilterPatterns > 1 )\n || ( (aNumOfFilterPatterns == 1) /* test because poor osx behaviour */\n && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) )\n {\n strcat(lDialogString , \"filetypes=(\" ) ;\n strcat( lDialogString , \"('\" ) ;\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , aSingleFilterDescription ) ;\n }\n strcat( lDialogString , \"',(\" ) ;\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , \"'\" ) ;\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \"',\" ) ;\n }\n strcat( lDialogString , \")),\" ) ;\n strcat( lDialogString , \"('All files','*'))\" ) ;\n }\n\t\t\tstrcat( lDialogString, \");\\nif not isinstance(res, tuple):\\n\\tprint res \\n\\\"\" ) ;\n\t\t}\n else if ( xdialogPresent() || dialogName() )\n {\n if ( xdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return (char *)1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(Xdialog \" ) ;\n }\n else if ( isTerminalRunning( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n strcpy( lDialogString , \"(dialog \" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(\" ) ;\n strcat( lDialogString , dialogName() ) ;\n strcat( lDialogString , \" \" ) ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( !xdialogPresent() && !gdialogPresent() )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat( lDialogString , \"--fselect \\\"\" ) ;\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n if ( ! strchr(aDefaultPathAndFile, '/') )\n {\n strcat(lDialogString, \"./\") ;\n }\n strcat(lDialogString, aDefaultPathAndFile) ;\n }\n else if ( ! isTerminalRunning( ) && !lWasGraphicDialog )\n {\n strcat(lDialogString, getenv(\"HOME\")) ;\n strcat(lDialogString, \"/\") ;\n }\n else\n {\n strcat(lDialogString, \"./\") ;\n }\n\n if ( lWasGraphicDialog )\n {\n strcat(lDialogString, \"\\\" 0 60 ) 2>&1 \") ;\n }\n else\n {\n strcat(lDialogString, \"\\\" 0 60 >/dev/tty) \") ;\n if ( lWasXterm )\n {\n strcat( lDialogString ,\n \"2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt\");\n }\n else\n {\n strcat(lDialogString, \"2>&1 ; clear >/dev/tty\") ;\n }\n }\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){return tinyfd_inputBox(aTitle,NULL,NULL);}\n\t\t\t\tstrcpy(lBuff, \"Save file in \");\n\t\t\t\tstrcat(lBuff, getCurDir());\n\t\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\t\tif (lPointerInputBox) strcpy(lString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\t\tp = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\t\tif (p) strcpy(lBuff, p); else lBuff[0] = '\\0';\n\t\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lString); /* restore its previous content to tinyfd_inputBox */\n\t\t\t\tp = lBuff;\n\n\t\t\t\tgetPathWithoutFinalSlash( lString , p ) ;\n if ( strlen( lString ) && ! dirExists( lString ) )\n {\n return NULL ;\n }\n getLastName(lString,p);\n if ( ! strlen(lString) )\n {\n return NULL;\n }\n return p ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n return NULL ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n pclose( lIn ) ;\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n if ( ! strlen(lBuff) )\n {\n return NULL;\n }\n getPathWithoutFinalSlash( lString , lBuff ) ;\n if ( strlen( lString ) && ! dirExists( lString ) )\n {\n return NULL ;\n }\n getLastName(lString,lBuff);\n if ( ! filenameValid(lString) )\n {\n return NULL;\n }\n return lBuff ;\n}\n\n\n/* in case of multiple files, the separator is | */\nchar * tinyfd_openFileDialog(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultPathAndFile , /* NULL or \"\" */\n int aNumOfFilterPatterns , /* 0 */\n char const * const * aFilterPatterns , /* NULL or {\"*.jpg\",\"*.png\"} */\n char const * aSingleFilterDescription , /* NULL or \"image files\" */\n int aAllowMultipleSelects ) /* 0 or 1 */\n{\n char lDialogString [MAX_PATH_OR_CMD] ;\n char lString [MAX_PATH_OR_CMD] ;\n int i ;\n FILE * lIn ;\n char * p ;\n char * p2 ;\n\t\tchar * lPointerInputBox ;\n int lWasKdialog = 0 ;\n int lWasGraphicDialog = 0 ;\n int lWasXterm = 0 ;\n\t\tsize_t lFullBuffLen ;\n\t\tstatic char * lBuff = NULL;\n\n\t\tfree(lBuff);\n\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\"))\n\t\t{\n\t\t\tlBuff = NULL;\n\t\t}\n\t\telse\n\t\t{\n\t\t\tif (aAllowMultipleSelects)\n\t\t\t{\n\t\t\t\tlFullBuffLen = MAX_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\t\tlBuff = (char *)(malloc(lFullBuffLen * sizeof(char)));\n\t\t\t\tif (!lBuff)\n\t\t\t\t{\n\t\t\t\t\tlFullBuffLen = LOW_MULTIPLE_FILES * MAX_PATH_OR_CMD + 1;\n\t\t\t\t\tlBuff = (char *)( malloc( lFullBuffLen * sizeof(char)));\n\t\t\t\t}\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\tlFullBuffLen = MAX_PATH_OR_CMD + 1;\n\t\t\t\tlBuff = (char *)(malloc(lFullBuffLen * sizeof(char)));\n\t\t\t}\n\t\t\tif (!lBuff) return NULL;\n\t\t\tlBuff[0]='\\0';\n\t\t}\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return (char *)1;}\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e '\" );\n if ( ! aAllowMultipleSelects )\n {\n\n\n strcat( lDialogString , \"POSIX path of ( \" );\n }\n else\n {\n strcat( lDialogString , \"set mylist to \" );\n }\n strcat( lDialogString , \"choose file \" );\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with prompt \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"default location \\\"\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"\\\" \" ) ;\n }\n if ( aNumOfFilterPatterns > 0 )\n {\n strcat(lDialogString , \"of type {\\\"\" );\n strcat( lDialogString , aFilterPatterns [0] + 2 ) ;\n strcat( lDialogString , \"\\\"\" ) ;\n for ( i = 1 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , \",\\\"\" ) ;\n strcat( lDialogString , aFilterPatterns [i] + 2) ;\n strcat( lDialogString , \"\\\"\" ) ;\n }\n strcat( lDialogString , \"} \" ) ;\n }\n if ( aAllowMultipleSelects )\n {\n strcat( lDialogString , \"multiple selections allowed true ' \" ) ;\n strcat( lDialogString ,\n \"-e 'set mystring to POSIX path of item 1 of mylist' \" );\n strcat( lDialogString ,\n \"-e 'repeat with i from 2 to the count of mylist' \" );\n strcat( lDialogString , \"-e 'set mystring to mystring & \\\"|\\\"' \" );\n strcat( lDialogString ,\n \"-e 'set mystring to mystring & POSIX path of item i of mylist' \" );\n strcat( lDialogString , \"-e 'end repeat' \" );\n strcat( lDialogString , \"-e 'mystring' \" );\n }\n else\n {\n strcat( lDialogString , \")' \" ) ;\n }\n strcat(lDialogString, \"-e 'on error number -128' \" ) ;\n strcat(lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return (char *)1;}\n lWasKdialog = 1 ;\n\n strcpy( lDialogString , \"kdialog\" ) ;\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n strcat( lDialogString , \" --getopenfilename \" ) ;\n\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n if ( aDefaultPathAndFile[0] != '/' )\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n strcat(lDialogString, \"\\\"\") ;\n strcat(lDialogString, aDefaultPathAndFile ) ;\n strcat(lDialogString , \"\\\"\" ) ;\n }\n else\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n\n if ( aNumOfFilterPatterns > 0 )\n {\n strcat(lDialogString , \" \\\"\" ) ;\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \" \" ) ;\n }\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , \" | \" ) ;\n strcat( lDialogString , aSingleFilterDescription ) ;\n }\n strcat( lDialogString , \"\\\"\" ) ;\n }\n if ( aAllowMultipleSelects )\n {\n strcat( lDialogString , \" --multiple --separate-output\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n }\n else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return (char *)1;}\n strcpy( lDialogString , \"zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat( lDialogString , \" --file-selection\" ) ;\n\n if ( aAllowMultipleSelects )\n {\n strcat( lDialogString , \" --multiple\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n strcat(lDialogString, \" --filename=\\\"\") ;\n strcat(lDialogString, aDefaultPathAndFile) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aNumOfFilterPatterns > 0 )\n {\n strcat( lDialogString , \" --file-filter='\" ) ;\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , aSingleFilterDescription ) ;\n strcat( lDialogString , \" | \" ) ;\n }\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \" \" ) ;\n }\n strcat( lDialogString , \"' --file-filter='All files | *'\" ) ;\n }\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n }\n\t\telse if ( tkinter3Present( ) )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return (char *)1;}\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();\");\n\t\t\tstrcat( lDialogString , \"lFiles=filedialog.askopenfilename(\");\n\t\t\tif ( aAllowMultipleSelects )\n\t\t\t{\n\t\t\t\tstrcat( lDialogString , \"multiple=1,\" ) ;\n\t\t\t}\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n\t\t\t{\n\t\t\t\tgetPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n\t\t\t\tif ( strlen(lString) )\n\t\t\t\t{\n\t\t\t\t\tstrcat(lDialogString, \"initialdir='\") ;\n\t\t\t\t\tstrcat(lDialogString, lString ) ;\n\t\t\t\t\tstrcat(lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t\tgetLastName( lString , aDefaultPathAndFile ) ;\n\t\t\t\tif ( strlen(lString) )\n\t\t\t\t{\n\t\t\t\t\tstrcat(lDialogString, \"initialfile='\") ;\n\t\t\t\t\tstrcat(lDialogString, lString ) ;\n\t\t\t\t\tstrcat(lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t}\n\t\t\tif ( ( aNumOfFilterPatterns > 1 )\n\t\t\t\t|| ( ( aNumOfFilterPatterns == 1 ) /*test because poor osx behaviour*/\n\t\t\t\t&& ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString , \"filetypes=(\" ) ;\n\t\t\t\tstrcat( lDialogString , \"('\" ) ;\n\t\t\t\tif ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , aSingleFilterDescription ) ;\n\t\t\t\t}\n\t\t\t\tstrcat( lDialogString , \"',(\" ) ;\n\t\t\t\tfor ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n\t\t\t\t{\n\t\t\t\t\tstrcat( lDialogString , \"'\" ) ;\n\t\t\t\t\tstrcat( lDialogString , aFilterPatterns [i] ) ;\n\t\t\t\t\tstrcat( lDialogString , \"',\" ) ;\n\t\t\t\t}\n\t\t\t\tstrcat( lDialogString , \")),\" ) ;\n\t\t\t\tstrcat( lDialogString , \"('All files','*'))\" ) ;\n\t\t\t}\n\t\t\tstrcat( lDialogString , \");\\\n\\nif not isinstance(lFiles, tuple):\\n\\tprint(lFiles)\\nelse:\\\n\\n\\tlFilesString=''\\n\\tfor lFile in lFiles:\\n\\t\\tlFilesString+=str(lFile)+'|'\\\n\\n\\tprint(lFilesString[:-1])\\n\\\"\" ) ;\n\t\t}\n\t\telse if ( tkinter2Present( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return (char *)1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n\t\t\t\tstrcat( lDialogString , gPython2Name ) ;\n\t\t\t\tif ( ! isTerminalRunning( ) && isDarwin( ) )\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n strcat( lDialogString ,\n\" -S -c \\\"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''/usr/bin/osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set \\\nfrontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n strcat( lDialogString , \"lFiles=tkFileDialog.askopenfilename(\");\n if ( aAllowMultipleSelects )\n {\n strcat( lDialogString , \"multiple=1,\" ) ;\n }\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n getPathWithoutFinalSlash( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"initialdir='\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"',\" ) ;\n }\n getLastName( lString , aDefaultPathAndFile ) ;\n if ( strlen(lString) )\n {\n strcat(lDialogString, \"initialfile='\") ;\n strcat(lDialogString, lString ) ;\n strcat(lDialogString , \"',\" ) ;\n }\n }\n if ( ( aNumOfFilterPatterns > 1 )\n || ( ( aNumOfFilterPatterns == 1 ) /*test because poor osx behaviour*/\n && ( aFilterPatterns[0][strlen(aFilterPatterns[0])-1] != '*' ) ) )\n {\n strcat(lDialogString , \"filetypes=(\" ) ;\n strcat( lDialogString , \"('\" ) ;\n if ( aSingleFilterDescription && strlen(aSingleFilterDescription) )\n {\n strcat( lDialogString , aSingleFilterDescription ) ;\n }\n strcat( lDialogString , \"',(\" ) ;\n for ( i = 0 ; i < aNumOfFilterPatterns ; i ++ )\n {\n strcat( lDialogString , \"'\" ) ;\n strcat( lDialogString , aFilterPatterns [i] ) ;\n strcat( lDialogString , \"',\" ) ;\n }\n strcat( lDialogString , \")),\" ) ;\n strcat( lDialogString , \"('All files','*'))\" ) ;\n }\n strcat( lDialogString , \");\\\n\\nif not isinstance(lFiles, tuple):\\n\\tprint lFiles\\nelse:\\\n\\n\\tlFilesString=''\\n\\tfor lFile in lFiles:\\n\\t\\tlFilesString+=str(lFile)+'|'\\\n\\n\\tprint lFilesString[:-1]\\n\\\"\" ) ;\n }\n else if ( xdialogPresent() || dialogName() )\n {\n if ( xdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return (char *)1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(Xdialog \" ) ;\n }\n else if ( isTerminalRunning( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n strcpy( lDialogString , \"(dialog \" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(\" ) ;\n strcat( lDialogString , dialogName() ) ;\n strcat( lDialogString , \" \" ) ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( !xdialogPresent() && !gdialogPresent() )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat( lDialogString , \"--fselect \\\"\" ) ;\n if ( aDefaultPathAndFile && strlen(aDefaultPathAndFile) )\n {\n if ( ! strchr(aDefaultPathAndFile, '/') )\n {\n strcat(lDialogString, \"./\") ;\n }\n strcat(lDialogString, aDefaultPathAndFile) ;\n }\n else if ( ! isTerminalRunning( ) && !lWasGraphicDialog )\n {\n strcat(lDialogString, getenv(\"HOME\")) ;\n strcat(lDialogString, \"/\");\n }\n else\n {\n strcat(lDialogString, \"./\") ;\n }\n\n if ( lWasGraphicDialog )\n {\n strcat(lDialogString, \"\\\" 0 60 ) 2>&1 \") ;\n }\n else\n {\n strcat(lDialogString, \"\\\" 0 60 >/dev/tty) \") ;\n if ( lWasXterm )\n {\n strcat( lDialogString ,\n \"2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt\");\n }\n else\n {\n strcat(lDialogString, \"2>&1 ; clear >/dev/tty\") ;\n }\n }\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){return tinyfd_inputBox(aTitle,NULL,NULL);}\n\t\t\t\tstrcpy(lBuff, \"Open file from \");\n\t\t\t\tstrcat(lBuff, getCurDir());\n\t\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\t\tif (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\t\tp2 = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\t\tif (p2) strcpy(lBuff, p2); else lBuff[0] = '\\0';\n\t\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */\n\t\t\t\tp2 = lBuff;\n\n if ( ! fileExists(p2) )\n {\n\t\t\t\t\tfree(lBuff);\n\t\t\t\t\tlBuff = NULL;\n }\n\t\t\t\telse\n\t\t\t\t{\n\t\t\t\t\tstrcpy(lBuff, p2);\n\t\t\t\t\tlBuff = (char *)( realloc( lBuff, (strlen(lBuff)+1) * sizeof(char)));\n\t\t\t\t}\n\t\t\t\treturn lBuff ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n\t\tfree(lBuff);\n\t\tlBuff = NULL;\n\t\treturn NULL ;\n }\n lBuff[0]='\\0';\n p=lBuff;\n while ( fgets( p , sizeof( lBuff ) , lIn ) != NULL )\n {\n p += strlen( p );\n }\n pclose( lIn ) ;\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n if ( lWasKdialog && aAllowMultipleSelects )\n {\n p = lBuff ;\n while ( ( p = strchr( p , '\\n' ) ) )\n * p = '|' ;\n }\n /* printf( \"lBuff2: %s\\n\" , lBuff ) ; */\n if ( ! strlen( lBuff ) )\n {\n\t\t\tfree(lBuff);\n\t\t\tlBuff = NULL;\n\t\t\treturn NULL;\n }\n if ( aAllowMultipleSelects && strchr(lBuff, '|') )\n {\n\t\t\tif( ! ensureFilesExist( lBuff , lBuff ) )\n\t\t\t{\n\t\t\t\tfree(lBuff);\n\t\t\t\tlBuff = NULL;\n\t\t\t\treturn NULL;\n\t\t\t}\n }\n else if ( !fileExists(lBuff) )\n {\n\t\t\tfree(lBuff);\n\t\t\tlBuff = NULL;\n\t\t\treturn NULL;\n\t\t}\n\n\t\tlBuff = (char *)( realloc( lBuff, (strlen(lBuff)+1) * sizeof(char)));\n\n /*printf( \"lBuff3: %s\\n\" , lBuff ) ; */\n\t\treturn lBuff ;\n}\n\n\nchar * tinyfd_selectFolderDialog(\n char const * aTitle , /* \"\" */\n char const * aDefaultPath ) /* \"\" */\n{\n static char lBuff [MAX_PATH_OR_CMD] ;\n char lDialogString [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n char * p ;\n\t\tchar * lPointerInputBox ;\n int lWasGraphicDialog = 0 ;\n int lWasXterm = 0 ;\n lBuff[0]='\\0';\n\n if ( osascriptPresent( ))\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return (char *)1;}\n strcpy( lDialogString , \"osascript \");\n if ( ! osx9orBetter() ) strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'POSIX path of ( choose folder \");\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"with prompt \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n strcat(lDialogString, \"default location \\\"\") ;\n strcat(lDialogString, aDefaultPath ) ;\n strcat(lDialogString , \"\\\" \" ) ;\n }\n strcat( lDialogString , \")' \" ) ;\n strcat(lDialogString, \"-e 'on error number -128' \" ) ;\n strcat(lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return (char *)1;}\n strcpy( lDialogString , \"kdialog\" ) ;\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n strcat( lDialogString , \" --getexistingdirectory \" ) ;\n\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n if ( aDefaultPath[0] != '/' )\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n strcat(lDialogString, \"\\\"\") ;\n strcat(lDialogString, aDefaultPath ) ;\n strcat(lDialogString , \"\\\"\" ) ;\n }\n else\n {\n strcat(lDialogString, \"$PWD/\") ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n }\n else if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return (char *)1;}\n strcpy( lDialogString , \"zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat( lDialogString , \" --file-selection --directory\" ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n strcat(lDialogString, \" --filename=\\\"\") ;\n strcat(lDialogString, aDefaultPath) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n }\n\t\telse if ( !xdialogPresent() && tkinter3Present( ) )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return (char *)1;}\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter;from tkinter import filedialog;root=tkinter.Tk();root.withdraw();\");\n\t\t\tstrcat( lDialogString , \"res=filedialog.askdirectory(\");\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"',\") ;\n\t\t\t}\n\t\t\tif ( aDefaultPath && strlen(aDefaultPath) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \"initialdir='\") ;\n\t\t\t\tstrcat(lDialogString, aDefaultPath ) ;\n\t\t\t\tstrcat(lDialogString , \"'\" ) ;\n\t\t\t}\n\t\t\tstrcat( lDialogString, \");\\nif not isinstance(res, tuple):\\n\\tprint(res)\\n\\\"\" ) ;\n\t\t}\n\t\telse if ( !xdialogPresent() && tkinter2Present( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return (char *)1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n strcat( lDialogString , gPython2Name ) ;\n if ( ! isTerminalRunning( ) && isDarwin( ) )\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n strcat( lDialogString ,\n\" -S -c \\\"import Tkinter,tkFileDialog;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''/usr/bin/osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set \\\nfrontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n\n strcat( lDialogString , \"print tkFileDialog.askdirectory(\");\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"',\") ;\n }\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n strcat(lDialogString, \"initialdir='\") ;\n strcat(lDialogString, aDefaultPath ) ;\n strcat(lDialogString , \"'\" ) ;\n }\n strcat( lDialogString , \")\\\"\" ) ;\n }\n else if ( xdialogPresent() || dialogName() )\n {\n if ( xdialogPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return (char *)1;}\n lWasGraphicDialog = 1 ;\n strcpy( lDialogString , \"(Xdialog \" ) ;\n }\n else if ( isTerminalRunning( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n strcpy( lDialogString , \"(dialog \" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"dialog\");return (char *)0;}\n lWasXterm = 1 ;\n strcpy( lDialogString , terminalName() ) ;\n strcat( lDialogString , \"'(\" ) ;\n strcat( lDialogString , dialogName() ) ;\n strcat( lDialogString , \" \" ) ;\n }\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \"--title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n if ( !xdialogPresent() && !gdialogPresent() )\n {\n strcat(lDialogString, \"--backtitle \\\"\") ;\n strcat(lDialogString,\n \"tab: focus | /: populate | spacebar: fill text field | ok: TEXT FIELD ONLY\") ;\n strcat(lDialogString, \"\\\" \") ;\n }\n\n strcat( lDialogString , \"--dselect \\\"\" ) ;\n if ( aDefaultPath && strlen(aDefaultPath) )\n {\n strcat(lDialogString, aDefaultPath) ;\n ensureFinalSlash(lDialogString);\n }\n else if ( ! isTerminalRunning( ) && !lWasGraphicDialog )\n {\n strcat(lDialogString, getenv(\"HOME\")) ;\n strcat(lDialogString, \"/\");\n }\n else\n {\n strcat(lDialogString, \"./\") ;\n }\n\n if ( lWasGraphicDialog )\n {\n strcat(lDialogString, \"\\\" 0 60 ) 2>&1 \") ;\n }\n else\n {\n strcat(lDialogString, \"\\\" 0 60 >/dev/tty) \") ;\n if ( lWasXterm )\n {\n strcat( lDialogString ,\n \"2>/tmp/tinyfd.txt';cat /tmp/tinyfd.txt;rm /tmp/tinyfd.txt\");\n }\n else\n {\n strcat(lDialogString, \"2>&1 ; clear >/dev/tty\") ;\n }\n }\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){return tinyfd_inputBox(aTitle,NULL,NULL);}\n\t\t\t\tstrcpy(lBuff, \"Select folder from \");\n\t\t\t\tstrcat(lBuff, getCurDir());\n\t\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\t\tif (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\t\tp = tinyfd_inputBox(aTitle, lBuff, \"\");\n\t\t\t\tif (p) strcpy(lBuff, p); else lBuff[0] = '\\0';\n\t\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */\n\t\t\t\tp = lBuff;\n\n if ( !p || ! strlen( p ) || ! dirExists( p ) )\n {\n return NULL ;\n }\n return p ;\n }\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n return NULL ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n pclose( lIn ) ;\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n if ( ! strlen( lBuff ) || ! dirExists( lBuff ) )\n {\n return NULL ;\n }\n return lBuff ;\n}\n\n\n/* returns the hexcolor as a string \"#FF0000\" */\n/* aoResultRGB also contains the result */\n/* aDefaultRGB is used only if aDefaultHexRGB is NULL */\n/* aDefaultRGB and aoResultRGB can be the same array */\nchar * tinyfd_colorChooser(\n char const * aTitle , /* NULL or \"\" */\n char const * aDefaultHexRGB , /* NULL or \"#FF0000\"*/\n unsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */\n unsigned char aoResultRGB[3] ) /* { 0 , 0 , 0 } */\n{\n\tstatic char lDefaultHexRGB[16];\n\tchar lBuff [128] ;\n\n char lTmp [128] ;\n#if !((defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__))\n\t\tchar * lTmp2 ;\n#endif\n char lDialogString [MAX_PATH_OR_CMD] ;\n unsigned char lDefaultRGB[3];\n char * p;\n\t\tchar * lPointerInputBox;\n FILE * lIn ;\n int i ;\n int lWasZenity3 = 0 ;\n int lWasOsascript = 0 ;\n int lWasXdialog = 0 ;\n lBuff[0]='\\0';\n\n\t\tif (aDefaultHexRGB)\n\t\t{\n\t\t\tHex2RGB(aDefaultHexRGB, lDefaultRGB);\n\t\t}\n\t\telse\n\t\t{\n\t\t\tlDefaultRGB[0] = aDefaultRGB[0];\n\t\t\tlDefaultRGB[1] = aDefaultRGB[1];\n\t\t\tlDefaultRGB[2] = aDefaultRGB[2];\n\t\t}\n\n if ( osascriptPresent( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"applescript\");return (char *)1;}\n lWasOsascript = 1 ;\n strcpy( lDialogString , \"osascript\");\n\n if ( ! osx9orBetter() )\n {\n strcat( lDialogString , \" -e 'tell application \\\"System Events\\\"' -e 'Activate'\");\n strcat( lDialogString , \" -e 'try' -e 'set mycolor to choose color default color {\");\n }\n else\n {\n strcat( lDialogString ,\n\" -e 'try' -e 'tell app (path to frontmost application as Unicode text) \\\nto set mycolor to choose color default color {\");\n }\n\n sprintf(lTmp, \"%d\", 256 * lDefaultRGB[0] ) ;\n strcat(lDialogString, lTmp ) ;\n strcat(lDialogString, \",\" ) ;\n sprintf(lTmp, \"%d\", 256 * lDefaultRGB[1] ) ;\n strcat(lDialogString, lTmp ) ;\n strcat(lDialogString, \",\" ) ;\n sprintf(lTmp, \"%d\", 256 * lDefaultRGB[2] ) ;\n strcat(lDialogString, lTmp ) ;\n strcat(lDialogString, \"}' \" ) ;\n strcat( lDialogString ,\n\"-e 'set mystring to ((item 1 of mycolor) div 256 as integer) as string' \" );\n strcat( lDialogString ,\n\"-e 'repeat with i from 2 to the count of mycolor' \" );\n strcat( lDialogString ,\n\"-e 'set mystring to mystring & \\\" \\\" & ((item i of mycolor) div 256 as integer) as string' \" );\n strcat( lDialogString , \"-e 'end repeat' \" );\n strcat( lDialogString , \"-e 'mystring' \");\n strcat(lDialogString, \"-e 'on error number -128' \" ) ;\n strcat(lDialogString, \"-e 'end try'\") ;\n if ( ! osx9orBetter() ) strcat( lDialogString, \" -e 'end tell'\") ;\n }\n else if ( kdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"kdialog\");return (char *)1;}\n strcpy( lDialogString , \"kdialog\" ) ;\n if ( kdialogPresent() == 2 )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n sprintf( lDialogString + strlen(lDialogString) , \" --getcolor --default '%s'\" , lDefaultHexRGB ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title \\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n }\n else if ( zenity3Present() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n lWasZenity3 = 1 ;\n if ( zenity3Present() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity3\");return (char *)1;}\n strcpy( lDialogString , \"zenity\" );\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat( lDialogString , \" --color-selection --show-palette\" ) ;\n sprintf( lDialogString + strlen(lDialogString), \" --color=%s\" , lDefaultHexRGB ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n if (tinyfd_silent) strcat( lDialogString , \" 2>/dev/null \");\n }\n else if ( xdialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"xdialog\");return (char *)1;}\n lWasXdialog = 1 ;\n strcpy( lDialogString , \"Xdialog --colorsel \\\"\" ) ;\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, aTitle) ;\n }\n strcat(lDialogString, \"\\\" 0 60 \") ;\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n\t\t\t\tsprintf(lTmp,\"%hhu %hhu %hhu\",lDefaultRGB[0],lDefaultRGB[1],lDefaultRGB[2]);\n#else\n sprintf(lTmp,\"%hu %hu %hu\",lDefaultRGB[0],lDefaultRGB[1],lDefaultRGB[2]);\n#endif\n strcat(lDialogString, lTmp) ;\n strcat(lDialogString, \" 2>&1\");\n }\n\t\telse if ( tkinter3Present( ) )\n\t\t{\n\t\t\tif (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python3-tkinter\");return (char *)1;}\n\t\t\tstrcpy( lDialogString , gPython3Name ) ;\n\t\t\tstrcat( lDialogString ,\n\t\t\t\t\" -S -c \\\"import tkinter;from tkinter import colorchooser;root=tkinter.Tk();root.withdraw();\");\n\t\t\tstrcat( lDialogString , \"res=colorchooser.askcolor(color='\" ) ;\n\t\t\tstrcat(lDialogString, lDefaultHexRGB ) ;\n\t\t\tstrcat(lDialogString, \"'\") ;\n\n\t\t\tif ( aTitle && strlen(aTitle) )\n\t\t\t{\n\t\t\t\tstrcat(lDialogString, \",title='\") ;\n\t\t\t\tstrcat(lDialogString, aTitle) ;\n\t\t\t\tstrcat(lDialogString, \"'\") ;\n\t\t\t}\n\t\t\tstrcat( lDialogString , \");\\\n\\nif res[1] is not None:\\n\\tprint(res[1])\\\"\" ) ;\n\t\t}\n\t\telse if ( tkinter2Present( ) )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"python2-tkinter\");return (char *)1;}\n\t\t\t\tstrcpy( lDialogString , \"export PYTHONIOENCODING=utf-8;\" ) ;\n\t\t\t\tstrcat( lDialogString , gPython2Name ) ;\n\t\t\t\tif ( ! isTerminalRunning( ) && isDarwin( ) )\n {\n strcat( lDialogString , \" -i\" ) ; /* for osx without console */\n }\n\n strcat( lDialogString ,\n\" -S -c \\\"import Tkinter,tkColorChooser;root=Tkinter.Tk();root.withdraw();\");\n\n if ( isDarwin( ) )\n {\n strcat( lDialogString ,\n\"import os;os.system('''osascript -e 'tell app \\\\\\\"Finder\\\\\\\" to set \\\nfrontmost of process \\\\\\\"Python\\\\\\\" to true' ''');\");\n }\n\n strcat( lDialogString , \"res=tkColorChooser.askcolor(color='\" ) ;\n strcat(lDialogString, lDefaultHexRGB ) ;\n strcat(lDialogString, \"'\") ;\n\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \",title='\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"'\") ;\n }\n strcat( lDialogString , \");\\\n\\nif res[1] is not None:\\n\\tprint res[1]\\\"\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){return tinyfd_inputBox(aTitle,NULL,NULL);}\n\t\t\t\tlPointerInputBox = tinyfd_inputBox(NULL, NULL, NULL); /* obtain a pointer on the current content of tinyfd_inputBox */\n\t\t\t\tif (lPointerInputBox) strcpy(lDialogString, lPointerInputBox); /* preserve the current content of tinyfd_inputBox */\n\t\t\t\tp = tinyfd_inputBox(aTitle, \"Enter hex rgb color (i.e. #f5ca20)\", lDefaultHexRGB);\n\n if ( !p || (strlen(p) != 7) || (p[0] != '#') )\n {\n return NULL ;\n }\n for ( i = 1 ; i < 7 ; i ++ )\n {\n if ( ! isxdigit( (int) p[i] ) )\n {\n return NULL ;\n }\n }\n\t\t\t\tHex2RGB(p,aoResultRGB);\n\t\t\t\tstrcpy(lDefaultHexRGB, p);\n\t\t\t\tif (lPointerInputBox) strcpy(lPointerInputBox, lDialogString); /* restore its previous content to tinyfd_inputBox */\n\t\t\t\treturn lDefaultHexRGB;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n return NULL ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {\n }\n pclose( lIn ) ;\n if ( ! strlen( lBuff ) )\n {\n return NULL ;\n }\n /* printf( \"len Buff: %lu\\n\" , strlen(lBuff) ) ; */\n /* printf( \"lBuff0: %s\\n\" , lBuff ) ; */\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n\n if ( lWasZenity3 )\n {\n if ( lBuff[0] == '#' )\n {\n if ( strlen(lBuff)>7 )\n {\n lBuff[3]=lBuff[5];\n lBuff[4]=lBuff[6];\n lBuff[5]=lBuff[9];\n lBuff[6]=lBuff[10];\n lBuff[7]='\\0';\n }\n Hex2RGB(lBuff,aoResultRGB);\n }\n else if ( lBuff[3] == '(' ) {\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n sscanf(lBuff,\"rgb(%hhu,%hhu,%hhu\", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]);\n#else\n aoResultRGB[0] = strtol(lBuff+4, & lTmp2, 10 );\n aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 );\n aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 );\n#endif\n RGB2Hex(aoResultRGB,lBuff);\n }\n else if ( lBuff[4] == '(' ) {\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n sscanf(lBuff,\"rgba(%hhu,%hhu,%hhu\", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]);\n#else\n aoResultRGB[0] = strtol(lBuff+5, & lTmp2, 10 );\n aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 );\n aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 );\n#endif\n RGB2Hex(aoResultRGB,lBuff);\n }\n }\n else if ( lWasOsascript || lWasXdialog )\n {\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n#if (defined(__cplusplus ) && __cplusplus >= 201103L) || (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__clang__)\n sscanf(lBuff,\"%hhu %hhu %hhu\", & aoResultRGB[0], & aoResultRGB[1],& aoResultRGB[2]);\n#else\n aoResultRGB[0] = strtol(lBuff, & lTmp2, 10 );\n aoResultRGB[1] = strtol(lTmp2+1, & lTmp2, 10 );\n aoResultRGB[2] = strtol(lTmp2+1, NULL, 10 );\n#endif\n RGB2Hex(aoResultRGB,lBuff);\n }\n else\n {\n Hex2RGB(lBuff,aoResultRGB);\n }\n /* printf(\"%d %d %d\\n\", aoResultRGB[0],aoResultRGB[1],aoResultRGB[2]); */\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n\n\tstrcpy(lDefaultHexRGB,lBuff);\n\treturn lDefaultHexRGB ;\n}\n\n\n/* not cross platform - zenity only */\n/* contributed by Attila Dusnoki */\nchar * tinyfd_arrayDialog(\n char const * aTitle , /* \"\" */\n int aNumOfColumns , /* 2 */\n char const * const * aColumns , /* {\"Column 1\",\"Column 2\"} */\n int aNumOfRows , /* 2 */\n char const * const * aCells )\n /* {\"Row1 Col1\",\"Row1 Col2\",\"Row2 Col1\",\"Row2 Col2\"} */\n{\n static char lBuff [MAX_PATH_OR_CMD] ;\n char lDialogString [MAX_PATH_OR_CMD] ;\n FILE * lIn ;\n int i ;\n\n lBuff[0]='\\0';\n\n if ( zenityPresent() || matedialogPresent() || shellementaryPresent() || qarmaPresent() )\n {\n if ( zenityPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"zenity\");return (char *)1;}\n strcpy( lDialogString , \"zenity\" ) ;\n if ( (zenity3Present() >= 4) && !getenv(\"SSH_TTY\") )\n {\n strcat( lDialogString, \" --attach=$(sleep .01;xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n else if ( matedialogPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"matedialog\");return (char *)1;}\n strcpy( lDialogString , \"matedialog\" ) ;\n }\n else if ( shellementaryPresent() )\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"shellementary\");return (char *)1;}\n strcpy( lDialogString , \"shellementary\" ) ;\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"qarma\");return (char *)1;}\n strcpy( lDialogString , \"qarma\" ) ;\n if ( !getenv(\"SSH_TTY\") )\n {\n strcat(lDialogString, \" --attach=$(xprop -root 32x '\\t$0' _NET_ACTIVE_WINDOW | cut -f 2)\"); /* contribution: Paul Rouget */\n }\n }\n strcat( lDialogString , \" --list --print-column=ALL\" ) ;\n\n if ( aTitle && strlen(aTitle) )\n {\n strcat(lDialogString, \" --title=\\\"\") ;\n strcat(lDialogString, aTitle) ;\n strcat(lDialogString, \"\\\"\") ;\n }\n\n if ( aColumns && (aNumOfColumns > 0) )\n {\n for ( i = 0 ; i < aNumOfColumns ; i ++ )\n {\n strcat( lDialogString , \" --column=\\\"\" ) ;\n strcat( lDialogString , aColumns [i] ) ;\n strcat( lDialogString , \"\\\"\" ) ;\n }\n }\n\n if ( aCells && (aNumOfRows > 0) )\n {\n strcat( lDialogString , \" \" ) ;\n for ( i = 0 ; i < aNumOfRows*aNumOfColumns ; i ++ )\n {\n strcat( lDialogString , \"\\\"\" ) ;\n strcat( lDialogString , aCells [i] ) ;\n strcat( lDialogString , \"\\\" \" ) ;\n }\n }\n }\n else\n {\n if (aTitle&&!strcmp(aTitle,\"tinyfd_query\")){strcpy(tinyfd_response,\"\");return (char *)0;}\n return NULL ;\n }\n\n if (tinyfd_verbose) printf( \"lDialogString: %s\\n\" , lDialogString ) ;\n if ( ! ( lIn = popen( lDialogString , \"r\" ) ) )\n {\n return NULL ;\n }\n while ( fgets( lBuff , sizeof( lBuff ) , lIn ) != NULL )\n {}\n pclose( lIn ) ;\n if ( lBuff[strlen( lBuff ) -1] == '\\n' )\n {\n lBuff[strlen( lBuff ) -1] = '\\0' ;\n }\n /* printf( \"lBuff: %s\\n\" , lBuff ) ; */\n if ( ! strlen( lBuff ) )\n {\n return NULL ;\n }\n return lBuff ;\n}\n#endif /* _WIN32 */\n\n\n/*\nint main( int argc , char * argv[] )\n{\nchar const * lTmp;\nchar const * lTheSaveFileName;\nchar const * lTheOpenFileName;\nchar const * lTheSelectFolderName;\nchar const * lTheHexColor;\nchar const * lWillBeGraphicMode;\nunsigned char lRgbColor[3];\nFILE * lIn;\nchar lBuffer[1024];\nchar lString[1024];\nchar const * lFilterPatterns[2] = { \"*.txt\", \"*.text\" };\n\ntinyfd_verbose = argc - 1;\ntinyfd_silent = 1;\n\nlWillBeGraphicMode = tinyfd_inputBox(\"tinyfd_query\", NULL, NULL);\n\nstrcpy(lBuffer, \"v\");\nstrcat(lBuffer, tinyfd_version);\nif (lWillBeGraphicMode)\n{\n strcat(lBuffer, \"\\ngraphic mode: \");\n}\nelse\n{\n strcat(lBuffer, \"\\nconsole mode: \");\n}\nstrcat(lBuffer, tinyfd_response);\nstrcat(lBuffer, \"\\n\");\nstrcat(lBuffer, tinyfd_needs+78);\nstrcpy(lString, \"tinyfiledialogs\");\ntinyfd_messageBox(lString, lBuffer, \"ok\", \"info\", 0);\n\ntinyfd_notifyPopup(\"the title\", \"the message\\n\\tfrom outer-space\", \"info\");\n\nif (lWillBeGraphicMode && !tinyfd_forceConsole)\n{\n tinyfd_forceConsole = ! tinyfd_messageBox(\"Hello World\",\n \"graphic dialogs [yes] / console mode [no]?\",\n \"yesno\", \"question\", 1);\n}\n\nlTmp = tinyfd_inputBox(\n \"a password box\", \"your password will be revealed\", NULL);\n\nif (!lTmp) return 1;\n\nstrcpy(lString, lTmp);\n\nlTheSaveFileName = tinyfd_saveFileDialog(\n \"let us save this password\",\n \"passwordFile.txt\",\n 2,\n lFilterPatterns,\n NULL);\n\nif (!lTheSaveFileName)\n{\n tinyfd_messageBox(\n \"Error\",\n \"Save file name is NULL\",\n \"ok\",\n \"error\",\n 1);\n return 1;\n}\n\nlIn = fopen(lTheSaveFileName, \"w\");\nif (!lIn)\n{\n tinyfd_messageBox(\n \"Error\",\n \"Can not open this file in write mode\",\n \"ok\",\n \"error\",\n 1);\n return 1;\n}\nfputs(lString, lIn);\nfclose(lIn);\n\nlTheOpenFileName = tinyfd_openFileDialog(\n \"let us read the password back\",\n \"\",\n 2,\n lFilterPatterns,\n NULL,\n 0);\n\nif (!lTheOpenFileName)\n{\n tinyfd_messageBox(\n \"Error\",\n \"Open file name is NULL\",\n \"ok\",\n \"error\",\n 1);\n return 1;\n}\n\nlIn = fopen(lTheOpenFileName, \"r\");\n\nif (!lIn)\n{\n tinyfd_messageBox(\n \"Error\",\n \"Can not open this file in read mode\",\n \"ok\",\n \"error\",\n 1);\n return(1);\n}\nlBuffer[0] = '\\0';\nfgets(lBuffer, sizeof(lBuffer), lIn);\nfclose(lIn);\n\ntinyfd_messageBox(\"your password is\",\n lBuffer, \"ok\", \"info\", 1);\n\nlTheSelectFolderName = tinyfd_selectFolderDialog(\n \"let us just select a directory\", NULL);\n\nif (!lTheSelectFolderName)\n{\n tinyfd_messageBox(\n \"Error\",\n \"Select folder name is NULL\",\n \"ok\",\n \"error\",\n 1);\n return 1;\n}\n\ntinyfd_messageBox(\"The selected folder is\",\n lTheSelectFolderName, \"ok\", \"info\", 1);\n\nlTheHexColor = tinyfd_colorChooser(\n \"choose a nice color\",\n \"#FF0077\",\n lRgbColor,\n lRgbColor);\n\nif (!lTheHexColor)\n{\n tinyfd_messageBox(\n \"Error\",\n \"hexcolor is NULL\",\n \"ok\",\n \"error\",\n 1);\n return 1;\n}\n\ntinyfd_messageBox(\"The selected hexcolor is\",\n lTheHexColor, \"ok\", \"info\", 1);\n\n tinyfd_beep();\n\n return 0;\n}\n*/\n\n#ifdef _MSC_VER\n#pragma warning(default:4996)\n#pragma warning(default:4100)\n#pragma warning(default:4706)\n#endif\n" }, { "path": "src/utilities/TINYFILEDIALOGS/tinyfiledialogs.h", "content": "/*_________\n / \\ tinyfiledialogs.h v3.6.4 [Sep 14, 2020] zlib licence\n |tiny file| Unique header file created [November 9, 2014]\n | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com\n \\____ ___/ http://tinyfiledialogs.sourceforge.net\n \\| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd\n ____________________________________________\n | |\n | email: tinyfiledialogs at ysengrin.com |\n |____________________________________________|\n _________________________________________________________________________________\n | |\n | the windows only wchar_t UTF-16 functions are at the bottom of this header file |\n |_________________________________________________________________________________|\n _________________________________________________________\n | |\n | on windows: - since v3.6 char is UTF-8 by default |\n | - if you want MBCS set tinyfd_winUtf8 to 0 |\n | - functions like fopen expect MBCS |\n |_________________________________________________________|\n\nIf you like tinyfiledialogs, please upvote my stackoverflow answer\nhttps://stackoverflow.com/a/47651444\n\ntiny file dialogs (cross-platform C C++)\nInputBox PasswordBox MessageBox ColorPicker\nOpenFileDialog SaveFileDialog SelectFolderDialog\nNative dialog library for WINDOWS MAC OSX GTK+ QT CONSOLE & more\nSSH supported via automatic switch to console mode or X11 forwarding\n\none C file + a header (add them to your C or C++ project) with 8 functions:\n- beep\n- notify popup (tray)\n- message & question\n- input & password\n- save file\n- open file(s)\n- select folder\n- color picker\n\nComplements OpenGL Vulkan GLFW GLUT GLUI VTK SFML TGUI\nSDL Ogre Unity3d ION OpenCV CEGUI MathGL GLM CPW GLOW\nOpen3D IMGUI MyGUI GLT NGL STB & GUI less programs\n\nNO INIT\nNO MAIN LOOP\nNO LINKING\nNO INCLUDE\n\nThe dialogs can be forced into console mode\n\nWindows (XP to 10) ASCII MBCS UTF-8 UTF-16\n- native code & vbs create the graphic dialogs\n- enhanced console mode can use dialog.exe from\nhttp://andrear.altervista.org/home/cdialog.php\n- basic console input\n\nUnix (command line calls) ASCII UTF-8\n- applescript, kdialog, zenity\n- python (2 or 3) + tkinter + python-dbus (optional)\n- dialog (opens a console if needed)\n- basic console input\nThe same executable can run across desktops & distributions\n\nC89/C18 & C++98/C++20 compliant: tested with C & C++ compilers\nVisualStudio MinGW-gcc GCC Clang TinyCC OpenWatcom-v2 BorlandC SunCC ZapCC\non Windows Mac Linux Bsd Solaris Minix Raspbian\nusing Gnome Kde Enlightenment Mate Cinnamon Budgie Unity Lxde Lxqt Xfce\nWindowMaker IceWm Cde Jds OpenBox Awesome Jwm Xdm Cwm\n\nBindings for LUA and C# dll, Haskell, Fortran\nIncluded in LWJGL(java), Rust, Allegrobasic\n\n- License -\n\nThis software is provided 'as-is', without any express or implied\nwarranty. In no event will the authors be held liable for any damages\narising from the use of this software.\n\nPermission is granted to anyone to use this software for any purpose,\nincluding commercial applications, and to alter it and redistribute it\nfreely, subject to the following restrictions:\n\n1. The origin of this software must not be misrepresented; you must not\nclaim that you wrote the original software. If you use this software\nin a product, an acknowledgment in the product documentation would be\nappreciated but is not required.\n2. Altered source versions must be plainly marked as such, and must not be\nmisrepresented as being the original software.\n3. This notice may not be removed or altered from any source distribution.\n*/\n\n#ifndef TINYFILEDIALOGS_H\n#define TINYFILEDIALOGS_H\n\n#ifdef\t__cplusplus\nextern \"C\" { /* if tinydialogs.c is compiled as C++ code rather than C code, you may need to comment this out\n\t\t\t and the corresponding closing bracket near the end of this file. */\n#endif\n\n/******************************************************************************************************/\n/**************************************** UTF-8 on Windows ********************************************/\n/******************************************************************************************************/\n#ifdef _WIN32\n/* On windows, if you want to use UTF-8 ( instead of the UTF-16/wchar_t functions at the end of this file )\nMake sure your code is really prepared for UTF-8 (on windows, functions like fopen() expect MBCS and not UTF-8) */\nextern int tinyfd_winUtf8; /* on windows char strings can be 1:UTF-8(default) or 0:MBCS */\n/* for MBCS change this to 0, in tinyfiledialogs.c or in your code */\n\n/* Here are some functions to help you convert between UTF-16 UTF-8 MBSC */\nchar * tinyfd_utf8toMbcs(char const * aUtf8string);\nwchar_t * tinyfd_utf8to16(char const * aUtf8string);\nchar * tinyfd_utf16to8(wchar_t const * aUtf16string);\nvoid tinyfd_setWinUtf8(int aIsUtf8); /* made to be used from C# to set the global variable tinyfd_winUtf8 to 1 or 0 */\n#endif\n/******************************************************************************************************/\n/******************************************************************************************************/\n/******************************************************************************************************/\n\nextern char const tinyfd_version[8]; /* contains tinyfd current version number */\nextern char const tinyfd_needs[]; /* info about requirements */\nextern int tinyfd_verbose; /* 0 (default) or 1 : on unix, prints the command line calls */\nextern int tinyfd_silent; /* 1 (default) or 0 : on unix, hide errors and warnings from called dialogs */\n\n/* Curses dialogs are difficult to use, on windows they are only ascii */\n/* int const tinyfd_allowCursesDialogs; 0 (default) or 1 : you can change this in tinyfiledialogs.c */\n\nextern int tinyfd_forceConsole; /* 0 (default) or 1 */\n/* for unix & windows: 0 (graphic mode) or 1 (console mode).\n0: try to use a graphic solution, if it fails then it uses console mode.\n1: forces all dialogs into console mode even when an X server is present,\n if the package dialog (and a console is present) or dialog.exe is installed.\n on windows it only make sense for console applications */\n\nextern char tinyfd_response[1024];\n/* if you pass \"tinyfd_query\" as aTitle,\nthe functions will not display the dialogs\nbut will return 0 for console mode, 1 for graphic mode.\ntinyfd_response is then filled with the retain solution.\npossible values for tinyfd_response are (all lowercase)\nfor graphic mode:\n windows_wchar windows\n applescript kdialog zenity zenity3 matedialog qarma\n python2-tkinter python3-tkinter python-dbus perl-dbus\n gxmessage gmessage xmessage xdialog gdialog\nfor console mode:\n dialog whiptail basicinput no_solution */\n\nvoid tinyfd_beep(void);\n\nint tinyfd_notifyPopup(\n\tchar const * aTitle, /* NULL or \"\" */\n\tchar const * aMessage, /* NULL or \"\" may contain \\n \\t */\n\tchar const * aIconType); /* \"info\" \"warning\" \"error\" */\n\t\t/* return has only meaning for tinyfd_query */\n\nint tinyfd_messageBox(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aMessage , /* NULL or \"\" may contain \\n \\t */\n\tchar const * aDialogType , /* \"ok\" \"okcancel\" \"yesno\" \"yesnocancel\" */\n\tchar const * aIconType , /* \"info\" \"warning\" \"error\" \"question\" */\n\tint aDefaultButton ) ;\n\t\t/* 0 for cancel/no , 1 for ok/yes , 2 for no in yesnocancel */\n\nchar * tinyfd_inputBox(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aMessage , /* NULL or \"\" may NOT contain \\n \\t on windows */\n\tchar const * aDefaultInput ) ; /* \"\" , if NULL it's a passwordBox */\n\t\t/* returns NULL on cancel */\n\nchar * tinyfd_saveFileDialog(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aDefaultPathAndFile , /* NULL or \"\" */\n\tint aNumOfFilterPatterns , /* 0 */\n\tchar const * const * aFilterPatterns , /* NULL | {\"*.jpg\",\"*.png\"} */\n\tchar const * aSingleFilterDescription ) ; /* NULL | \"text files\" */\n\t\t/* returns NULL on cancel */\n\nchar * tinyfd_openFileDialog(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aDefaultPathAndFile , /* NULL or \"\" */\n\tint aNumOfFilterPatterns , /* 0 */\n\tchar const * const * aFilterPatterns , /* NULL | {\"*.jpg\",\"*.png\"} */\n\tchar const * aSingleFilterDescription , /* NULL | \"image files\" */\n\tint aAllowMultipleSelects ) ; /* 0 or 1 */\n\t\t/* in case of multiple files, the separator is | */\n\t\t/* returns NULL on cancel */\n\nchar * tinyfd_selectFolderDialog(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aDefaultPath ) ; /* NULL or \"\" */\n\t\t/* returns NULL on cancel */\n\nchar * tinyfd_colorChooser(\n\tchar const * aTitle , /* NULL or \"\" */\n\tchar const * aDefaultHexRGB , /* NULL or \"#FF0000\" */\n\tunsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */\n\tunsigned char aoResultRGB[3] ) ; /* { 0 , 0 , 0 } */\n\t\t/* returns the hexcolor as a string \"#FF0000\" */\n\t\t/* aoResultRGB also contains the result */\n\t\t/* aDefaultRGB is used only if aDefaultHexRGB is NULL */\n\t\t/* aDefaultRGB and aoResultRGB can be the same array */\n\t\t/* returns NULL on cancel */\n\n\n/************ NOT CROSS PLATFORM SECTION STARTS HERE ************************/\n#ifdef _WIN32\n\n/* windows only - utf-16 version */\nint tinyfd_notifyPopupW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aMessage, /* NULL or L\"\" may contain \\n \\t */\n\twchar_t const * aIconType); /* L\"info\" L\"warning\" L\"error\" */\n\n/* windows only - utf-16 version */\nint tinyfd_messageBoxW(\n\twchar_t const * aTitle , /* NULL or L\"\" */\n\twchar_t const * aMessage, /* NULL or L\"\" may contain \\n \\t */\n\twchar_t const * aDialogType, /* L\"ok\" L\"okcancel\" L\"yesno\" */\n\twchar_t const * aIconType, /* L\"info\" L\"warning\" L\"error\" L\"question\" */\n\tint aDefaultButton ); /* 0 for cancel/no , 1 for ok/yes */\n\t\t/* returns 0 for cancel/no , 1 for ok/yes */\n\n/* windows only - utf-16 version */\nwchar_t * tinyfd_inputBoxW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aMessage, /* NULL or L\"\" may NOT contain \\n nor \\t */\n\twchar_t const * aDefaultInput ); /* L\"\" , if NULL it's a passwordBox */\n\n/* windows only - utf-16 version */\nwchar_t * tinyfd_saveFileDialogW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aDefaultPathAndFile, /* NULL or L\"\" */\n\tint aNumOfFilterPatterns, /* 0 */\n\twchar_t const * const * aFilterPatterns, /* NULL or {L\"*.jpg\",L\"*.png\"} */\n\twchar_t const * aSingleFilterDescription); /* NULL or L\"image files\" */\n\t\t/* returns NULL on cancel */\n\n/* windows only - utf-16 version */\nwchar_t * tinyfd_openFileDialogW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aDefaultPathAndFile, /* NULL or L\"\" */\n\tint aNumOfFilterPatterns , /* 0 */\n\twchar_t const * const * aFilterPatterns, /* NULL {L\"*.jpg\",L\"*.png\"} */\n\twchar_t const * aSingleFilterDescription, /* NULL or L\"image files\" */\n\tint aAllowMultipleSelects ) ; /* 0 or 1 */\n\t\t/* in case of multiple files, the separator is | */\n\t\t/* returns NULL on cancel */\n\n/* windows only - utf-16 version */\nwchar_t * tinyfd_selectFolderDialogW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aDefaultPath); /* NULL or L\"\" */\n\t\t/* returns NULL on cancel */\n\n/* windows only - utf-16 version */\nwchar_t * tinyfd_colorChooserW(\n\twchar_t const * aTitle, /* NULL or L\"\" */\n\twchar_t const * aDefaultHexRGB, /* NULL or L\"#FF0000\" */\n\tunsigned char const aDefaultRGB[3] , /* { 0 , 255 , 255 } */\n\tunsigned char aoResultRGB[3] ) ; /* { 0 , 0 , 0 } */\n\t\t/* returns the hexcolor as a string L\"#FF0000\" */\n\t\t/* aoResultRGB also contains the result */\n\t\t/* aDefaultRGB is used only if aDefaultHexRGB is NULL */\n\t\t/* aDefaultRGB and aoResultRGB can be the same array */\n\t\t/* returns NULL on cancel */\n\n#else /*_WIN32*/\n\n/* unix zenity only */\nchar * tinyfd_arrayDialog(\n\tchar const * aTitle , /* NULL or \"\" */\n\tint aNumOfColumns , /* 2 */\n\tchar const * const * aColumns, /* {\"Column 1\",\"Column 2\"} */\n\tint aNumOfRows, /* 2 */\n\tchar const * const * aCells);\n\t\t/* {\"Row1 Col1\",\"Row1 Col2\",\"Row2 Col1\",\"Row2 Col2\"} */\n\n#endif /*_WIN32 */\n\n#ifdef\t__cplusplus\n} /*extern \"C\"*/\n#endif\n\n#endif /* TINYFILEDIALOGS_H */\n\n/*\n- This is not for ios nor android (it works in termux though).\n- The code is pure C, perfectly compatible with C++.\n- the windows only wchar_t (utf-16) prototypes are in the header file\n- windows is fully supported from XP to 10 (maybe even older versions)\n- C# & LUA via dll, see files in the folder EXTRAS\n- OSX supported from 10.4 to latest (maybe even older versions)\n- Avoid using \" and ' in titles and messages.\n- There's one file filter only, it may contain several patterns.\n- If no filter description is provided,\n the list of patterns will become the description.\n- char const * filterPatterns[3] = { \"*.obj\" , \"*.stl\" , \"*.dxf\" } ;\n- On windows char defaults to UTF-8, set tinyfd_winUtf8=0 to use MBCS\n- On windows link against Comdlg32.lib and Ole32.lib\n (on windows the no linking claim is a lie)\n This linking is not compulsary for console mode (see header file).\n- On unix: it tries command line calls, so no such need (NO LINKING).\n- On unix you need one of the following:\n applescript, kdialog, zenity, matedialog, shellementary, qarma,\n python (2 or 3)/tkinter/python-dbus (optional), Xdialog\n or dialog (opens terminal if running without console) or xterm.\n- One of those is already included on most (if not all) desktops.\n- In the absence of those it will use gdialog, gxmessage or whiptail\n with a textinputbox.\n- If nothing is found, it switches to basic console input,\n it opens a console if needed (requires xterm + bash).\n- Use windows separators on windows and unix separators on unix.\n- String memory is preallocated statically for all the returned values.\n- File and path names are tested before return, they are valid.\n- If you pass only a path instead of path + filename,\n make sure it ends with a separator.\n- tinyfd_forceConsole=1; at run time, forces dialogs into console mode.\n- On windows, console mode only make sense for console applications.\n- On windows, Console mode is not implemented for wchar_T UTF-16.\n- Mutiple selects are not allowed in console mode.\n- The package dialog must be installed to run in enhanced console mode.\n It is already installed on most unix systems.\n- On osx, the package dialog can be installed via\n http://macappstore.org/dialog or http://macports.org\n- On windows, for enhanced console mode,\n dialog.exe should be copied somewhere on your executable path.\n It can be found at the bottom of the following page:\n http://andrear.altervista.org/home/cdialog.php\n- If dialog is missing, it will switch to basic console input.\n- You can query the type of dialog that will be use (pass \"tinyfd_query\" as aTitle)\n*/\n" }, { "path": "src/utilities/TINYFILEDIALOGS/tinyopen.c", "content": "/*_________\n / \\ tinyfiledialogs v3.5.0 [Apr 13, 2020] zlib licence\n |tiny file| \n | dialogs | Copyright (c) 2014 - 2020 Guillaume Vareille http://ysengrin.com\n \\____ ___/ http://tinyfiledialogs.sourceforge.net\n \\| git clone http://git.code.sf.net/p/tinyfiledialogs/code tinyfd\n\n - License -\n This software is provided 'as-is', without any express or implied\n warranty. In no event will the authors be held liable for any damages\n arising from the use of this software.\n Permission is granted to anyone to use this software for any purpose,\n including commercial applications, and to alter it and redistribute it\n freely, subject to the following restrictions:\n 1. The origin of this software must not be misrepresented; you must not\n claim that you wrote the original software. If you use this software\n in a product, an acknowledgment in the product documentation would be\n appreciated but is not required.\n 2. Altered source versions must be plainly marked as such, and must not be\n misrepresented as being the original software.\n 3. This notice may not be removed or altered from any source distribution.\n\n this fortran code for tinyfiledialogs was contributed by Bo Sundman */\n\n\n/* dummy C routine that returns a legal filename */\n\n#include \n#include \n#include \"tinyfiledialogs.h\"\n\nchar const * tinyopen(\n\t\t int const typ)\n{\n char const * lFilterPatterns1[1] = {\"*.TDB\"};\n char const * lFilterPatterns2[1] = {\"*.OCU\"};\n char const * lFilterPatterns3[1] = {\"*.OCM\"};\n char const * lFilterPatterns4[1] = {\"*.OCD\"};\n char const * lFilterPatterns5[1] = {\"*.PLT\"};\n char const * p2;\n //printf(\"start of tinydummy \\n\");\n //printf(\"input value of typ: %i \\n\",typ);\n //printf(\"now copy the string \\n\");\n //strcpy(filename,\"C:\\\\User\\\\Bosse\\\\Document\\\\Software\\\\openfile\\\\test.TDB\");\n if(typ<0)\n {\n //lTheOpenFileName = tinyfd_openFileDialog(\n //p2 = tinyfd_openFileDialog(\n p2 = tinyfd_saveFileDialog(\n\t\t\t\t\t \"Output file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 0,\n\t\t\t\t\t NULL,\n\t\t\t\t\t NULL);\n\t\t\t\t\t // lFilterPatterns1,\n\t\t\t\t\t // NULL,\n\t\t\t\t\t // 0);\n }\n else if(typ==1)\n {\n //lTheOpenFileName = tinyfd_openFileDialog(\n p2 = tinyfd_openFileDialog(\n\t\t\t\t\t \"Input file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 1,\n\t\t\t\t\t lFilterPatterns1,\n\t\t\t\t\t NULL,\n\t\t\t\t\t 0);\n }\n else if(typ==2)\n {\n //lTheOpenFileName = tinyfd_openFileDialog(\n p2 = tinyfd_openFileDialog(\n\t\t\t\t\t \"Input file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 1,\n\t\t\t\t\t lFilterPatterns2,\n\t\t\t\t\t NULL,\n\t\t\t\t\t 0);\n //p2=\"C:\\\\User\\\\Bosse\\\\Document\\\\Software\\\\openfile\\\\test.UNF\";\n }\n else if(typ==3)\n {\n //lTheOpenFileName = tinyfd_openFileDialog(\n p2 = tinyfd_openFileDialog(\n\t\t\t\t\t \"Input file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 1,\n\t\t\t\t\t lFilterPatterns3,\n\t\t\t\t\t NULL,\n\t\t\t\t\t 0);\n //p2=\"C:\\\\User\\\\Bosse\\\\Document\\\\Software\\\\openfile\\\\test.UNF\";\n }\n else if(typ==4)\n {\n //lTheOpenFileName = tinyfd_openFileDialog(\n p2 = tinyfd_openFileDialog(\n\t\t\t\t\t \"Input file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 1,\n\t\t\t\t\t lFilterPatterns3,\n\t\t\t\t\t NULL,\n\t\t\t\t\t 0);\n //p2=\"C:\\\\User\\\\Bosse\\\\Document\\\\Software\\\\openfile\\\\test.UNF\";\n }\n else\n {\n //no default extension\n p2 = tinyfd_openFileDialog(\n\t\t\t\t\t \"Input file name\",\n\t\t\t\t\t \"\",\n\t\t\t\t\t 0,\n\t\t\t\t\t NULL,\n\t\t\t\t\t NULL,\n\t\t\t\t\t 0);\n //p2=\"C:\\\\User\\\\Bosse\\\\Document\\\\Software\\\\openfile\\\\test.DAT\";\n }\n //if (! lTheOpenFileName)\n if (! p2)\n {\n tinyfd_messageBox(\n\t\t\t\"Error\",\n\t\t\t\"Open file name is NULL\",\n\t\t\t\"ok\",\n\t\t\t\"error\",\n\t\t\t1);\n return NULL ;\n }\n //printf(\"return name: %s \\n\",p2);\n //printf(\"end of tinydummy \\n\");\n //return lTheOpenFileName;\n return p2;\n}\n" }, { "path": "src/utilities/metlib4.F90", "content": "!\n! general utilities in Fortran 95 a la METLIB upgraded 2015-2019 to\n! eliminate most specific F77 features\n! 1. All ENTRY removed. GPARxyz and MACRO routines seems OK\n! 2. Problems with getkey developed by John S. Urban has been fixed,\n! It has been renamed getkex in the iso-C interface.\n! 3. IMPLICT NONE introduced in the whole module.\n! 4. A revised online help system using HTML \\hypertarget in user guide\n!\n! To be done:\n!CCI done in ocparam.F90\n! - move constants ZERO, ONE here (from gtp3)\n!CCI\n! - use same error code system as in gtp\n! - revise the online help system\n!\nMODULE METLIB\n!\n! Copyright 1980-2022, Bo Sundman bo.sundman@gmail.com \n! \n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 2 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License\n! along with this program; if not, write to the Free Software\n! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n!\n!--------------------------------------------------------------------------\n#ifdef lixed\n! LINUX: For character by character input allowing emacs editing\n use M_getkey\n#endif\n!\n#ifdef tinyfd\n! use tinyfiledialogs to browse for files\n use ftinyopen\n#endif\n\n! ocparam is in models/ocparam.F90\n!CCI\n use OCPARAM\n!CCI\n!\n!--------------------------------------------------------------------------\n!\n! Error codes (buperr)\n! 1001 Too small stack for sorting integers\n! 1002 Too small workspace\n! 1003 Pointer outside workspace\n! 1004 Free areas not in increasing order\n! 1005 Too small or too big free area\n! 1006 No space available\n! 1007 Free workspace destroyed\n! 1008 Attempt to reserve one word or less\n! 1009 Released area inside free area\n! 1010 Too large character or real arrays in LOADC/STORC or LOADRN/STORRN\n! 1030 NO SUCH TYPE OPTION\n! 1031 Empty line, expected number\n! 1032 PARAMETER VALUE MISSING\n! 1033 Decimal point but no digits\n! 1034 No digits\n! 1035 Positive sign but no digits\n! 1036 Negative sign but no digits\n! 1037 No sign and no digits\n! 1038 NO DIGITS AFTER EXPONENTIAL E\n! 1039 Exponent larget then 99\n! 1040 NO HELP FOR \n! 1041 NO SUCH QUESTION FOR \n! 1042 TOO LARGE INTEGER VALUE\n! 1057 Too long input line\n! 1060 illegal bit number\n! 1070 Margin error in wrice\n! 1083 Too deeply nested macros\n! 1100 Not enough space to write number in text\n! 1101 Name does not start with letter A-Z\n! 1235 too many (\n! 1236 too few )\n! 1237 error with parenthesis\n! 1332 Illegal option\n! 1333 Missing option value delimiter\n! 1334 Missing option value\n! 1350 File system error\n! 1360 Missing column number for substitution\n!\n!----------------------------------------------------------\n!\n! global variables and constants\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n! implicit none\n!\n! Using open MP parallelization\n!$ use OMP_LIB\n!\n! GLOBAL ERROR CODE moved from gtp3\n!\\begin{verbatim}\n TYPE gtp_parerr\n! This record contains the global error code. In parallel processing each\n! parallel processes has its own error code copied to this if nonzero\n! it should be replaced by gtperr for separate errors in treads\n INTEGER :: bmperr\n END TYPE gtp_parerr\n TYPE(gtp_parerr) :: gx\n!\n! needed to have error code as private in threads\n!$OMP threadprivate(gx)\n!\\end{verbatim}\n!\n!----------------------------------------------------------\n!\n! Data structures for putfun below (no change 190802)\n!\\begin{verbatim}\n! Data structures in METLIB\n TYPE putfun_node\n! all nodes of function stored as part of a binary tree\n! kod is operation kod (0 datanod), links is how many links to this node\n integer kod,links\n! this is the sequential order the node is allocated (for debugging)\n integer debug\n! each node has a left and a right link. If the left node is empty the\n! right is normally a data node\n TYPE(putfun_node), pointer :: left,right\n! A data node can have a numeric value and/or a link to another function\n double precision value\n! this is an identification of external symbols\n integer dataid\n end TYPE putfun_node\n!\n! BEWARE entering putfuns cannot be made in parallel processing\n! but one may evaluate them in different threads\n!\n! PUTFUNNVAR is associated with external symbols in the LOKV array\n integer, private :: putfunvar\n TYPE PUTFUN_STACK\n type(putfun_node), pointer ::savetop, savebin, saveuni\n type(putfun_stack), pointer :: previous\n end TYPE PUTFUN_STACK\n type(putfun_stack), pointer :: stacktop\n! topnod is the current top node\n! lastopnod is last binary opkod node\n! datanod is last data node\n TYPE(putfun_node), private, pointer :: topnod,datanod,lastopnod\n integer pfnerr,debuginc\n!\n! end data structures for PUTFUN\n!\\end{verbatim}\n!\n!\\begin{verbatim}\n! data structures for history and help\n! \n integer, parameter :: histlines=100\n!\n TYPE CHISTORY\n! to save the last 20 lines of commands\n character*80 hline(histlines)\n integer :: hpos=0\n END TYPE CHISTORY\n type(chistory) :: myhistory\n! \n integer, parameter :: maxhelplevel=15\n! A help structure used in new on-line help system\n! this was designed for both LaTeX and HTML help, now only HTML\n TYPE help_str\n integer :: okinit=0\n character*128 filename\n character*8 type\n integer level\n character*32, dimension(maxhelplevel) :: cpath\n END TYPE help_str\n! this record is used to file the appropriate help text\n type(help_str), save :: helprec\n! this is useful to add %\\section and %\\subsection in helpfile\n logical :: helptrace=.FALSE.\n!\n! using browser and html files for on-line help\n type onlinehelp\n! if htmlhelp is TRUE then browser is the path/name of browser\n! htmlfile is full path/name of html file\n! target is used to find the relevant text the html file\n! values of browser and htmlfile set by the main program (and htmlhelp=.TRUE.)\n! The value of target is found searching the original LaTeX file!!\n! In this file there are \\hypertarget{target} which can be searched in the\n! html file as \n! Searching the LaTeX file the help system will find a section\n! matching the history of commands/questions the user has given\n! and the target in the first \\hypertarget {target} found within these lines\n! will be used for the help displayed in the browser window\n logical :: htmlhelp=.FALSE.\n character*128 browser\n character*128 htmlfile\n character*128 latexfile\n character*64 target\n end type onlinehelp\n type(onlinehelp) :: ochelp\n save ochelp\n! end data structures for history and help\n!\\end{verbatim}\n! \n!\n! default units for command output, input, error message, list\n! and default language\n integer, parameter :: koud=6,kiud=5,keud=6,lutd=6,lerd=6,langd=1\n! representation of the numerical value \"none\"\n double precision, parameter :: RNONE=-1.0D-36,FLTSML=1.0D-36,FLTPRS=1.0D-14\n integer, parameter :: NONE=-2147483647,MAXINT=2147483647,MININT=-2147483646\n character*4, parameter :: CNONE='NONE'\n! initiate i/o and error code\n integer :: kou=koud,kiu=kiud,keu=keud,lut=lutd,ler=lerd,lang=langd\n integer :: buperr=0,iox(10)\n! LSTCMD is the last command given. Saved by NCOMP, used by help routines\n character, private :: lstcmd*40\n! LUN unsed for macros and SAVE files\n integer :: lun=50\n! LOGFIL is nonzero if a log file is set\n integer, private :: logfil=0\n! global values for history\n CHARACTER, private :: HIST(20)*80\n integer, private :: LHL=0,LHM=0,LHP=0\n! terminal charcterististics, koltrm is number of columns, default 80\n integer :: KOLTRM=80\n! ECHO on/off\n integer :: JECHO=0\n! no idea what is in KFLAGS, has to do with VT200 terminals. Not needed??\n! integer KFLAGS(24)\n!\n! This is for environment variables used in MACROs\n character, private :: ENVIR(9)*60\n!\n character*3, parameter :: MACEXT='OCM'\n!\n!----------- some added things 190802/BoS\n! prevent use of popup windows for open/save file\n! logical nopopup\n logical :: NOPENPOPUP=.FALSE.\n! character for PATH to macro file in order to open files inside macro\n character macropath(5)*256\n! the working directory\n character workingdir*256\n! for macros\n integer IUMACLEVL,MACROUNIT(5)\n!\\begin{verbatim}\n! >>>>>>>>>> SYSTEM DEPENDENT <<<<<<<<<<\n! nbpw is number if bytes per INTEGER, nwpr number of words per (double) real \n! nbitpw number of bits per word\n! USED when WPACK routines store data in integer workspace \n integer, parameter :: nbpw=4,nwpr=2,nbitpw=32\n! >>>>>>>>>> SYSTEM DEPENDENT <<<<<<<<<<\n!\\end{verbatim}\n!\n ! some constants\n !CCI Comment the next line because of already defined in ocparam.F90\n !CCI double precision, parameter, private :: ZERO=0.0D0,ONE=1.0D0,TEN=1.0D1\n!\n! -------------------------------------------------------------------\n! GPARxyz routines parameter transfer of integer, real and logical values\n! \n! integer GPARIDEF,GPARITYP\n! double precision GPARRDEF\n! logical GPARWDEF,GPARENTES\n! character GPARCH2*1\n!\n! added private to avoid problem with modules using metlib\n integer, private :: GPARIDEF,GPARITYP\n double precision, private :: GPARRDEF\n logical, private :: GPARWDEF,GPARENTES\n character, private :: GPARCH2*1\n!\n!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n\nCONTAINS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! SORTING SUBROUTINES FOR INTEGERS, REALS AND CHARACTERS\n! QUICKSORT ENL KNUTH ALGORTIM Q\n! THE ART OF COMPUTER PROGRAMMING, VOL 3, P 117\n! \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine sortrd & Sorting reals\n!\\begin{verbatim}\n SUBROUTINE SORTRD(ARR,N,IX)\n! ...SORTING REAL NUMBERS IN ASCENDING ORDER\n! INPUT:\n! ARR ARRAY TO BE SORTED\n! N NUMBER OF ELEMENTS TO BE SORTED >1\n! IX INTEGER ARRAY WITH DIMENSION N\n! EXIT:\n! ARR SORTED ARRAY\n! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF ARR(I)\n implicit none\n real ARR(*)\n integer n,ix(*)\n!\\end{verbatim} %+\n integer, parameter :: MSTACK=20\n real part,val\n integer LOW(MSTACK),IGH(MSTACK)\n integer i,is,j,k,m,min,max\n! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTION BOUNDARIES\n IF(N.LT.1) GOTO 900\n! IX IS ORIGINAL INDEX OF ELEMENT I IN ARR\n DO I=1,N\n IX(I)=I\n enddo\n IF(N.EQ.1) GOTO 900\n! M IS THE PARTION SIZE THAT IS SORTED WITH STRIGHT INSERTION\n! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK\n M=1\n IS=1\n!******STEP Q1, INITIATING\n IF(N.LE.M) GOTO 900\n MIN=1\n MAX=N\n!******STEP Q2, NEW STAGE\n! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTION\n100 PART=ARR(MIN)\n I=MIN\n J=MAX+1\n!******STEP Q3, INCREASE I UNTIL I>J OR ARR(I)>PART\n110 I=I+1\n IF(I.GE.J) GOTO 200\n IF(ARR(I).LE.PART) GOTO 110\n!******STEP Q4, DECREASE J UNTIL JM\n IF(MAX-J.LE.M) GOTO 360\n! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=MIN\n IGH(IS)=J-1\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n310 MIN=J+1\n GOTO 100\n! MAX-J GREATEST\n350 IF(MAX-J.LE.M) GOTO 400\n! PUSH ONLY IF J-MIN>M\n IF(J-MIN.LE.M) GOTO 310\n! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=J+1\n IGH(IS)=MAX\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n360 MAX=J-1\n GOTO 100\n!******STEP Q8, POP FROM STACK\n400 IS=IS-1\n IF(IS.LT.1) GOTO 500\n MIN=LOW(IS)\n MAX=IGH(IS)\n GOTO 100\n!******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1\n500 CONTINUE\n900 RETURN\n910 buperr=1051\n GOTO 900\n end SUBROUTINE SORTRD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine sortrdd & Sorting doubles\n!\\begin{verbatim}\n SUBROUTINE SORTRDD(ARR,N,IX)\n! ...SORTING DOUBLE PRECISION NUMBERS IN DECENDING ORDER\n! INPUT:\n! ARR ARRAY TO BE SORTED\n! N NUMBER OF ELEMENTS TO BE SORTED >1\n! IX INTEGER ARRAY WITH DIMENSION N\n! EXIT:\n! ARR SORTED ARRAY\n! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF ARR(I)\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n double precision ARR(*)\n integer n,ix(*)\n!\\end{verbatim} %+\n integer, parameter :: MSTACK=20\n double precision part,val\n integer LOW(MSTACK),IGH(MSTACK)\n integer i,is,j,k,m,min,max\n! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTION BOUNDARIES\n IF(N.LT.1) GOTO 900\n! IX IS ORIGINAL INDEX OF ELEMENT I IN ARR\n DO I=1,N\n IX(I)=I\n enddo\n IF(N.EQ.1) GOTO 900\n! M IS THE PARTION SIZE THAT IS SORTED WITH STRIGHT INSERTION\n! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK\n M=1\n IS=1\n!******STEP Q1, INITIATING\n IF(N.LE.M) GOTO 900\n MIN=1\n MAX=N\n!******STEP Q2, NEW STAGE\n! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTION\n100 PART=ARR(MIN)\n I=MIN\n J=MAX+1\n!******STEP Q3, INCREASE I UNTIL I>J OR ARR(I)>PART\n110 I=I+1\n IF(I.GE.J) GOTO 200\n! IF(ARR(I).LE.PART) GOTO 110\n IF(ARR(I).GE.PART) GOTO 110\n!******STEP Q4, DECREASE J UNTIL JM\n IF(MAX-J.LE.M) GOTO 360\n! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=MIN\n IGH(IS)=J-1\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n310 MIN=J+1\n GOTO 100\n! MAX-J GREATEST\n350 IF(MAX-J.LE.M) GOTO 400\n! PUSH ONLY IF J-MIN>M\n IF(J-MIN.LE.M) GOTO 310\n! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=J+1\n IGH(IS)=MAX\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n360 MAX=J-1\n GOTO 100\n!******STEP Q8, POP FROM STACK\n400 IS=IS-1\n IF(IS.LT.1) GOTO 500\n MIN=LOW(IS)\n MAX=IGH(IS)\n GOTO 100\n!******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1\n500 CONTINUE\n900 RETURN\n910 buperr=1051\n GOTO 900\n end SUBROUTINE SORTRDD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine sortin & Sorting integers\n!\\begin{verbatim}\n SUBROUTINE SORTIN(IARR,N,IX)\n! ...SORTING INTEGERS IN ASCENDING ORDER\n! INPUT:\n! IARR ARRAY TO BE SORTED\n! N NUMBER OF ELEMENTS TO BE SORTED >1\n! IX INTEGER ARRAY WITH DIMENSION N\n! EXIT:\n! IARR SORTED ARRAY\n! IX ARRAY WHERE IX(I) IS THE PREVIOS INDEX OF IARR(I)\n implicit none\n integer IARR(*),n,ix(*)\n!\\end{verbatim} %+\n integer, parameter :: MSTACK=20\n integer ipart,ival\n integer LOW(MSTACK),IGH(MSTACK)\n integer i,is,j,k,m,min,max\n! PARAMETER (MSTACK=20)\n! DIMENSION IARR(*),IX(*),LOW(MSTACK),IGH(MSTACK)\n! LOW AND IGH IS USED TO STORE THE LOWER AND HIGHER PARTISION BOUNDARIES\n IF(N.LT.1) GOTO 900\n! IX IS ORIGINAL INDEX OF ELEMENT I IN IARR\n DO I=1,N\n IX(I)=I\n endDO\n IF(N.EQ.1) GOTO 900\n! M IS THE PARTITION SIZE THAT IS SORTED WITH STRIGHT INSERTION\n! IS POINTS TO FREE STACK, MSTACK IS SIZE OF STACK\n M=1\n IS=1\n!******STEP Q1, INITIATING\n IF(N.LE.M) GOTO 900\n MIN=1\n MAX=N\n!******STEP Q2, NEW STAGE\n! MIN AND MAX ARE LOWER AND UPPER LIMITS FOR THE PARTISION\n100 IPART=IARR(MIN)\n I=MIN\n J=MAX+1\n!******STEP Q3, INCREASE I UNTIL I>J OR IARR(I)>IPART\n110 I=I+1\n IF(I.GE.J) GOTO 200\n IF(IARR(I).LE.IPART) GOTO 110\n!******STEP Q4, DECREASE J UNTIL JM\n IF(MAX-J.LE.M) GOTO 360\n! BOTH PARTITIONS ARE GREATER THAN M, THE GREATEST IS PUSHED\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=MIN\n IGH(IS)=J-1\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n310 MIN=J+1\n GOTO 100\n! MAX-J GREATEST\n350 IF(MAX-J.LE.M) GOTO 400\n! PUSH ONLY IF J-MIN>M\n IF(J-MIN.LE.M) GOTO 310\n! BOTH PARTITIONS ARE GREATER THAN M, PUSH THE GREATEST\n IF(IS.GT.MSTACK) GOTO 910\n LOW(IS)=J+1\n IGH(IS)=MAX\n IS=IS+1\n! CONTINUE TO PARTITION THE SMALLEST\n360 MAX=J-1\n GOTO 100\n!******STEP Q8, POP FROM STACK\n400 IS=IS-1\n IF(IS.LT.1) GOTO 500\n MIN=LOW(IS)\n MAX=IGH(IS)\n GOTO 100\n!******STEP Q9, STRIGHT INSERTION, ONLY NECESSARY IF M>1\n500 CONTINUE\n buperr=0\n900 RETURN\n910 buperr=1001\n GOTO 900\n END SUBROUTINE SORTIN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine ssort DOES NOT WORK\n!\\begin{verbatim}\n SUBROUTINE SSORT(CMD,NS,INDEX)\n!...SORTING a character array, max 40 characters long\n! THIS DOES NOT WORK !!!\n implicit none\n CHARACTER CMD(*)*(*)\n integer ns,index(*)\n!\\end{verbatim}\n CHARACTER STR*40\n integer l,itop,j,j1,j2,k\n!\n L=LEN(CMD(1))\n ITOP=1\n INDEX(ITOP)=1\n100 ITOP=ITOP+1\n IF(ITOP.GT.NS) GOTO 900\n STR=CMD(ITOP)\n IF(STR(1:L).GE.CMD(INDEX(ITOP-1))) THEN\n INDEX(ITOP)=ITOP\n GOTO 100\n ENDIF\n J1=1\n J2=ITOP\n J=(J1+J2)/2\n200 IF(STR(1:L).LT.CMD(INDEX(J))) THEN\n J2=J\n ELSEIF(J.GT.J1) THEN\n J1=J\n ELSE\n J=J2\n GOTO 300\n ENDIF\n IF(J1.NE.J2) THEN\n K=J\n J=(J1+J2)/2\n IF(K.NE.J) GOTO 200\n J=J2\n ENDIF\n!...PLACE FOUND\n300 CONTINUE\n MOVE: DO K=ITOP-1,J,-1\n INDEX(K+1)=INDEX(K)\n enddo MOVE\n INDEX(J)=ITOP\n GOTO 100\n900 RETURN\n END SUBROUTINE SSORT\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine ssort & Sorting characters\n!\\begin{verbatim}\n SUBROUTINE SSORT2(CMD,NS,INDX)\n!...SORTING a character array, max 40 characters long\n! it does not change the position of the texts in CMD but return order in ORDER\n implicit none\n CHARACTER CMD(*)*(*)\n integer ns,indx(*)\n!\\end{verbatim}\n! CHARACTER STR*40\n! integer j1,j2,first,previous,next,limit\n integer j1,first,previous,next,limit\n integer, allocatable, dimension(:) :: order\n!\n! links has the the index of the CMD in the increasing order\n if(ns.le.0) then\n write(*,*)'SSORT called with no arguments to sort'\n buperr=1100; goto 900\n endif\n allocate(order(ns))\n do j1=1,ns\n order(j1)=-j1\n enddo\n! write(*,'(a,20i4)')'SSORT ',ns,(order(j1),j1=1,ns)\n next=1\n first=1\n! write(*,*)'SSORT first quad ',next,': ',trim(cmd(next))\n all: do j1=2,ns\n previous=-1\n next=first\n limit=0\n! write(*,'(a,i3,a,i3,a,a)')'SSORT loop from ',first,' to ',j1,&\n! ' to find place for ',trim(cmd(j1))\n find: do while(next.le.j1)\n limit=limit+1; if(limit.gt.2*ns) stop 'ininite loop'\n if(next.lt.0) then\n! there are no more to compare with, this is the last\n order(previous)=j1\n! write(*,'(a,i3,2x,20i3)')'SSORT insert last at ',&\n! previous,(order(j2),j2=1,ns)\n! do not change sign or order(j1)\n cycle all\n endif\n! write(*,'(a,3i3,1x,a,1x,a,1x,a,1x,a)')'SSORT 1:',previous,j1,next,&\n! ' compare ',trim(cmd(j1)),' and ',trim(cmd(next))\n if(cmd(j1).lt.cmd(next)) then\n! insert this after previous, copy link to next to order(j1)\n if(previous.lt.0) then\n! write(*,'(a,a,3i3)')'SSORT 2: insert first before ',&\n! trim(cmd(next)),previous,j1,next\n order(j1)=first; first=j1\n else\n! write(*,'(a,a,\"< \",a,\" >\",a,3i3)')'SSORT 2: insert between ',&\n! trim(cmd(previous)),trim(cmd(j1)),trim(cmd(next)),&\n! previous,j1,next\n order(j1)=order(previous);\n order(previous)=j1\n endif\n! write(*,'(a,2i3,2x,20i3)')'SSORT 3:',first,j1,(order(j2),j2=1,ns)\n exit find\n endif\n! write(*,'(a,2i3,2x,20i3)')'SSORT 5:',next,j1,(order(j2),j2=1,ns)\n! compare with next\n previous=next\n next=order(next)\n enddo find\n! write(*,'(a,2i3,2x,20i3)')'SSORT 6:',first,0,(order(j2),j2=1,ns)\n enddo all\n! write(*,'(a,2i3,2x,20i3)')'SSORT 7:',first,ns,(order(j2),j2=1,ns)\n!\n! next=first\n! limit=1\n! do while(next.gt.0)\n! write(*,*)limit,' ',cmd(next)\n! next=order(next)\n! limit=limit+1\n! enddo\n! convert to positions ...\n next=first\n limit=1\n do while(next.gt.0)\n j1=next\n next=order(next)\n indx(j1)=limit\n limit=limit+1\n enddo\n! write(*,'(a,2i3,2x,20i3)')'SSORT 9:',first,ns,(order(j2),j2=1,ns)\n! stop 'ssol'\n900 continue\n return\n end SUBROUTINE SSORT2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine mqsort & Sorting MQMQA constituents\n!\\begin{verbatim}\n SUBROUTINE MQSORT(CMD,NS,INDX)\n!...SORTING a character array, max 40 characters long BUBLESORT\n! it does not change the position of the texts in CMD but return order in ORDER\n implicit none\n CHARACTER CMD(*)*(*)\n integer ns,indx(*)\n!\\end{verbatim}\n CHARACTER STR*40\n integer j1,j2,bytt\n! integer, allocatable, dimension(:) :: order\n!\n! links has the the index of the CMD in the increasing order\n if(ns.le.0) then\n write(*,*)'QSORT called with no arguments to sort'\n buperr=1100; goto 900\n endif\n do j1=1,ns\n indx(j1)=j1\n enddo\n bytt=1\n do while(bytt.gt.0) \n bytt=0\n! write(*,*)'QSORT loop ',trim(cmd(indx(1))),' ',trim(cmd(indx(ns)))\n all: do j1=2,ns\n if(cmd(indx(j1)).lt.cmd(indx(j1-1))) then\n j2=indx(j1)\n indx(j1)=indx(j1-1)\n indx(j1-1)=j2\n! write(*,*)'M4 QSORT: ',trim(cmd(indx(j1-1))),' < ',&\n! trim(cmd(indx(j1)))\n bytt=bytt+1\n endif\n enddo all\n enddo\n! write(*,10)'QSORT done: ',ns,(indx(j1),j1=1,ns)\n!10 format(a,i3,2x,20i3)\n900 continue\n return\n end SUBROUTINE MQSORT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! Routines for manipulation of characters\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable logical function ucletter & Check if character is UPPER case\n!\\begin{verbatim}\n LOGICAL FUNCTION ucletter(ch1)\n! returns TRUE if the character is A to Z\n implicit none\n character ch1*1\n!\\end{verbatim} %+\n if(lge(ch1,'A') .and. lle(ch1,'Z')) then\n ucletter=.TRUE.\n else\n ucletter=.FALSE.\n endif\n END FUNCTION ucletter\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable character function biglet & Convert one character to UPPER case\n!\\begin{verbatim}\n CHARACTER FUNCTION BIGLET(CHA)\n!...CONVERTS ONE CHARACTER FROM LOWER TO UPPER CASE\n implicit none\n CHARACTER*1 CHA\n!\\end{verbatim} %+\n CHARACTER*1 CHLAST\n PARAMETER (CHLAST='z')\n IF(CHA.GE.'a' .AND. CHA.LE.CHLAST) THEN\n BIGLET=CHAR(ICHAR(CHA)+ICHAR('A')-ICHAR('a'))\n ELSE\n BIGLET=CHA\n ENDIF\n RETURN\n END FUNCTION BIGLET\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine capson & Convert character to UPPER case\n!\\begin{verbatim}\n SUBROUTINE capson(text)\n! converts lower case ASCII a-z to upper case A-Z, no other changes\n implicit none\n character text*(*)\n!\\end{verbatim}\n integer, parameter :: lowa=ichar('a'),lowz=ichar('z'),&\n iup=ICHAR('A')-ICHAR('a')\n integer i,ich1\n DO i=1,len(text)\n ich1=ichar(text(i:i))\n IF(ich1.ge.lowa .and. ich1.le.lowz) THEN\n text(i:i)=char(ich1+iup)\n ENDIF\n ENDDO\n END SUBROUTINE capson\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable logical function eolch & TRUE is character is empty after ip\n!\\begin{verbatim}\n LOGICAL FUNCTION EOLCH(STR,IP)\n!...End of Line CHeck, TO SKIP SPACES FROM IP. RETURNS .TRUE. IF ONLY SPACES\n!....MODIFIED TO SKIP TAB CHARACTERS ALSO\n implicit none\n CHARACTER STR*(*)\n integer ip\n integer, parameter :: ITAB=9\n!\\end{verbatim}\n!\n EOLCH=.FALSE.\n IF(IP.LE.0) IP=1\n100 IF(IP.GT.LEN(STR)) GOTO 110\n IF(STR(IP:IP).NE.' ' .AND. ICHAR(STR(IP:IP)).NE.ITAB) GOTO 900\n IP=IP+1\n GOTO 100\n110 EOLCH=.TRUE.\n900 RETURN\n END FUNCTION EOLCH\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getrel & Extrtact real or double\n!\\begin{verbatim}\n SUBROUTINE GETREL(SVAR,LAST,VALUE)\n! extract a real from a character\n implicit none\n character svar*(*)\n integer last\n double precision value\n!\\end{verbatim} %+\n integer isig\n call getrels(svar,last,value,isig)\n return\n END SUBROUTINE GETREL\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getrem & Extract real skipping trailing ;\n!\\begin{verbatim}\n SUBROUTINE GETREM(SVAR,LAST,VAL)\n! ...IDENTICAL TO GETREL EXCEPT THAT A TERMINATING COMMA \",\" IS SKIPPED\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER SVAR*(*)\n integer last\n double precision val\n!\\end{verbatim} %+\n CALL GETREL(SVAR,LAST,VAL)\n IF(BUPERR.NE.0) RETURN\n IF(SVAR(LAST:LAST).EQ.',') LAST=LAST+1\n RETURN\n END SUBROUTINE GETREM\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getrels & Extract real\n!\\begin{verbatim}\n SUBROUTINE GETRELS(SVAR,LAST,VALUE,ISIG)\n!...DECODES A REAL NUMBER FROM A TEXT\n! IT MAY BE PRECEEDED BY SPACES AND A + OR -\n! THERE MUST BE AT LEAST ONE NUMBER BEFORE OR AFTER A PERIOD\n! THERE MUST BE AT LEAST ONE NUMBER BEFORE AN \"E\" OR \"D\"\n! AFTER AN \"E\" OR \"D\" THERE MAY BE A + OR - AND MUST BE ONE OR TWO NUMBERS\n! 840310 CHANGE TO ALLOW SPACES AFTER A SIGN I.E. + 2.2 IS ALLOWED\n! 860201 EXPONENTIAL D ACCEPTED\n! 100910 F95 version\n! ISIG is zero if no sign, needed to separte terms inside expressions\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n character svar*(*)\n integer last,isig\n double precision value\n!\\end{verbatim} %+\n! EOLCH is declared as logical function in this module so not needed here\n! LOGICAL EOLCH\n CHARACTER CH*1\n integer i,ierr,jerr\n double precision hel,dec,expo\n! INTEGER GPS,GPN\n CONTINUE\n letter: IF(EOLCH(SVAR,LAST)) THEN\n buperr=1031\n GOTO 9000\n ELSEIF(LAST.LT.LEN(SVAR)-2) THEN\n IF(SVAR(LAST:LAST+3).EQ.'NONE') THEN\n VALUE=RNONE\n buperr=0\n GOTO 9000\n ENDIF\n ENDIF letter\n CH=SVAR(LAST:LAST)\n isig=0\n sign: IF(CH.EQ.'-') THEN\n LAST=LAST+1\n ISIG=-1\n IERR=1036\n ELSE\n ISIG=1\n IF(CH.EQ.'+') THEN\n IERR=1035\n LAST=LAST+1\n ELSE\n IERR=0\n ENDIF\n ENDIF sign\n! 840310 NEXT LINE ADDED TO ALLOW FOR SPACES AFTER A SIGN\n IF(EOLCH(SVAR,LAST)) THEN\n! if nothing after sign return error\n buperr=IERR; GOTO 9000\n ENDIF\n CH=SVAR(LAST:LAST)\n continue\n! CCI\n HEL=ZERO\n nodot: IF(CH.NE.'.') THEN\n JERR=GPN(SVAR,LAST,HEL)\n IF(JERR.NE.0) THEN\n! keep error code meaning nagative or positive sign\n if(ierr.eq.0) then\n buperr=jerr\n else\n buperr=ierr\n endif\n GOTO 9000\n ELSE\n!... REMOVE POSSIBLE ERROR CODE SET BY NEGATIVE SIGN\n IERR=0\n ENDIF\n ELSE\n!... MARK THAT THERE WHERE NO DIGITS BEFORE THE DECIMAL POINT\n IF(IERR.EQ.0) IERR=1037\n HEL=ZERO\n ENDIF nodot\n!...If the next character is a period then decode the decimal part.\n! If there is no numbers after the period, JERR is nonzero.\n! Then check if IERR is nonzero otherwise there is no numbers at all\n! before or after the period. If so return with error code.\n continue\n decimalpoint: if(last.ge.len(svar)) then\n dec=zero\n elseIF(SVAR(LAST:LAST).EQ.'.') THEN\n LAST=LAST+1\n I=LAST\n JERR=GPN(SVAR,LAST,DEC)\n IF(JERR.EQ.0) THEN\n IERR=0\n I=LAST-I\n DEC=DEC/(TEN**I)\n ELSEIF(IERR.EQ.0) THEN\n DEC=ZERO\n ELSE\n!... NO DIGITS BEFORE OR AFTER A DECIMAL POINT\n buperr=1033\n GOTO 9000\n ENDIF\n ELSE\n DEC=ZERO\n ENDIF decimalpoint\n EXPO=ONE\n exponent: if(last.lt.len(svar)) then\n IF(BIGLET(SVAR(LAST:LAST)).EQ.'E' &\n .OR. BIGLET(SVAR(LAST:LAST)).EQ.'D') THEN\n LAST=LAST+1\n IERR=GPS(SVAR,LAST,EXPO) \n if(ierr.ne.0) then\n buperr=ierr\n GOTO 9000\n ENDIF\n IF(INT(ABS(EXPO)).GT.99) THEN\n buperr=1039\n GOTO 9000\n ENDIF\n I=INT(EXPO)\n EXPO=TEN**I\n ENDIF\n endif exponent\n VALUE=DBLE(ISIG)*(HEL+DEC)*EXPO\n9000 continue\n RETURN\n END SUBROUTINE GETRELS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function gps & Extract real\n!\\begin{verbatim}\n INTEGER FUNCTION GPS(SVAR,LAST,VALUE)\n!...DECODES A NUMBER WITH OR WITHOUT A SIGN\n implicit none\n DOUBLE PRECISION VALUE\n CHARACTER SVAR*(*)\n integer last\n!\\end{verbatim} %+\n integer ierr,jerr,isig\n CHARACTER SIG*1\n SIG=SVAR(LAST:LAST)\n IF(SIG.EQ.'-') THEN\n LAST=LAST+1\n ISIG=-1\n IERR=1036\n ELSE\n ISIG=1\n IF(SIG.EQ.'+') THEN\n LAST=LAST+1\n IERR=1035\n ELSE\n IERR=1037\n ENDIF\n ENDIF\n JERR=GPN(SVAR,LAST,VALUE)\n IF(JERR.EQ.0) IERR=0\n GPS=IERR\n VALUE=DBLE(ISIG)*VALUE\n RETURN\n END FUNCTION GPS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function gpn & Extract real without sign\n!\\begin{verbatim}\n INTEGER FUNCTION GPN(SVAR,LAST,VALUE)\n!...DECODES A NUMBER WITHOUT SIGN\n! DOUBLE PRECISION VALUE\n implicit none\n CHARACTER SVAR*(*)\n integer last\n double precision value\n!\\end{verbatim}\n! DOUBLE PRECISION, parameter :: ZERO=0.0D0,TEN=1.0D1\n integer l,ierr,n\n L=LEN_TRIM(SVAR)\n VALUE=ZERO\n IERR=1034\n digits: DO LAST=LAST,L\n N=ICHAR(SVAR(LAST:LAST))-ICHAR('0')\n IF(N.LT.0 .OR. N.GT.9) GOTO 800\n IERR=0\n VALUE=TEN*VALUE+DBLE(N)\n enddo digits\n800 GPN=IERR\n RETURN\n END FUNCTION GPN\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getint & Extract integer\n!\\begin{verbatim}\n SUBROUTINE GETINT(SVAR,LAST,IVAL)\n!...DECODES AN INTEGER FROM A TEXT\n! IT MAY BE PRECCEDED BY SPACES AND A + OR -\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER SVAR*(*)\n integer last,ival\n!\\end{verbatim} %+\n integer ierr\n double precision value\n! \n IF(EOLCH(SVAR,LAST)) THEN\n! CALL ST2ERR(1031,'GETINT','LINE EMPTY')\n buperr=1031\n ELSEIF(SVAR(LAST:MIN(LEN(SVAR),LAST+3)).EQ.'NONE') THEN\n IVAL=NONE\n IERR=0\n ELSE\n IERR=GPS(SVAR,LAST,VALUE)\n IF(IERR.EQ.0) THEN\n! IF(VALUE.GT.FLOAT(MAXINT) .OR. VALUE.LT.FLOAT(MININT)) THEN\n IF(VALUE.GT.DBLE(MAXINT) .OR. VALUE.LT.DBLE(MININT)) THEN\n! CALL ST2ERR(1033,'GETINT','TOO LARGE INTEGER VALUE')\n buperr=1042\n IVAL=0\n ELSE\n IVAL=INT(VALUE)\n ENDIF\n ELSE\n! CALL ST2ERR(IERR,'GETINT','NO DIGIT')\n buperr=ierr\n IVAL=0\n ENDIF\n ENDIF\n RETURN\n END SUBROUTINE GETINT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getinm & Extract integer and trailing ,\n!\\begin{verbatim}\n SUBROUTINE GETINM(SVAR,LAST,IVAL)\n! ...IDENTICAL TO GETINT EXCEPT THAT A TERMINATING COMMA \",\", IS SKIPPED\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER SVAR*(*)\n integer last,ival\n!\\end{verbatim} %+\n CALL GETINT(SVAR,LAST,IVAL)\n IF(BUPERR.NE.0) RETURN\n IF(SVAR(LAST:LAST).EQ.',') LAST=LAST+1\n RETURN\n END SUBROUTINE GETINM\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getoct & Extract octal number\n!\\begin{verbatim}\n SUBROUTINE GETOCT(LINE,IP,IVAL)\n!...DECODE AN OCTAL NUMBER\n implicit none\n CHARACTER LINE*(*)\n integer ip,ival\n!\\end{verbatim} %+\n integer ierr,j\n IERR=0\n IF(EOLCH(LINE,IP)) THEN\n! CALL ST2ERR(1031,'GETOCT','LINE EMPTY')\n buperr=1031\n ELSEIF(LINE(IP:IP+3).EQ.'NONE') THEN\n IVAL=NONE\n ELSE\n IERR=1038\n IVAL=0\n100 J=ICHAR(LINE(IP:IP))-ICHAR('0')\n IF(J.GE.0 .AND. J.LE.7) THEN\n IERR=0\n IVAL=8*IVAL+J\n ELSE\n GOTO 800\n ENDIF\n IP=IP+1\n GOTO 100\n ENDIF\n!800 IF(IERR.NE.0) CALL ST2ERR(IERR,'GETOCT','NO DIGIT')\n800 continue\n RETURN\n END SUBROUTINE GETOCT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gethex & Extract hexadecimal number\n!\\begin{verbatim}\n SUBROUTINE GETHEX(LINE,IP,IVAL)\n!...DECODE A HEXADECIMAL NUMBER\n implicit none\n CHARACTER LINE*(*)\n integer ip,ival\n!\\end{verbatim}\n integer bug,ierr,isign,idig,maxdig,j\n CHARACTER CH1*1\n!\n IERR=0\n ISIGN=0\n IF(EOLCH(LINE,IP)) THEN\n! CALL ST2ERR(1031,'GETHEX','LINE EMPTY')\n buperr=1031\n ELSEIF(LINE(IP:IP+3).EQ.'NONE') THEN\n IVAL=NONE\n ELSE\n IERR=1038\n IVAL=0\n IDIG=0\n MAXDIG=NBITPW/4\n100 CH1=LINE(IP:IP)\n IF(LGE(CH1,'0') .AND. LLE(CH1,'9')) THEN\n J=ICHAR(CH1)-ICHAR('0')\n IERR=0\n ELSEIF(LGE(CH1,'A') .AND. LLE(CH1,'F')) THEN\n J=ICHAR(CH1)-ICHAR('A')+10\n IERR=0\n ELSE\n GOTO 800\n ENDIF\n IDIG=IDIG+1\n IF(IDIG.EQ.1 .AND. J.GE.8) THEN\n ISIGN=1\n J=J-8\n ENDIF\n IVAL=16*IVAL+J\n IP=IP+1\n GOTO 100\n ENDIF\n!800 IF(IERR.NE.0) CALL ST2ERR(IERR,'GETHEX','NO DIGIT')\n800 continue\n! IF(ISIGN.EQ.1) CALL SETB(1,IVAL)\n bug=ival\n! wow, set sign bit of an integer? Assume 32 bits ...\n IF(ISIGN.EQ.1) ival=ibset(ival,31)\n! write(*,*)'In metlib4 GETHEX: ',ival,bug\n RETURN\n END SUBROUTINE GETHEX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getname & Extract a species name\n!\\begin{verbatim}\n subroutine getname(text,ip,name,mode,ch1)\n! reading a species name, this should be incorporated in metlib, \n implicit none\n character text*(*),name*(*),ch1*1\n integer ip,mode\n!\\end{verbatim} %+\n! Always a letter A-Z as first character\n! mode=0 is normal, letters, numbers, \".\" and \"_\" allowed ?? should . be allowed\n! mode=1 used for species names with \"/\", \"+\" and \"-\" allowed also\n integer jp\n ch1=biglet(text(ip:ip))\n if(ch1.lt.'A' .or. ch1.gt.'Z') then\n write(*,17)ichar(ch1),ch1,text(1:24),ip\n17 format('GETNAME error: ',i5,' \"',a,'\" in \"',a,'\" at ',i4)\n buperr=1101; goto 1000\n endif\n jp=ip\n do while(ip.lt.len(text))\n ip=ip+1\n ch1=biglet(text(ip:ip))\n if(ch1.ge.'A' .and. ch1.le.'Z') goto 100\n if(ch1.ge.'0' .and. ch1.le.'9') goto 100\n if(ch1.eq.'_' .or. ch1.eq.'.') goto 100\n if(mode.eq.1) then\n! special for species names\n if(ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-') goto 100\n endif\n goto 200\n100 continue\n enddo\n200 continue\n name=text(jp:ip-1)\n1000 continue\n return\n end subroutine getname\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine getext & Extact a text item\n!\\begin{verbatim}\n SUBROUTINE GETEXT(SVAR,LAST,JTYP,STRING,CDEF,LENC)\n!...SVAR SHALL CONTAIN A TEXT. SCAN STARTS AT POSITION LAST.\n! STRING IS SET TO THE FIRST NONBLANK CHARACTER UP TO THE TERMINATOR.\n! CDEF IS A DEFAULT VAUE IF SVAR IS EMPTY.\n! LENC IS THE LENGTH OF THE TEXT IN STRING\n! JTYP DEFINES THE TERMINATION OF A STRING\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 text terminated by space but if first char is ', \" up to next ' or \"\n! 8 text terminated by space but if first char is (, {, [ or < all text\n! until matching ), }, ] or >. Possibly including more ( ) etc.\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER SVAR*(*),CDEF*(*),STRING*(*)\n integer last,jtyp,lenc\n!\\end{verbatim}\n! \n CHARACTER CH1*1,CH2*1\n character*1, parameter :: par(4)=['(','{','[','<']\n character*1, parameter :: ipar(4)=[')','}',']','>']\n integer i,j,k,l1,l2,level,ityp\n! LOGICAL EOLCH,SG2ERR\n IF(JTYP.LE.0) THEN\n! CALL ST2ERR(1030,'GETEXT','NO SUCH TYPE OPTION')\n buperr=1030\n GOTO 900\n ENDIF\n IF(JTYP.LE.6) THEN\n ITYP=JTYP+3\n ELSE\n ITYP=10\n CH2=CHAR(JTYP)\n ENDIF\n!...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS\n! ANSWER\n LAST=LAST+1\n IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1\n!...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST\n! IF LAST OUTSIDE SVAR THEN ASK QUESTION\n I=LAST\n CONTINUE\n IF(EOLCH(SVAR,I)) GOTO 910\n! STRING=CDEF\n! LENC=LEN(CDEF)\n! LAST=I\n! GOTO 900\n! ENDIF\n CH1=SVAR(I:I)\n!...IF FIRST CHARACTER IS \",\" PUT DEFAULT VALUE IF ANY\n IF(CH1.EQ.',') GOTO 910\n! handle ITYP=7 and 8 separately\n if(jtyp.eq.7) then\n if(ch1.eq.\"'\") then\n j=index(svar(i+1:),\"'\")\n if(j.eq.0) then\n! no matching ', return whole string, position after last character\n string=svar(i:len_trim(svar))\n last=len_trim(svar)\n lenc=last-i\n buperr=1032\n else\n! return string without ', position after last '\n string=svar(i+1:i+j-1)\n last=i+j+1\n lenc=j-1\n endif\n elseif(ch1.eq.'\"') then\n j=index(svar(i+1:),'\"')\n if(j.eq.0) then\n! no matching \", return whole string, position after last character\n string=svar(i:len_trim(svar))\n last=len_trim(svar)\n lenc=last-i\n buperr=1032\n else\n! return string without \", position after last \"\n string=svar(i+1:i+j-1)\n last=i+j+1\n lenc=j-1\n endif\n endif\n goto 900\n elseif(jtyp.eq.8) then\n! check if first character is ( { or [\n do j=1,4\n if(ch1.eq.par(j)) goto 17\n enddo\n write(*,*)'no open parenthesis ',ch1\n! if not ( { [ or < continue with original code\n goto 33\n! we must scan svar character by character until matching ipar(j) \n17 continue\n level=1\n k=i\n write(*,*)'jtyp 8, found ',par(j),', in position: ',k\n20 k=k+1\n if(k.gt.len(svar)) goto 920\n ch1=svar(k:k)\n if(ch1.eq.par(j)) then\n! if we find a new ( { [ or < increase level\n level=level+1\n elseif(ch1.eq.ipar(j)) then\n level=level-1\n if(level.eq.0) then\n! we have found matching ) } ] or >\n string=svar(i+1:k-1)\n last=k+1\n lenc=k-i-2\n goto 900\n endif\n endif\n goto 20\n endif\n!-------------------------------\n! here original code continue\n33 continue\n!...FETCH THE VALUE FROM SVAR\n LAST=I\n L1=0\n L2=0\n GOTO(40,50,60,70,80,70,100),ITYP-3\n40 L1=INDEX(SVAR(LAST:),',')\n50 L2=INDEX(SVAR(LAST:),' ')\n GOTO 400\n!...\n60 L1=INDEX(SVAR(LAST:),'.')\n70 L2=INDEX(SVAR(LAST:),';')\n!...STRING INCLUDING THE ;\n IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1\n GOTO 400\n!...\n80 L1=LEN(SVAR)\n GOTO 400\n100 L2=INDEX(SVAR(LAST:),CH2)\n400 IF(L1.GT.0 .AND. L2.GT.0) THEN\n L1=LAST+MIN(L1,L2)-1\n ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN\n L1=LEN(SVAR)+1\n ELSE\n L1=LAST+MAX(L1,L2)-1\n ENDIF\n IF(L1.GT.LAST) THEN\n STRING=SVAR(LAST:MIN(LEN(SVAR),L1-1))\n LENC=L1-LAST\n ELSE\n STRING=' '\n LENC=0\n ENDIF\n LAST=L1\n!\n900 RETURN\n!...SET DEFAULT VALUE\n910 IF(CDEF.NE.CNONE) THEN\n STRING=CDEF\n LENC=LEN(CDEF)\n!...SET POSITION IN STRING TO POSITION OF ,\n LAST=I\n GOTO 900\n ENDIF\n!...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN\n!920 CALL ST2ERR(1032,'GETEXT','TEXT VALUE MISSING')\n920 continue\n buperr=1032\n GOTO 900\n END SUBROUTINE GETEXT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine wrinum & Write a double left justified\n!\\begin{verbatim}\n SUBROUTINE WRINUM(STR,IP,NNW,JSIGN,VALUE)\n!...EDITS A REAL NUMBER INTO STR WITH LEAST NUMBER OF DIGITS\n! NNW IS MAXIMUM NUMBER OF SIGNIFICANT DIGITS (00 INDICATES THAT + SIGN SHOULD BE WRITTEN\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER STR*(*)\n integer ip,nnw,jsign\n double precision value\n!\\end{verbatim} %+\n CHARACTER CSTR*21,CFRMT*12\n! double precision, parameter :: ZERO=0.0D0,TEN=1.0D1,EPS=1.0D-7\n double precision, parameter :: EPS=1.0D-7\n double precision cc,xx\n integer nw,jj,k,nwd\n CSTR=' '\n NW=NNW\n IF(NW.LE.0) NW=1\n IF(NW.GT.15) NW=15\n IF(IP+NW.GT.LEN(STR)) then\n buperr=1100\n goto 9000\n endif\n IF(VALUE.EQ.ZERO) THEN\n IF(JSIGN.GT.0) THEN\n STR(IP:IP+1)='+0'\n IP=IP+2\n ELSE\n STR(IP:IP)='0'\n IP=IP+1\n ENDIF\n GOTO 9000\n ELSEIF(VALUE.LT.ZERO) THEN\n STR(IP:IP)='-'\n IP=IP+1\n ELSEIF(JSIGN.GT.0) THEN\n STR(IP:IP)='+'\n IP=IP+1\n ENDIF\n CC=ABS(VALUE)\n XX=LOG10(CC+MAX(CC*EPS,EPS))\n! K=INT(XX)\n K=INT(XX)+1\n IF(XX.GT.ZERO) K=K+1\n! some problems writing 81000000000 as fixed format ...\n! This should be handelled by checking the number of zeroes at the end !!\n! write(*,27)k,nw,cc\n!27 format('wrinum: ',2i5,1pe20.12)\n IF(NW.GT.2 .AND. (K.GE.NW .OR. K.LT.-2)) THEN\n!...FLOATING FORMAT\n WRITE(CFRMT,100)NW+5,NW-1\n100 FORMAT('(1P,E',I2,'.',I2,')')\n WRITE(CSTR,CFRMT)CC\n JJ=NW+1\n150 IF(CSTR(JJ:JJ).EQ.'0') THEN\n JJ=JJ-1\n GOTO 150\n ENDIF\n IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1\n STR(IP:IP+JJ-1)=CSTR(1:JJ)\n STR(IP+JJ:IP+JJ+3)=CSTR(NW+2:NW+5)\n IP=IP+JJ+4\n ELSE\n!...FIXED FORMAT\n NWD=NW-K\n WRITE(CFRMT,200)MAX(NW,NWD)+1,NWD\n200 FORMAT('(F',I2,'.',I2,') ')\n WRITE(CSTR,CFRMT)CC\n JJ=MAX(NW,NWD)+1\n250 IF(CSTR(JJ:JJ).EQ.'0') THEN\n JJ=JJ-1\n GOTO 250\n ENDIF\n IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1\n if(CSTR(1:1).eq.' ') then\n! supress any initial space in CSTR, adjust lenght!!\n CSTR(1:)=CSTR(2:)\n jj=jj-1\n endif\n STR(IP:IP+JJ-1)=CSTR(1:JJ)\n IP=IP+JJ\n ENDIF\n9000 continue\n RETURN\n END SUBROUTINE WRINUM\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine wriint & Write an inter left justified\n!\\begin{verbatim}\n subroutine wriint(text,ipos,int)\n! write an integer in text from position ipos (left adjusted)\n implicit none\n character text*(*),number*16\n integer ipos,int,jp\n!\\end{verbatim} %+\n if(int.lt.0) then\n buperr=1200; text(ipos:ipos)='*'; ipos=ipos+1\n elseif(int.eq.0) then\n text(ipos:ipos)='0'; ipos=ipos+1\n else\n write(number,20)int\n20 format(i16)\n jp=1\n if(eolch(number,jp)) then\n buperr=1201; goto 1000\n else\n text(ipos:)=number(jp:)\n! write(*,22)'wriint: ',jp,number(jp:),text(ipos:ipos+16-jp)\n!22 format(a,i3,'>',a,'< >',a,'<')\n ipos=ipos+17-jp\n! write(*,30)'wriint: ',ipos,jp,' >'//text(1:ipos+5)//'<'\n!30 format(a,2i3,a)\n endif\n endif\n1000 continue\n return\n end subroutine wriint\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine wrihex & Write a hexadecimal\n!\\begin{verbatim}\n SUBROUTINE WRIHEX(STR,IVAL)\n!...TO WRITE AN INTEGER AS HEXADECIMAL\n! LOGICAL TESTB\n implicit none\n CHARACTER STR*(*)\n integer ival\n!\\end{verbatim} %+\n integer j,ip,k\n J=IVAL\n IP=0\n10 IP=IP+1\n K=0\n write(*,*)'calling testb from wrihex'\n! IF(TESTB(4*IP-3,J)) K=8\n! IF(TESTB(4*IP-2,J)) K=K+4\n! IF(TESTB(4*IP-1,J)) K=K+2\n! IF(TESTB(4*IP,J)) K=K+1\n IF(btest(4*IP-3,J)) K=8\n IF(btest(4*IP-2,J)) K=K+4\n IF(btest(4*IP-1,J)) K=K+2\n IF(btest(4*IP,J)) K=K+1\n IF(K.GT.9) THEN\n STR(IP:IP)=CHAR(K-10+ICHAR('A'))\n ELSE\n STR(IP:IP)=CHAR(K+ICHAR('0'))\n ENDIF\n IF(IP.LT.LEN(STR)) GOTO 10\n RETURN\n END SUBROUTINE WRIHEX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine wrice & Write a long text\n!\\begin{verbatim}\n subroutine wrice(lut,margl1,margl2,maxl,str)\n! writes str on unit lut with left margin largl1 for first line, margl2 for all\n! following lines, max length maxl characters (assuming typewriter font)\n implicit none\n integer lut,margl1,margl2,maxl\n character str*(*)\n!\\end{verbatim} %+\n! \n! character margx*40\n integer lbreak\n lbreak=0\n call wrice2(lut,margl1,margl2,maxl,lbreak,str)\n continue\n return\n end subroutine wrice\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine wrice2 & Write a long text\n!\\begin{verbatim}\n subroutine wrice2(lut,margl1,margl2,maxl,lbreak,str)\n! writes str on unit lut with left margin largl1 for first line, margl2 for all\n! following lines, max length maxl characters (assuming typewriter font)\n! lbreak>0 for writing math expression, with stricter linebreak rules\n! lbreak<0 for breaking only at space\n implicit none\n character str*(*)\n integer lut,margl1,margl2,maxl,lbreak\n!\\end{verbatim} %+\n!\n character margx*40\n integer lend,nend,lbeg\n!\n nend=len_trim(str)\n margx=' '\n lbeg=1\n lend=maxl-margl1\n if(margl1.lt.0.or.margl2.lt.0 .or. maxl.lt.margl1.or.maxl.lt.margl2) then\n buperr=1070; goto 1000\n endif\n if(nend.lt.lend) then\n if(margl1.eq.0) then\n write(lut,10)str(1:nend)\n10 format(A)\n else\n write(lut,11)margx(1:margl1),str(1:nend)\n11 format(A,A)\n endif\n else\n call cwricend(str,lbeg,lend,lbreak)\n if(margl1.eq.0) then\n write(lut,10)str(1:lend)\n else\n write(lut,11)margx(1:margl1),str(1:lend)\n endif\n do while(lend.lt.nend)\n lbeg=lend+1\n lend=min(lbeg+maxl-margl2-1,nend)\n if(lend.lt.nend) call cwricend(str,lbeg,lend,lbreak)\n if(margl2.eq.0) then\n write(lut,10)str(lbeg:lend)\n else\n write(lut,11)margx(1:margl2),str(lbeg:lend)\n endif\n enddo\n endif\n1000 continue\n return\n end subroutine wrice2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine cwicend & Find a possible place for linebreak\n!\\begin{verbatim}\n subroutine cwricend(str,lbeg,lend,lbreak)\n! find a possible place for a newline in str going back from lend\n! but not bypassing lbeg. str is a numerical expression.\n! lbreak>0 means stricter rules (mathematical expression)\n! lbreak<0 means break only at space\n implicit none\n character str*(*)\n integer lbeg,lend,lbreak\n!\\end{verbatim}\n!\n character ch1*1,ch2*1\n integer ip\n! lbreak=0 means\n! newline possible at space, ;, +, - (but not sign in exponents like E+02)\n findpos: do ip=lend,lbeg,-1\n ch1=str(ip:ip)\n if(ch1.eq.' ' .or. ch1.eq.';') then\n lend=ip\n goto 1000\n elseif(lbreak.ge.0 .and. (ch1.eq.'+' .or. ch1.eq.'-')) then\n ch2=str(ip-1:ip-1)\n! write(*,*)'cwriceend 3: ',ch2,ch1\n if(ch2.eq.'e' .or. ch2.eq.'E' .or. ch2.eq.'d' .or. ch2.eq.'D' .or. &\n ch2.eq.'(' ) then\n continue\n else\n! we cannot find a good breakpoint, break the line here\n lend=ip-1\n goto 1000\n endif\n endif\n enddo findpos\n! no position found, just cut at lend\n1000 continue\n return\n end subroutine cwricend\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n \n!\\addtotable logical function isabbr\n!\\begin{verbatim}\n INTEGER FUNCTION ISABBR(LONG,SHORT,NC)\n! This is for comparing user provided phase names with database phase names\n! LONG is a phase name read from database file\n! SHORT is an array with abbreviated phase names that should be selected\n! Seach array SHORT for any that is an abbreviation of LONG\n! Abbreviations between each _ allowed\n! NOTE: Any - (minus) in SHORT should have been converted to _\n implicit none\n integer nc\n CHARACTER LONG*(*),SHORT(NC)*(*)\n!\\end{verbatim} %\n character chs\n integer j1,k1,k2,ltrim,fit,slen\n fit=0\n ltrim=len_trim(long)\n! write(*,*)'M4 ISABBR ***********: ',trim(long),nc,ltrim\n! loop to compare LONG with all abbreviations in short\n find: do k1=1,nc\n slen=len_trim(short(k1))\n j1=1\n! write(*,*)'M4 abbr: ',trim(short(k1)),slen\n letter: do k2=1,slen\n! this is a loop for all characters in short\n chs=short(k1)(k2:k2)\n uscore: if(chs.eq.'-' .or. chs.eq.'_') then\n! write(*,*)'M4 Found \"-\" in short, skipping to \"-\" in long',j1\n long1: do j1=j1,ltrim\n if(long(j1:j1).eq.'-' .or. long(j1:j1).eq.'_') exit long1\n enddo long1\n! write(*,*)'M4 Looking for \"-\": ',j1,ltrim\n j1=j1+1\n! there is no _ or - in long, skip this abbreviation\n if(j1.gt.ltrim) cycle find\n! found a - in long, compare letter after - in short and long\n cycle letter\n endif uscore\n! accept if next character in short is blank (also if first!)\n if(k2.gt.1 .and. chs.eq.' ') then\n fit=k1; exit find\n endif\n! compare letter in short(k1)(k2:k2) with long(j1:j1)\n! write(*,*)'M4 Letter: \"',chs,'\" and \"',long(j1:j1),k2,j1\n if(chs.ne.long(j1:j1)) cycle find\n j1=j1+1\n enddo letter\n! accept as all slen letters in SHORT match corresponding leters in LONG\n fit=k1\n exit find\n enddo find\n!1000 continue\n! if(fit.gt.0) then\n! write(*,*)'Accept abbreviation ',trim(short(fit)),' for ',trim(long),fit\n! endif\n isabbr=fit\n return\n end FUNCTION ISABBR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! command interpreters\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n \n!\\addtotable integer function ncomp & Top command interpreter\n!\\begin{verbatim}\n INTEGER FUNCTION NCOMP(SVAR,COMM,NC,NEXT)\n! SUBROUTINE NCOMP\n implicit none\n integer nc,next,ient\n CHARACTER SVAR*(*),COMM(NC)*(*)\n!\\end{verbatim} %+\n IENT=1\n ncomp=ncompx(svar,comm,nc,next,ient)\n return\n end FUNCTION NCOMP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function ncomp2 & Level 1 subcommand\n!\\begin{verbatim}\n INTEGER FUNCTION NCOMP2(SVAR,COMM,NC,NEXT)\n! SUBROUTINE NCOMP2\n implicit none\n integer nc,next,ient\n CHARACTER SVAR*(*),COMM(NC)*(*)\n!\\end{verbatim} %+\n IENT=2\n ncomp2=ncompx(svar,comm,nc,next,ient)\n return\n end FUNCTION NCOMP2\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function ncomp3 & Level 2 subcommand\n!\\begin{verbatim}\n INTEGER FUNCTION NCOMP3(SVAR,COMM,NC,NEXT)\n! SUBROUTINE NCOMP3\n implicit none\n integer nc,next,ient\n CHARACTER SVAR*(*),COMM(NC)*(*)\n!\\end{verbatim} %+\n IENT=3\n ncomp3=ncompx(svar,comm,nc,next,ient)\n return\n end FUNCTION NCOMP3\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function ncompx & Actual command interpreter\n!\\begin{verbatim}\n INTEGER FUNCTION NCOMPX(SVAR,COMM,NC,NEXT,IENT)\n! ...TO DECODE A COMMAND\n implicit none\n CHARACTER SVAR*(*),COMM(NC)*(*)\n integer nc,next,ient\n!\\end{verbatim}\n character LINE*80\n CHARACTER*1 CH1,CHSEP,CHLAST,CHSYS,CHSEP2,CH2,CHHELP\n CHARACTER*1 CHHIST,CHMAC\n LOGICAL EXAKT,YESLOG\n PARAMETER (CHSEP='_',CHSEP2='-',CHLAST='Z',CHSYS='@',CHHELP='?')\n PARAMETER (CHHIST='!',CHMAC='#')\n integer ls,lc,lika,klik,i,j,last,n,nmatc\n!\n if(ient.eq.1) then\n YESLOG=.TRUE.\n last=1\n elseif(ient.eq.2) then\n last=1\n else\n LAST=NEXT+1\n endif\n3 LS=LEN(SVAR)\n LC=LEN(COMM(1))\n LIKA=0\n KLIK=0\n IF(EOLCH(SVAR,LAST)) GOTO 300\n IF(LAST.GT.LEN(SVAR)) GOTO 300\n!...SPECIAL TREATMENT IF FIRST CHARACTER IS CHSYS OR CHHELP\n CH1=SVAR(LAST:LAST)\n IF(CH1.EQ.CHSYS) GOTO 800\n IF(IENT.EQ.1 .AND. CH1.EQ.CHHELP) THEN\n LAST=LAST+1\n HELP: DO LIKA=1,NC\n IF(COMM(LIKA)(1:5).EQ.'HELP ') THEN\n!... SKIP QUESTION FOR COMMAND IF LINE EMPTY\n IF(SVAR(LAST+1:LAST+1).EQ.' ') SVAR(LAST+1:LAST+2)=',,'\n GOTO 300\n ENDIF\n enddo HELP\n LAST=LAST-1\n ENDIF\n LIKA=0\n IF(IENT.EQ.1 .AND. CH1.EQ.CHHIST) THEN\n!... A HISTORY COMMAND. RETURN TO 3 IF A PREVIOUS COMMAND SHALL BE EXEC\n CALL NGHIST(SVAR,LAST)\n IF(LAST.EQ.0) GOTO 3\n NCOMPX=0\n NEXT=0\n GOTO 900\n ENDIF\n! FIND LAST CHARACTER IN SVAR THAT IS LEGAL IN A COMMAND\n! CONVERT TO CAPITAL LETTERS AT THE SAME TIME\n IF(IENT.EQ.1) LHP=LAST\n LS=LS-LAST+1\n L20: DO N=1,LS\n CH1=BIGLET(SVAR(N+LAST-1:N+LAST-1))\n IF(LGE(CH1,'A') .AND. LLE(CH1,CHLAST)) GOTO 15\n IF(LGE(CH1,'0') .AND. LLE(CH1,'9')) GOTO 15\n IF(CH1.EQ.CHSEP .OR. CH1.EQ.CHSEP2) GOTO 15\n GOTO 50\n15 LINE(N:N)=CH1\n enddo L20\n!...N UNDEFINED AFTER LOOP?\n N=LS+1\n50 LS=N-1\n KLIK=0\n NMATC=0\n IF(N.EQ.1) GOTO 300\n COMPERE: DO N=1,NC\n EXAKT=.TRUE.\n J=0\n LETTER: DO I=1,LS\n CH1=LINE(I:I)\n J=J+1\n IF(CH1.EQ.CHSEP .OR. CH1.EQ.CHSEP2) THEN\n!... PREPARE FOR A \"-\" JOINING COMMAND AND ARGUMENT\n IF(I.GT.NMATC) THEN\n KLIK=N\n NMATC=I\n ELSEIF(I.EQ.NMATC) THEN\n KLIK=-1\n ENDIF\n90 CH2=COMM(N)(J:J)\n IF(CH2.EQ.CHSEP .OR. CH2.EQ.CHSEP2) GOTO 100\n EXAKT=.FALSE.\n J=J+1\n IF(J.GT.LC) GOTO 200\n GOTO 90\n ENDIF\n IF(CH1.NE.COMM(N)(J:J)) GOTO 200\n100 CONTINUE\n enddo LETTER\n!...A COMMAND THAT CAN FIT, IF EXACTLY EQUAL FINISH\n IF(EXAKT) THEN\n IF(J.EQ.LC) GOTO 500\n IF(COMM(N)(J+1:J+1).EQ.' ') GOTO 500\n ENDIF\n!...IF LIKA>0 THE COMMAND IS AMBIGUOUS\n IF(LIKA.GT.0) GOTO 910\n LIKA=N\n LAST=I+LAST-1\n200 CONTINUE\n enddo COMPERE\n!...ALL COMMANDS COMPERED, IF LIKA=0 THERE WAS NO SUCH COMMAND\n300 NEXT=LAST\n IF(LIKA.EQ.0 .AND. KLIK.GT.0) THEN\n!... NO MATCHING COMMAND BUT PART BEFORE A - MATCHES\n LIKA=-(NC+KLIK)\n NEXT=NMATC\n ENDIF\n GOTO 510\n500 NEXT=I+LAST-1\n YESLOG=.FALSE.\n LIKA=N\n510 CONTINUE\n!...RETURN FUNCTION VALUE\n IF(IENT.EQ.1) THEN\n NCOMPX=LIKA\n IF(LIKA.GT.0) THEN\n LSTCMD=COMM(LIKA)\n IF(LOGFIL.GT.0 .AND. YESLOG) WRITE(KOU,517)LSTCMD\n517 FORMAT(' ... the command in full is ',A)\n CALL CAPSON(LSTCMD)\n ENDIF\n!...SAVE HISTORY, do not save empty lines\n IF(LHP.LE.0)LHP=1\n IF(LEN_TRIM(SVAR(LHP:)).GT.0)THEN\n LHL=LHL+1\n IF(LHL.GT.20) THEN\n LHL=1\n LHM=LHM+20\n ENDIF\n HIST(LHL)=SVAR(LHP:)\n ENDIF\n ELSEIF(IENT.EQ.2) THEN\n NCOMPX=LIKA\n ELSE\n NCOMPX=LIKA\n ENDIF\n GOTO 900\n!...A SYSTEM COMMAND OR COMMENT, UPDATE ACCOUNT RECORD BEFORE EXECUTION\n! TWO CHSYS means skip this line (comment)\n! CHSYS followed by CHMAC means macro line, skip it\n800 IF(SVAR(LAST+1:LAST+1).EQ.CHSYS) GOTO 810\n IF(SVAR(LAST+1:LAST+1).EQ.CHMAC) GOTO 810\n LINE(1:)=SVAR(LAST+1:)\n! CALL CAPSON(LINE)\n! CALL WPAC2\n! CALL UECOM(LINE)\n write(*,*)'Hit return to continue'\n read(*,808)ch1\n808 format(a)\n! CALL COMND(LINE)\n810 NEXT=0\n LIKA=0\n GOTO 510\n900 RETURN\n!...AMBIGUOUS\n910 LIKA=-LIKA\n GOTO 510\n END FUNCTION NCOMPX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! Extracting command arguments from a character\n!\n! There are two groups, those new finishing with x\n! the old without final x (which are listed first)\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparid & Superceeded by gparidx\n!\\begin{verbatim}\n SUBROUTINE GPARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n! ask for integer value with default\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival,idef\n EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*512\n integer iflag\n! chcek for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARID\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gpari\n!\\begin{verbatim}\n SUBROUTINE GPARI_old(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n! ask for integer value woth no default\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival,idef\n EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! check for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARI(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARI_OLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparr\n!\\begin{verbatim}\n SUBROUTINE GPARR_old(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n! asks for a double with no default\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last\n double precision val,rdef\n EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! check for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARR(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n! CALL GPTCM1(IFLAG,SVAR,LAST,SLIN,ENVIR)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARR_OLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparrd\n!\\begin{verbatim}\n SUBROUTINE GPARRD_old(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n! ask for a double with default provided\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last\n EXTERNAL HELP\n double precision val,rdef\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! ths checks for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARRD(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARRD_OLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparc\n!\\begin{verbatim}\n SUBROUTINE GPARC_old(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP)\n! read a character without default\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*)\n integer last,jtyp\n EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! this call handles environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARC(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL(1:max(1,LEN_TRIM(sval)))\n! CALL GPTCM2(IFLAG,SVAR,LAST,SLIN,ENVIR)\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n900 RETURN\n END SUBROUTINE GPARC_OLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparcd\n!\\begin{verbatim}\n SUBROUTINE GPARCD_old(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP)\n! read a character with default provided\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*)\n integer last,jtyp\n EXTERNAL HELP\n!\\end{verbatim} %+\n!\n CHARACTER SLIN*80\n integer iflag\n! this call exchanges environment variables for actual variables\n CALL GQXENV(SVAR)\n! this is the real interactive call\n100 CALL GQARCD(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n!...the next line was missing ...\n IF (IFLAG.NE.0) GOTO 100\n900 RETURN\n END SUBROUTINE GPARCD_OLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarrd\n!\\begin{verbatim}\n subroutine GQARRD(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n! read real with default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival\n character*1 str,cdef\n double precision val,rdef\n EXTERNAL HELP\n!\\end{verbatim} %+\n GPARITYP=3\n GPARWDEF=.TRUE.\n GPARRDEF=RDEF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n return\n end SUBROUTINE GQARRD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarr\n!\\begin{verbatim}\n subroutine GQARR(PROMT,SVAR,LAST,VAL,RDEF,HELP)\n! read real without default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival\n EXTERNAL HELP\n double precision val,rdef\n character*1 str,cdef\n!\\end{verbatim} %+\n GPARITYP=3\n GPARWDEF=.FALSE.\n GPARRDEF=RDEF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n return\n end SUBROUTINE GQARR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarid\n!\\begin{verbatim}\n SUBROUTINE GQARID(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n! previously subroutine GPARID\n!...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR\n! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED\n! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN\n! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE\n! DEFAULT VALUE\n! HELP IS A ROUTINE THAT WRITES AN EXPLAINING MESSAGE.\n! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR\n! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival,idef\n character*1 str,cdef\n double precision val\n EXTERNAL HELP\n!\\end{verbatim} %+\n GPARITYP=1\n GPARWDEF=.TRUE.\n GPARIDEF=IDEF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n return\n end SUBROUTINE GQARID\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqari\n!\\begin{verbatim}\n subroutine GQARI(PROMT,SVAR,LAST,IVAL,IDEF,HELP)\n! read integer with no default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival,idef\n character*1 str,cdef\n double precision val\n EXTERNAL HELP\n!\\end{verbatim} %+\n GPARITYP=1\n GPARWDEF=.FALSE.\n GPARIDEF=IDEF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n return\n end SUBROUTINE GQARI\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarcd\n!\\begin{verbatim}\n subroutine GQARCD(PROMT,SVAR,LAST,JTYP,STR,CDEF,HELP)\n! TO READ A STRING VALUE with default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*)\n integer last,jtyp\n EXTERNAL HELP\n!\\end{verbatim} %+\n!...SUBROUTINE GQARCD\n! JTYP DEFINES THE TERMINATION OF A STRING\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n integer ival\n double precision val\n GPARWDEF=.TRUE.\n IF(JTYP.LE.0) THEN\n! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION')\n buperr=1030\n GOTO 900\n ENDIF\n IF(JTYP.EQ.7) THEN\n GPARENTES=.TRUE.\n GPARITYP=4\n ELSE\n GPARENTES=.FALSE.\n IF(JTYP.LE.6) THEN\n! NOTE GPARITYP 1 and 3 used for integer and double precision !!!\n GPARITYP=JTYP+3\n ELSE\n GPARITYP=10\n GPARCH2=CHAR(JTYP)\n ENDIF\n ENDIF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n return\n900 continue\n end SUBROUTINE GQARCD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparall\n!\\begin{verbatim}\n SUBROUTINE gparall(PROMT,SVAR,LAST,IVAL,val,string,cdef,HELP)\n! previously subroutine GPARID\n!...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR\n! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED\n! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN\n! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE\n! DEFAULT VALUE\n! HELP IS A ROUTINE THAT WRITES AN EXPLAINING MESSAGE.\n! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR\n! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),CH1*1,CDEF*(*),STRING*(*),SSD*30\n CHARACTER PPROMT*132,CH2*1\n! LOGICAL EOLCH,SG2ERR,WDEF,MATP\n LOGICAL WDEF,MATP\n EXTERNAL HELP\n!\\end{verbatim} %+\n integer last,ival\n double precision val\n! local variables\n integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,kxy,iqq,ityp,idef\n double precision rdef,x\n! All routines converge here, update command level and save promt \n! for use by help routines\n CONTINUE\n! check if promt already in path, otherwise increase level\n do iqq=2,helprec%level\n kxy=min(len_trim(promt),12)\n if(promt(1:kxy).eq.helprec%cpath(iqq)(1:kxy)) then\n helprec%level=iqq\n goto 991\n endif\n enddo\n if(helprec%level.lt.maxhelplevel) then\n helprec%level=helprec%level+1\n helprec%cpath(helprec%level)=promt\n! write(*,*)'Help level increased to: ',helprec%level\n else\n! write(*,*)'Warning, too many levels in help path'\n! This can happen when asking for constitution including the constituent\n! just save the last questions\n helprec%cpath(helprec%level)=promt\n endif\n991 continue\n!-------------------------------\n! extract values from calling routines stored in GPARxyz\n wdef=gparwdef\n if(gparityp.eq.1) then\n! calling routine wants an integer value\n ityp=1\n! if(wdef) idef=gparidef\n! always set the default, it may be used anyway!!\n idef=gparidef\n elseif(gparityp.eq.3) then\n! calling routine wants a double precision value\n ityp=3\n! if(wdef) rdef=gparrdef\n rdef=gparrdef\n else\n! calling routine wants a string, ityp>3, \n ityp=gparityp\n matp=gparentes\n ch2=' '\n if(ityp.eq.10) ch2=gparch2\n endif\n!-------------------------------------------------------\n!...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS ANSWER\n LAST=LAST+1\n IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1\n!...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST\n! IF LAST OUTSIDE SVAR THEN ASK QUESTION\n I=LAST\n10 CONTINUE\n IF(EOLCH(SVAR,I)) THEN\n!... EMPTY STRING, IF NO BYTES IN PROMT TAKE DEFAULT VALUES\n M=LEN_TRIM(PROMT)\n IF(M.LT.1) GOTO 910\n IF(WDEF) THEN\n PPROMT=PROMT(1:M)//' /'\n JJP=M+3\n!... INSERT DEFAULT VALUE INTO PROMT\n IF(ITYP.EQ.1) THEN\n X=REAL(IDEF)\n CALL WRINUM(PPROMT,JJP,10,0,X)\n ELSEIF(ITYP.EQ.3) THEN\n! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,10,0,RDEF)\n! to avoid getting values as 0.0250000004 rather than 0.025 ...\n! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,8,0,RDEF)\n CALL WRINUM(PPROMT,JJP,8,0,RDEF)\n ELSE\n PPROMT(JJP:)=CDEF\n I=LEN_TRIM(CDEF)\n JJP=JJP+I\n ENDIF\n IF(LEN_TRIM(PPROMT).GT.M+2) THEN\n PPROMT(JJP:)='/: '\n JJP=JJP+2\n ELSE\n!... TO AVOID AN EMPTY STRING BETWEEN SLASHES\n! PPROMT(M+1:M+2)=': '\n PPROMT(M+1:)=': '\n JJP=len_trim(ppromt)\n ENDIF\n CALL BOUTXT(KOU,PPROMT(1:JJP))\n IJP=JJP\n ELSE\n PPROMT=PROMT\n JJP=LEN_TRIM(PPROMT)\n CALL BOUTXT(KOU,PPROMT(1:MAX(1,JJP)))\n ENDIF\n SVAR=' '\n CALL BINTXT(KIU,SVAR(1:MIN(LEN(SVAR),130)))\n if(jecho.ne.0) then\n! echo ....\n j=len_trim(svar)\n if(j.gt.0) then\n write(kou,77)svar(1:len_trim(svar))\n77 format('... echo: ',a)\n endif\n endif\n!...WRITE INPUT ON LOG FILE IF ANY\n IF(LOGFIL.GT.0) THEN\n!...write on logfile only if question asked !!!\n I=LEN_TRIM(SVAR)\n IF(I.LE.0 .AND. WDEF) THEN\n IF(IJP-3.GE.M+3) THEN\n!...WRITE THE DEFAULT ANSWER IF USER INPUT IS EMPTY\n WRITE(LOGFIL,17)PPROMT(M+3:IJP-3)\n ELSE\n WRITE(LOGFIL,17)' '\n ENDIF\n ELSE\n WRITE(LOGFIL,17)SVAR(1:MAX(1,I))\n ENDIF\n17 FORMAT(A)\n ENDIF\n I=1\n IF(EOLCH(SVAR,I)) GOTO 910\n ENDIF\n!...DECODE THE ANSWER IN SVAR\n CH1=SVAR(I:I)\n!...IF FIRST CHARACTER IS \",\" PUT DEFAULT VALUE IF ANY\n IF(CH1.EQ.',') GOTO 910\n!...IF FIRST CHARACTER IS '?' WRITE HELP MESSAGE\n IF(CH1.EQ.'?') THEN\n M=LEN_TRIM(PROMT)\n CALL HELP(PROMT(1:M),SVAR(I:))\n IF(SVAR(I:I+1).EQ.'?!') THEN\n!... THE SPECIAL ROUTINE TOPHLP SHOULD BE USED WHEN HELP IS\n! PROVIDED INSIDE THE CALLING ROUTINE! A ? IS RETURNED\n SVAR(I+1:I+1)=' '\n if (ityp.gt.3) STRING=SVAR(I:)\n GOTO 900\n ENDIF\n I=LEN(SVAR)\n GOTO 10\n ENDIF\n!...FETCH THE VALUE FROM SVAR\n LAST=I\n IF(ITYP.EQ.1) THEN\n CALL GETINT(SVAR,LAST,IVAL)\n ELSEIF(ITYP.EQ.3) THEN\n CALL GETREL(SVAR,LAST,VAL)\n ELSEIF(ITYP.LE.10) THEN\n!...THE PART HERE IS GLITCHY AS ICE ... handling character input\n L1=0\n L2=0\n! ITYP= 4 5 6 7 8 9 10\n GOTO( 40, 50, 60, 70, 80, 70,100),ITYP-3\n! terminate with space or ,\n40 L1=INDEX(SVAR(LAST:),',')\n! terminate with space\n50 L2=INDEX(SVAR(LAST:),' ')\n! handle if space or , inside parenthesis should be ignored, like x(fcc,cr)\n IF(MATP) THEN\n!...A , OR SPACE INSIDE PARENTHESIS SHOULD BE IGNORED\n LLQ=MIN(L1,L2)\n IF(LLQ.EQ.0) LLQ=MAX(L1,L2)\n LLP=INDEX(SVAR(LAST:),'(')\n IF(LLP.GT.0 .AND. LLP.LT.LLQ) THEN\n!...\tLLP SHALL BE POSITION OF (, FDMTP UPDATES LLP TO POSITION AFTER )\n51 CALL FDMTP(SVAR(LAST:),LLP,SSD)\n IF(BUPERR.NE.0) GOTO 900\n IF(ITYP.EQ.4) L1=INDEX(SVAR(LAST+LLP-1:),',')\n L2=INDEX(SVAR(LAST+LLP-1:),' ')\n IF(L1.GT.0) L1=L1+LLP-1\n IF(L2.GT.0) L2=L2+LLP-1\n LLQ=MIN(L1,L2)\n IF(LLQ.EQ.0) LLQ=MAX(L1,L2)\n LLZ=INDEX(SVAR(LAST+LLP-1:),'(')\n IF(LLZ.GT.0 .AND. LLP+LLZ.LT.LLQ) THEN\n!...\t\t WE HAVE MORE THAN ONE ( BEFORE , OR SPACE\n LLP=LLP+LLZ-1\n GOTO 51\n ENDIF\n ENDIF\n ENDIF\n GOTO 400\n! terminale with period\n60 L1=INDEX(SVAR(LAST:),'.')\n! terminate with semicolon\n70 L2=INDEX(SVAR(LAST:),';')\n!...STRING INCLUDING THE ;\n IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1\n GOTO 400\n!...WHOLE STRING\n80 L1=LEN(SVAR)\n GOTO 400\n! terminate with provided character >31\n100 L2=INDEX(SVAR(LAST:),CH2)\n400 IF(L1.GT.0 .AND. L2.GT.0) THEN\n L1=LAST+MIN(L1,L2)-1\n ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN\n L1=LEN(SVAR)+1\n ELSE\n!... BUG FOUND HERE: IF L1 IS LEN(SVAR) AND LAST>1 L1 SET >LEN(SVAR)+1\n L1=MIN(LAST+MAX(L1,L2)-1,LEN(SVAR)+1)\n ENDIF\n IF(L1.GT.LAST) THEN\n STRING=SVAR(LAST:L1-1)\n ELSE\n STRING=' '\n ENDIF\n LAST=L1\n ELSE\n! CALL ST2ERR(1030,'GPAR','NO SUCH TYPE OPTION')\n buperr=1030\n ENDIF\n900 RETURN\n!...SET DEFAULT VALUE\n910 continue\n IF(ITYP.EQ.1) THEN\n IF(IDEF.EQ.NONE) GOTO 920\n IVAL=IDEF\n ELSEIF(ITYP.EQ.3) THEN\n IF(RDEF.EQ.RNONE) GOTO 920\n VAL=RDEF\n ELSE\n! write(*,911)'ML gparqall: ',trim(cdef),trim(cnone),wdef\n!911 format(a,a,' - ',a,l2)\n IF(CDEF.NE.CNONE) THEN\n STRING=CDEF\n!! endif\n ELSE\n GOTO 920\n endif\n ENDIF\n!...SET POSITION IN STRING TO POSITION OF ,\n LAST=I\n GOTO 900\n!...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN\n!920 CALL ST2ERR(1032,'GPAR','PARAMETER VALUE MISSING')\n920 buperr=1032\n GOTO 900\n END SUBROUTINE GPARALL\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarc\n!\\begin{verbatim}\n subroutine GQARC(PROMT,SVAR,LAST,JTYP,STR,CDEF,HELP)\n! read a string without default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*)\n integer last,ival,jtyp\n EXTERNAL HELP\n double precision val\n character str*(*),cdef*(*)\n!\\end{verbatim} %+\n GPARWDEF=.FALSE.\n IF(JTYP.LE.0) THEN\n! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION')\n buperr=1030\n GOTO 900\n ENDIF\n IF(JTYP.EQ.7) THEN\n GPARENTES=.TRUE.\n GPARITYP=4\n ELSE\n GPARENTES=.FALSE.\n IF(JTYP.LE.6) THEN\n GPARITYP=JTYP+3\n ELSE\n GPARITYP=10\n GPARCH2=CHAR(JTYP)\n ENDIF\n ENDIF\n call gparall(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP)\n900 continue\n return\n end SUBROUTINE GQARC\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparfile\n!\\begin{verbatim}\n SUBROUTINE GPARFILE(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,TYP,HELP)\n! to ask for a file name using command line or external window\n! prompt is question\n! svar is a character variable which may already contain an answer\n! last is position in svar to start searching for an answer\n! JTYP DEFINES THE TERMINATION OF A STRING\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n! sval is the answer either extracted from SVAR or obtained by user input\n! cdef is a default answer\n! typ is default file extenion, at present only:\n! 1=\".TDB\", 2=\".UNF\", 3=\".OCM\"\n! help is a help routine \n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*)\n integer last,jtyp\n EXTERNAL HELP\n!\\end{verbatim}\n CHARACTER SLIN*80\n integer typ,typeahead,kk,iflag\n logical beware\n#ifdef tinyfd\n! only if we use tinyfiledialogs, check if any character after last+1\n typeahead=last+1\n beware=.FALSE.\n! beware set to TRUE if no typeahead (there are non-blanks after positon last+1)\n beware=eolch(svar,typeahead)\n! write(*,*)'M3 gparfile: ',kou,koud,last,eolch(svar,last)\n if(nopenpopup .or. kiu.ne.kiud .or. .not.beware) then\n#endif\n! If we are not connected to a terminal (reading a macro file) use line input\n! Also if there are \"type ahead\" use the line input\n! This call exchanges any macro variables in SVAR for defined macro values\n CALL GQXENV(SVAR)\n! If interactive\n if(kiu.eq.kiud .and. beware) write(kou,\"(a)\") &\n 'Beware: you must give the full path unless the file '//&\n 'is in working directory!'\n100 CALL GQARC(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL(1:max(1,LEN_TRIM(sval)))\n! This call handles ? @ and other things in SVAR\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n if(IUMACLEVL.ge.1) then\n if(sval(1:2).eq.'./') then\n! we are running a macro and if SVAL(1:2) is './' replace this with MACROPATH'\n sval=trim(macropath(IUMACLEVL))//sval(3:)\n elseif(sval(1:3).eq.'../') then\n! we are running a macro and if SVAL(1:3) is '../' prefix with MACROPATH'\n sval=trim(macropath(IUMACLEVL))//sval\n! write(*,*)'M3 add path: ',trim(sval),IUMACLEVL\n! else\n! write(*,*)'M3 assuming full path or in working directory: '\n endif\n endif\n#ifdef tinyfd\n else\n! open a popup window to browse directories and files using tinyfiledialogs\n! typ<0 means new or old file; 0 old file no filer, \n! typ >0 means old file with filter:\n! typ=1 TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT\n! these are defined in pmon6.F90 also !!!!!!!!!!!!!!!!!!!!!!!!!\n! getfilename is in utilities/TINYFILEDIALOGS/ftinyopen\n call getfilename(typ,sval)\n! write(*,333)trim(sval),typ\n333 format('METLIB: Back from getfilename 1: \"',a,'\" typ: ',i3)\n if(sval(1:1).eq.' ') then\n buperr=1020\n elseif(typ.eq.-7) then\n! this is for output and file created, if no extension add DAT\n kk=index(sval,'.DAT ')\n if(kk.eq.0) then\n sval(len_trim(sval)+1:)='.DAT'\n endif\n endif\n endif\n#endif \n900 RETURN\n END SUBROUTINE GPARFILE\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\! new X routines /!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! Extracting command arguments from a character\n!\n! This is second group with new routines\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparidx & Ask for integer with default\n!\\begin{verbatim}\n SUBROUTINE GPARIDx(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n! ask for integer value with default\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last,ival,idef\n! EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*512\n integer iflag\n! chcek for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARIDx(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARIDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparix & Ask for integer no default\n!\\begin{verbatim}\n SUBROUTINE GPARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n! ask for integer value woth no default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last,ival,idef\n! EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! check for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARIX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparrx & Ask for double no default\n!\\begin{verbatim}\n SUBROUTINE GPARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n! asks for a double with no default\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last\n double precision val,rdef\n! EXTERNAL HELP\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! check for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n! CALL GPTCM1(IFLAG,SVAR,LAST,SLIN,ENVIR)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARRX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparrdx & Ask for double with default\n!\\begin{verbatim}\n SUBROUTINE GPARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n! ask for a double with default provided\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last\n! EXTERNAL HELP\n double precision val,rdef\n!\\end{verbatim} %+\n CHARACTER SLIN*80\n integer iflag\n! ths checks for environment variables\n CALL GQXENV(SVAR)\n100 CALL GQARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n CALL GPTCM1(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n RETURN\n END SUBROUTINE GPARRDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparcdx & Ask for character with default\n!\\begin{verbatim}\n SUBROUTINE GPARCDx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper)\n! read a character with default provided\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*)\n integer last,jtyp\n EXTERNAL HELP\n!\\end{verbatim} %+\n!\n CHARACTER SLIN*80\n integer iflag\n! this call exchanges environment variables for actual variables\n CALL GQXENV(SVAR)\n! this is the real interactive call\n100 continue\n! CALL GQARCDX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP,hyper)\n CALL GQARCDX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n!...the next line was missing ...\n IF (IFLAG.NE.0) GOTO 100\n900 RETURN\n END SUBROUTINE GPARCDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparcx & Ask for character no default\n!\\begin{verbatim}\n SUBROUTINE GPARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper)\n! read a character with default provided and hypertarget\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*)\n integer last,jtyp\n! EXTERNAL HELP now always use Q4HELP\n!\\end{verbatim} %+\n!\n CHARACTER SLIN*80\n integer iflag\n! this call exchanges environment variables for actual variables\n CALL GQXENV(SVAR)\n! this is the real interactive call ... well no longer ...\n!100 CALL GQARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,HELP,hyper)\n100 continue\n CALL GQARCX(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n!...the next line was missing ...\n IF (IFLAG.NE.0) GOTO 100\n900 RETURN\n END SUBROUTINE GPARCX\n\n!\\addtotable subroutine gqaridx & Ask for integer with default\n!\\begin{verbatim}\n SUBROUTINE GQARIDX(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n!...SVAR SHALL CONTAIN A PARAMETER VALUE. IF EMPTY THE PARAMETER IS ASKED FOR\n! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF IS RETURNED\n! INTEGER VALUES. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN\n! SLASHES. THE SAME ROUTINES WITHOUT THE FINAL D DOES NOT DISPALY THE\n! DEFAULT VALUE\n! hyper is a hypertarget for online help\n! LAST IS THE POSITION OF THE TERMINATOR OF THE FORMER PARAMETER OR\n! COMMAND, DECODING STARTS FROM THE POSITION AFTER LAST\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last,ival,idef\n character*1 str,cdef\n double precision val\n!\\end{verbatim} %+\n GPARITYP=1\n GPARWDEF=.TRUE.\n GPARIDEF=IDEF\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n end SUBROUTINE GQARIDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarix & Ask for integer no default\n!\\begin{verbatim}\n subroutine GQARIx(PROMT,SVAR,LAST,IVAL,IDEF,hyper)\n! read integer with no default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last,ival,idef\n! EXTERNAL HELP\n!\\end{verbatim} %+\n! dummy variables for gparallx\n character*1 str,cdef\n double precision val\n GPARITYP=1\n GPARWDEF=.FALSE.\n GPARIDEF=IDEF\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n end SUBROUTINE GQARIX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarrdx & Ask for double with default\n!\\begin{verbatim}\n subroutine GQARRDx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n! read real with default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last\n double precision val,rdef\n EXTERNAL HELP\n!\\end{verbatim} %+\n character*1 str,cdef\n integer ival\n GPARITYP=3\n GPARWDEF=.TRUE.\n GPARRDEF=RDEF\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n end SUBROUTINE GQARRDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarrx & Ask for double no default\n!\\begin{verbatim}\n subroutine GQARRx(PROMT,SVAR,LAST,VAL,RDEF,hyper)\n! read real without default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),hyper*(*)\n integer last\n double precision val,rdef\n!\\end{verbatim} %+\n character*1 str,cdef\n integer ival\n GPARITYP=3\n GPARWDEF=.FALSE.\n GPARRDEF=RDEF\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n end SUBROUTINE GQARRX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarcdx & Ask for character with default\n!\\begin{verbatim}\n subroutine GQARCDX(PROMT,SVAR,LAST,JTYP,STR,CDEF,hyper)\n! TO READ A STRING VALUE with default\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*),hyper*(*)\n integer last,jtyp\n! EXTERNAL HELP no longer needed\n!\\end{verbatim} %+\n!...SUBROUTINE GQARCDX\n! JTYP DEFINES THE TERMINATION OF A STRING\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n integer ival\n double precision val\n GPARWDEF=.TRUE.\n IF(JTYP.LE.0) THEN\n! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION')\n buperr=1030\n GOTO 900\n ENDIF\n IF(JTYP.EQ.7) THEN\n GPARENTES=.TRUE.\n GPARITYP=4\n ELSE\n GPARENTES=.FALSE.\n IF(JTYP.LE.6) THEN\n! NOTE GPARITYP 1 and 3 used for integer and double precision !!!\n GPARITYP=JTYP+3\n ELSE\n GPARITYP=10\n GPARCH2=CHAR(JTYP)\n ENDIF\n ENDIF\n! call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP,hyper)\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n900 continue\n end SUBROUTINE GQARCDX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gqarcx & Ask for character no default\n!\\begin{verbatim}\n subroutine GQARCX(PROMT,SVAR,LAST,JTYP,STR,CDEF,hyper)\n! TO READ A STRING VALUE with default user hypertext\n implicit none\n CHARACTER PROMT*(*),SVAR*(*),str*(*),cdef*(*),hyper*(*)\n integer last,jtyp\n! EXTERNAL HELP no longer needed\n!\\end{verbatim} %+\n!...SUBROUTINE GQARCx\n! JTYP DEFINES THE TERMINATION OF A STRING\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n integer ival\n double precision val\n GPARWDEF=.TRUE.\n IF(JTYP.LE.0) THEN\n! CALL ST2ERR(1030,'GPARC','NO SUCH TYPE OPTION')\n buperr=1030\n GOTO 900\n ENDIF\n IF(JTYP.EQ.7) THEN\n GPARENTES=.TRUE.\n GPARITYP=4\n ELSE\n GPARENTES=.FALSE.\n IF(JTYP.LE.6) THEN\n! NOTE GPARITYP 1 and 3 used for integer and double precision !!!\n GPARITYP=JTYP+3\n ELSE\n GPARITYP=10\n GPARCH2=CHAR(JTYP)\n ENDIF\n ENDIF\n! write(*,*)'In GQARCX calling gparallx: ',trim(hyper)\n! call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,HELP,hyper)\n call gparallx(PROMT,SVAR,LAST,IVAL,val,str,cdef,hyper)\n return\n900 continue\n end SUBROUTINE GQARCX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparallx & Ask for anything\n!\\begin{verbatim}\n SUBROUTINE gparallx(PROMT,SVAR,LAST,IVAL,val,string,cdef,hyper)\n! this is the focal routine for all variants of GPARxyz\n!...SVAR shall contain an answer or command. If EMPTY THE answer IS ASKED FOR\n! USING PROMT AS OUTPUT STRING. IF NO ANSWER THE VALUE IN DEF (default) \n! is returned if a provided. The routine can return integer, double or\n! character variables. THE DEFAULT VALUE IS DISPLAYED IN THE PROMT WITHIN\n! SLASHES. if no answer and no defualt an error is returned.\n! HELP is no longer a parameter Q4HELP is always used\n! as hypertarget in a HTML file\n! If hyper contains the character ?TOPHLP and the user has typed a single ?\n! the routine returns with this ? and the calling routine can display\n! a menu. If the user types two ?? the PROMT is used as hypertarget.\n! LAST IS THE current POSITION IN SVAR, it is incremented by one\n! before looking for an answer (skipping the terminator of any previous\n! input.\n! REPEAT:\n! when called on top level or from a submenu then hyper='?TOPHLP'\n! if user types a single ? only menu listed, with ?? use PROMT as target \n implicit none\n CHARACTER PROMT*(*),SVAR*(*),CH1*1,CDEF*(*),STRING*(*),hyper*(*)\n integer ival\n double precision val\n! EXTERNAL HELP\n!\\end{verbatim}\n CHARACTER PPROMT*132,CH2*1,ssd*30\n LOGICAL WDEF,MATP\n integer last,unused\n! local variables\n! integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,kxy,iqq,ityp,idef,kk,nw,kl\n integer i,ijp,j,jjp,l1,l2,llq,llp,llz,m,ityp,idef,kk,nw,kl,qz\n double precision rdef,x\n character hypertarget*(40)\n logical once\n! All input routines converge here, update command level and save promt \n! for use by help routines\n once=.TRUE.\n CONTINUE\n! write(*,*)'In gparallx: ',trim(promt),' & ',trim(hyper)\n! check if promt already in path, otherwise increase level\n unused=0\n! skip old helprec stuff ...\n! do iqq=2,helprec%level\n! save first 12 characters in helprec%path (obsolete now?)\n! kxy=min(len_trim(promt),12)\n! if(promt(1:kxy).eq.helprec%cpath(iqq)(1:kxy)) then\n! helprec%level=iqq\n! goto 991\n! endif\n! enddo\n! if(helprec%level.lt.maxhelplevel) then\n! helprec%level=helprec%level+1\n! helprec%cpath(helprec%level)=promt\n! write(*,*)'Help level increased to: ',helprec%level\n! else\n! write(*,*)'Warning, too many levels in help path'\n! This can happen when asking for constitution including the constituent\n! just save the last questions\n! helprec%cpath(helprec%level)=promt\n! endif\n!991 continue\n!-------------------------------\n! extract values from calling routines stored in GPARxyz\n! gparityp is a GLOBAL private variable to transfer type of value to return\n! Assuming this is not run in parallel...\n wdef=gparwdef\n if(gparityp.eq.1) then\n! calling routine wants an integer value\n ityp=1\n! if(wdef) idef=gparidef\n! always set the default, it may be used anyway!!\n idef=gparidef\n elseif(gparityp.eq.3) then\n! calling routine wants a double precision value\n ityp=3\n! if(wdef) rdef=gparrdef\n rdef=gparrdef\n else\n! calling routine wants a string, ityp>3, \n ityp=gparityp\n matp=gparentes\n ch2=' '\n if(ityp.eq.10) ch2=gparch2\n endif\n!-------------------------------------------------------\n!...INCREMENT LAST BY ONE TO BYPASS TERMINATOR OF COMMAND OR PREVIOUS ANSWER\n LAST=LAST+1\n IF(LAST.LT.1 .OR. LAST.GT.LEN(SVAR)) LAST=LEN(SVAR)+1\n!...SKIP BLANKS STARTING FROM THE POSITION AFTER LAST\n! IF LAST OUTSIDE SVAR THEN ASK QUESTION\n I=LAST\n10 CONTINUE\n! write(*,*)'GPARALLX 10: ',trim(promt)\n IF(EOLCH(SVAR,I)) THEN\n!... EMPTY STRING, IF PROMT empty TAKE DEFAULT VALUES\n M=LEN_TRIM(PROMT)\n IF(M.LT.1) GOTO 910\n! avoid promt with double ::\n! if(M.GT.2 .and. promt(M:M).eq.promt(M-1:M-1)) M=M-1\n if(M.GT.2 .and. promt(M:M).eq.':') M=M-1\n ijp=0\n IF(WDEF) THEN\n PPROMT=PROMT(1:M)//' /'\n JJP=M+3\n!... INSERT DEFAULT VALUE INTO PROMT\n IF(ITYP.EQ.1) THEN\n X=REAL(IDEF)\n CALL WRINUM(PPROMT,JJP,10,0,X)\n ELSEIF(ITYP.EQ.3) THEN\n! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,10,0,RDEF)\n! to avoid getting values as 0.0250000004 rather than 0.025 ...\n! IF(RDEF.NE.RNONE) CALL WRINUM(PPROMT,JJP,8,0,RDEF)\n CALL WRINUM(PPROMT,JJP,8,0,RDEF)\n ELSE\n PPROMT(JJP:)=CDEF\n I=LEN_TRIM(CDEF)\n JJP=JJP+I\n ENDIF\n IF(LEN_TRIM(PPROMT).GT.M+2) THEN\n PPROMT(JJP:)='/: '\n JJP=JJP+2\n ELSE\n!... TO AVOID AN EMPTY STRING BETWEEN SLASHES\n! PPROMT(M+1:M+2)=': '\n PPROMT(M+1:)=': '\n JJP=len_trim(ppromt)\n ENDIF\n CALL BOUTXT(KOU,PPROMT(1:JJP))\n IJP=JJP\n ELSE\n PPROMT=PROMT\n JJP=LEN_TRIM(PPROMT)\n CALL BOUTXT(KOU,PPROMT(1:MAX(1,JJP)))\n ENDIF\n SVAR=' '\n CALL BINTXT(KIU,SVAR(1:MIN(LEN(SVAR),130)))\n! THIS IS USER INPUT\n! write(*,*)'GPARALLX 77: ',trim(svar)\n! if(hyper.eq.'TOPHLP') write(*,*)'gparallx input: ',trim(svar)\n if(jecho.ne.0) then\n! echo ....\n j=len_trim(svar)\n if(j.gt.0) then\n write(kou,77)svar(1:len_trim(svar))\n77 format('... echo: ',a)\n endif\n endif\n!...WRITE INPUT ON LOG FILE IF ANY\n IF(LOGFIL.GT.0) THEN\n!...write on logfile only if question asked !!!\n I=LEN_TRIM(SVAR)\n IF(I.LE.0 .AND. WDEF) THEN\n IF(IJP-3.GE.M+3) THEN\n!...WRITE THE DEFAULT ANSWER IF USER INPUT IS EMPTY and there is a default\n WRITE(LOGFIL,17)PPROMT(M+3:IJP-3)\n ELSE\n WRITE(LOGFIL,17)' '\n ENDIF\n ELSE\n WRITE(LOGFIL,17)SVAR(1:MAX(1,I))\n ENDIF\n17 FORMAT(A)\n ENDIF\n I=1\n IF(EOLCH(SVAR,I)) GOTO 910\n ENDIF\n!...DECODE THE ANSWER IN SVAR\n! write(*,*)'GPARALLX 17: ',trim(svar),i\n CH1=SVAR(I:I)\n!...IF FIRST CHARACTER IS \",\" PUT DEFAULT VALUE IF ANY\n IF(CH1.EQ.',') GOTO 910\n!...IF FIRST CHARACTER IS '?' WRITE HELP MESSAGE\n IF(CH1.EQ.'?') THEN\n if(hyper.eq.'?TOPHLP') then\n if(SVAR(I+1:I+1).ne.'?') then\n! if the user types a single ? then just display the menu, no browserhelp!\n last=i\n string=svar(i:)\n! The menu is displayed in calling routine, just return here\n! write(*,*)'GPARALLX quick help exit!',trim(string),i\n goto 900\n else\n! user types two ??, generate the hypertarget from prompt\n if(promt(1:2).eq.'--') then\n! this is ?? typed at top level\n hypertarget='?All commands'\n else\n! when prompting for commands the default must be a character\n write(*,*)'gparallx extract: \"',trim(promt),'\" and \"',&\n trim(cdef),'\"'\n! extract part of the promt as hypertarget, \n! for a promt \"Amend for phase LIQUID what?\" extract \"Amend for phase\"\n! to use as hypertarget. Use only the 3 first words\n kl=1\n kk=1\n nw=0\n max3: do while(kk.gt.0)\n! a subsub command should always have 3 fixed words in the promt!!!\n! the last word of a subcommand, \"what?\", has no \" \" at the end\n kk=index(promt(kl:),' ')\n if(kk.gt.0) then\n kl=kl+kk\n nw=nw+1\n else\n kl=kl-1\n exit max3\n endif\n if(nw.eq.3) then\n kl=kl-1\n exit max3\n endif\n enddo max3\n if(kl.le.1) kl=len_trim(promt)\n hypertarget='?'//promt(1:kl)\n! to handle help when user types two ?? for the promt \"amend what? /phase/:\"\n! then include the default answer \"phase\" in the hypertarget !!\n! A single ? already gives the submenu for \"amend phase\"\n if(cdef(1:1).ne.' ') then\n hypertarget(kl+2:)=trim(cdef)\n endif\n! convert prompt to lower case except first letter\n! qz=len_trim(hypertarget)\n call lowercase1(hypertarget)\n! write(*,*)'gparallx hypertarget: \"',&\n! trim(hypertarget),'\" and \"',trim(cdef),'\"',nw,kl\n endif\n! write(*,*)'GPARALLX hypertarget: ',trim(hypertarget)\n endif\n else\n! normal questions have the hypretarget in hyper to provide help\n hypertarget=hyper\n endif\n! if two ?? or a real question (not menu) provide more advanced help\n M=LEN_TRIM(PROMT)\n! using q4help the arguments should be hyper and an (so far) unused integer\n! CALL HELP(PROMT(1:M),SVAR(I:))\n! CALL HELP(hypertarget,unused)\n write(*,*)'Calling Q4HELP: \"',trim(hypertarget),'\"',unused\n CALL q4help(hypertarget,unused)\n if(unused.ne.0) then\n! return a ? to calling routine ... why?\n SVAR(I+1:I+1)='?'\n if (ityp.gt.3) STRING=SVAR(I:)\n GOTO 900\n ENDIF\n I=LEN(SVAR)\n if(once) then\n once=.false.; GOTO 10\n else\n! A ? more than once as answer, quit with error\n goto 920\n endif\n ENDIF\n!...FETCH THE VALUE FROM SVAR\n LAST=I\n IF(ITYP.EQ.1) THEN\n CALL GETINT(SVAR,LAST,IVAL)\n ELSEIF(ITYP.EQ.3) THEN\n CALL GETREL(SVAR,LAST,VAL)\n ELSEIF(ITYP.LE.10) THEN\n!...THE PART HERE IS GLITCHY AS ICE ... handling character input\n L1=0\n L2=0\n! ITYP= 4 5 6 7 8 9 10\n GOTO( 40, 50, 60, 70, 80, 70,100),ITYP-3\n! terminate with space or ,\n40 L1=INDEX(SVAR(LAST:),',')\n! terminate with space\n50 L2=INDEX(SVAR(LAST:),' ')\n! handle if space or , inside parenthesis should be ignored, like x(fcc,cr)\n IF(MATP) THEN\n!...A , OR SPACE INSIDE PARENTHESIS SHOULD BE IGNORED\n LLQ=MIN(L1,L2)\n IF(LLQ.EQ.0) LLQ=MAX(L1,L2)\n LLP=INDEX(SVAR(LAST:),'(')\n IF(LLP.GT.0 .AND. LLP.LT.LLQ) THEN\n!...\tLLP SHALL BE POSITION OF (, FDMTP UPDATES LLP TO POSITION AFTER )\n51 CALL FDMTP(SVAR(LAST:),LLP,SSD)\n IF(BUPERR.NE.0) GOTO 900\n IF(ITYP.EQ.4) L1=INDEX(SVAR(LAST+LLP-1:),',')\n L2=INDEX(SVAR(LAST+LLP-1:),' ')\n IF(L1.GT.0) L1=L1+LLP-1\n IF(L2.GT.0) L2=L2+LLP-1\n LLQ=MIN(L1,L2)\n IF(LLQ.EQ.0) LLQ=MAX(L1,L2)\n LLZ=INDEX(SVAR(LAST+LLP-1:),'(')\n IF(LLZ.GT.0 .AND. LLP+LLZ.LT.LLQ) THEN\n!...\t\t WE HAVE MORE THAN ONE ( BEFORE , OR SPACE\n LLP=LLP+LLZ-1\n GOTO 51\n ENDIF\n ENDIF\n ENDIF\n GOTO 400\n! input terminates with period\n60 L1=INDEX(SVAR(LAST:),'.')\n! input terminates with semicolon\n70 L2=INDEX(SVAR(LAST:),';')\n!...STRING INCLUDING THE ;\n IF(ITYP.EQ.9 .AND. L2.GT.0) L2=L2+1\n GOTO 400\n!...WHOLE STRING\n80 L1=LEN(SVAR)\n GOTO 400\n! input terminates with provided character >31\n100 L2=INDEX(SVAR(LAST:),CH2)\n400 IF(L1.GT.0 .AND. L2.GT.0) THEN\n L1=LAST+MIN(L1,L2)-1\n ELSEIF(L1.LE.0 .AND. L2.LE.0) THEN\n L1=LEN(SVAR)+1\n ELSE\n!... BUG FOUND HERE: IF L1 IS LEN(SVAR) AND LAST>1 L1 SET >LEN(SVAR)+1\n L1=MIN(LAST+MAX(L1,L2)-1,LEN(SVAR)+1)\n ENDIF\n IF(L1.GT.LAST) THEN\n STRING=SVAR(LAST:L1-1)\n ELSE\n STRING=' '\n ENDIF\n LAST=L1\n ELSE\n! CALL ST2ERR(1030,'GPAR','NO SUCH TYPE OPTION')\n buperr=1030\n ENDIF\n900 RETURN\n!...SET DEFAULT VALUE\n910 continue\n IF(ITYP.EQ.1) THEN\n IF(IDEF.EQ.NONE) GOTO 920\n IVAL=IDEF\n ELSEIF(ITYP.EQ.3) THEN\n IF(RDEF.EQ.RNONE) GOTO 920\n VAL=RDEF\n ELSE\n! write(*,911)'ML gparqall: ',trim(cdef),trim(cnone),wdef\n!911 format(a,a,' - ',a,l2)\n IF(CDEF.NE.CNONE) THEN\n STRING=CDEF\n!! endif\n ELSE\n GOTO 920\n endif\n ENDIF\n!...SET POSITION IN STRING TO POSITION OF ,\n LAST=I\n GOTO 900\n!...NO ANSWER AND NO DEFAULT VALUE, ERROR RETURN\n!920 CALL ST2ERR(1032,'GPAR','PARAMETER VALUE MISSING')\n920 buperr=1032\n GOTO 900\n END SUBROUTINE GPARALLX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine lowercase1 & convert character to lower case\n!\\begin{verbatim}\n subroutine lowercase1(text)\n character text*(*)\n!\\end{verbatim}\n! integer ip,jp,kp,ichA,ichZ,chlower,ich1\n integer ip,ichA,ichZ,chlower,ich1\n ichA=ichar('A')\n ichZ=ichar('Z')\n! cha = chA+chlower\n chlower=ichar('a')-ichA\n! write(*,*)'ML text: \"',trim(text),'\"'\n! do not convert first 2 characters or any character not between chA and chZ\n do ip=3,len(text)\n ich1=ichar(text(ip:ip))\n if(ich1.ge.ichA .and. ich1.le.ichZ) then\n text(ip:ip)=char(ich1+chlower)\n endif\n enddo\n! write(*,*)'ML text: \"',trim(text),'\"'\n!900 return\n end subroutine lowercase1\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gparfilex & Ask for file name\n!\\begin{verbatim}\n SUBROUTINE GPARFILEx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,TYP,hyper)\n! to ask for a file name using command line or external window\n! prompt is question\n! svar is a character variable which may already contain an answer\n! last is position in svar to start searching for an answer\n! JTYP DEFINES THE TERMINATION OF A STRING (maybe redundant??)\n! 1 TEXT TERMINATED BY SPACE OR \",\"\n! 2 TEXT TERMINATED BY SPACE\n! 3 TEXT TERMINATED BY \";\" OR \".\"\n! 4 TEXT TERMINATED BY \";\"\n! 5 TEXT UP TO END-OF-LINE\n! 6 TEXT UP TO AND INCLUDING \";\"\n! 7 TEXT TERMINATED BY SPACE OR \",\" BUT IGNORING SUCH INSIDE ( )\n! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER\n! sval is the answer either extracted from SVAR or obtained by user input\n! cdef is a default answer\n! typ is default file extenion in OpenCalphad (OC), at present only:\n! 1=\".TDB\", 2=\".OCU\", 3=\".OCM\", 4=OCD , 5=\".PLT\" , 6=XTDB , 7=\".DAT\" , 8=\".LOG\"\n! 1 TDB is old TDB format\n! 2 OCU is unformatted file (works)\n! 3 OCM is macro file (not implemented)\n! 4 OCD is unformatted direct files (not implemented)\n! 5 PLT is GNUPLOT graphics format (OK)\n! 6 XTDB is XML format\n! 7 DAT is unspecified data file \n! 8 LOG is not used ?? \n! negative value for writing ...\n! hyper is a hypertext target for help\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER PROMT*(*),SVAR*(*),CDEF*(*),SVAL*(*),hyper*(*)\n! type is cnaged inside this rooutine, must be a variable when called\n integer last,jtyp,typ\n! EXTERNAL HELP\n!\\end{verbatim}\n CHARACTER SLIN*256\n integer typeahead,kk,iflag\n logical beware\n sval=' '\n slin=cdef\n! write(*,10)'M4 in gparfilex: ',typ,trim(cdef),trim(sval),trim(slin)\n!10 format(a,i3,' \"',a,'\" \"',a,'\" \"',a,'\"')\n#ifdef tinyfd\n! only if we use tinyfiledialogs, check if any character after last+1\n typeahead=last+1\n beware=.FALSE.\n! beware set to TRUE if no typeahead (there are non-blanks after positon last+1)\n beware=eolch(svar,typeahead)\n! write(*,*)'M3 gparfile: ',kou,koud,last,eolch(svar,last)\n if(nopenpopup .or. kiu.ne.kiud .or. .not.beware) then\n continue\n#endif\n! If we are not connected to a terminal (reading a macro file) use line input\n! Also if there are \"type ahead\" use the line input\n! This call exchanges any macro variables in SVAR for defined macro values\n CALL GQXENV(SVAR)\n! If interactive\n if(kiu.eq.kiud .and. beware) write(kou,\"(a)\") &\n 'Beware: you must give the full path unless the file '//&\n 'is in working directory!'\n100 CALL GQARCx(PROMT,SVAR,LAST,JTYP,SVAL,CDEF,hyper)\n IF(BUPERR.NE.0) GOTO 900\n SLIN=SVAL(1:max(1,LEN_TRIM(sval)))\n! This call handles ? @ and other things in SVAR\n CALL GPTCM2(IFLAG,SVAR,LAST,SLIN)\n IF (IFLAG.NE.0) GOTO 100\n if(IUMACLEVL.ge.1) then\n if(sval(1:2).eq.'./') then\n! we are running a macro and if SVAL(1:2) is './' replace this with MACROPATH'\n sval=trim(macropath(IUMACLEVL))//sval(3:)\n elseif(sval(1:3).eq.'../') then\n! we are running a macro and if SVAL(1:3) is '../' then prefix with MACROPATH'\n sval=trim(macropath(IUMACLEVL))//sval\n! write(*,*)'M3 add path: ',trim(sval),IUMACLEVL\n! else\n! write(*,*)'M3 assuming full path or in working directory: '\n endif\n endif\n#ifdef tinyfd\n else\n! open a popup window to browse directories and files using tinyfiledialogs\n! typ<0 means new or old file; 0 old file no filter, \n! typ >0 means old file with filter:\n! typ=1 TDB, 2=OCU, 3=OCM, 4=OCD, 5=plt, 6=XTDB, 7=DAT, 8=LOG\n! these are defined in pmon6.F90 also !!!!!!!!!!!!!!!!!!!!!!!!!\n! write(*,*)'M4 opening popup window',typ\n! getfilename is in utilities/TINYFILEDIALOGS/ftinyopen\n call getfilename(typ,sval)\n! write(*,*)'M4 From getfilename: \"',trim(sval),'\"',typ\n if(sval(1:1).eq.' ') then\n buperr=1020\n elseif(typ.eq.-1) then\n! this is for writing a TDB file\n kk=index(sval,'.TDB ')\n if(kk.eq.0) then\n sval(len_trim(sval)+1:)='.TDB'\n endif\n elseif(typ.eq.-7) then\n! this is for output and file created, if no extension add DAT\n kk=index(sval,'.DAT ')\n if(kk.eq.0) then\n sval(len_trim(sval)+1:)='.DAT'\n endif\n elseif(typ.eq.-8) then\n! this is for output and file created(?), if no extension add LOG\n! Check if last 4 letters are none\n kk=len_trim(sval)\n if(kk.ge.4) then\n if(sval(kk-3:kk).eq.'none') then\n sval='NONE'\n goto 300\n endif\n endif\n kk=index(sval,'.LOG ')\n! write(*,*)'gparfilex: ',trim(sval),kk,trim(cdef)\n if(kk.eq.0) then\n iflag=len_trim(sval)\n sval(iflag+1:)='.LOG'\n endif\n300 continue\n! write(*,*)'gparfilex: ',trim(sval),kk\n endif\n! write(*,*)'M4 file: \"',trim(sval),'\"'\n endif\n#endif \n! Can the rather odd ifdef/endif cause problems ???\n! if there is a segmentation fault it is after this write statement ... SUCK\n! write(*,*)'M4 exit gparfilex: ',trim(sval)\n! In 2021.10.04 the program dies after this without error message at all SUCK\n900 RETURN\n END SUBROUTINE GPARFILEX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! A new set of on-line help routines using browser\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine init_help & Initiate help and history\n!\\begin{verbatim}\n subroutine init_help(browser,htmlfile)\n! This routine is called from oc_command_monitor to inititate\n! the on-line help system. It saves the name of the browser and HTML file\n implicit none\n character*(*) htmlfile,browser\n!\\end{verbatim} %+\n character noquotes*128\n integer kk\n logical logok\n! the latex file no longer used for help\n ochelp%latexfile=' '\n! test that file exists\n inquire(file=browser,exist=logok)\n! write(*,*)'m4A: ',trim(browser),logok\n if(.not.logok) then\n! This is emergency use of explorer if no Firefox\n! browser='C:\\PROGRA~1\\INTERN~1\\iexplore.exe '\n noquotes=browser\n kk=index(noquotes,'\"')\n do while(kk.gt.0)\n noquotes(kk:)=noquotes(kk+1:)\n kk=index(noquotes,'\"')\n enddo\n inquire(file=noquotes,exist=logok)\n! write(*,*)'m4C: ',trim(noquotes),logok\n endif\n allok: if(logok) then\n ochelp%browser=browser\n inquire(file=htmlfile,exist=logok)\n! write(*,*)'m4B: ',trim(htmlfile),logok\n if(logok) then\n helprec%okinit=1\n helprec%type='html'\n ochelp%htmlhelp=.TRUE.\n ochelp%htmlfile=htmlfile\n goto 1000\n endif\n endif allok\n helprec%okinit=0\n helprec%type=' '\n ochelp%htmlhelp=.FALSE.\n ochelp%htmlfile=' '\n ochelp%browser=' '\n1000 continue\n return\n end subroutine init_help\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine helplevel & Redundant\n!\\begin{verbatim}\n subroutine helplevel1(line)\n! This routine is called from the monitor for the top level command\n! It initiates the path to find the correct help text\n! In all gparx routines the help level in increased and the question saved\n implicit none\n character*(*) line\n!\\end{verbatim} %+\n helprec%level=1\n helprec%cpath(1)=line\n return\n end subroutine helplevel1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine q1help & Old help routine 1\n!\\begin{verbatim}\n subroutine q1help(prompt,line)\n! This routine is called from all gparx routines \n! when the user types a ?\n! prompt is never used ...\n implicit none\n character*(*) prompt,line\n character hline*80,mtext*12\n integer, parameter :: maxlevel=20\n!\\end{verbatim} %+\n! character subsec(5)*10,saved(maxlevel)*24\n character subsec(5)*10\n character htmlhelp*256\n integer nsaved(maxlevel)\n! integer izz,jj,kk,kkk,level,nl,l2,np1,np2,nsub,zz\n integer izz,jj,kk,level,nl,np1,np2,nsub,zz\n logical foundall\n!\n nsaved=0\n subsec(1)='%\\section{'\n subsec(2)='%\\subsecti'\n subsec(3)='%\\subsubse'\n subsec(4)='%\\subsubsu'\n subsec(5)='%\\question'\n if(helprec%okinit.eq.0) then\n if(helptrace) write(kou,*)'Sorry no help file'\n goto 1000\n endif\n! USEFUL for helptraceging list current search path:\n if(helptrace) then\n do nl=1,helprec%level\n write(*,17)'Search level: ',nl,trim(helprec%cpath(nl))\n17 format(a,i3,2x,a)\n enddo\n endif\n!\n open(31,file=ochelp%latexfile,status='old',access='sequential')\n nl=0\n level=2\n np1=0\n np2=0\n nsub=1\n foundall=.false.\n ochelp%target=' '\n if(helprec%type.ne.'latex ') then\n write(*,*)'Sorry only help based on LaTeX implemented'\n goto 900\n endif\n! plain LaTeX file. The questions the OC software asks are saved from the\n! top level in helprec%cpath(1..level). This makes it possible to compare\n! the these commands with comment lines in the help file to find the relevant \n! helptext. The comment lines are structured as the LaTeX sections\n! %\\subsection{question1}, %\\subsubse..{questione} etc\n! for each match the sublevel is increased and when we find match\n! with the last helprec%cpath(helprec%level) we assume the text until\n! the next %\\sub.... can be provided as help\n! If there is an additional HTML help file the text can instead be displayed\n! in a browser using \\hypertarget{label} from the LaTeX file found after\n! the last matching sublevel\n! Only first 12 characters in helprec%cpath and %\\section{ sublevel are used\n! return here when we found match at level\n100 continue\n level=level+1\n if(helptrace) write(*,*)'At label 100: ',level,helprec%level,nl\n if(level.gt.helprec%level) then\n foundall=.true.\n if(helptrace) write(*,*)'Foundall 1',nl\n goto 200\n elseif(level.eq.helprec%level .and.&\n helprec%cpath(level)(1:2).eq.'? ') then\n! this is when help is asked in a submenue with two ??\n! with just one ? the menue is displayed, with ?? the helpfile is used\n foundall=.TRUE.\n if(helptrace) write(*,*)'Foundall 2',nl\n goto 200\n endif\n110 continue\n! skip cpath levels that contain COMMAND: or WHAT?\n! if last level and cpath contain ? we have found all\n if(index(helprec%cpath(level),'COMMAND: ').gt.0 .or. &\n index(helprec%cpath(level),' WHAT? ').gt.0) then\n level=level+1\n if(level.gt.helprec%level) then\n foundall=.TRUE.\n if(helptrace) write(*,*)'Foundall 2',nl\n goto 200\n endif\n goto 110\n endif\n if(helptrace) write(*,*)'Searching for: ',trim(helprec%cpath(level)),level\n! return here when last line did not contain any matching subsec\n! we can arrive here with np1=0 and foundall==true\n! for help at first command level\n200 continue\n read(31,210,end=700)hline\n210 format(a)\n nl=nl+1\n if(np1.gt.0) then\n! np1 is nonzero if we have found a line matching one helprec%cpath\n! We will save all hypertarget labels to have some idea what help text\n! to provide if we do not find all %cpath\n! If we found the helprec%cpath(helprec%level) foundall is set TRUE\n! but we continue until we find the following %\\section at the same\n! or higher sublevel\n kk=index(hline,'\\hypertarget{')\n if(kk.gt.0) then\n ochelp%target=hline(kk+13:)\n endif\n if(foundall) then\n! terminate at a line with any sublevel\n izz=0\n do kk=1,5\n if(hline(1:10).eq.subsec(6-kk)) izz=1\n enddo\n if(izz.gt.0) then\n np2=nl-1\n goto 700\n endif\n goto 200\n endif\n elseif(foundall) then\n! this should give help from user guide for section %\\section{All commands}\n! write(*,*)'M3 \"All commands\"',hline(1:24),nl\n if(hline(1:23).eq.'%\\section{All commands}') then\n np1=nl\n np2=nl+20\n! next line should be hypertarget\n read(31,210)hline\n! write(*,*)'next line: ',trim(hline),nl\n kk=index(hline,'\\hypertarget{')\n if(kk.gt.0) then\n ochelp%target=hline(kk+13:)\n kk=index(ochelp%target,'}')\n ochelp%target(kk:)=' '\n goto 700\n else\n! the help file is messed up ... \n ochelp%target='All commands'\n goto 700\n endif\n endif\n goto 200\n! else\n! here we now have np1>0 and use the rest of this routine as usual\n endif\n! we are searching for a subsec on the sublevel nsub\n! Check if we have a %\\section of this sublevel on the line\n kk=index(hline,subsec(nsub))\n section: if(kk.eq.0) then\n! if there is none but we already found one sublevel check if we find the same\n! write(*,*)'no subsec: ',nsub\n prevsub: if(nsub.gt.2) then\n kk=index(hline,subsec(nsub-2))\n if(kk.gt.0) then\n! we have found a sublevel 2 levels up ... we are out of scope \n if(helptrace) write(*,*)'Found subsec two levels up!'\n np2=nl\n goto 700\n elseif(nsub.gt.1) then\n kk=index(hline,subsec(nsub-1))\n if(kk.gt.0) then\n! we have found a subsec at the same sublevel we already found\n! check if we have match with the helprec%cpath, only 12 first characters!\n jj=index(hline,'{')\n if(jj.le.0) then\n write(*,*)'LaTeX helpfil missing { on line:',nl\n goto 200\n endif\n mtext=hline(jj+1:)\n kk=index(mtext,'}')\n if(kk.gt.0) mtext(kk:)=' '\n call capson(mtext)\n zz=len_trim(mtext)\n if(helptrace) write(*,300)'same: ',helprec%cpath(level)(1:zz),&\n ' =?= ',mtext(1:zz),level,nsub,nl\n if(helprec%cpath(level)(1:zz).eq.mtext(1:zz)) then\n! we have found match with the next level of user path on same sublevel\n goto 100\n endif\n endif\n endif\n endif prevsub\n! just read another line\n goto 200\n else\n! we have found a %\\sub... for next level, check if it is %cpath(level)\n jj=index(hline,'{')\n if(jj.le.0) then\n write(*,*)'LaTeX helpfil missing { on line:',nl\n goto 200\n endif\n mtext=hline(jj+1:)\n kk=index(mtext,'}')\n if(kk.gt.0) mtext(kk:)=' '\n call capson(mtext)\n zz=len_trim(mtext)\n if(helptrace) write(*,300)'next: ',helprec%cpath(level)(1:zz),' =?= ',&\n mtext(1:zz),level,nsub,nl\n300 format(a,a,a,a,5i5)\n if(helprec%cpath(level)(1:zz).eq.mtext(1:zz)) then\n! we have found match with the next level of user path\n if(helptrace) write(*,*)'Match: ',level,nsub,nl\n nsub=nsub+1\n np1=nl\n goto 100\n endif\n goto 200\n endif section\n! jump here if we do not search any more\n! we should write lines from np1 to np2 from help file or HTML file\n700 continue\n if(np1.gt.0) then\n if(np2.le.np1) then\n! we found no obvious end of help text\n write(*,*)'Help text range error: ',np1,np2\n endif\n! if htmlhelp is true open a browser window and place text at target\n htmlfil: if(ochelp%htmlhelp .and. ochelp%target(1:1).ne.' ') then\n! the user has to close the help window to continue ... spawn??\n! write(*,711)np1,np2\n!711 format(/' *** You must close the browser window to continue OC',2i5/)\n! the \\hypertaget should be finished by a }\n kk=index(ochelp%target,'}')-1\n if(kk.le.0) kk=len_trim(ochelp%target)\n#ifdef lixhlp\n! on linux just ' \"file:\" as ochelp#htmlfile start with a /\n! The & at the end spawns the browser window and furter ? creates new tags !!\n htmlhelp=trim(ochelp%browser)//' \"file:'//&\n trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'\" &'\n#else\n! on Windows we need the / after file\n! the initial start spawns a new window with the browser, each ? a new browser\n htmlhelp='start '//trim(ochelp%browser)//' \"file:/'//&\n trim(ochelp%htmlfile)//'#'//ochelp%target(1:kk)//'\"'\n#endif\n if(helptrace) write(*,*)'MM: ',trim(htmlhelp)\n call execute_command_line(htmlhelp)\n goto 900\n else\n! help in user terminal screen: write a blank line\n write(kou,*)\n write(*,798)np1,np2\n798 format(' >>> We should open a help window to display text: ',2i5)\n rewind(31)\n nl=0\n800 continue\n read(31,210)hline\n nl=nl+1\n if(nl.ge.np2) then\n goto 900\n elseif(nl.ge.np1) then\n if(hline(1:1).ne.'%') then\n! ignore LaTeX comment lines and replace \\item with a -\n if(hline(2:5).eq.'item') then\n write(*,811)trim(hline(6:))\n811 format('- ',a)\n else\n write(*,210)trim(hline)\n endif\n endif\n endif\n goto 800\n endif htmlfil\n else\n write(*,*)'No help found'\n endif\n900 continue\n close(31)\n!\n1000 continue\n return\n end subroutine q1help\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine q2help & Old help routine 2\n!\\begin{verbatim}\n subroutine q2help(prompt,line)\n! This routine is called from submenu\n! when the user types a ?\n implicit none\n character*(*) prompt,line\n!\\end{verbatim} %+\n character helpquest*32\n integer savedlevel,kk,ip\n!\n savedlevel=helprec%level-1\n! If the ? is followed by a text push that text on the helprec%cpath\n ip=2\n! This is to force q2help to work ... otherwise segmentation fault ??!!! \n if(ip.lt.0) write(*,*)'q2help: ',savedlevel,line(1:20)\n if(.not.eolch(line,ip)) then\n! write(*,*)'q2help: ',helprec%level,ip,helprec%cpath(helprec%level)\n helpquest=line(ip:)\n helpquest=prompt\n call capson(helpquest)\n! remove any WHAT? as such levels will be ignored by q1help\n kk=index(helpquest,'WHAT?')\n if(kk.gt.0) then\n helpquest(kk:)='COMMAND '\n if(helptrace) write(*,*)'MM hepquest: ',kk,trim(helpquest)\n endif\n! use the saved helprec%level \n helprec%level=savedlevel\n helprec%cpath(helprec%level)=helpquest\n! always upper case ...\n call capson(helprec%cpath(helprec%level))\n! if(helptrace) write(*,11)helprec%level,&\n! (trim(helprec%cpath(i)),i=1,helprec%level)\n!11 format('q2help: ',i3,10(', ',a))\n else\n! when we are here we have just a ? from user, return to submenu with that\n! with two ?? or anything else q1help is called (I hope ...)\n line='?!'\n if(ochelp%htmlhelp) then\n write(*,17)\n17 format(/'By typing two ?? you will open the browser')\n endif\n goto 1000\n endif\n! this is a dummy line needed to force the MacOS linker to find this routine\n!?? if(savedlevel.eq.helprec%level) write(*,*)'Inside q2help: ',trim(prompt)\n if(ip.lt.0) write(*,*)'in q2help calling q1help'\n! write help text from help file and then return with ?! to get submenu\n if(helptrace) write(*,*)'q2help calling q1help: ',trim(helpquest)\n call q1help(prompt,line)\n line='?!'\n1000 continue\n return\n end subroutine q2help\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine q3help & Old help routine 3\n!\\begin{verbatim}\n SUBROUTINE Q3HELP(LINE,LAST,COMM,NC)\n! used in submeny when user gives \"? 'command' \" taken as \"help 'command'\"\n!...EXECUTES A HELP COMMAND\n implicit none\n CHARACTER LINE*(*),COMM(NC)*(*)\n integer last\n!\\end{verbatim} %+\n CHARACTER CMD*40\n integer, parameter :: MC=100\n integer INDX(MC)\n integer nkpl,nc,nlfk,nbk,i,j,k\n! To avoid storing \"COMMAND\" in the helprec%cpath\n! if(helprec%level.gt.2) helprec%level=helprec%level-1 !.. HELP HELP not OK\n if(helprec%level.gt.3) helprec%level=helprec%level-1\n! write(*,*)'q3help: asking for help for command: \"',trim(line),'\"',last,nc\n CALL GPARC_old('Help for which command? ',LINE,LAST,1,CMD,'*',tophlp)\n! write(*,*)'q3help: command: \"',trim(cmd),'\"'\n IF(CMD(1:1).EQ.'*' .or. cmd(1:1).eq.'?') THEN\n!...LIST ALL COMMANDS IN UNIX ALPHABETICAL ORDER\n NKPL=80/(LEN(COMM(1))+1)\n IF(NKPL*(LEN(COMM(1))+1).GE.80) NKPL=NKPL-1\n IF(NC.LT.MC) THEN\n CALL SSORT(COMM,NC,INDX)\n ALLCOM: DO NBK=1,NC\n IF(COMM(INDX(NBK))(1:1).NE.' ') GOTO 301\n enddo ALLCOM\n301 NLFK=(NC+NKPL-NBK)/NKPL\n NBK=NBK-1\n COMLIST: DO I=1,NLFK\n WRITE(KOU,320)(COMM(INDX(NBK+J)),J=I,NC-NBK,NLFK)\n enddo COMLIST\n320 FORMAT(10(1X,A))\n ELSE\n!... TOO MANY COMMANDS TO SORT\n NLFK=(NC+NKPL-1)/NKPL\n UNSORTED: DO I=1,NLFK\n WRITE(KOU,320)(COMM(J),J=I,NC,NLFK)\n enddo UNSORTED\n ENDIF\n ELSE\n!...HELP \n! IF UNIQUE LIST DESCRIPTION ON HELP FILE. OTHERWISE\n! ALL COMMANDS THAT MATCHES\n K=NCOMP2(CMD,COMM,NC,I)\n IF(K.GT.0) THEN\n! we have to replace HELP by CMD on the stack of commands\n! to get the correct help text\n CALL CAPSON(CMD)\n helprec%level=helprec%level-1\n helprec%cpath(helprec%level)=CMD(1:32)\n! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level)\n!11 format('q3help: ',i3,10(', ',a))\n! write(*,*)helprec%level\n! do ii=1,helprec%level\n! write(*,*)helprec%cpath(ii)\n! enddo\n call q1help(' ',CMD)\n ELSEIF(K.EQ.0 .OR. K.LT.-NC) THEN\n WRITE(KOU,*)'No matching command, use HELP * or ?'\n ELSE\n500 WRITE(KOU,*)COMM(-K)\n IF(NC+K.LE.0) GOTO 900\n J=NCOMP2(CMD,COMM(1-K),NC+K,I)\n! ...bugfix for \"help s-i\" in poly\n IF(j .LT. -(NC+K) ) GOTO 900\n IF(K.EQ.-NC .OR. J.EQ.0) GOTO 900\n K=K-ABS(J)\n GOTO 500\n ENDIF\n ENDIF\n900 RETURN\n END SUBROUTINE Q3HELP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine q3helpx & New help routine 3\n!\\begin{verbatim}\n SUBROUTINE Q3HELPx(LINE,LAST,COMM,NC)\n! used in submeny when user gives \"? 'command' \" taken as \"help 'command'\"\n!...EXECUTES A HELP COMMAND\n implicit none\n CHARACTER LINE*(*),COMM(NC)*(*)\n integer last\n!\\end{verbatim} %+\n CHARACTER CMD*40\n integer, parameter :: MC=100\n integer INDX(MC)\n integer nkpl,nc,nlfk,nbk,i,j,k\n! To avoid storing \"COMMAND\" in the helprec%cpath\n! if(helprec%level.gt.2) helprec%level=helprec%level-1 !.. HELP HELP not OK\n if(helprec%level.gt.3) helprec%level=helprec%level-1\n! write(*,*)'q3help: asking for help for command: \"',trim(line),'\"',last,nc\n CALL GPARCx('Help for which command? ',LINE,LAST,1,CMD,'*','?TOPHLP')\n! write(*,*)'q3help: command: \"',trim(cmd),'\"'\n IF(CMD(1:1).EQ.'*' .or. cmd(1:1).eq.'?') THEN\n!...LIST ALL COMMANDS IN UNIX ALPHABETICAL ORDER\n NKPL=80/(LEN(COMM(1))+1)\n IF(NKPL*(LEN(COMM(1))+1).GE.80) NKPL=NKPL-1\n IF(NC.LT.MC) THEN\n CALL SSORT(COMM,NC,INDX)\n ALLCOM: DO NBK=1,NC\n IF(COMM(INDX(NBK))(1:1).NE.' ') GOTO 301\n enddo ALLCOM\n301 NLFK=(NC+NKPL-NBK)/NKPL\n NBK=NBK-1\n COMLIST: DO I=1,NLFK\n WRITE(KOU,320)(COMM(INDX(NBK+J)),J=I,NC-NBK,NLFK)\n enddo COMLIST\n320 FORMAT(10(1X,A))\n ELSE\n!... TOO MANY COMMANDS TO SORT\n NLFK=(NC+NKPL-1)/NKPL\n UNSORTED: DO I=1,NLFK\n WRITE(KOU,320)(COMM(J),J=I,NC,NLFK)\n enddo UNSORTED\n ENDIF\n ELSE\n!...HELP \n! IF UNIQUE LIST DESCRIPTION ON HELP FILE. OTHERWISE\n! ALL COMMANDS THAT MATCHES\n K=NCOMP2(CMD,COMM,NC,I)\n IF(K.GT.0) THEN\n! we have to replace HELP by CMD on the stack of commands\n! to get the correct help text\n CMD=COMM(K)\n! CALL CAPSON(CMD)\n! helprec%level=helprec%level-1\n! helprec%cpath(helprec%level)=CMD\n! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level)\n!11 format('q3help: ',i3,10(', ',a))\n! write(*,*)helprec%level\n! do ii=1,helprec%level\n! write(*,*)helprec%cpath(ii)\n! enddo\n write(*,*)'Calling q4help from q3helpx: ',trim(cmd)\n call q4help(cmd,0)\n! call q1help(' ',CMD)\n ELSEIF(K.EQ.0 .OR. K.LT.-NC) THEN\n WRITE(KOU,*)'No matching command, use HELP * or ?'\n ELSE\n500 WRITE(KOU,*)COMM(-K)\n IF(NC+K.LE.0) GOTO 900\n J=NCOMP2(CMD,COMM(1-K),NC+K,I)\n! ...bugfix for \"help s-i\" in poly\n IF(j .LT. -(NC+K) ) GOTO 900\n IF(K.EQ.-NC .OR. J.EQ.0) GOTO 900\n K=K-ABS(J)\n GOTO 500\n ENDIF\n ENDIF\n900 RETURN\n END SUBROUTINE Q3HELPx\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine q4help & New help routine 4\n!\\begin{verbatim}\n subroutine q4help(hypertarget,extra)\n! This routine is adapted to provide help from webrowsers using hypertarget\n! when the user types a ? or ??\n implicit none\n integer extra\n character*(*) hypertarget\n!\\end{verbatim} %+\n! this routine independent of the command history. The GPARX routines\n! call this with the hypertarget provided in the call to GPARX routine\n! and searches this target in the HTML file\n! if extra=0 help has been provided, otherwise the calling routine try to do it\n character htmlhelp*256\n if(helprec%okinit.eq.0) then\n if(helptrace) write(kou,*)'Sorry no help file'\n goto 1000\n endif\n if(helprec%type.ne.'html ') then\n write(*,*)'Sorry only help based on HTML implemented'\n goto 1000\n endif\n! if(helptrace) then\n! helptrace help debugging ...\n! write(*,*)'q4help: ',trim(hypertarget),extra\n! endif\n if(hypertarget(1:1).eq.' ') then\n write(*,*)'Sorry, the software provides no help for this question'\n goto 1000\n endif\n! \n! we have tested this file exists when initating help \n! write(*,*)'Q4HELP: ',trim(hypertarget),extra\n! open(31,file=ochelp%latexfile,status='old',access='sequential')\n! if first character in hypertarget is ? remove that\n! in OC I try to use a ? in all calls for gparxyz to find hypertargets in \n! the source code. Seach for \"'?\" in the source code!\n! This ? is not needed or used in the LaTeX file.\n if(hypertarget(1:1).eq.'?') then\n ochelp%target=hypertarget(2:)\n else\n ochelp%target=hypertarget\n endif\n! The help system depends on 3 files:\n! 1: a plain LaTeX file is the base. The \\hypertarget{target}{text} feature\n! is are used to find a specific help text in the user guide.\n! 2: a html file is generated from this LaTeX file with the hypertargets.\n! this allows to locate the text inside the html file and display\n! in a separate windows in a browser. The user can scroll this \n! while running the program.\n! 3: the same LaTeX can also be used to generate a PDF. But no one reads \n! the manual.\n! For each command and question the software asks it uses a GPARX routine.\n! in the call this subroutine and a hypertarget text is provided.\n! When inside this routine the user has typed ? or ?? to get help.\n! The browser used depend on compiler options ...\n#ifdef winhlp\n! on Windows we need the / after file\n! the initial start spawns a new window with the browser, each ? a new browser\n htmlhelp='start '//trim(ochelp%browser)//' \"file:/'//&\n trim(ochelp%htmlfile)//'#'//ochelp%target//'\"'\n#else\n! on linux or Mac just ' \"file:\" as ochelp#htmlfile start with a /\n! The & at the end spawns the browser window and furter ? creates new tags !!\n htmlhelp=trim(ochelp%browser)//' \"file:'//&\n trim(ochelp%htmlfile)//'#'//ochelp%target//'\" &'\n#endif\n if(helptrace) write(*,*)'QZ: ',trim(htmlhelp)\n call execute_command_line(htmlhelp)\n close(31)\n!\n1000 continue\n return\n end subroutine q4help\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine nohelp & No help\n!\\begin{verbatim}\n SUBROUTINE NOHELP(PROMT,LINE)\n! no help available\n implicit none\n CHARACTER PROMT*(*),LINE*(*)\n!\\end{verbatim} %+\n RETURN\n END SUBROUTINE NOHELP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine tophlp & Help from top level\n!\\begin{verbatim}\n SUBROUTINE TOPHLP(PROMPT,LINE)\n! return to calling routine for help, do not save the current command ...\n implicit none\n CHARACTER PROMPT*(*),LINE*(*)\n!\\end{verbatim} %+\n! helprec%level=helprec%level-1\n! write(*,11)helprec%level,(helprec%cpath(i)(1:8),i=1,helprec%level)\n!11 format('tophlp: ',i3,10(', ',a))\n LINE(2:2)='!'\n RETURN\n END SUBROUTINE TOPHLP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable logical function yeschk & Check for Y or y\n!\\begin{verbatim}\n LOGICAL FUNCTION YESCHK(CH1)\n! returns TRUE if CH1 is Y or y\n CHARACTER CH1*1\n!\\end{verbatim}\n YESCHK=.FALSE.\n IF(CH1.EQ.'Y' .OR. CH1.EQ.'y') YESCHK=.TRUE.\n RETURN\n END FUNCTION YESCHK\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! History of commands\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine nghist & Execute history caommand\n!\\begin{verbatim}\n SUBROUTINE NGHIST(LINE,LAST)\n!...EXECUTES A HISTORY COMMAND\n! LAST IS SET TO 0 IF LINE IS SET TO A COMMAND FROM HISTORY LIST\n! CHARACTER HIST*80,LINE*(*),CH1*1\n implicit none\n CHARACTER LINE*(*)\n integer last\n!\\end{verbatim} %+\n CHARACTER CH1*1\n LOGICAL IED\n! LHL, LHM,LHP are prive global variables\n integer LOW,KADD,K,IDIG\n!\n CHARACTER*1 CHHIST,CHHELP,CHEDIT\n PARAMETER (CHHIST='!',CHHELP='?',CHEDIT='*')\n LAST=LAST+1\n CH1=LINE(LAST:LAST)\n IF(CH1.EQ.CHHELP) THEN\n WRITE(KOU,100)\n100 FORMAT(' History commands are useful when the same command ', &\n ' shall'/' be executed several times. It is also possible to',&\n ' amend or correct'/' a command before it is executed again.'//&\n ' A history command always begins with an !'/&\n ' !? gives this help'/&\n ' !! gives a list of the history'/&\n ' ! executes the command in the history',&\n ' list'/&\n ' ! executes the most recent command starting with',&\n ' '/&\n ' !* or !* makes the command available for',&\n ' editing before execution'//&\n ' NOTE the < > around digit and text should not be typed!')\n ELSEIF(CH1.EQ.CHHIST) THEN\n!... A LIST OF THE HISTORY\n IF(LHM.GT.0) THEN\n LOW=LHL\n KADD=-20\n ELSEIF(LHL.EQ.0) THEN\n WRITE(KOU,*)'No history yet!'\n GOTO 900\n ELSE\n LOW=0\n KADD=0\n ENDIF\n!... LOOP\n200 LOW=LOW+1\n IF(LOW.GT.20) THEN\n LOW=1\n KADD=KADD+20\n ENDIF\n K=LEN_TRIM(HIST(LOW))\n IF(K.GT.0)WRITE(KOU,210)LHM+LOW+KADD,HIST(LOW)(1:K)\n210 FORMAT(I5,'> ',A)\n IF(LOW.NE.LHL) GOTO 200\n ELSE\n!... A COMMAND TO BE EXECUTED OR EDITED SHOULD BE FOUND\n IF(CH1.EQ.CHEDIT) THEN\n LAST=LAST+1\n IED=.TRUE.\n ELSE\n IED=.FALSE.\n ENDIF\n CALL GETINT(LINE,LAST,IDIG)\n IF(BUPERR.NE.0) THEN\n BUPERR=0\n K=LEN_TRIM(LINE)\n LOW=LHL\n IF(K.GT.LAST) THEN\n400 CONTINUE\n IF(HIST(LOW)(1:K-LAST+1).NE.LINE(LAST:K)) THEN\n LOW=LOW-1\n IF(LOW.EQ.0) LOW=20\n IF(LOW.NE.LHL) GOTO 400\n WRITE(KOU,*)'No matching command'\n GOTO 900\n ENDIF\n ENDIF\n ELSE\n IF(IDIG.GE.-20 .AND. IDIG.LT.0) IDIG=LHM+LHL+IDIG+1\n IF(IDIG.LE.MAX(0,LHM+LHL-20) .OR. IDIG.GT.LHM+LHL) THEN\n WRITE(KOU,*)'Number outside history'\n GOTO 900\n ENDIF\n LOW=MOD(IDIG,20)\n IF(LOW.EQ.0) LOW=20\n ENDIF\n LINE=HIST(LOW)\n em1: IF(IED) THEN\n ENDIF em1\n LAST=0\n ENDIF\n900 RETURN\n END SUBROUTINE NGHIST\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine openlogfile & Opem log file\n!\\begin{verbatim}\n subroutine openlogfile(name,text,lun)\n! opens a logfile for commands, if exits it will overwrite\n implicit none\n character name*(*),text*(*)\n integer lun\n!\\end{verbatim} %+\n integer kkp,ierr\n if(lun.le.0) then\n if(logfil.gt.0) close(logfil)\n goto 1000\n endif\n! write(*,*)'METLIB: opening logfile: \"',trim(name),'\"'\n if(len_trim(name).le.0) then\n name='OCLOG.LOG'\n write(*,*)'No logfile name, using default: ',trim(name)\n else\n! it seems tinyfiledialogs return working directory ...\n kkp=index(name,'.')\n if(kkp.le.0) then\n kkp=len_trim(name)\n name(kkp+1:)='./OCLOG.LOG'\n write(*,*)'No logfile extention, using: ',trim(name)\n endif\n endif\n open(lun,file=name,access='sequential',status='unknown',&\n err=1100,iostat=ierr)\n write(lun,10)text(1:len_trim(text))\n10 format('Logfile title: ',a)\n logfil=lun\n1000 continue\n return\n! error opening\n1100 continue\n buperr=ierr\n goto 1000\n end subroutine openlogfile\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine set_echo & Set/reet echo of commands\n!\\begin{verbatim}\n subroutine set_echo(ion)\n! set echo of command input, does this really work?\n implicit none\n integer ion\n!\\end{verbatim}\n jecho=ion\n return\n end subroutine set_echo\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n! >>>> subsection \n! output of promt for command\n! and input of command including command line editing on Linux\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n \n!\\addtotable subroutine boutxt & Write a text noadvance\n!\\begin{verbatim}\n subroutine boutxt(lut,line)\n! writes the text on line on unit lut without CR/LF\n implicit none\n integer lut\n character line*(*)\n!\\end{verbatim} %+\n! write(*,*)'boutxt; ',lut,line\n write(lut,10,advance='no')line\n10 format(a)\n return\n end subroutine boutxt\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bintxt & Read a text\n!\\begin{verbatim}\n subroutine bintxt(lin,cline)\n! read a command line with or without arguments. On LINUX command line editing\n implicit none\n character cline*(*)\n integer lin\n!\\end{verbatim} %+\n#ifdef lixed\n! LINUX: to have command line editing uncomment the line above and comment the \n! line with the call bintxt_nogetkey\n call bintxt_getkey(lin,cline)\n#else\n! On Windows command line editing is provided by the OS\n call bintxt_nogetkey(lin,cline)\n#endif\n return\n end subroutine bintxt\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bintxt_getkey & Read a text with editing\n!\\begin{verbatim}\n subroutine bintxt_getkey(lin,cline)\n! LINUX subroutine to read a line with history and editing a la emacs\n!\n implicit none\n character cline*(*)\n integer lin\n!\\end{verbatim} %+\n!-------------------- \n! CONTROL CHARACTERS FROM KEYBOARD\n! DEL delete curret character\n integer, parameter :: ctrla=1 ! CTRLA move cursor to first position\n integer, parameter :: backspace2=2 ! CTRLB move cursor one step left\n integer, parameter :: ctrlc=3 ! CTRLC terminate program\n integer, parameter :: ctrld=4 ! CTRLD delete char at cursor\n integer, parameter :: ctrle=5 ! CTRLE move cursor to last position\n integer, parameter :: forward=6 ! CTRLF move cursor one step right\n integer, parameter :: HELP=8 ! CTRLH give coordinates and update\n integer, parameter :: TAB=9 ! CTRLI end of input\n integer, parameter :: ctrlk=11 ! CTRLK delete to end of line\n integer, parameter :: return=13 ! CTRLM end of input\n integer, parameter :: DEL=127 ! DEL delete char left of cursor\n integer, parameter :: mode=17 ! CTRLQ toggle insert/replace\n! on MAC same as UP DOWN FORWARD suck\n integer, parameter :: backspace=27 ! CTRL[ previous in history\n!-------------------- \n! UP previous history line (if any)\n! DOWN and LF next history line (if any)\n integer, parameter :: CTRLP=16 ! CTRLP previous in history\n! integer, parameter :: UP=27 ! uparrow previous in history\n integer, parameter :: LF=10 ! CTRLJ next in history\n integer, parameter :: ctrln=14 ! CTRLN next in history\n!--------------------\n! backspace on a MAC screen\n integer, parameter :: tbackspace=8\n!-----------\n!\n! ip is cursor position (>=1), lastp is last character on line (>=0)\n integer ip,lastp,kiud,jj,kou,size,hlast\n character line*128,ch1*1\n! character getkey\n logical endoftext\n! global structure myhistory\n! type(chistory) :: myhistory\n logical insert\n!\n kiud=5; kou=6\n size=1\n!\n! write(*,*)'Reading input using getkey',lin,kiud\n if(lin.ne.kiud) then\n! reading macro from file\n read(lin,10)cline\n10 format(a) \n goto 1000\n endif\n!\n! input trom terminal with editing\n!\n insert=.TRUE.\n ip=1\n lastp=0\n line=' '\n endoftext=.true.\n hlast=myhistory%hpos+1\n! read one character at a time without echo\n100 continue\n#ifdef lixed\n! LINUX: read one character at a time without echo and allow editing history\n ch1=getkex()\n! write(*,*)'got from getkey: ',ichar(ch1)\n! on MAC all the arrow keys just generate integer 27 once, then input ignored\n! OC reacts in cntrl-P 16 previous line (history)\n! cntrl-N 14 next line (history)\n! cntrl-A 1 move to first character on line\n! cntrl-B 2 move back one character\n! cntrl-D 4 delete one character ar cursor\n! cntrl-E 5 move to after last character\n! cntrl-F 6 move forward one character\n! cntrl-K 11 delete from cursor to end of line\n! all of this is like emacs ,,,\n!\n#endif\n110 continue\n! write(*,*)'got from getkey: ',ichar(ch1)\n! handle control character\n if(ichar(ch1).ge.32 .and. ichar(ch1).lt.127) then\n! printable character, write on screen and store inline \n if(ip.eq.lastp+1 .or. .not.insert) then\n write(kou,10,advance='no')ch1\n line(ip:ip)=ch1\n if(ip.eq.lastp+1) lastp=lastp+1\n ip=ip+1\n else\n! insert a character inside a text\n line(ip+1:)=line(ip:)\n line(ip:ip)=ch1\n lastp=lastp+1\n! write(kou,10,advance='no')tbackspace\n write(kou,10,advance='no')line(ip:lastp)\n do jj=ip,lastp-1\n write(kou,10,advance='no')tbackspace\n enddo\n ip=ip+1\n endif\n goto 100\n endif\n!======================= \n! write(*,*)'control character: ',ichar(ch1)\n120 continue\n select case(ichar(ch1))\n case default\n! ignore\n! write(*,*)'Ignoring ',ichar(ch1)\n goto 100\n!............. OK\n case(ctrla)\n! move cursor to first character\n do jj=1,ip-1\n write(kou,10,advance='no')tbackspace\n enddo\n ip=1\n#ifdef lixed\n!............. NEW handle arrow key on Linix/Mac\n case(backspace) ! try to handle arrow keys sequence of 27, 91, A/B/C/D\n ch1=getkex()\n if(ichar(ch1).ne.91) goto 110\n ch1=getkex()\n if(ch1.eq.'A') then\n! write(*,*)'Arrow up'\n ch1=char(ctrlp)\n elseif(ch1.eq.'B') then\n! write(*,*)'Arrow down'\n ch1=char(ctrln)\n elseif(ch1.eq.'C') then\n! write(*,*)'Arrow forward'\n ch1=char(forward)\n elseif(ch1.eq.'D') then\n! write(*,*)'Arrow backward'\n ch1=char(backspace2)\n else !page up/down which has similar sequences etc ignored\n goto 100\n! write(*,*)'Input messed up ...'\n endif\n goto 120\n!...............OK\n! case(backspace,backspace2) ! ctrlb leftarrow (also up/down/right arrow)\n case(backspace2) ! ctrlb leftarrow (also up/down/right arrow)\n! move cursor one step back\n if(ip.gt.1) then\n write(kou,10,advance='no')tbackspace\n ip=ip-1\n endif\n\n#else\n! this rooutine is never called on Windows\n case(backspace,backspace2) ! ctrlb leftarrow (also up/down/right arrow)\n! move cursor one step back\n if(ip.gt.1) then\n write(kou,10,advance='no')tbackspace\n ip=ip-1\n endif\n#endif\n!............. OK\n case(ctrlc)\n! terminate the program\n stop 'User break'\n case(ctrle)\n! move cursor after last character\n! if(ip.eq.1) then\n! jj=ip+1\n! else\n! jj=ip\n! endif\n jj=ip\n do jj=jj,lastp\n write(kou,10,advance='no')line(jj:jj)\n enddo\n ip=lastp+1\n!............. OK\n case(ctrld)\n! delete character at cursor (ctrld)\n if(ip.gt.lastp .or. lastp.eq.0) goto 100\n jj=ip\n! remove the character at position jj and write the whole line from jj to end\n line(jj:)=line(jj+1:)\n write(kou,10,advance='no')line(jj:lastp)\n do jj=lastp,ip,-1\n write(kou,10,advance='no')tbackspace\n enddo\n lastp=lastp-1\n!............. OK\n case(del)\n! delete character to the left of cursor (del), if ip=1 ignore\n if(ip.eq.1) goto 100\n write(kou,10,advance='no')tbackspace\n! remove the character at position jj and write the whole line from jj to end\n jj=ip-1\n line(jj:)=line(jj+1:)\n write(kou,10,advance='no')line(jj:lastp)\n ip=ip-1\n lastp=lastp-1\n! NOTE lastp can be zero here\n! otherwise we should backspace lastp-ip positions\n do jj=lastp+1,ip,-1\n write(kou,10,advance='no')tbackspace\n enddo\n!............. OK\n case(ctrlk)\n! delete all characters from cursor to end of line\n if(ip.le.lastp) then\n line(ip:)=' '\n! write(kou,10,advance='no')tbackspace\n write(kou,10,advance='no')line(ip:lastp)\n do jj=ip,lastp\n write(kou,10,advance='no')tbackspace\n enddo\n lastp=ip-1\n endif\n!.............\n case(help) ! ctrlh\n write(kou,77, advance='no')ip,lastp,line(1:lastp+1)\n77 format(/'Current local values are: ',2i4/a)\n! write(kou,10,advance='no')'xyz'\n do jj=lastp,ip,-1\n write(kou,10,advance='no')tbackspace\n enddo\n!.............\n case(mode) ! crtlQ\n! change inset mode\n if(insert) then\n insert=.FALSE.\n else\n insert=.TRUE.\n endif\n!.............\n case(return,tab)\n! save line (if not empty) finish editing and return current line\n cline=line\n if(len_trim(line).eq.0) then\n continue\n! write(*,*)'Not saving empty line'\n elseif(myhistory%hpos.le.0) then\n! saving the first line as\n myhistory%hpos=1\n myhistory%hline(myhistory%hpos)=line(1:80)\n elseif(line(1:ip+1).eq.myhistory%hline(myhistory%hpos)(1:ip+1)) then\n continue\n! write(*,*)'Not saving same line'\n else\n if(myhistory%hpos.ge.histlines) then\n! history full, the oldest history line deleted\n do jj=2,histlines\n myhistory%hline(jj-1)=myhistory%hline(jj)\n enddo\n else\n myhistory%hpos=myhistory%hpos+1\n endif\n myhistory%hline(myhistory%hpos)=line(1:80)\n endif\n! write a CR on screen ... maybe also LF ?? NO!!\n if(ichar(ch1).eq.return) write(kou,*)\n goto 1000\n!............. OK\n case(forward)\n! move cursor one step right if we are not at lastp\n if(ip.le.lastp) then\n write(kou,10,advance='no')line(ip:ip)\n ip=ip+1\n! if(ip.eq.lastp) endoftext=.true.\n! elseif(.not.endoftext) then\n! write(kou,10,advance='no')line(ip:ip)\n! endoftext=.true.\n endif\n!.............\n case(ctrlp)\n! copy previous history line to current\n! first remove anything on the line (not the question ...)\n if(hlast.gt.1) then\n do jj=1,ip-1\n write(kou,10,advance='no')tbackspace\n enddo\n line=' '\n write(kou,10,advance='no')line(1:lastp)\n do jj=1,lastp\n write(kou,10,advance='no')tbackspace\n enddo\n hlast=hlast-1\n line=myhistory%hline(hlast)\n lastp=len_trim(line)\n ip=lastp+1\n write(kou,10,advance='no')line(1:lastp)\n endif\n!.............CTRLJ and CTRLN\n case(lf,ctrln)\n! copy next history line to current\n if(hlast.lt.myhistory%hpos) then\n do jj=1,ip-1\n write(kou,10,advance='no')tbackspace\n enddo\n line=' '\n write(kou,10,advance='no')line(1:lastp)\n do jj=1,lastp\n write(kou,10,advance='no')tbackspace\n enddo\n hlast=hlast+1\n line=myhistory%hline(hlast)\n lastp=len_trim(line)\n ip=lastp+1\n write(kou,10,advance='no')line(1:lastp)\n endif\n end select\n!-----------------\n goto 100\n!================= \n1000 continue\n return\n end subroutine bintxt_getkey\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine bintxt_nogetkey & Read a text\n!\\begin{verbatim}\n subroutine bintxt_nogetkey(lin,line)\n! Reading a command line on Windows with editing provided by the OS\n implicit none\n character line*(*)\n integer lin\n!\\end{verbatim}\n integer iostatus\n read(lin,10,iostat=iostatus)line\n10 format(a)\n if(iostatus.lt.0) then\n! reading a macro beyond EOL/EOF ??\n write(*,*)' *** WARNING: MACRO ENDS WITHOUT SET INTERACTIVE!'\n line='set inter '\n endif\n return\n end subroutine bintxt_nogetkey\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection \n! command line macros\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine macbeg & Start a maro\n!\\begin{verbatim}\n SUBROUTINE MACBEG(LINE,LAST,OK)\n!....subroutine to execute set-interactive allowing nesting of macros\n!\n! IDEA: addera lablar i macro sa man kan ange MACRO fil LABEL\n! och vid stop som @? eller @& man kan interaktivt ange GOTO label\n! Ocksa en generisk subrutin som gor att man kan fa fram ett variabelvarde\n! call macsymval(package,symbol,ival,rval,cval)\n!\n implicit none\n CHARACTER LINE*(*)\n LOGICAL OK\n integer last\n!\\end{verbatim} %+\n!\n! CHARACTER MACFIL*256,FIL*256,CH1*1\n CHARACTER MACFIL*256,FIL*256\n LOGICAL FIRST\n character*3 USEEXT\n character*1 dirsep,backslash\n character dummy*256\n integer ll,kk,ierr\n SAVE FIRST\n DATA FIRST/.TRUE./\n IF(FIRST) THEN\n FIRST=.FALSE.\n IUMACLEVL=0\n! lun=50\n ENDIF\n MACFIL=' '\n useext=macext\n! ipos=index(line(max(1,last):),'.')\n! if (ipos.gt.0) then\n! if (LEN_TRIM(line(ipos:)).gt.1) then\n! useext=' '\n! endif\n! endif\n! write(*,*)'In MACBEG: ',trim(line),last\n! added that extension should be OCM by the argument \"3\"\n CALL GPARFILEx('Macro filename: ',LINE,LAST,1,FIL,MACFIL,3,'?MACRO file')\n! CALL GPARC('Macro filename: ',LINE,LAST,1,FIL,MACFIL,nohelp)\n! add default extension if needed\n CALL FXDFLT(FIL,MACEXT)\n IF(BUPERR.NE.0) GOTO 910\n! write(*,*)'open macro: ',lun,IUMACLEVL\n! LUN=50\n OPEN(LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD', &\n FORM='FORMATTED',IOSTAT=IERR,ERR=910)\n! we can have macros nested 5 livels deep\n IF(IUMACLEVL.LT.5) THEN\n IUMACLEVL=IUMACLEVL+1\n MACROUNIT(IUMACLEVL)=KIU\n ELSE\n! CALL ST2ERR(1083,'MACBEG','TOO DEEPLY NESTED MACRO FILES')\n buperr=1083\n OK=.FALSE.\n GOTO 900\n ENDIF\n! extract the PATH to this macro file, needed to open files inside the macro\n backslash=char(92)\n! write(*,*)'M3 macro file: ',trim(fil),' bacslash: ',backslash\n if(index(fil,backslash).gt.0) then\n! this is on Windows\n dirsep=backslash\n else\n! this is on UNIX type systems \n dirsep='/'\n endif\n! write(*,*)'M3 macro file: ',trim(fil),' backslash: ',backslash,IUMACLEVL\n ll=1\n kk=0\n do while(ll.gt.0)\n kk=ll+kk\n dummy=fil(kk:)\n ll=index(dummy,dirsep)\n! ll=index(fil(kk:),dirsep)\n enddo\n! we have found the position of the actual filename. Save the path incl dirsep\n if(kk.gt.1) then\n macropath(IUMACLEVL)=fil(1:kk-1)\n else\n macropath(IUMACLEVL)=' '\n endif\n! write(*,*)'Macro path saved: ',IUMACLEVL,': ',trim(macropath(IUMACLEVL))\n! write(*,*)'Command input set: ',kiu,IUMACLEVL\n! this is to suprees \"press return to continue\" but not implemented ...\n OK=.TRUE.\n KIU=LUN\n LUN=LUN+1\n! write(*,*)'Command input is: ',kiu\n900 continue\n return\n910 OK=.FALSE.\n write(*,*)'Error ',ierr,' opening macro file: ',trim(fil)\n buperr=1000+ierr\n GOTO 900\n end SUBROUTINE MACBEG\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine macend & End a macro\n!\\begin{verbatim}\n SUBROUTINE MACEND(LINE,LAST,OK)\n! end of macro detected, close file and return to upper level\n implicit none\n CHARACTER LINE*(*)\n LOGICAL OK\n integer last\n!\\end{verbatim} %+\n! set interactive gives back control to calling macro if any\n IF(KIU.NE.KIUD) THEN\n IF(KIU.NE.0) CLOSE(KIU)\n! write(*,*)'end of macro: ',kiu,kiud,IUMACLEVL\n IF(IUMACLEVL.GT.0) THEN\n! write(*,*)'calling macro: ',macrounit(IUMACLEVL)\n KIU=MACROUNIT(IUMACLEVL)\n IUMACLEVL=IUMACLEVL-1\n ELSE\n! write(*,*)'terminal: ',kiud\n KIU=KIUD\n ENDIF\n ENDIF\n! write(*,*)'Output: ',kou,koud\n IF(KOU.NE.KOUD) THEN\n IF(KOU.NE.0) CLOSE(KOU)\n KOU=KOUD\n ENDIF\n!...ANYTHING AFTER A SET_INTERACTIVE IS TAKEN AS A MODULE NAME\n OK=.FALSE.\n IF(EOLCH(LINE,LAST)) GOTO 900\n OK=.TRUE.\n LAST=LAST-1\n900 continue\n! write(*,*)'Leaving macbeg/macend'\n RETURN\n END SUBROUTINE MACEND\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gptcm1 & Replace macro variables with value 1\n!\\begin{verbatim}\n SUBROUTINE GPTCM1(IFLAG,SVAR,LAST,SLIN)\n!...handling of MACRO directives like @& @? and @# etc\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER SVAR*(*),slin*(*)\n integer iflag,last\n!\\end{verbatim} %+\n! CHARACTER PP*30,CH1*1\n! CHARACTER ENVIR(9)*60,LABEL*8,LABLIN*60,SYMBOL*60\n! CHARACTER LABEL*8,LABLIN*60,SYMBOL*60\n! LOGICAL SG2ERR,TESTB,EOLCH\n!\n IFLAG=0\n!...IF NO ERROR RETURN\n IF(.NOT.BUPERR.NE.0) GOTO 900\n IF(LAST.LE.0 .OR. LAST.GE.LEN(SVAR)) GOTO 900\n SLIN=SVAR(LAST:)\n!...IF FIRST CHARACTER NOT A @ RETURN\n call gptcm2(iflag,svar,last,slin)\n900 continue\n return\n end SUBROUTINE GPTCM1\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine gptcm2 & Replace a macro variable with value 2\n!\\begin{verbatim}\n subroutine GPTCM2(IFLAG,SVAR,LAST,SLIN)\n! handling of macro variables\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER SVAR*(*),slin*(*)\n integer iflag,last\n!\\end{verbatim} %+\n! CHARACTER ENVIR(9)*60,LABEL*8,LABLIN*60,SYMBOL*60\n CHARACTER PP*30,CH1*1\n! CHARACTER LABEL*8,LABLIN*60,SYMBOL*60\n CHARACTER LABLIN*60\n! double precision, parameter :: ZERO=0.0D0,ONE=1.0D0\n integer ienv\n! LOGICAL SG2ERR,TESTB,EOLCH\n IFLAG=0\n IF(SLIN(1:1).NE.'@') GOTO 900\n!...A @ MEANS THAT THE FOLLOWING CHARACTER MAY HAVE SPECIAL MEANING\n! (many of these not implemented)\n! @$ MEANS A COMMENT LINE\n! @& MEANS PAUSE\n! @?text MEANS QUEARY, value supplied entered to program\n! @#itext MEANS DEFINING MACRO VARIABLE i, queary is \"text\", 0',a)\n GOTO 100\n ENDIF\n900 RETURN\n END SUBROUTINE GQXENV\n \n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n!\n! >>>> subsection\n! PUTFUN can parse a fortran like expression and create a binary tree\n! It cannot calculate derivatives. Used for state variable symbols in OC\n! Rather final version of PUTFUN below \n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine putfun & Enter an expression\n!\\begin{verbatim}\n SUBROUTINE PUTFUN(STRING,L,MAXS,SYMBOL,LOKV,LROT,ALLOWCH,NV)\n!...READS AN EXPRESSION FROM STRING POSITION L AND CREATES AN BINARY TREE\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER STRING*(*),SYMBOL(*)*(*)\n integer LOKV(*)\n integer maxs,allowch,nv\n! type(putfun_symlink) :: symlist\n LOGICAL NOTPP\n TYPE(putfun_node), pointer :: LROT\n!\\end{verbatim}\n CHARACTER CH*1\n! double precision, parameter :: ZERO=0.0D0\n integer l,i,ipn,lab,lq,negmark,iopuni\n double precision val\n TYPE(putfun_node), pointer :: nynod,nonod\n! these dummy pointers seem to be redundant ... ???\n TYPE(putfun_node), pointer :: dummy,dummy2\n! INPUT:\n! STRING CHARACTER WITH EXPRESSION\n! L POSITION WHERE THE EXPRESSION STARTS\n! MAXS NUMBER OF SYMBOLIC VARIABLES THAT MAY BE USED.\n! MAXS=0 NO VARIABLES ALLOWED\n! MAXS>0 INDICATES THAT MAXS ALLOWED NAMES ARE IN SYMBOL.\n! MAXS<0 INDICATES THAT ABS(MAXS) USERDEFINED NAMES ARE ALLOWED.\n! NOTE! SYMBOL AND LOKV MUST HAVE THE DIMENSION ABS(MAXS)\n! SYMBOL CHARACTER ARRAY OF DIMENSION ABS(MAXS)\n! LOKV ARRAY FOR LOCAL USE OF DIMENSION ABS(MAXS)\n! EXIT:\n! L POSITION AFTER LAST CHARACTER IN THE EXPRESSION\n! LROT POINTER TO ROOT (MAY BE ZERO IF NO TREE)\n! NV NUMBER OF SYMBOLIC VARIABLES DEFINED BY USER\n!...THE FOLLOWING NODES ARE USED\n! 1. OPKOD,LLINK,MLINK BIN[R OPERATOR\n! 2. OPKOD,LLINK,0 UNIT[R OPERATOR\n! 3. OPKOD,0,0,VALUE DATA ELLER VARIABEL\n! The following binary opcodes:\n! 1 +\n! 2 -\n! 3 *\n! 4 /\n! 5 ** (EXPONENTIERING)\n! The following unary functions:\n! 1 - (should not be used)\n! 2 SQRT\n! 3 EXP\n! 4 LOG (Natural log, e-log)\n! 5 LOG10 (logaritm bas 10)\n! 6 SIN\n! 7 COS\n! 8 ATAN (Arctangent)\n! 9 ERF (Error function)\n! 10 IVAN (Ivantsof function)\n! The following data codes\n! -1 Whole number (stored as real in node)\n! 0 Real constant stored in node\n! >0 Symbol variable, INT(value) is the index ????\n!..INITIERA\n PUTFUNVAR=0\n NOTPP=.TRUE.\n debuginc=0\n! IPN associated with the LEVEL array\n IPN=0\n NEGMARK=0\n LAB=1\n nullify(topnod); nullify(datanod); nullify(lastopnod); nullify(nonod)\n!...initiate external symbolik links\n! write(*,*)'putfun: ',maxs\n do i=1,abs(maxs)\n LOKV(i)=0\n enddo\n! I cannot make it work to have one node for all occurence of one symbol\n! allocate(symlist%symnod(20))\n nullify(stacktop)\n if(eolch(string,l)) then\n! expected function, found nothing\n pfnerr=1059; goto 880\n endif\n!..IF FIRST CHARACTER ; THEN EXIT with function zero\n IF(STRING(L:L).EQ.';') GOTO 800\n L=L-1\n! write(*,*)'PUTFUN: ',lab,l\n GOTO(100,100,200),LAB\n! if(lab.gt.0) goto 200\n! ******* Expecting variable ********* > Expecting next\n! Allowed characters\n! ? > Give hekptext\n! - (make negative) > Expect variable\n! Variabele or constant > Binary operator\n! Unary operator (includ. '(') > Expect variable\n! ( > Expect variable\n100 L=L+1\n if(pfnerr.ne.0) goto 900\n IF(L.GT.len(string)) then\n pfnerr=1052; GOTO 900\n endif\n CH=STRING(L:L)\n IF(CH.EQ.' ') GOTO 100\n IF(CH.EQ.'-') THEN\n! treat negative sign special as one can have a symbol afterwards\n NEGMARK=-1\n110 continue\n L=L+1\n IF(L.GT.len(string)) then\n pfnerr=1052; GOTO 900\n endif\n! allow spaces after sign\n CH=STRING(L:L)\n IF(CH.EQ.' ') GOTO 110\n else\n NEGMARK=0\n endif\n IF(CH.EQ.'(') THEN\n CALL NYLP(nonod,IPN,NOTPP)\n GOTO 100\n endif\n LQ=L\n CALL GETREL(STRING,L,VAL)\n if(buperr.ne.0) then\n buperr=0\n! not a number, it must be a symbol or unary operator\n L=LQ\n! write(*,*)'PUTFUN buperror: ',l\n CALL NYVAR(STRING,L,IOPUNI,negmark,MAXS,SYMBOL,LOKV,allowch,dummy2)\n IF(pfnerr.ne.0) GOTO 900\n! write(*,*)'After nyvar: ',iopuni,symbol(1)\n IF(IOPUNI.GT.0) THEN\n CALL NYUNI(IOPUNI,negmark,NYNOD,IPN,NOTPP)\n GOTO 100\n ENDIF\n! write(*,*)'PUTFUN buperror: nyvar return iopuni=0, look for operator'\n ELSE\n! we have found a symbol\n CALL NYDAT(0,VAL,dummy,negmark)\n if(pfnerr.ne.0) goto 900\n L=L-1\n ENDIF\n LAB=3\n! ****** Expecting binary operator **** > Expected next\n! Allowed characters \n! +,-,*,**,/ > Expect variable for right tree, LAB=2\n! ) > Binary operator\n! ; > This means end of expression\n200 L=L+1\n IF(L.GT.len(string)) GOTO 800\n CH=STRING(L:L)\n IF(CH.EQ.' ') GOTO 200\n IF(CH.EQ.';') GOTO 800\n binop: IF(CH.EQ.'+') THEN\n CALL NYBIN(1,NYNOD,NOTPP)\n ELSEIF(CH.EQ.'-') THEN\n CALL NYBIN(2,NYNOD,NOTPP)\n ELSEIF(CH.EQ.'*') THEN\n IF(STRING(L+1:L+1).EQ.'*') THEN\n! exponentiation **\n L=L+1\n CALL NYBIN(5,NYNOD,NOTPP)\n ELSE\n CALL NYBIN(3,NYNOD,NOTPP)\n ENDIF\n ELSEIF(CH.EQ.'/') THEN\n CALL NYBIN(4,NYNOD,NOTPP)\n ELSEIF(CH.EQ.')') THEN\n CALL NYRP(IPN,NOTPP)\n GOTO 200\n ELSE\n write(*,*)'putfun error: \"',ch,'\" position ',L\n pfnerr=1051; GOTO 900\n ENDIF binop\n NEGMARK=0\n LAB=2\n GOTO 100\n! we have evaluated the expression, IPN is parenthesis level\n800 L=L+1\n! write(*,*)'PUTFUN: label 800'\n IF(IPN.NE.0) THEN\n pfnerr=1050; GOTO 900\n endif\n! expression finished, set lrot\n if(associated(topnod)) then\n if(topnod%kod.ne.0) then\n lrot=>topnod\n else\n! topnode has no binary operation, return datanod if any\n if(.not.associated(datanod)) then\n nullify(lrot)\n elseif(datanod%value.eq.zero) then\n! single value equal to zero, do not return any node. A symbol would have 1.0\n nullify(lrot)\n else\n lrot=>datanod\n endif\n endif\n else\n! there is no topnod\n! write(*,*)'PUTFUN: no topnode'\n if(associated(datanod)) then\n if(datanod%value.eq.zero) then\n! write(*,*)'PUTFUN: datanode with zero'\n nullify(lrot)\n else\n! write(*,*)'PUTFUN: datanode with non-zero'\n lrot=>datanod\n endif\n! else\n! no topnode and no datanode, empty function\n! write(*,*)'PUTFUN: no datanode'\n endif\n endif\n880 continue\n! return number of external variables used\n NV=PUTFUNVAR\n900 RETURN\n END SUBROUTINE PUTFUN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine nybin & Found a binary operator + - * /\n!\\begin{verbatim}\n SUBROUTINE NYBIN(kod,binnod,NOTPP)\n!...INSERTS A NEW OPNODE IN THE TREE\n implicit none\n integer kod\n TYPE(putfun_node), pointer :: binnod\n LOGICAL NOTPP\n!\\end{verbatim} %+\n!\n TYPE(putfun_node), pointer :: temp\n! double precision, parameter :: zero=0.0d0\n! INPUT:\n! KOD IS OPERATION CODE: 1 +, 2 -, 3 *, 4 /, 5 **\n! EXIT: \n! LOKBIN IS NEW BINARY NODE WITH NEW OPERATION\n! 1. IF THERE IS NO TOP NODE:\n! INSERT THIS NODE AS TOP NODE\n! 2. IF THE NEW NODE IS + OR -:\n! THE PREVIOUS TOP NODE IS SET AS LEFT SUBTREE OF NEW NODE\n! THE NEW NODE IS SET AS TOP NODE\n! 3. IF THE NEW NODE IS * OR /:\n! IF THE PREVIOUS TOP NODE IS * OR / OR ** DO AS 2.\n! ELSE THE RIGHT SUBTREE OF THE TOP NODE IS SET AS LEFT SUBTREE\n! OF NEW NODE. NEW NODE IS SET AS RIGHT SUBTREE OF THE TOP NODE\n! 4. IF THE NEW NODE IS **:\n! THE RIGHT SUBTREE OF THE TOP NODE IS SET AS LEFT SUBTREE\n! OF NEW NODE. NEW NODE IS SET AS RIGHT SUBTREE OF THE TOP NODE\n!\n IF(KOD.LE.0) then\n pfnerr=1058; goto 900\n endif\n! one may get error \"already allocated??\"\n allocate(binnod)\n debuginc=debuginc+1\n binnod%debug=debuginc\n nullify(binnod%left); nullify(binnod%right); binnod%value=zero\n binnod%kod=kod; binnod%links=0\n lastopnod=>binnod\n!...arrange binary opnodes according to priorities\n binop: IF(.not.associated(topnod)) THEN\n! set this as topnod and link the datanod as left subtree\n topnod=>binnod\n topnod%left=>datanod\n ELSEIF(KOD.LE.2) THEN\n! + OR -\n binnod%left=>topnod\n topnod=>binnod\n ELSEIF(KOD.LE.4) THEN\n! * OR / one has to consider priorities of operators\n if(topnod%kod.gt.2) then\n binnod%left=>topnod\n topnod=>binnod\n else\n binnod%left=>topnod%right\n topnod%right=>binnod\n endif\n NOTPP=.TRUE.\n ELSEIF(KOD.EQ.5 .AND. NOTPP) THEN\n! ** (TWO ** IN A ROW ILLEGAL)\n if(topnod%kod.gt.2) then\n binnod%left=topnod%right\n topnod%right=binnod\n else\n! rearrange\n temp=>topnod%right\n if(associated(temp)) then\n binnod%left=>temp%right\n temp%right=>binnod\n else\n binnod%left=>topnod%right\n topnod%right=>binnod\n endif\n endif\n NOTPP=.FALSE.\n ELSE\n pfnerr=1058\n ENDIF binop\n900 RETURN\n END SUBROUTINE NYBIN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine nyuni & Found a unary operator LOG EXP ...\n!\\begin{verbatim}\n SUBROUTINE NYUNI(KOD,negmark,uninod,IPN,NOTPP)\n! Creates a node with a unary operator\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n TYPE(putfun_node), pointer :: UNINOD\n LOGICAL NOTPP\n integer kod,negmark,ipn\n!\\end{verbatim} %+\n!\n double precision, parameter :: one=1.0D0\n allocate(uninod)\n debuginc=debuginc+1\n uninod%debug=debuginc\n nullify(uninod%left); nullify(uninod%right); uninod%value=zero\n uninod%kod=-kod; uninod%links=0\n! write(*,*)'creating unary node ',kod,debuginc\n if(negmark.lt.0) then\n uninod%value=-one\n else\n uninod%value=one\n endif\n! if there is a previous binary operator\n if(associated(lastopnod)) then\n! write(*,*)'linking unary node as right link: ',lastopnod%debug\n lastopnod%right=>uninod\n elseif(.not.associated(topnod)) then\n datanod=>uninod\n else\n! this should nover happen\n pfnerr=1064\n endif\n CALL NYLP(uninod,IPN,NOTPP)\n RETURN\n END SUBROUTINE NYUNI\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine nylp & Found a left (\n!\\begin{verbatim}\n SUBROUTINE NYLP(uninod,IPN,NOTPP)\n!...OPENING PARENTHESIS, push links on LEVEL. Also after unary operator\n implicit none\n TYPE(putfun_node), pointer :: uninod\n integer ipn\n LOGICAL NOTPP\n!\\end{verbatim} %+\n type(putfun_stack), pointer :: temp\n!\n IPN=IPN+1\n IF(IPN.GT.20) THEN\n pfnerr=1055; goto 1000\n endif\n if(associated(stacktop)) then\n allocate(temp)\n temp%previous=>stacktop\n stacktop=>temp\n else\n allocate(stacktop)\n endif\n stacktop%savetop=>topnod\n stacktop%savebin=>lastopnod\n stacktop%saveuni=>uninod\n! NSTACK(1,IPN)=>topnod\n! NSTACK(2,IPN)=>lastopnod\n! uninod is null if not ( after unary operator\n! NSTACK(3,IPN)=>uninod\n! start new expression after (\n NOTPP=.TRUE.\n nullify(topnod)\n nullify(lastopnod)\n1000 continue\n return\n end SUBROUTINE NYLP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine nyrp & Found a )\n!\\begin{verbatim}\n subroutine NYRP(IPN,NOTPP)\n!...CLOSING PARENTHESIS\n! implicit double precision (a-h,o-z)\n implicit none\n integer ipn\n LOGICAL NOTPP\n!\\end{verbatim} %+\n TYPE(putfun_node), pointer :: uninod,subtree\n!\n IF(IPN.LE.0) then\n pfnerr=1056; goto 1000\n endif\n! save link to expression inside parenthesis\n if(.not.associated(topnod)) then\n subtree=>datanod\n else\n subtree=>topnod\n endif\n! POP previous nstack\n! topnod=>NSTACK(1,IPN)\n! lastopnod=>NSTACK(2,IPN)\n! uninod=>nstack(3,IPN)\n topnod=>stacktop%savetop\n lastopnod=>stacktop%savebin\n uninod=>stacktop%saveuni\n stacktop=>stacktop%previous\n IPN=IPN-1\n! write(*,*)'right ): ',topnod%debug,lastopnod%debug,subtree%debug\n! I do not understand why this IF is not related to those following\n IF(associated(uninod)) THEN\n! write(*,*)'right ) after unary function: ',uninod%debug\n uninod%left=>subtree\n endif\n if(associated(lastopnod)) then\n if(.not.associated(lastopnod%right)) then\n lastopnod%right=>subtree\n else\n datanod=>subtree\n endif\n elseif(associated(uninod)) then\n datanod=>uninod\n else\n!...PARENTHESISED EXPRESSION IS LEFT SUBTREE OF EMPTY BINARY NODE.\n datanod=>subtree\n endif\n NOTPP=.TRUE.\n1000 continue\n RETURN\n END SUBROUTINE NYRP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine nyvar & Found a symbol\n!\\begin{verbatim}\n SUBROUTINE NYVAR(TEXT,L,IOPUNI,negmark,MAXS,SYMBOL,LOKV,allowch,dummy2)\n! inserts a symbol in an expression\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER TEXT*(*),SYMBOL(*)*(*)\n integer LOKV(*)\n integer iopuni,negmark,maxs,allowch\n type(putfun_node), pointer :: dummy2\n!\\end{verbatim} %+\n!\n integer, parameter :: NOPER=14\n CHARACTER CH*1,NAME*16\n! double precision, parameter :: ZERO=0.0D0,ONE=1.0D0\n LOGICAL DEL2\n integer l,k,ln,i\n! type(putfun_symlink) :: symlist\n character*6, dimension(noper) :: OPER=&\n ['SQRT ','EXP ','LOG ','LOG10 ','SIN ','COS ','ATAN ',&\n 'SIGN ','ERF ','IVAN ','BSUM ','ABS ','HS ','LN ']\n!\n IOPUNI=0\n DEL2=.FALSE.\n70 NAME=' '\n K=1\n100 CH=BIGLET(TEXT(L:L))\n L=L+1\n IF(K.GT.1 .AND. ((CH.GE.'0' .AND. CH.LE.'9') .or. CH.eq.'_')) THEN\n NAME(K:K)=CH\n K=K+1\n ELSE\n! first letter must be A-Z\n IF(CH.GE.'A' .AND. CH.LE.'Z') THEN\n NAME(K:K)=CH\n K=K+1\n ELSEIF(K.GT.1 .AND. allowch.EQ.1) THEN\n! allowch=1 means allow & and # in symbol names\n if(ch.eq.'#' .or. ch.eq.'&') then\n name(k:k)=ch\n k=k+1\n else\n goto 200\n endif\n ELSE\n GOTO 200\n ENDIF\n ENDIF\n GOTO 100\n!..DEL2 is true if it is the second part of a symbol with a dot\n200 IF(DEL2) GOTO 315\n!.. if character is ( it must be a unary operator\n IF(CH.EQ.'(') GOTO 300\n!..If character is \".\" it is an external derivative (like H.T)\n IF(CH.EQ.'.') GOTO 311\n!\n IF(MAXS.LE.0 .AND. PUTFUNVAR.EQ.0) GOTO 220\n!..compare with existing variable symbols\n! If maxs>0 no new symbols allowed, only those in symbol(1..maxs)\n IF(MAXS.GT.0) PUTFUNVAR=MAXS\n! exact match required, include final space in name, max 15 characters\n ln=len_trim(name)+1\n if(ln.gt.16) then\n pfnerr=1062; goto 900\n endif\n DO I=1,PUTFUNVAR\n IF(NAME(1:ln).EQ.SYMBOL(I)(1:ln)) GOTO 230\n enddo\n!..New symbol, error if MAXS>0, if not add it to SYMBOL and increment PUTFUNVAR\n220 IF(MAXS.GT.0) GOTO 910\n IF(PUTFUNVAR.GE.ABS(MAXS)) GOTO 920\n PUTFUNVAR=PUTFUNVAR+1\n SYMBOL(PUTFUNVAR)=NAME\n! if this is never set each occurence of the same symbol will have a node\n! LOKV(PUTFUNVAR)=1\n! jump here from several places below\n224 continue\n I=PUTFUNVAR\n225 continue\n CALL NYDAT(I,one,dummy2,negmark)\n! write(*,*)'nyvar assigning symnod: ',dummy2%debug,dummy2%value\n! symlist%symnod(i)=>dummy2\n GOTO 800\n!..Known symbol, with index I\n! If LOKV(I)=0 it is a predefined symbol without node and one must created\n230 continue\n IF(LOKV(I).EQ.0) GOTO 225\n! CALL SETADS(symnod(I))\n! write(*,*)'nyvar 230: ',i\n! IF(associated(lastopnod)) THEN\n! lastopnod%right=>symlist%symnod(i)\n! ELSE\n! datanod=>symlist%symnod(i)\n! ENDIF\n!...Keep track of number of links to this node\n! symlist%symnod(i)%links=symlist%symnod(i)%links-1\n! write(*,*)'nyvar 230: ',i,symlist%symnod(i)%links,symlist%symnod(i)%debug\n! return\n! GOTO 800\n!=======================================\n!..A unary OPERATOR\n300 continue\n! write(*,*)'nyvar found unary operator: ',name\n DO I=1,NOPER\n IF(NAME(1:6).EQ.OPER(I)(1:6)) GOTO 330\n enddo\n!..IF USERDEFINED UNARY OPERATORS (OR ARRAYS) ALLOWED (MAXS<0)\n311 IF(MAXS.GT.0) GOTO 910\n IF(PUTFUNVAR.GE.ABS(MAXS)) GOTO 920\n PUTFUNVAR=PUTFUNVAR+1\n IF(CH.EQ.'.') THEN\n SYMBOL(PUTFUNVAR)=NAME(1:K-1)\n L=L-1\n ELSE\n SYMBOL(PUTFUNVAR)=NAME(1:K-1)//'('\n L=L-1\n! FDMTP extracts text within parenthesis\n CALL FDMTP(TEXT,L,SYMBOL(PUTFUNVAR)(K+1:))\n K=LEN_trim(SYMBOL(PUTFUNVAR))\n SYMBOL(PUTFUNVAR)(K+1:K+1)=')'\n CH=TEXT(L:L)\n!... this line I do not understand\n IF(CH.NE.'.') L=L+1\n ENDIF\n CALL CAPSON(SYMBOL(PUTFUNVAR))\n!...check if an external symbol with dot (derivative like H.T)\n IF(CH.NE.'.') GOTO 224\n L=L+1\n DEL2=.TRUE.\n GOTO 70\n!\n!...Second part of symbolic derivative after a \".\"\n315 K=LEN_TRIM(SYMBOL(PUTFUNVAR))\n SYMBOL(PUTFUNVAR)(K+1:)='.'//NAME\n IF(CH.EQ.'(') THEN\n K=LEN_TRIM(SYMBOL(PUTFUNVAR))\n SYMBOL(PUTFUNVAR)(K+1:K+1)='('\n L=L-1\n CALL FDMTP(TEXT,L,SYMBOL(PUTFUNVAR)(K+2:))\n K=LEN_TRIM(SYMBOL(PUTFUNVAR))\n SYMBOL(PUTFUNVAR)(K+1:K+1)=')'\n L=L+1\n ENDIF\n CALL CAPSON(SYMBOL(PUTFUNVAR))\n GOTO 224\n!\n!...note unary opcode is one larger than opcode index!\n330 continue\n IOPUNI=I+1\n L=L+1\n800 L=L-2\n900 RETURN\n910 continue\n pfnerr=1053; GOTO 900\n920 continue\n pfnerr=1054; GOTO 900\n END SUBROUTINE NYVAR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine nydat & Found a numeric value\n!\\begin{verbatim}\n SUBROUTINE NYDAT(KOD,VAL,nynod,negmark)\n! store a constant or symbol. The address to the node is returned in lok\n! which is used if the symbol is used several times.\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer kod,negmark\n TYPE(putfun_node), pointer :: nynod\n double precision val\n!\\end{verbatim}\n! write(*,*)'nydat 1: ',kod,negmark\n allocate(nynod)\n nynod%kod=kod; nynod%links=0\n nullify(nynod%left); nullify(nynod%right)\n debuginc=debuginc+1\n nynod%debug=debuginc\n if(negmark.lt.0) then\n nynod%value=-val\n else\n nynod%value=val\n endif\n! write(*,*)'nydat 2: ',nynod%kod,debuginc,nynod%value\n if(associated(lastopnod)) then\n if(.not.associated(lastopnod%right)) then\n lastopnod%right=>nynod\n else\n! this should never happen\n write(*,*)'PUTFUN never never error 1'\n pfnerr=7777\n endif\n! write(*,*)'nydat 4A: ',lastopnod%kod,lastopnod%value\n! write(*,*)'nydat 4B: ',lastopnod%right%kod,lastopnod%right%value\n! write(*,*)'nydat 4C: ',lastopnod%left%kod,lastopnod%left%value\n else\n datanod=>nynod\n! write(*,*)'nydat 5: ',datanod%kod,datanod%value\n endif\n return\n end SUBROUTINE NYDAT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable double precision evalf & Evaluate a function\n!\\begin{verbatim}\n double precision function evalf(LROT,VAR)\n! Calculates the value of an expression MEMORY LEAK \n! ?? I do not know what is the difference with evalf_x ??/BoS 190804\n!\n! VAR is array with values of symbols that can be referenced\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n double precision VAR(*)\n type(putfun_node), pointer :: lrot\n!\\end{verbatim} %+\n! character ch1*1\n double precision STACK(20)\n! type(putfun_node), pointer :: llink,current,mlink\n type(putfun_node), pointer :: current,mlink\n TYPE PUTFUN_SAVE\n integer right\n type(putfun_node), pointer :: savecurrent\n type(putfun_save), pointer :: previous\n end TYPE PUTFUN_SAVE\n! these pointers are allocated creating memory leaks\n type(putfun_save), pointer :: topsave,temp\n! double precision, parameter :: ZERO=0.0D0\n integer last,lstp,kod\n!\n!...If LROT<=0 there is no expression, return sero\n STACK(1)=ZERO\n IF(.not.associated(LROT)) THEN\n GOTO 800\n ENDIF\n!..INITIATE\n LAST=0\n LSTP=0\n current=>LROT\n nullify(topsave)\n! read(*,72)ch1\n!72 format(a)\n!71 format(a,5i5,1pe16.6)\n!..New node, take is left link if any\n100 continue\n! if(associated(current%right)) then\n! write(*,71)'>>>> evalf 100A1: ',current%debug,current%kod,&\n! current%left%debug,current%right%debug,current%links,current%value\n! elseif(associated(current%left)) then\n! write(*,71)'>>>> evalf 100A2: ',current%debug,current%kod,&\n! current%left%debug,0,current%links,current%value\n! else\n! write(*,71)'>>>> evalf 100A3: ',current%debug,current%kod,&\n! 0,0,current%links,current%value\n! endif\n! ERROR if I first set llink=>current%left and then tested llink if associated\n if(associated(current%left)) then\n! write(*,*)'Taking the left link and pushing current'\n LAST=LAST+1\n if(associated(topsave)) then\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n else\n allocate(topsave)\n nullify(topsave%previous)\n endif\n topsave%savecurrent=>current\n! write(*,71)'evalf 100D: ',topsave%savecurrent%debug,current%left%debug\n! mark that right link not visited\n topsave%right=1\n current=>current%left\n ELSE\n!..If no left link the right link must be a data or unary negation\n KOD=current%kod\n LSTP=LSTP+1\n IF(KOD.GT.0) then\n! unary operator, store the operation as a real\n STACK(LSTP)=VAR(KOD)\n else\n stack(lstp)=current%value\n endif\n! write(*,71)'evalf 100X: ',current%debug,kod,lstp,0,0,stack(lstp)\n!..When coming here with LAST=0 the expression has been evaluated.\n! If not check if right link of current node has been visited\n200 IF(LAST.LE.0) GOTO 800\n current=>topsave%savecurrent\n! write(*,71)'evalf 100YA: ',current%debug,topsave%right,current%kod\n IF(topsave%right.gt.0) THEN\n!..Follow the right link\n if(associated(current%right)) then\n MLINK=>current%right\n! write(*,71)'evalf 100YB: ',mlink%debug,mlink%kod\n!..Follow the left link of the right link but first mark that the right\n! link of current has been visited\n topsave%right=-1\n current=>MLINK\n! write(*,71)'evalf 100Z: ',current%debug,current%kod,topsave%right\n GOTO 100\n ELSE\n!..unary operator, in some cases it can have a sign\n CALL EUNARY(current%kod,STACK(LSTP))\n STACK(LSTP)=current%value*STACK(LSTP)\n! write(*,71)'evalf U: ',current%debug,current%kod,&\n! lstp,0,0,stack(lstp)\n ENDIF\n ELSE\n!..Binary operator with both left and right links evaluated\n LSTP=LSTP-1\n! write(*,73)'evalf B: ',current%debug,current%kod,lstp,&\n! stack(lstp),stack(lstp+1)\n!73 format(a,3i3,2(1pe14.5))\n CALL EBINRY(current%kod,STACK(LSTP),STACK(LSTP+1))\n ENDIF\n LAST=LAST-1\n topsave=>topsave%previous\n IF(LAST.LT.0) goto 900\n IF(LAST.EQ.0) goto 800\n goto 200\n ENDIF\n! write(*,*)'evalf 799: ',current%debug,current%kod,lstp,current%value\n GOTO 100\n!..KLAR\n800 EVALF=STACK(1)\n900 RETURN\n END FUNCTION EVALF\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable double precision function evalf_x & Evaluate a function\n!\\begin{verbatim}\n double precision FUNCTION EVALF_X(LROT,VAR)\n! Calculates the value of an expression\n! ?? I do not know what is the difference with evalf ??/BoS 190804\n!\n! VAR is array with values of symbols that can be referenced\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n type(putfun_node), pointer :: lrot\n double precision VAR(*)\n!\\end{verbatim} %+\n double precision STACK(20)\n! character ch1*1\n! type(putfun_node), pointer :: llink,current,mlink\n type(putfun_node), pointer :: current,mlink\n TYPE PUTFUN_SAVE\n integer right\n type(putfun_node), pointer :: savecurrent\n type(putfun_save), pointer :: previous\n end TYPE PUTFUN_SAVE\n! memory leak allocating pointers\n! type(putfun_save), target :: saverec\n type(putfun_save), pointer :: topsave,temp\n! double precision, parameter :: ZERO=0.0D0\n integer last,lstp,kod\n!\n!...If LROT<=0 there is no expression, return sero\n IF(.not.associated(LROT)) THEN\n STACK(1)=ZERO\n GOTO 800\n ENDIF\n!..INITIATE\n LAST=0\n LSTP=0\n current=>LROT\n nullify(topsave)\n! read(*,72)ch1\n!72 format(a)\n!71 format(a,5i5,1pe16.6)\n!..New node, take is left link if any\n100 continue\n! if(associated(current%right)) then\n! write(*,71)'>>>> evalf 100A1: ',current%debug,current%kod,&\n! current%left%debug,current%right%debug,current%links,current%value\n! elseif(associated(current%left)) then\n! write(*,71)'>>>> evalf 100A2: ',current%debug,current%kod,&\n! current%left%debug,0,current%links,current%value\n! else\n! write(*,71)'>>>> evalf 100A3: ',current%debug,current%kod,&\n! 0,0,current%links,current%value\n! endif\n! ERROR if I first set llink=>current%left and then tested llink if associated\n if(associated(current%left)) then\n! write(*,*)'Taking the left link and pushing current'\n LAST=LAST+1\n if(associated(topsave)) then\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n else\n allocate(topsave)\n nullify(topsave%previous)\n endif\n topsave%savecurrent=>current\n! write(*,71)'evalf 100D: ',topsave%savecurrent%debug,current%left%debug\n! mark that right link not visited\n topsave%right=1\n current=>current%left\n ELSE\n!..If no left link the right link must be a data or unary negation\n KOD=current%kod\n LSTP=LSTP+1\n IF(KOD.GT.0) then\n! unary operator, store the operation as a real\n STACK(LSTP)=VAR(KOD)\n else\n stack(lstp)=current%value\n endif\n! write(*,71)'evalf 100X: ',current%debug,kod,lstp,0,0,stack(lstp)\n!..When coming here with LAST=0 the expression has been evaluated.\n! If not check if right link of current node has been visited\n200 IF(LAST.LE.0) GOTO 800\n current=>topsave%savecurrent\n! write(*,71)'evalf 100YA: ',current%debug,topsave%right,current%kod\n IF(topsave%right.gt.0) THEN\n!..Follow the right link\n if(associated(current%right)) then\n MLINK=>current%right\n! write(*,71)'evalf 100YB: ',mlink%debug,mlink%kod\n!..Follow the left link of the right link but first mark that the right\n! link of current has been visited\n topsave%right=-1\n current=>MLINK\n! write(*,71)'evalf 100Z: ',current%debug,current%kod,topsave%right\n GOTO 100\n ELSE\n!..unary operator, in some cases it can have a sign\n CALL EUNARY(current%kod,STACK(LSTP))\n STACK(LSTP)=current%value*STACK(LSTP)\n! write(*,71)'evalf U: ',current%debug,current%kod,&\n! lstp,0,0,stack(lstp)\n ENDIF\n ELSE\n!..Binary operator with both left and right links evaluated\n LSTP=LSTP-1\n! write(*,73)'evalf B: ',current%debug,current%kod,lstp,&\n! stack(lstp),stack(lstp+1)\n!73 format(a,3i3,2(1pe14.5))\n CALL EBINRY(current%kod,STACK(LSTP),STACK(LSTP+1))\n ENDIF\n LAST=LAST-1\n topsave=>topsave%previous\n IF(LAST.LT.0) goto 900\n IF(LAST.EQ.0) goto 800\n goto 200\n ENDIF\n! write(*,*)'evalf 799: ',current%debug,current%kod,lstp,current%value\n GOTO 100\n!..KLAR\n800 EVALF_X=STACK(1)\n900 RETURN\n END FUNCTION EVALF_X\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine eunary & Evaluate a unary function\n!\\begin{verbatim}\n SUBROUTINE EUNARY(KOD,X)\n! calculates a unary function such as LOG, EXP etc\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer kod\n double precision X\n!\\end{verbatim} %+\n double precision, parameter :: ONE=1.0D0\n! y=x\n IF(KOD.EQ.-1) X=-X\n IF(KOD.EQ.-2) X=SQRT(X)\n IF(KOD.EQ.-3) X=EXP(X)\n IF(KOD.EQ.-4) X=LOG(X)\n IF(KOD.EQ.-5) X=LOG10(X)\n IF(KOD.EQ.-6) X=SIN(X)\n IF(KOD.EQ.-7) X=COS(X)\n IF(KOD.EQ.-8) X=ATAN(X)\n IF(KOD.EQ.-9) X=SIGN(ONE,X)\n IF(KOD.EQ.-10) X=ERF(X)\n IF(KOD.EQ.-11) X=AIVAN(X)\n IF(KOD.EQ.-12) X=PF_BSUM(X)\n IF(KOD.EQ.-13) X=ABS(X)\n IF(KOD.EQ.-14) X=PF_HS(X)\n! this is LN same as LOG, 10th log is LOG10\n IF(KOD.EQ.-15) X=LOG(X)\n! write(*,*)'eunary: ',y,x\n RETURN\n END SUBROUTINE EUNARY\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine ebinary & Evaluate a binary operator\n!\\begin{verbatim}\n SUBROUTINE EBINRY(KOD,X,Y)\n! Calculates the value of a binary node with two data nodes\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer kod\n double precision X,Y\n!\\end{verbatim} %+\n integer nn\n!\n IF(KOD.EQ.1) X=X+Y\n IF(KOD.EQ.2) X=X-Y\n IF(KOD.EQ.3) X=X*Y\n IF(KOD.EQ.4) THEN\n IF(Y.ne.zero) then\n X=X/Y\n else\n pfnerr=1063\n endif\n endif\n IF(KOD.EQ.5) THEN\n NN=INT(Y)\n IF(ABS(X).LE.0.1D-30) THEN\n X=0.0D0\n ELSEIF(ABS(DBLE(NN)-Y).LT.1.0D-30) THEN\n X=X**NN\n ELSEIF(X.GT.0.1D-30) THEN\n X=EXP(Y*LOG(X))\n ELSE\n X=0.0D0\n ENDIF\n ENDIF\n RETURN\n END SUBROUTINE EBINRY\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable double precision function aivan & Evaluate Ivantsov's function\n!\\begin{verbatim}\n double precision FUNCTION AIVAN(PECN)\n! CALCULATES THE DIMENSIONLESS SUPERCOOLING OF DIFFUSION BY\n! IVANTSOV'S SOLUTION\n!...added by Zikui and also an updated ERF\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n double precision PECN\n! APPROXIMATIVE FORMULA FOR ERROR FUNCTION GIVEN BY:\n! ABRAMOWITZ AND STEGUN: HANDBOOK OF MATHEMATICAL FUNCTIONS,\n! NATIONAL BUREAU OF STANDARDS, 9TH EDITION, 1970\n!\\end{verbatim} %+\n !CCI Comment the next line because of already defined in ocparam.F90\n !CCI double precision, parameter :: ONE=1.0D0,TWO=2.0D0,PI=3.141592654D0\n !CCI\n double precision A,C,Q\n integer i\n IF(PECN.LE.8.5D0) THEN\n AIVAN=DSQRT(PI*PECN)*DEXP(PECN)*(ONE-ERF(DSQRT(PECN)))\n ELSE\n A=ONE\n C=ONE\n Q=ONE\n DO I=1,9\n A=A*(TWO*DBLE(I)-ONE)/TWO/PECN\n C=-C\n Q=Q+A*C\n enddo\n AIVAN=Q\n ENDIF\n RETURN\n END FUNCTION AIVAN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable double precision function pf_bsum & Evaluate BSUM\n!\\begin{verbatim}\n double precision FUNCTION PF_BSUM(FA)\n!.. 1993-10-06 20:10:56 /BJ\n!\n! ( sin(n*pi*f) )^2 \n! Calc. the infinit sum B = sum(-------------------)\n! (n*pi)^3 \n!\n!.. If we truncate the sum at N=200 the relative error is\n! less than ?% for 0.01 < F < 0.99\n!\n!\n implicit none\n! IMPLICIT DOUBLE PRECISION(A-H,O-Z)\n double precision FA\n!\\end{verbatim} %+\n! value of PI not very accurate ....\n! double precision, parameter :: ZERO=0.0D+00,PI=3.14159D0\n !CCI Comment the next line because of already defined in ocparam.F90\n !CCI double precision, parameter :: PI=3.14159D0\n double precision, parameter :: PI3=PI*PI*PI\n!\n integer loopmx\n double precision val,a,b\n integer i\n!\n LOOPMX=1000\n VAL=ZERO\n DO I=1,LOOPMX\n A=DBLE(I)\n B=SIN(A*PI*FA)\n VAL=VAL+B*B/(A*A*A*PI3)\n enddo\n!\n PF_BSUM=VAL\n RETURN\n END FUNCTION PF_BSUM\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable double precision function pf_hs & Evaluate Heaviside \n!\\begin{verbatim}\n double precision FUNCTION PF_HS(X)\n! Calculates Heaviside function\n! IMPLICIT DOUBLE PRECISION(A-H,O-Z)\n implicit none\n double precision X\n!\\end{verbatim} %+\n! double precision, parameter :: ZERO=0.0D+00,ONE=1.0D+00\n! BUG!!!!\n! HS=ZERO\n PF_HS=ZERO\n IF (X.GE.ZERO) PF_HS=ONE\n RETURN\n END FUNCTION PF_HS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable double precision function pf_erf & Evaluate ERF\n!\\begin{verbatim}\n double precision FUNCTION PF_ERF(X0)\n! CALCULATES ERROR-FUNCTION OF X, USING AN\n! APPROXIMATIVE FORMULA GIVEN BY:\n! ABRAMOWITZ AND STEGUN: HANDBOOK OF MATHEMATICAL FUNCTIONS,\n! NATIONAL BUREAU OF STANDARDS, 9TH EDITION, 1970\n implicit none\n double precision X0\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n !\\end{verbatim}\n !CCI Comment the next line because of already defined in ocparam.F90\n !CCI double precision, parameter :: ONE=1.0D0,TWO=2.0D0\n double precision P,A1,A2,A3,A4,A5,PI,S,X,T,Q\n DATA P,A1,A2,A3,A4,A5,PI/.3275911D0,.254829592D0,-.284496736D0, &\n 1.421413741D0,-1.453152027D0,1.061405429D0,3.141592654D0/\n S=DSIGN(ONE,X0)\n X=DABS(X0)\n T=ONE/(ONE+P*X)\n Q=T*(A1+T*(A2+T*(A3+T*(A4+T*A5))))\n Q=(ONE-Q*DEXP(-X*X))*S\n PF_ERF=Q\n RETURN\n END FUNCTION PF_ERF\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine wrtfun & Write the function\n!\\begin{verbatim}\n SUBROUTINE WRTFUN(STRING,IPOS,LROT,SYMBOL)\n! Writes a PUTFUN expression\n!\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER STRING*(*),SYMBOL(*)*(*)\n integer ipos\n type(putfun_node), pointer :: lrot,current,lnode,rnode,tnode\n!\\end{verbatim} %+\n TYPE PUTFUN_SAVE\n integer right\n type(putfun_node), pointer :: savecurrent\n type(putfun_save), pointer :: previous\n end TYPE PUTFUN_SAVE\n type(putfun_save), pointer :: topsave,temp,bug\n integer last,noneg,negmark\n double precision val\n! type(putfun_node), dimension(20) :: link\n! integer doneboth(20)\n! string=' '\n! ipos=1\n! write(*,*)'wrtfun: ',trim(symbol(1))\n!...Quick return if no expression\n IF(.not.associated(LROT)) THEN\n CALL CONS(STRING,IPOS,'0')\n GOTO 900\n ENDIF\n!..INITIATE\n LAST=0\n current=>LROT\n! write(*,*)'wrtfun 1: ',current%kod\n nullify(topsave)\n IF(current%kod.LT.0) then\n!..start with a unary operator\n noneg=1\n if(current%value.lt.zero) noneg=-1\n CALL WRTLPQ(STRING,IPOS,0,0,current%kod,noneg)\n! write(*,76)'wrtfun 99: ',current%kod,current%debug,current%value\n! write(*,77)'wrtfun 100A: ',ipos,string(1:ipos)\n endif\n!..new node, visit its left link\n100 continue\n lnode=>current%left\n! write(*,76)'wrtfun 99: ',current%debug,current%kod,current%value\n if(associated(topsave)) then\n endif\n bigif: IF(associated(LNODE)) THEN\n!..PUSH LINK\n IF(associated(LNODE%left)) &\n CALL WRTLPQ(STRING,IPOS,1,current%kod,lnode%kod,1)\n if(associated(topsave)) then\n allocate(temp)\n temp%previous=>topsave\n topsave=>temp\n else\n allocate(topsave)\n nullify(topsave%previous)\n endif\n topsave%savecurrent=>current\n! write all saved links\n bug=>topsave\n55 continue\n if(associated(bug%previous)) then\n bug=>bug%previous\n goto 55\n endif\n!\n! mark that right link not visited\n LAST=LAST+1\n topsave%right=1\n current=>LNODE\n! write(*,77)'wrtfun 100A: ',ipos,string(1:ipos)\n!77 format(a,i3,' \"',a,'\"')\n ELSE !bigif\n!..If no left link node must be data\n val=current%value\n negmark=0\n if(last.gt.0) then\n! surround a negative value by ( ) if this data in a right link\n if(topsave%right.lt.0) negmark=-1\n endif\n CALL WRTDAQ(STRING,IPOS,current%kod,VAL,SYMBOL,negmark)\n! write(*,77)'wrtfun 100B: ',ipos,string(1:ipos)\n IF(LAST.EQ.0) GOTO 800\n!..check if right link has been visited\n200 continue\n current=>topsave%savecurrent\n smallif: IF(topsave%right.gt.0) THEN\n!..follow right link\n RNODE=>current%right\n hlink: IF(associated(RNODE)) THEN\n!..there is a right link, follow its left link\n! mark first the the right link of current has been visited\n topsave%right=-1\n! check if ) is needed\n! then write the operator and possibly a (\n TNODE=>current%left\n IF(associated(tnode%left)) &\n CALL WRTRPQ(STRING,IPOS,1,current%kod,tnode%kod)\n CALL WRTBIQ(STRING,IPOS,current%kod)\n! write(*,77)'wrtfun 200A: ',ipos,string(1:ipos)\n TNODE=>current%right\n IF(associated(tnode%left)) then\n noneg=1\n if(current%kod.lt.0 .and. &\n current%value.lt.zero) noneg=-1\n CALL WRTLPQ(STRING,IPOS,2,current%kod,tnode%kod,noneg)\n! write(*,77)'wrtfun 200B: ',ipos,string(1:ipos)\n endif\n current=>RNODE\n GOTO 100\n ELSE\n!..unary operator, write ) if necessary\n IF(current%kod.LT.-1) CALL CONS(STRING,IPOS,')')\n! write(*,77)'wrtfun 200C: ',ipos,string(1:ipos)\n ENDIF hlink\n else !smallif\n!..binary operator and both links visited, check if ) needed\n! IT WAS A DIFFICULT BUG TO FIND WHEN tnode=topsave%savecurrent .....\n tnode=>topsave%savecurrent\n if(associated(tnode%right%left)) &\n call WRTRPQ(STRING,IPOS,2,tnode%kod,tnode%right%kod)\n! write(*,77)'wrtfun 200D: ',ipos,string(1:ipos)\n ENDIF smallif\n LAST=LAST-1\n topsave=>topsave%previous\n! IF(LAST) 900,800,200\n! write(*,*)'wrtfun 798: ',last\n IF(LAST.lt.0) goto 900\n IF(LAST.eq.0) goto 800\n goto 200\n ENDIF bigif\n! write(*,*)'wrtfun 799: ',current%kod,last\n GOTO 100\n!..KLAR\n800 continue\n string(ipos:ipos)=';'\n ipos=ipos+1\n900 RETURN\n END SUBROUTINE WRTFUN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine wrtlpq & Write a keft (\n!\\begin{verbatim}\n SUBROUTINE WRTLPQ(STRING,IPOS,LINK,KOD,LOD,negmark)\n! write a left ( or unary operator followed by (\n! the unary operator is in LOD\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER STRING*(*)\n integer ipos,link,kod,lod,negmark\n!\\end{verbatim} %+\n! IF(LOD) 10,90,20\n IF(LOD.eq.0) goto 90\n if(LOD.gt.0) goto 20\n!..unary operator\n IF(LOD.EQ.-1) THEN\n IF(KOD.LE.0) THEN\n CALL CONS(STRING,IPOS,'-')\n ELSE\n IF(LINK.EQ.1) CALL CONS(STRING,IPOS,'-(')\n IF(LINK.EQ.2) CALL CONS(STRING,IPOS,'(-')\n ENDIF\n ELSE\n! this is a sign for a unary function\n if(negmark.eq.-1) then\n CALL CONS(STRING,IPOS,'-')\n endif\n IF(LOD.EQ. -2) CALL CONS(STRING,IPOS,'SQRT(')\n IF(LOD.EQ. -3) CALL CONS(STRING,IPOS,'EXP(')\n IF(LOD.EQ. -4) CALL CONS(STRING,IPOS,'LOG(')\n IF(LOD.EQ. -5) CALL CONS(STRING,IPOS,'LOG10(')\n IF(LOD.EQ. -6) CALL CONS(STRING,IPOS,'SIN(')\n IF(LOD.EQ. -7) CALL CONS(STRING,IPOS,'COS(')\n IF(LOD.EQ. -8) CALL CONS(STRING,IPOS,'ATAN(')\n IF(LOD.EQ. -9) CALL CONS(STRING,IPOS,'SIGN(')\n IF(LOD.EQ.-10) CALL CONS(STRING,IPOS,'ERF(')\n IF(LOD.EQ.-11) CALL CONS(STRING,IPOS,'IVAN(')\n IF(LOD.EQ.-12) CALL CONS(STRING,IPOS,'BSUM(')\n IF(LOD.EQ.-13) CALL CONS(STRING,IPOS,'ABS(')\n IF(LOD.EQ.-14) CALL CONS(STRING,IPOS,'HS(')\n IF(LOD.EQ.-15) CALL CONS(STRING,IPOS,'LN(')\n ENDIF\n GOTO 90\n!..one must check LOD if left (\n20 continue\n IF(KOD.GE.3 .AND. LOD.LT.3) CALL CONS(STRING,IPOS,'(')\n IF(KOD.EQ.5 .AND. LOD.GE.3) CALL CONS(STRING,IPOS,'(')\n!..if LINK=2, i.e. a right link, write ( of KOD is - or /\n IF(LINK.EQ.2) THEN\n IF(KOD.EQ.2 .AND. LOD.EQ.1) CALL CONS(STRING,IPOS,'(')\n IF(KOD.EQ.4 .AND. LOD.EQ.3) CALL CONS(STRING,IPOS,'(')\n ENDIF\n90 RETURN\n END SUBROUTINE WRTLPQ\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine wrtrpq & Write a right )\n!\\begin{verbatim}\n SUBROUTINE WRTRPQ(STRING,IPOS,LINK,KOD,LOD)\n! write a right ) but if LOD<-1 do not write (\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n CHARACTER STRING*(*)\n integer ipos,link,kod,lod\n!\\end{verbatim} %+\n! IF(LOD+1) 90,10,20\n IF(LOD+1.lt.0) goto 90\n if(LOD+1.gt.0) goto 20\n!..negation need ) if KOD>0\n IF(KOD.GT.0) CALL CONS(STRING,IPOS,')')\n GOTO 90\n20 IF(KOD.GE.3 .AND. LOD.LT.3) CALL CONS(STRING,IPOS,')')\n IF(KOD.EQ.5 .AND. LOD.GE.3) CALL CONS(STRING,IPOS,')')\n IF(LINK.EQ.2) THEN\n IF(KOD.EQ.2 .AND. LOD.EQ.1) CALL CONS(STRING,IPOS,')')\n IF(KOD.EQ.4 .AND. LOD.EQ.3) CALL CONS(STRING,IPOS,')')\n ENDIF\n90 RETURN\n END SUBROUTINE WRTRPQ\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine wrtbiq & Write a binary operator \n!\\begin{verbatim}\n SUBROUTINE WRTBIQ(STRING,IPOS,KOD)\n! write a binary operator\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n CHARACTER STRING*(*)\n integer ipos,kod\n!\\end{verbatim} %+\n! write a binary operator\n! write(*,*)'wrtbiq 1: ',ipos,kod\n IF(KOD.EQ.1) CALL CONS(STRING,IPOS,'+')\n IF(KOD.EQ.2) CALL CONS(STRING,IPOS,'-')\n IF(KOD.EQ.3) CALL CONS(STRING,IPOS,'*')\n IF(KOD.EQ.4) CALL CONS(STRING,IPOS,'/')\n IF(KOD.EQ.5) CALL CONS(STRING,IPOS,'**')\n RETURN\n END SUBROUTINE WRTBIQ\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine wrtdaq & Write a number\n!\\begin{verbatim}\n SUBROUTINE WRTDAQ(STRING,IPOS,KOD,VAL,SYMBOL,negmark)\n! write a number, if KOD<0 a whole number\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n! CHARACTER NAME*8,SYMBOL(*)*(*)\n CHARACTER SYMBOL(*)*(*)\n CHARACTER STRING*(*)\n integer ipos,kod,negmark\n double precision val\n!\\end{verbatim} %+\n! double precision, PARAMETER :: ZERO=0.0D0\n IF(KOD.EQ.0) THEN\n IF(VAL.GT.ZERO .or. negmark.eq.0) then\n CALL WRINUM(STRING,IPOS,12,0,VAL)\n elseif(VAL.LT.ZERO) then\n CALL CONS(STRING,IPOS,'(')\n CALL WRINUM(STRING,IPOS,12,0,VAL)\n CALL CONS(STRING,IPOS,')')\n endif\n ELSE\n!..a name of a variable, the name is in SYMBOL(KOD), skip trailing spaces\n! if negated surround by ( )\n! CALL CONS(STRING,IPOS,SYMBOL(KOD))\n! write(*,*)'wrtdaq symbol: ',kod,trim(symbol(kod))\n if(val.lt.zero) then\n CALL CONS(STRING,IPOS,'(')\n CALL CONS(STRING,IPOS,SYMBOL(KOD))\n CALL CONS(STRING,IPOS,')')\n else\n CALL CONS(STRING,IPOS,SYMBOL(KOD))\n endif\n ENDIF\n RETURN\n END SUBROUTINE WRTDAQ\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine cons & Concatinate\n!\\begin{verbatim}\n SUBROUTINE CONS(STR1,IPOS,STR2)\n! used in PUTFUN but should be replaced by //\n implicit none\n CHARACTER STR1*(*),STR2*(*)\n integer ipos\n!\\end{verbatim}\n! CONS. TWO STRINGS, RESULT IN PARAMETER STR1\n! IPOS = POSITION IN STR1 WHERE STR2 SHOULD BE PUT\n! IPOS IS UPPDATED TO THE FIRST FREE POSITION AT THE END\n! OF STR1. TRAILING SPACES ARE STRIPPED OFF.\n! IF STR2 CONTAINES ONLY SPACES ONE SPACE IS WRITTEN\n! IN TO STR1.\n CHARACTER SPC*(1)\n PARAMETER (SPC=' ')\n integer ilen,k,i\n ILEN=LEN(STR2)\n!...FIND THE LENGHT OF STR2\n K=ILEN\n DO I=K,1,-1\n IF(STR2(ILEN:ILEN).EQ.SPC) ILEN=ILEN-1\n enddo\n IF(ILEN.EQ.0)ILEN=1\n STR1(IPOS:IPOS+ILEN-1)=STR2(1:ILEN)\n IPOS=IPOS+ILEN\n RETURN\n END SUBROUTINE CONS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine exphlp & Provide help\n!\\begin{verbatim}\n! SUBROUTINE EXPHLP(PROMPT,SVAR)\n SUBROUTINE EXPHLP\n! writes help to enter a PUTFUN expression\n implicit none\n! CHARACTER PROMPT*(*),SVAR*(*)\n!\\end{verbatim} %+\n WRITE(KOU,10)\n10 FORMAT(' You are expected to give a formula that shall be', &\n ' evaluated or manipulated.'/ &\n ' The formula shall be written as a FORTRAN statement with the', &\n ' following rules:'/ &\n ' A variable must begin with a letter', &\n ' and a number with a number (not a dot).'/' A real number must', &\n ' have a dot or an exponent (E).'/ &\n ' The operators + , - , , / , ** (exponentiation) can be used'/ &\n ' and any level of parenthesis.'/ &\n ' SQRT(X) is the square root'/ &\n ' EXP(X) is the exponential'/ &\n ' LOG(X) or LN(X) is the natural logarithm'/ &\n ' LOG10(X) is the base 10 logarithm'/ &\n ' SIN(X), COS(X), ATAN(X)'/ &\n ' SIGN(X)'/ &\n ' ERF(X) is the error function'/ &\n ' IVAN(X) Ivantsof function'/ &\n ' BSUM(X) is sum(sin(n*pi*f)**2/(n*pi)**3)'/ &\n ' ABS(X) is absolute value'/ &\n ' HS(X) is the Heaviside function'/ &\n ' Notice that these operators must be followed by a (.'// &\n ' The statement must be terminated by a ;'/)\n RETURN\n END SUBROUTINE EXPHLP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine putprp & Asking for a function\n!\\begin{verbatim}\n SUBROUTINE PUTPRP(NAMN,MAXS,SYMBOL,PROMPT,ILEN)\n!...CREATES A PROMPT asking for a putfun expression with formal arguments\n implicit none\n CHARACTER NAMN*(*),PROMPT*(*),SYMBOL(*)*(*)\n integer ilen,maxs\n!...write a prompt with name of all variables\n!\\end{verbatim} %+\n integer i,j\n ILEN=1\n PROMPT=' '\n CALL CONS(PROMPT,ILEN,NAMN)\n IF(MAXS.LE.0) THEN\n CALL CONS(PROMPT,ILEN,'=')\n GOTO 900\n ENDIF\n CALL CONS(PROMPT,ILEN,'(')\n I=1\n11 IF(I.GT.MAXS) GOTO 12\n J=LEN_trim(SYMBOL(I))\n IF(LEN(SYMBOL(I)).GT.J) THEN\n J=J+1\n SYMBOL(I)(J:J)=' '\n ENDIF\n CALL CONS(PROMPT,ILEN,SYMBOL(I)(1:J))\n IF(I.NE.MAXS) CALL CONS(PROMPT,ILEN,',')\n I=I+1\n GOTO 11\n12 CONTINUE\n CALL CONS(PROMPT,ILEN,')= ')\n ILEN=ILEN-1\n900 RETURN\n END SUBROUTINE PUTPRP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!\n\n!\\addtotable subroutine delfun & Delete a function\n!\\begin{verbatim}\n SUBROUTINE DELFUN(LROT,IWS)\n! delete a putfun expression :: not converted to structures\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer IWS(*)\n integer lrot\n!\\end{verbatim}\n integer link(20)\n integer nod,last,lnode\n! DIMENSION LINK(20)\n! LOGICAL SG2ERR\n NOD=LROT\n IF(NOD.LE.2 .OR. NOD.GT.IWS(2)) GOTO 800\n IF(NOD.LE.0) GOTO 900\n LAST=0\n!..visit left link\n100 LNODE=IWS(NOD+1)\n IF(LNODE.LE.0) GOTO 110\n LAST=LAST+1\n LINK(LAST)=NOD\n NOD=LNODE\n GOTO 100\n!..data record at bottom\n110 IF(IWS(NOD).EQ.0 .OR. IWS(NOD+3).EQ.1) THEN\n! CALL WRELS(NOD,3+NWPR,IWS)\n! IF(SG2ERR(KERR)) GOTO 900\n! call release_pnode(nod)\n if(pfnerr.ne.0) goto 900\n ELSE\n IWS(NOD+3)=IWS(NOD+3)-1\n ENDIF\n!..visit right link\n200 IF(LAST.LE.0) GOTO 800\n NOD=LINK(LAST)\n IF(NOD.LT.0) THEN\n!..right link visited, remove binary operator, CHECK CODE HERE ...\n! CALL WRELS(-NOD,3,IWS)\n! IF(SG2ERR(KERR)) GOTO 900\n ELSE\n!..mark right link is now visited\n LINK(LAST)=-NOD\n IF(IWS(NOD+2).LE.0) THEN\n!..remove unary operator\n! CALL WRELS(NOD,3,IWS)\n! IF(SG2ERR(KERR)) GOTO 900\n ELSE\n!..set node to this and visit its left link\n NOD=IWS(NOD+2)\n GOTO 100\n ENDIF\n ENDIF\n LAST=LAST-1\n IF(LAST.GT.0) GOTO 200\n800 LROT=0\n900 RETURN\n END SUBROUTINE DELFUN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! HPCALC is a screen HP calculator\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine hpcalc & HP calculator\n!\\begin{verbatim}\n SUBROUTINE HPCALC\n!...EMULATES A HP CALCULATOR ON SCREEN\n implicit none\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n!\\end{verbatim} %+\n integer, parameter :: NOP=40,MAXPRG=100\n double precision stk(4),reg(0:9)\n! DIMENSION STK(4),REG(0:9)\n CHARACTER LINE*80,INPUT*80,OPER(NOP)*10,CH1*1,CH2*2\n CHARACTER PROG(MAXPRG+1)*20\n LOGICAL PROGT,OK,RUN,TRACE\n SAVE STK,REG,PROG\n integer naxop,lprog,kprog,ip,iback,k,next,i,jprog,last\n double precision ss,val\n DATA STK/0.0,0.0,0.0,0.0/\n DATA REG/0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/\n DATA &\n OPER( 1)/'BACK '/,OPER( 2)/'HELP '/, &\n OPER( 3)/'SHOW_STACK'/,OPER( 4)/'EXP '/, &\n OPER( 5)/'LN '/,OPER( 6)/'LOG '/, &\n OPER( 7)/'SIN '/,OPER( 8)/'COS '/, &\n OPER( 9)/'TAN '/,OPER(10)/'[ASIN '/, &\n OPER(11)/'[ACOS '/,OPER(12)/'[ATAN '/, &\n OPER(13)/'SQRT '/,OPER(14)/'ROT_STACK '/, &\n OPER(15)/'SWITCH_XY '/,OPER(16)/'POWER_2 '/, &\n OPER(17)/'CLX '/,OPER(18)/'CLSTACK '/, &\n OPER(19)/'STO_REG '/,OPER(20)/'RCL_REG '/ \n DATA &\n OPER(21)/'CLEAR_REG '/,OPER(22)/'CHSIGN '/, &\n OPER(23)/'DISPLAYREG'/,OPER(24)/' '/, &\n OPER(25)/'_STOP '/,OPER(26)/'_GOTO '/, &\n OPER(27)/'_IF '/,OPER(28)/'_PROGRAM '/, &\n OPER(29)/'ENTER_PUSH'/,OPER(30)/'_LIST '/, &\n OPER(31)/'_ERASE_PRO'/,OPER(32)/'_STEP '/, &\n OPER(33)/'_EDIT '/,OPER(34)/'_BACK '/, &\n OPER(35)/'_NOOP '/,OPER(36)/'_TRACE '/, &\n OPER(37)/'_END '/,OPER(38)/'_RUN '/, &\n OPER(39)/'QUIT '/,OPER(40)/'FIN '/\n!\n WRITE(*,*)'REVERSE POLISH CALCULATOR'\n! uninitiated in original?\n jprog=0\n NAXOP=24\n PROGT=.FALSE.\n RUN=.FALSE.\n OK=.FALSE.\n LPROG=0\n PROG(MAXPRG+1)='_END'\n LAST=LEN(LINE)\n100 CONTINUE\n IF(PROGT .AND. OK) THEN\n!...SAVE PROGRAM STEP\n LPROG=LPROG+1\n IF(LPROG.GT.MAXPRG) THEN\n WRITE(*,*)'TOO MANY PROGRAM STEPS, MAXIMUM IS ',MAXPRG\n ELSE\n PROG(LPROG)=INPUT(1:20)\n WRITE(*,98)LPROG,INPUT(1:LEN_TRIM(INPUT))\n98 FORMAT(' STEP',I4,': ',A)\n ENDIF\n ENDIF\n IF(RUN) THEN\n KPROG=KPROG+1\n IF(KPROG.GT.MAXPRG) THEN\n WRITE(*,*)'ILLEGAL STEP'\n RUN=.FALSE.\n GOTO 100\n ENDIF\n INPUT=PROG(KPROG)\n IF(TRACE)WRITE(*,*)KPROG,STK(1),INPUT\n ELSEIF(PROGT) THEN\n! CALL GPARC('HPP>',LINE,LAST,1,INPUT,' ',HPHLP)\n CALL GPARC_old('HPP>',LINE,LAST,1,INPUT,' ',HPHLP)\n CALL CAPSON(INPUT)\n IF(INPUT(1:1).EQ.' ') GOTO 100\n OK=.FALSE.\n ELSE\n WRITE(*,101)STK(1)\n101 FORMAT(1PE15.7)\n CALL GPARC_old('HPC>',LINE,LAST,1,INPUT,' ',HPHLP)\n CALL CAPSON(INPUT)\n IF(INPUT(1:1).EQ.' ') GOTO 100\n OK=.FALSE.\n ENDIF\n!...MATH OP\n CH1=INPUT(1:1)\n IF(CH1.EQ.'+') THEN\n STK(1)=STK(1)+STK(2)\n GOTO 102\n ELSEIF(CH1.EQ.'-') THEN\n STK(1)=STK(2)-STK(1)\n GOTO 102\n ELSEIF(CH1.EQ.'*') THEN\n STK(1)=STK(1)*STK(2)\n GOTO 102\n ELSEIF(CH1.EQ.'/') THEN\n STK(1)=STK(2)/STK(1)\n GOTO 102\n ELSEIF(CH1.EQ.'^') THEN\n STK(1)=STK(2)**STK(1)\n GOTO 102\n ENDIF\n GOTO 109\n!...SHIFT STACK DOWN\n102 STK(2)=STK(3)\n STK(3)=STK(4)\n OK=.TRUE.\n GOTO 100\n!...NUMBER OR OPCODE\n109 IP=0\n buperr=0\n! write(*,*)'number 1: ',input(1:10),ip\n CALL GETREL(INPUT,IP,VAL)\n! write(*,*)'number 2: ',input(1:10),ip,buperr,val\n IF(buperr.eq.0) THEN\n!...\t NUMBER, SAVE ON STACK\n STK(4)=STK(3)\n STK(3)=STK(2)\n STK(2)=STK(1)\n STK(1)=VAL\n OK=.TRUE.\n! write(*,*)'pushed: ',ip\n IF(INPUT(IP:IP).NE.' ') THEN\n!...to allow input like 3000 3 4 5*/+\n IBACK=LEN_TRIM(INPUT)-IP+1\n LAST=LAST-IBACK-1\n ENDIF\n! write(*,*)'pushed: ',ip\n GOTO 100\n ENDIF\n! CALL RESERR\n K=NCOMP2(INPUT,OPER,NOP,NEXT)\n IF(K.EQ.0) THEN\n WRITE(*,*)'NO SUCH OPCODE'\n RUN=.FALSE.\n GOTO 100\n ELSEIF(K.LT.0) THEN\n WRITE(*,*)'AMBIGUOUS OPCODE'\n RUN=.FALSE.\n GOTO 100\n ELSE\n OK=.TRUE.\n GOTO(110,120,130,140,150,160,170,180,190,200, &\n 210,220,230,240,250,260,270,280,290,300, &\n 310,320,380,340,350,360,370,330,390,400, &\n 410,420,430,440,450,460,470,480,490,500),K\n ENDIF\n!...EXIT\n110 RETURN\n!...HELP\n120 INPUT(NEXT:NEXT+1)=',,'\n! CALL NGHELP(INPUT,NEXT,OPER,NAXOP) routine removed\n OK=.FALSE.\n GOTO 100\n!...SHOW STACK\n130 WRITE(*,131)STK\n131 FORMAT(4(1PE15.7))\n GOTO 100\n!...EXP\n140 STK(1)=EXP(STK(1))\n GOTO 100\n!...LN\n150 STK(1)=LOG(STK(1))\n GOTO 100\n!...LOG10\n160 STK(1)=LOG10(STK(1))\n GOTO 100\n!...SIN\n170 STK(1)=SIN(STK(1))\n GOTO 100\n!...COS\n180 STK(1)=COS(STK(1))\n GOTO 100\n!...TAN\n190 STK(1)=SIN(STK(1))/COS(STK(1))\n GOTO 100\n!...ASIN\n200 CONTINUE\n!...ACOS\n210 CONTINUE\n!...ATAN\n220 CONTINUE\n WRITE(*,*)'NOT IMPLEMENTED'\n GOTO 100\n!...SQRT\n230 STK(1)=SQRT(STK(1))\n GOTO 100\n!...ROT\n240 CONTINUE\n SS=STK(4)\n STK(4)=STK(3)\n STK(3)=STK(2)\n STK(2)=STK(1)\n STK(1)=SS\n GOTO 100\n!...SWITCH_XY\n250 CONTINUE\n SS=STK(2)\n STK(2)=STK(1)\n STK(1)=SS\n GOTO 100\n!...POWER_2\n260 CONTINUE\n STK(1)=STK(1)**2\n GOTO 100\n!...CLX\n270 STK(1)=0.0\n GOTO 100\n!...CLEAR\n280 STK(1)=0.0\n STK(2)=0.0\n STK(3)=0.0\n STK(4)=0.0\n GOTO 100\n!...STO_REG \n290 IF(RUN) THEN\n CALL GETINT(INPUT,NEXT,I)\n ELSE\n CALL GPARI_old('REG#',LINE,LAST,I,-1,NOHELP)\n ENDIF\n IF(I.LT.0 .OR. I.GT.9) THEN\n WRITE(*,*)'REGISTER NUMBER MUST BE 0..9'\n ELSE\n REG(I)=STK(1)\n IF(PROGT) INPUT(NEXT+1:NEXT+1)=CHAR(I+ICHAR('0'))\n ENDIF\n GOTO 100\n!...RCL_REG \n300 IF(RUN) THEN\n CALL GETINT(INPUT,NEXT,I)\n ELSE\n CALL GPARI_old('REG#',LINE,LAST,I,-1,NOHELP)\n ENDIF\n IF(I.LT.0 .OR. I.GT.9) THEN\n WRITE(*,*)'REGISTER NUMBER MUST BE 0..9'\n ELSE\n STK(1)=REG(I)\n IF(PROGT) INPUT(NEXT+1:NEXT+1)=CHAR(I+ICHAR('0'))\n ENDIF\n GOTO 100\n!...CLR_REG\n310 DO I=0,9\n REG(I)=0.0\n ENDDO\n GOTO 100\n!...CHSIGN\n320 STK(1)=-STK(1)\n GOTO 100\n!...PROGRAM\n330 IF(PROGT)THEN\n WRITE(*,*)'ALREDAY SET'\n ELSE\n PROGT=.TRUE.\n LPROG=0\n RUN=.FALSE.\n ENDIF\n OK=.FALSE.\n GOTO 100\n!...\n340 CONTINUE\n GOTO 100\n!...STOP\n350 IF(RUN) THEN\n RUN=.FALSE.\n WRITE(*,*)'PROGRAM STOP AT ',KPROG\n ELSEIF(PROGT) THEN\n PROGT=.FALSE.\n LPROG=LPROG+1\n PROG(LPROG)='STOP'\n WRITE(*,*)'PROGRAM STOP AT ',LPROG\n ENDIF\n GOTO 100\n!...GOTO\n360 IF(RUN) THEN\n CALL GETINT(INPUT,NEXT,IP)\n IF(IP.EQ.0) THEN\n WRITE(*,*)'PROGRAM STOP AT 0'\n RUN=.FALSE.\n ELSEIF(IP.LE.0 .OR. IP.GT.100 .OR. IP.EQ.KPROG) THEN\n WRITE(*,*)'ILLEGAL GOTO ADDRESS IN STEP ',KPROG\n RUN=.FALSE.\n ELSE\n KPROG=IP-1\n ENDIF\n ELSE\n CALL GPARI_old('STEP ',LINE,LAST,IP,0,NOHELP)\n IF(IP.LT.0 .OR. IP.GT.MAXPRG) THEN\n WRITE(*,*)'ILLEGAL ADDRESS'\n OK=.FALSE.\n ELSE\n WRITE(INPUT(NEXT+1:NEXT+3),365)IP\n365 FORMAT(I3)\n ENDIF\n ENDIF\n GOTO 100\n!...IF >=<\n370 IF(RUN) THEN\n IF(INPUT(NEXT+1:NEXT+1).EQ.'>') THEN\n IF(STK(1).GT.STK(2)) KPROG=KPROG+1\n ELSEIF(INPUT(NEXT+1:NEXT+1).EQ.'=') THEN\n IF(ABS(STK(1)-STK(2)).LT.1.0D-16) KPROG=KPROG+1\n ELSEIF(INPUT(NEXT+1:NEXT+1).EQ.'<') THEN\n IF(STK(1).LT.STK(2)) KPROG=KPROG+1\n ELSE\n WRITE(*,*)'ILLEGAL CONDITION IN STEP',KPROG\n RUN=.FALSE.\n ENDIF\n OK=.TRUE.\n ELSE\n CALL GPARC_old('CONDITION ( > = OR < )',LINE,LAST,1, &\n CH2,'NONE',NOHELP)\n IF(CH2.EQ.'> ' .OR. CH2.EQ.'= ' .OR. CH2.EQ.'< ') THEN\n INPUT(NEXT+1:)=CH2\n ELSE\n WRITE(*,*)'ILLEGAL CONDITION'\n OK=.FALSE.\n ENDIF\n ENDIF\n GOTO 100\n!...DISPLAY_REG\n380 WRITE(*,381)REG\n381 FORMAT(5(1PE15.7)/5(1PE15.7)/)\n GOTO 100\n!...ENTER, PUSH STACK\n390 STK(4)=STK(3)\n STK(3)=STK(2)\n STK(2)=STK(1)\n GOTO 100\n!...LIST\n400 WRITE(*,401)(I,PROG(I)(1:LEN_TRIM(PROG(I))),I=1,LPROG)\n401 FORMAT(I4,': ',A)\n OK=.FALSE.\n GOTO 100\n!...ERASE\n410 LPROG=0\n OK=.FALSE.\n GOTO 100\n!...STEP\n420 WRITE(*,*)'NOT IMPLEMENTED'\n GOTO 100\n KPROG=KPROG+1\n IF(KPROG.GT.LPROG) THEN\n WRITE(*,*)'PROGRAM ENDS AT ',LPROG\n ELSE\n WRITE(*,401)KPROG,PROG(KPROG)\n ENDIF\n OK=.FALSE.\n GOTO 100\n!...EDIT\n430 IF(JPROG.EQ.0) JPROG=LPROG-2\n CALL GPARI_old('STEP ',LINE,LAST,I,JPROG+1,NOHELP)\n WRITE(*,*)'NO SUCH STEP'\n OK=.FALSE.\n GOTO 100\n!...BACK\n440 WRITE(*,*)'NOT IMPLEMENTED'\n RETURN\n! GOTO 100\n WRITE(*,401)KPROG,PROG(KPROG)\n IF(KPROG.GT.1) KPROG=KPROG-2\n OK=.FALSE.\n!...NOOP\n450 GOTO 100\n!...TRACE\n460 CONTINUE\n IF(TRACE) THEN\n TRACE=.FALSE.\n ELSE\n TRACE=.TRUE.\n ENDIF\n GOTO 100\n!...END\n470 PROGT=.FALSE.\n LPROG=LPROG+1\n PROG(LPROG)='STOP'\n OK=.FALSE.\n GOTO 100\n!...RUN\n480 IF(LPROG.EQ.0) THEN\n WRITE(*,*)'NO PROGRAM'\n ELSE\n RUN=.TRUE.\n PROGT=.FALSE.\n KPROG=0\n ENDIF\n OK=.FALSE.\n GOTO 100\n!...QUIT\n490 CONTINUE\n RETURN\n!...FIN\n500 CONTINUE\n RETURN\n! GOTO 100\n END SUBROUTINE HPCALC\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine hphelp & Help to HP calculator\n!\\begin{verbatim}\n SUBROUTINE HPHLP\n! writes a help text for using the online HP calculator\n implicit none\n!\\end{verbatim}\n WRITE(*,10)\n10 FORMAT(' This is a revese polish calculator'/&\n ' Input are numbers, + - * / and ^ and OPCODEs.',&\n ' Use HELP to list OPCODEs.'/' Several numbers and operations',&\n ' can be given on one line.'/' The content of the X register',&\n ' is displayed after each operation'//&\n ' Example input: 30000 8 1273 * / chs 1.5 3 ^ + exp 2 *'/&\n ' Computes 2*EXP(1.5**3-30000/(8*1273))'//)\n RETURN\n END SUBROUTINE HPHLP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n!\n! >>>> subsection\n! WPACK can convert from an integer workspace to normal double/character\n! used to save data on an unformatted Fortran file\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine winit & Initate integer workspace\n!\\begin{verbatim}\n SUBROUTINE WINIT(NWT,NWR,IWS)\n!...INITIATES A WORKSPACE\n! INPUT: NWT IS THE DIMENSION OF THE WORKSPACE\n! NWR IS THE NUMBER OF WORDS TO BE EXCLUDED IN THE BEGINNING\n! IWS IS THE WORKSPACE\n! EXIT: THE FREE LIST IS INITIATED IN IWS\n! ERRORS: NWR LESSER THAN ZERO\n! NWT LESSER THAN NWR+100\n implicit none\n integer nwt,nwr,iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim} %+\n integer nwres,ifri\n IF(NWR.LT.0) GOTO 910\n IF(NWT.LT.NWR+100) GOTO 920\n NWRES=NWR+3\n!...IWS(1) IS PUT TO THE FIRST FREE AREA IN THE WORKSPACE AND IWS(2)\n! TO THE SIZE OF THE WORKSPACE. THE APPLICATION PROGRAM MUST NOT\n! CHANGE THESE LOCATIONS!\n IWS(1)=NWRES\n IWS(2)=NWT\n!...PUT ALL WORDS FROM 3 TO NWRES TO ZERO\n! THIS INCLUDES THE FIRST WORD IN THE FREE AREA\n DO IFRI=3,NWRES\n IWS(IFRI)=0\n enddo\n!...THE SECOND WORD IN THE FREE AREA IS PUT THE THE NUMBER OF FREE WORDS THIS\n! NUMBER IS NWT-NWR-(TWO WORDS IN THE BEGINNING)-(TWO WORDS IN THE END)\n IWS(NWRES+1)=NWT-NWR-4\n900 RETURN\n910 buperr=1008\n goto 900\n920 buperr=1002\n GOTO 900\n END SUBROUTINE WINIT\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n \n!\\addtotable subroutine wold & Read an integer workspace from file\n!\\begin{verbatim}\n SUBROUTINE WOLD(FIL,NW,IWS)\n!...READS A FILE INTO A WORKSPACE. THE FILE MUST HAVE BEEN WRITTEN BY WSAVE\n! INPUT: FIL A CHARACTER WITH A LEGAL FILE NAME\n! NW THE DIMENSION OF IWS\n! IWS THE WORKSPACE\n! CALLS: WRKCHK TO CHECK THE FREE LIST\n! EXIT: THE CONTENT OF THE FILE IS IN IWS. THE DIMENSION OF IWS IS SET TO\n! NW AND THE LAST FREE AREA IS CORRECTED\n implicit none\n CHARACTER FIL*(*)\n integer nw,iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim} %+\n integer ierr,last,j,k\n OPEN(UNIT=LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD',&\n IOSTAT=IERR,ERR=910,FORM='UNFORMATTED')\n! note: first integer on file is size of unformatted file\n READ(LUN,END=100,ERR=100)J,(IWS(K),K=1,J)\n!...CHECK THE WORKSPACE\n CALL WRKCHK(LAST,NW,IWS)\n100 CLOSE(LUN)\n RETURN\n910 continue\n GOTO 100\n END SUBROUTINE WOLD\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wsave & Save integer worspace to file\n!\\begin{verbatim}\n! SUBROUTINE WSAVE(FIL,NW,IWS)\n SUBROUTINE WSAVE(FIL,IWS)\n!...WRITES A WORKSPACE ON A FILE\n! INPUT: FIL IS A CHARACTER WITH A LEGAL FILE NAME\n! NW IS THE DIMENSION OF THE WORKSPACE\n! IWS IS THE WORKSPACE\n! CALLS: WRKCHK TO CHECK THE WORKSPACE\n! ERROR: IF THE WORKSPACE IS INCORRECT IT CANNOT BE SAVED\n implicit none\n! integer nw,iws(*)\n integer iws(*)\n! DIMENSION IWS(*)\n CHARACTER FIL*(*)\n!\\end{verbatim}\n integer i,ierr,last\n I=IWS(2)\n CALL WRKCHK(LAST,I,IWS)\n! IF(SG2ERR(IERR)) GOTO 900\n if(buperr.ne.0) goto 900\n OPEN(UNIT=LUN,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='UNKNOWN',&\n IOSTAT=IERR,ERR=910,FORM='UNFORMATTED')\n! note: first integer on file is size of unformatted file\n WRITE(LUN,ERR=910)LAST,(IWS(I),I=1,LAST)\n800 CLOSE(LUN)\n900 RETURN\n910 continue\n GOTO 800\n END SUBROUTINE WSAVE\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wpatch & Patch an integer workspace\n!\\begin{verbatim}\n SUBROUTINE WPATCH(NW,IWS)\n!...ROUTINE TO PATCH A WORKSPACE\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer nw,iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim} %+\n integer idum,ip,iadr,ival,j\n CHARACTER LINE*80,CHX*(NBPW),CHHEX*(2*NBPW)\n double precision x,z\n IF(IWS(2).NE.NW) THEN\n WRITE(KOU,*)' WORKSPACE DIMENSION INCORRECT, SET TO ',NW\n IWS(2)=NW\n ENDIF\n CALL WRKCHK(IDUM,NW,IWS)\n! IF(SG1ERR(IERR)) THEN\n if(buperr.ne.0) then\n WRITE(KOU,*)' YOU MAY ATTEMPT TO CORRECT THE FREE LIST'\n! CALL RESERR\n buperr=0\n ENDIF\n10 WRITE(KOU,*)' ADDRESS: '\n CALL BINTXT(KIU,LINE)\n IP=1\n CALL GETINT(LINE,IP,IADR)\n if(buperr.ne.0) then\n buperr=0\n! IF(LINE(1:1).EQ.'?') CALL WPHLP(IP,LINE)\n IF(LINE(1:1).EQ.'?') CALL WPHLP\n IF(LINE(1:1).EQ.'@') GOTO 900\n WRITE(KOU,20)\n20 FORMAT(' TYPE ? FOR HELP'/)\n GOTO 10\n ENDIF\n WRITE(KOU,30)\n30 FORMAT(' ADDRESS INTEGER CHAR HEXADEC. REAL VALUE'/)\n100 IF(IADR.LT.1 .OR. IADR.GT.NW) THEN\n WRITE(KOU,*)'OUTSIDE WORKSPACE',1,NW\n GOTO 900\n ENDIF\n CALL LOADR(1,IWS(IADR),X)\n CALL LOADC(NBPW,IWS(IADR),CHX)\n CALL WRIHEX(CHHEX,IWS(IADR))\n DO J=1,NBPW\n!...MACHDEP REPLACEMENT OF NON-PRINTABLE ASCII CHARACTERS WITH A PERIOD\n IF(LLT(CHX(J:J),' ') .OR. LGT(CHX(J:J),'~')) CHX(J:J)='.'\n enddo\n WRITE(KOU,110,ERR=911)IADR,IWS(IADR),CHX,CHHEX,X\n110 FORMAT('$',I7,5X,I15,2X,A,2X,A,2X,E15.8)\n111 CALL GPARR_old('NEW VALUE: ',LINE,IP,Z,RNONE,WPHLP)\n! IF(SG2ERR(IERR)) THEN\n!... NOT A DIGIT: EXIT, STORE AS BYTES, OCTAL OR IGNORE\n if(buperr.ne.0) then\n buperr=0\n! CALL RESERR\n IF(LINE(1:1).EQ.'@') GOTO 900\n IF(LINE(1:2).EQ.'EX'.OR.LINE(1:2).EQ.'ex') GOTO 900\n IF(LINE(1:1).EQ.'\"') THEN\n CALL STORC(NBPW,IWS(IADR),LINE(2:))\n IADR=IADR+1\n ELSEIF(LINE(1:1).EQ.'&') THEN\n! OCTAL VALUE\n IP=2\n CALL GETOCT(LINE,IP,IVAL)\n if(buperr.ne.0) then\n buperr=0\n! IF(SG2ERR(IERR)) THEN\n! CALL RESERR\n WRITE(KOU,*)'VALUE AFTER & NOT OCTAL'\n ELSE\n IWS(IADR)=IVAL\n IADR=IADR+1\n ENDIF\n ELSEIF(LINE(1:1).EQ.'#') THEN\n! HEXADECIMAL VALUE\n IP=2\n CALL GETHEX(LINE,IP,IVAL)\n! IF(SG2ERR(IERR)) THEN\n! CALL RESERR\n if(buperr.ne.0) then\n buperr=0\n WRITE(KOU,*)'VALUE AFTER # NOT HEXADECIMAL'\n ELSE\n IWS(IADR)=IVAL\n IADR=IADR+1\n ENDIF\n ELSEIF(EOLCH(LINE,IP)) THEN\n IADR=IADR+1\n ELSE\n WRITE(KOU,20)\n ENDIF\n ELSE\n! DIGIT\n IF(LINE(IP:IP).EQ.'/') THEN\n! NEW ADDRESS\n IADR=INT(Z)\n ELSEIF(INDEX(LINE,'.').GT.0) THEN\n! REAL VALUE\n CALL STORR(1,IWS(IADR),Z)\n IADR=IADR+NWPR\n ELSE\n! INTEGER VALUE\n IWS(IADR)=INT(Z)\n IADR=IADR+1\n ENDIF\n ENDIF\n! SKIP REST OF LINE\n IP=LEN(LINE)\n GOTO 100\n900 CALL WRKCHK(IDUM,NW,IWS)\n RETURN\n911 continue\n GOTO 111\n END SUBROUTINE WPATCH\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wphlp & Help to patch workspace\n!\\begin{verbatim}\n! SUBROUTINE WPHLP(ITYP,LINE)\n SUBROUTINE WPHLP\n!...HELP ROUTINE FOR WPATCH\n implicit none\n! CHARACTER LINE*(*)\n! integer ityp\n!\\end{verbatim} %+\n WRITE(KOU,10)\n10 FORMAT(' YOU MAY PATCH THE WORKSPACE.'/&\n ' THE VALUE AT THE SPECIFIED ADDRESS IN THE WORKSPACE',&\n ' IS DISPLAYED AS'/' INTEGER, CHAR (NON-PRINTABLE',&\n ' CHAR REPLACED BY .) HEXADECIMAL AND REAL.'//&\n ' THE FOLLOWING INPUT IS LEGAL:'/&\n ' VALUE IN NEXT ADDRESS IS DISPLAYED'/&\n ' IS STORED AT THE ADDRESS'/&\n ' A REAL NUMBER MUST INCLUDE A PERIOD (.)'/&\n ' / IS TAKEN AS NEW ADDRESS'/&\n ' & STORED AS OCTAL'/&\n ' # STORED AS HEXADECIMAL'/&\n ' \" STORED AS BYTES',&\n ' (BYTES FOR ONE WORD ONLY)'/&\n ' @ OR EXIT EXIT'/&\n ' ? THIS TEXT'/&\n ' IGNORED'/)\n RETURN\n END SUBROUTINE WPHLP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wrkchk & Check consistency of workspace\n!\\begin{verbatim}\n SUBROUTINE WRKCHK(LAST,NW,IWS)\n!...CHECKS THE FREE LIST IN A WORKSPACE\n! INPUT: NW IS THE DIMENSION\n! IWS IS THE WORKSPACE\n! EXIT: LAST IS PUT TO THE LAST WORD USED IN THE WORKSPACE\n! ERRORS: ANY ERROR IN THE FREE LIST (POINTER OUTSIDE WORKSPACE ETC)\n implicit none\n integer last,nw,iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim} %+\n integer lok,lfr\n IF(NW.LT.100) GOTO 910\n IWS(2)=NW\n!...SERACH THE FREE LIST STARTING IN WORD 1\n! (THERE MUST ALWAYS BE A FREE AREA!)\n LOK=IWS(1)\n!...A FREE AREA MUST LIE BETWEEN 2 AND THE DIMENSION\n100 IF(LOK.LE.2 .OR. LOK.GE.NW) GOTO 920\n LAST=LOK\n LOK=IWS(LOK)\n!...IN THE LAST FREE AREA LOK=0\n IF(LOK.EQ.0) GOTO 200\n!...THE FREE AREAS ARE ALWAYS ORDERD INCREASINGLY\n IF(LOK.LT.LAST+2) GOTO 930\n LFR=IWS(LAST+1)\n!...A FREE AREA IS AT LEAST TWO WORDS AND NOT PAST THE NEXT AREA\n IF(LFR.LT.2 .OR. LAST+LFR.GT.LOK) GOTO 940\n GOTO 100\n!...THE FREE AREA SEEMS CORRECT\n200 LFR=LAST+1\n IWS(LFR)=NW-LFR\n LAST=LFR\n900 RETURN\n910 continue\n buperr=1002\n GOTO 900\n920 continue\n buperr=1003\n GOTO 900\n930 continue \n buperr=1004\n GOTO 900\n940 continue\n buperr=1005\n GOTO 900\n END SUBROUTINE WRKCHK\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wlist & List free list in worspace\n!\\begin{verbatim}\n SUBROUTINE WLIST(IWS)\n!...LISTS THE FREE AREAS\n implicit none\n integer iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim}\n integer n,nw,nwp\n N=1\n NW=0\n WRITE(KOU,10)IWS(2)\n10 FORMAT(/' MAP OF THE FREE SPACE CONTAINING',I12,' WORDS')\n100 N=IWS(N)\n IF(N.LE.0) GOTO 200\n NWP=IWS(N+1)\n NW=NW+NWP\n WRITE(KOU,110)N,NWP\n110 FORMAT(' FROM ',I12,' ARE ',I12,' WORDS FREE')\n GOTO 100\n200 WRITE(KOU,210)NW\n210 FORMAT(/' TOTAL NUMBER OF FREE WORDS ARE',I12/)\n RETURN\n END SUBROUTINE WLIST\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wtrest & Reserve rest of workspace\n!\\begin{verbatim}\n SUBROUTINE WTREST(NYB,NW,IWS)\n!...RESERVES THE LAST PART OF THE WORKSPACE\n! INPUT: IWS IS A WORKSPACE\n! EXIT: NYB IS A POINTER TO THE RESERVED PART\n! NW IS THE NUMBER OF RESERVED WORDS\n implicit none\n integer nyb,nw,iws(*)\n! DIMENSION IWS(*)\n!\\end{verbatim} %+\n integer lok,last\n LOK=1\n100 LAST=LOK\n LOK=IWS(LAST)\n IF(LOK.GT.0) GOTO 100\n NW=IWS(LAST+1)\n CALL WTAKE(NYB,NW,IWS)\n RETURN\n END SUBROUTINE WTREST\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wtake & Reserve a record in workspace\n!\\begin{verbatim}\n SUBROUTINE WTAKE(NYB,NW,IWS)\n!......RESERVS NW WORDS IN THE WORKSPACE\n! INPUT: NW IS THE NUMBER OF WORDS TO BE RESERVED\n! IWS IS THE WORKSPACE\n! EXIT: NYB POINTS TO THE FIRST WORD THAT IS RESERVED\n! ERROR: TOO SMALL OR TOO LARGE NUMBER OF WORDS TO BE RESERVED\n implicit none\n integer nyb,nw,iws(*)\n! DIMENSION IWS(*)\n!...THE FREE LIST START IN THE FIRST WORD\n! IN EACH FREE AREA THE FIRST WORD POINTS TO THE NEXT FREE AREA\n! AND THE SECOND GIVES THE NUMBER OF WORDS IN THIS AREA\n! THE FREE LIST ENDS WITH THE POINTER EQUAL TO ZERO\n!\\end{verbatim} %+\n integer loka,lokb,next\n IF(NW.LT.2) GOTO 910\n LOKB=1\n4 LOKA=IWS(LOKB)\n IF(LOKA.LE.0) GOTO 920\n IF(LOKA.GE.IWS(2)) GOTO 930\n! deleted feature !!! if(X) <0 first label, =0 second label >0 third label\n! IF(IWS(LOKA+1)-NW) 10,20,30\n IF(IWS(LOKA+1)-NW .eq.0) then\n goto 20\n elseif(iws(loka+1)-nw.gt.0) then\n goto 30\n endif\n!...TOO SMALL AREA, CONTINUE WITH THE NEXT\n10 LOKB=LOKA\n GOTO 4\n!...EXACT FIT WITH THE REQUESTED NUMBER OF WORDS\n! IF IWS(LOKA)=0 IT IS THE LAST FREE AREA OF THE WORKSPACE.\n! AS WRELS WILL NOT WORK PROPERLY IF THERE IS NOT A FREE AREA AFTER THE\n! LAST RESERVED A POINTER IS SET. IN WINIT THE SIZE OF THE LAST FREE AREA\n! WAS DECREASED BY TWO TO LEAVE A UNRESERVABLE FREE AREA LAST\n20 IF(IWS(LOKA).GT.0) THEN\n IWS(LOKB)=IWS(LOKA)\n ELSE\n GOTO 31\n ENDIF\n GOTO 50\n!...LARGER AREA THAN REQUESTED\n! A FREE AREA MUST BE AT LEAST TWO WORDS, IF THIS AREA IS AT LEAST\n! TWO WORDS LARGER THAN THE REQUEST IT IS DIVIDED, OTHERWISE SKIPPED\n30 IF(IWS(LOKA+1)-NW-2.LT.0) GOTO 10\n31 NEXT=LOKA+NW\n IWS(NEXT)=IWS(LOKA)\n IWS(NEXT+1)=IWS(LOKA+1)-NW\n IWS(LOKB)=NEXT\n50 NYB=LOKA\n!...THE RESERVED AREA IS ZEROED\n LOKB=NYB+NW-1\n DO LOKA=NYB,LOKB\n IWS(LOKA)=0\n enddo\n900 RETURN\n910 continue\n buperr=1008\n GOTO 900\n920 continue\n buperr=1006\n GOTO 900\n930 continue\n buperr=1007\n GOTO 900\n END SUBROUTINE WTAKE\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine wrels & Release a record in workspace\n!\\begin{verbatim}\n SUBROUTINE WRELS(IDP,NW,IWS)\n!......Returns NW words beginning from IDP to the free workspace list\n! The free workspace list is in increasing order\n! IWS(1) points to the first free space\n! IWS(2) gives the total number of words in the workspace\n implicit none\n! DIMENSION IWS(*)\n integer idp,nw,iws(*)\n!......Check that the released space is at lest 2 words and that it is\n! inside the workspace (That is between 3 and IWS(2))\n!\\end{verbatim}\n integer loka,lokb,lokc\n IF(IDP.LT.3.OR.IDP.GE.IWS(2).OR.NW.LT.2.OR.NW.GE.IWS(2)) GOTO 910\n LOKC=IDP\n LOKB=1\n100 LOKA=LOKB\n LOKB=IWS(LOKA)\n IF(LOKB.LE.0) GOTO 920\n IF(LOKB.LT.LOKC) GOTO 100\n!..LOKA is the address of the nearest free space below LOKC\n IF(LOKA.EQ.1) GOTO 120\n!..Check if the two areas can be merged\n! IF(LOKA+IWS(LOKA+1)-LOKC) 120,110,930\n IF(LOKA+IWS(LOKA+1)-LOKC .lt.0) then\n goto 120\n ELSEIF(LOKA+IWS(LOKA+1)-LOKC .gt.0) then\n goto 930\n endif\n!..The released space follows directly on LOKA => Merge LOKA and LOKC\n LOKC=LOKA\n IWS(LOKC+1)=IWS(LOKC+1)+NW\n GOTO 130\n!..Set the pointer from LOKC to LOKB and from LOKA to LOKC\n120 IWS(LOKC)=LOKB\n IWS(LOKA)=LOKC\n IWS(LOKC+1)=NW\n!..Check if LOKC now can be merged with LOKB!\n! deleted fetaure\n!130 IF(LOKC+IWS(LOKC+1)-LOKB) 900,140,940\n130 continue\n IF(LOKC+IWS(LOKC+1)-LOKB .lt.0) then\n goto 900\n elseif(LOKC+IWS(LOKC+1)-LOKB.gt.0) then\n goto 940\n endif\n!..Merge LOKC and LOKB\n IWS(LOKC)=IWS(LOKB)\n IWS(LOKC+1)=IWS(LOKC+1)+IWS(LOKB+1)\n900 RETURN\n!...ERRORS\n! TOO SMALL OR OUTSIDE WORKSPACE\n910 buperr=1008\n GOTO 900\n! ABOVE HIGHEST FREE WORKSPACE\n920 buperr=1008\n GOTO 900\n! FIRST PART ALREADY FREE\n930 GOTO 920\n! LAST PART ALREADY FREE\n940 GOTO 920\n END SUBROUTINE WRELS\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable integer function nwch & Number of words to store a character\n!\\begin{verbatim}\n INTEGER FUNCTION NWCH(NB)\n! number of words to store a character with nb bytes\n! nbpw is the number of bytes in a word. If not even multiple add 1 word\n implicit none\n integer nb\n!\\end{verbatim} %+\n integer i\n i=nb/nbpw\n if(mod(nb,nbpw).gt.0) then\n i=i+1\n endif\n nwch=i\n return\n end FUNCTION NWCH\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine storc & Store a character in workspace\n!\\begin{verbatim}\n SUBROUTINE STORC(N,IWS,text)\n! Stores a text character in an integer workspace at position N\n! The length of the character to store is len(text)\n!\\end{verbatim} %+\n implicit none\n integer n,iws(*)\n character text*(*)\n! maximal size of character, note used also to store functions and bibliography\n integer, parameter :: maxchar=2048,maxequiv=512\n! NOTE BELOW DIMENSIONING BLEOW, maxchar=nbpw*maxequiv\n! character (len=:), allocatable :: localtxt\n! integer, allocatable, dimension(:) :: localint\n character*(maxchar) localtxt\n! assumed 32 bit integres, 8 bits/character, 4 characters/word =nbpw\n integer llen,j,now\n integer localint(maxequiv)\n! equivalence can only be made between local unallocated variables\n equivalence (localtxt,localint)\n! equivalence (localtxt2,localint2)\n if(maxchar.ne.nbpw*maxequiv) then\n write(*,*)'METLIB utility error: maxchar and maxequiv do not match'\n stop\n endif\n llen=len(text)\n if(llen.gt.maxchar) then\n write(*,*)'Cannot store texts larger than ',maxchar,' characters'\n buperr=1010; goto 900\n endif\n! due to the equivalence this stores the character bit map into localint2 !!\n! the localtext will be padded with spaces after text\n localtxt=text\n! number of words to store rounding off?? integers are 4 bytes (32 bits)\n now=nwch(llen)\n do j=1,now\n iws(n+j-1)=localint(j)\n enddo\n! localint2=localint\n! write(*,800)llen,now,text(1:llen),localtxt(1:llen),localtxt2(1:llen)\n!800 format('storc: ',2i4,3('\"',a),'\"')\n900 continue\n return\n end SUBROUTINE STORC\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine loadc & Load a character from workspace\n!\\begin{verbatim}\n SUBROUTINE LOADC(N,IWS,text)\n! copies a text from an integer workspace at position N into a character\n! The number of characters to copy is len(text)\n implicit none\n integer n,iws(*)\n character text*(*)\n! character (len=:), allocatable :: localtxt\n! integer, allocatable, dimension(:) :: localint\n! maximal size of character, note used also to store functions and bibliography\n!\\end{verbatim} %+\n integer, parameter :: maxchar=2048,maxequiv=512\n! NOTE BELOW DIMENSIONING BELOW, maxchar=nbpw*maxequiv\n character*(maxchar) localtxt\n! assumed 32 bit integer, 8 bits character, 4 characters/word\n integer llen,j,now\n integer localint(maxequiv)\n! equivalence can obly be made between local unallocated variables\n equivalence (localtxt,localint)\n llen=len(text)\n if(llen.gt.maxchar) then\n write(*,*)'Attempt to extract a text larger than ',maxchar\n buperr=1010;; goto 900\n endif\n now=nwch(llen)\n do j=1,now\n localint(j)=iws(n+j-1)\n enddo\n! write(*,800)llen,now,localtxt(1:llen)\n!800 format('LOADC: ',2i3,' \"',a,'\"')\n text=localtxt(1:llen)\n900 continue\n return\n end SUBROUTINE LOADC\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine storr & Store a double in workspace\n!\\begin{verbatim}\n SUBROUTINE STORR(N,IWS,VALUE)\n!...STORES A REAL NUMBER IN A WORKSPACE at index N\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n! DIMENSION IWS(*)\n implicit none\n integer iws(*)\n double precision value\n integer n\n!\\end{verbatim} %+\n INTEGER JWS(2),int(2)\n DOUBLE PRECISION WS,aws\n EQUIVALENCE (WS,JWS),(int,aws)\n! move the exact bit pattern from real VALUE to integer IWS(N)\n WS=VALUE\n IWS(N)=JWS(1)\n IWS(N+1)=JWS(2)\n! int=jws\n! write(*,17)value,ws,aws\n!17 format('storr: ',3(1pe14.6),/10x,4i14)\n RETURN\n END SUBROUTINE STORR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine loadr & Load a double from workspace\n!\\begin{verbatim}\n SUBROUTINE LOADR(N,IWS,VALUE)\n!...LOADS A REAL NUMBER FROM A WORKSPACE at index N\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n integer iws(*)\n! DIMENSION IWS(*)\n DOUBLE PRECISION VALUE\n integer N\n!\\end{verbatim} %+\n DOUBLE PRECISION WS\n INTEGER JWS(2)\n EQUIVALENCE (WS,JWS)\n! move the exact bit pattern from integer IWS(N) to real VALUE\n JWS(1)=IWS(N)\n JWS(2)=IWS(N+1)\n VALUE=WS\n RETURN\n END SUBROUTINE LOADR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine storrn & Store N doubles in workspace\n!\\begin{verbatim}\n SUBROUTINE STORRN(N,IWS,ARR)\n! store N doubles in workspace\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n! DIMENSION IWS(*),ARR(*)\n integer n,iws(*)\n double precision arr(*)\n!\\end{verbatim} %+\n integer, parameter :: maxr=256\n double precision dlocal(maxr)\n integer ilocal(maxr*nwpr)\n integer i\n equivalence (dlocal,ilocal)\n! if(n.gt.256) then\n if(n.gt.512) then\n write(*,*)'M4 STORRN cannot handle arrays larger than ',maxr,n\n buperr=1010; goto 900\n endif\n do i=1,n\n dlocal(i)=arr(i)\n enddo\n DO I=1,N*nwpr\n iws(I)=ilocal(I)\n enddo\n900 continue\n RETURN\n END SUBROUTINE STORRN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine loadrn & Load N doubles frm workspace\n!\\begin{verbatim}\n SUBROUTINE LOADRN(N,IWS,ARR)\n! load N doubles from workspace\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n double precision ARR(*)\n integer n,iws(*)\n integer, parameter :: maxr=256\n double precision dlocal(maxr)\n!\\end{verbatim} %+\n integer ilocal(maxr*nwpr)\n integer i\n equivalence (dlocal,ilocal)\n if(n.gt.256) then\n write(*,*)'LOADRN cannot handle arrays larger than ',maxr\n buperr=1010; goto 900\n endif\n do i=1,n*nwpr\n ilocal(i)=iws(i)\n enddo\n DO I=1,N\n ARR(I)=dlocal(I)\n enddo\n900 continue\n RETURN\n END SUBROUTINE LOADRN\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine storr1 & Store 1 double at current position\n!\\begin{verbatim}\n SUBROUTINE STORR1(ARR,VAL)\n! store a single double in workspace\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n double precision arr,val\n!\\end{verbatim} %+\n ARR=VAL\n RETURN\n END SUBROUTINE STORR1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable subroutine loadr1 & Load 1 double from current position\n!\\begin{verbatim}\n SUBROUTINE LOADR1(ARR,VAL)\n! load a single double from workspace\n! IMPLICIT DOUBLE PRECISION (A-H,O-Z)\n implicit none\n double precision arr,val\n!\\end{verbatim}\n VAL=ARR\n RETURN\n END SUBROUTINE LOADR1\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! 2D matrix indexing\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function ixsym & Index 2D array stored as upper triangle \n!\\begin{verbatim}\n integer function ixsym(ix1,ix2)\n! calculates the storage place of value at (i,j) for a symmetrix matrix\n! storage order 11, 12, 22, 13, 23, 33, etc\n implicit none\n integer ix1,ix2\n!\\end{verbatim} %+\n! integer, save :: ncall=0, mcall=0\n! integer, allocatable, dimension(:) :: bug\n! at a testing ncall=24623, mcall=507127\n! if(ix1.le.ix2) then\n! mcall=mcall+1\n! else\n! write(*,*)'Indices order',ncall,mcall,ix1,ix2\n! ncall=ncall+1\n! endif\n if(ix1.le.0 .or. ix2.le.0) then\n ixsym=0; buperr=1000; goto 1000\n endif\n if(ix1.gt.ix2) then\n ixsym=ix2+ix1*(ix1-1)/2\n else\n ixsym=ix1+ix2*(ix2-1)/2\n endif\n1000 continue\n return\n end function ixsym\n\n!\\addtotable integer function kxsym & Index 2D array stored as upper triangle\n!\\begin{verbatim}\n integer function kxsym(ix1,ix2)\n! calculates the storage place of value at (i,j) for a symmetrix matrix\n! storage order 11, 12, 22, 13, 23, 33, etc\n! In OC the calls to ixsym take about 10 % of the CPU time\n! I am trying to replace with local indexing but I need a routine\n! that calculates the index when both indices are equal or when I know\n! the second index is larger\n! if(ix1.le.0 .or. ix2.le.0) then\n! buperr=1000; goto 1000\n! endif\n implicit none\n integer ix1,ix2\n!\\end{verbatim}\n! this if should be removed when all works\n if(ix1.gt.ix2) stop \"Illegal call to kxsym\"\n kxsym=ix1+ix2*(ix2-1)/2\n return\n end function kxsym\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n!\n! >>>> subsection\n! miscaleneous\n!\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n \n!\\addtotable subroutine fxdflt & Add file extension\n!\\begin{verbatim}\n subroutine fxdflt(file,ext)\n! add default file extention, no good as it thinks .. is an externtion\n implicit none\n character file*(*),ext*(*)\n!\\end{verbatim} %+\n integer kx\n if(len_trim(file).gt.0) then\n kx=index(file,'.')\n if(kx.le.0) then\n kx=len_trim(file)\n file(kx+1:)='.'//ext\n elseif(kx.lt.len(file)) then\n if(file(kx:kx+1).eq.'..') then\n kx=len_trim(file)\n file(kx+1:)='.'//ext\n endif\n endif\n else\n write(*,*)'No file name'\n file=' '\n endif\n return\n end subroutine fxdflt\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine iniio & Initiate I/O variables\n!\\begin{verbatim}\n subroutine iniio\n! initiates i/o variables, they are all global variables\n implicit none\n!\\end{verbatim} %+\n kou=koud\n kiu=kiud\n ler=lerd\n iox=0\n return\n end subroutine iniio\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine fisepa & Find separator\n!\\begin{verbatim}\n SUBROUTINE FISEPA(STR,IP0,IP1)\n!...FINDS A SEPARATOR AFTER POSITION IP0\n! A separator is:\n! Any character exept A-Z, 0-9 and _\n implicit none\n CHARACTER STR*(*)\n integer IP0,IP1\n!\\end{verbatim} %+\n CHARACTER CH1*1\n integer l\n L=LEN_TRIM(STR)\n IP1=IP0\n100 IP1=IP1+1\n IF(IP1.GT.L) GOTO 900\n CH1=BIGLET(STR(IP1:IP1))\n IF((LGE(CH1,'0') .AND. LLE(CH1,'9')) .OR. &\n (LGE(CH1,'A') .AND. LLE(CH1,'Z')) .OR. CH1.EQ.'_') GOTO 100\n!...Return position before separator\n IP1=IP1-1\n900 RETURN\n END SUBROUTINE FISEPA\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine fdmtp & Find matching )\n!\\begin{verbatim}\n SUBROUTINE FDMTP(LINE1,IP,LINE2)\n!...FINDS A MATCHING ) AFTER THAT AT IP. IP UPDATED TO POSITION AFTER )\n implicit none\n CHARACTER LINE1*(*),LINE2*(*)\n integer ip\n!\\end{verbatim} %+\n integer jp,np,kp1,kp2\n IF(IP.LE.0) GOTO 900\n JP=IP+1\n!...np is number of inner levels of parenthesis\n NP=0\n10 KP1=INDEX(LINE1(JP:),'(')\n KP2=INDEX(LINE1(JP:),')')\n IF(KP1.EQ.0) THEN\n IF(NP.EQ.0) GOTO 100\n NP=NP-1\n IF(KP2.EQ.0) GOTO 910\n JP=JP+KP2\n ELSEIF(KP1.LT.KP2) THEN\n!...INNER PAIR OF ()\n JP=JP+KP1\n NP=NP+1\n ELSEIF(KP1.GT.KP2) THEN\n IF(NP.EQ.0) GOTO 100\n NP=NP-1\n IF(KP2.EQ.0) GOTO 910\n JP=JP+KP2\n ELSE\n! STOP 'FDMTP'\n buperr=1237\n goto 900\n ENDIF\n GOTO 10\n!...LINE2 SET TO TEXT INSIDE ( ), IP UPDATED TO POSITION BEHIND )\n100 IF(KP2.EQ.0) GOTO 920\n LINE2=LINE1(IP+1:JP+KP2-2)\n IP=JP+KP2\n900 RETURN\n!910 CALL ST2ERR(1235,'FDMTP','TOO MANY (')\n910 buperr=1235\n GOTO 900\n!920 CALL ST2ERR(1235,'FDMTP','NO MATCHING )')\n920 buperr=1236\n GOTO 900\n END SUBROUTINE FDMTP\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable integer function kndex & Find substring from current position\n!\\begin{verbatim}\n INTEGER FUNCTION KNDEX(LINE,IP,SS)\n! SUBROUTINE KNDEX\n!...SEARCHES FOR STRING SS IN LINE FROM IP\n implicit none\n CHARACTER LINE*(*),SS*(*)\n integer ip\n!\\end{verbatim} %+\n integer k\n K=INDEX(LINE(IP:),SS)\n IF(K.GT.0) K=IP-1+K\n KNDEX=K\n RETURN\n END FUNCTION KNDEX\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine cpsstr & Remove tabs and multiple spaces\n!\\begin{verbatim}\n SUBROUTINE CPSSTR(STRING,LC)\n!...THIS SUBROUINE COMPRESSES STRING BY REPLACING MULTIPLE SPACES\n!\tOR TABS WITH A SINGLE SPACE\n implicit none\n CHARACTER STRING*(*)\n integer LC\n!\\end{verbatim} %+\n integer i,k,l\n CALL UNTAB(STRING)\n10 K=INDEX(STRING(1:LC),' ')\n IF(K.GT.0) THEN\n L=K\n IF(EOLCH(STRING(1:LC),L)) THEN\n LC=K-1\n GOTO 900\n ENDIF\n L=L-K-1\n LC=LC-L\n REMSP: DO I=K+1,LC\n STRING(I:I)=STRING(I+L:I+L)\n enddo REMSP\n STRING(LC+1:)=' '\n GOTO 10\n ENDIF\n900 RETURN\n END SUBROUTINE CPSSTR\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine untab & Remove tab characters\n!\\begin{verbatim}\n SUBROUTINE UNTAB(LINE)\n!...REMOVES ALL TABS FROM LINE. INSERTS SPACES UP TO NEXT TAB STOP\n! TAB STOPS GIVEN IN ITABS. TABS AFTER POSITION 80 REPLACED\n! WITH A SPACE\n implicit none\n CHARACTER LINE*(*)\n!\\end{verbatim}\n CHARACTER CHTAB*1,XLINE*128\n integer ITABS(11)\n DATA ITABS/8,16,24,32,40,48,56,64,72,80,81/\n integer k,i\n! \n CHTAB=CHAR(9)\n100 XLINE=LINE\n K=INDEX(XLINE,CHTAB)\n IF(K.GT.0) THEN\n ADDSP: DO I=1,10\n IF(ITABS(I).GE.K) GOTO 120\n enddo ADDSP\n!...BEYOND POSITION 80\n I=11\n ITABS(11)=K\n120 I=ITABS(I)\n LINE(K:I)=' '\n LINE(I+1:)=XLINE(K+1:)\n GOTO 100\n ENDIF\n RETURN\n END SUBROUTINE UNTAB\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\n!\\addtotable subroutine incnum\n!\\begin{verbatim}\n SUBROUTINE INCNUM(NUMB)\n!...increments the number in character NUMB by 1, if >9 set to 0\n! and increment precedent number \n! if first number >9 set all to zero.\n implicit none\n CHARACTER numb*(*)\n!\\end{verbatim}\n integer clen,ipos,idig,czero\n czero=ichar('0')\n clen=len(numb)\n ipos=clen\n loop: do while(ipos.gt.0)\n idig=ichar(numb(ipos:ipos))-czero\n if(idig.eq.9) then\n numb(ipos:ipos)='0'\n ipos=ipos-1\n else\n numb(ipos:ipos)=char(czero+idig+1)\n exit loop\n endif\n enddo loop\n!1000 continue\n return\n end SUBROUTINE INCNUM\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\\n\n!\\addtotable logical function compare_abbrev\n!\\begin{verbatim} %-\n logical function compare_abbrev(name1,name2)\n! returns TRUE if name1 is an abbreviation of name2\n! termintaes when a space is found in name1\n! each part between _ or - can be abbreviated from the left\n! a slash is treated as _\n! case insensitive. Only 36 first characters compared\n implicit none\n character*(*) name1,name2 \n!\\end{verbatim}\n integer, parameter :: maxl=36\n integer jp,ip,noabbr\n character ch1*1\n character (len=maxl) :: lname1,lname2\n lname1=name1; lname2=name2\n call capson(lname1)\n call capson(lname2)\n compare_abbrev=.FALSE.\n noabbr=0\n jp=1\n bigloop: do ip=1,36\n ch1=lname1(ip:ip)\n if(ip.gt.1 .and. ch1.eq.' ') goto 900\n! in species - has a special meaning of charge (and other things)\n if(ch1.eq.'-') then\n if(ch1.eq.lname2(jp:jp)) goto 300\n ch1='_'\n endif\n! in species / has a special meaning of cluster\n! if(ch1.eq.'/') then\n! if(ch1.eq.lname2(jp:jp)) goto 300\n! write(*,*)'3Z accepting /'\n! endif\n if(ch1.eq.lname2(jp:jp)) goto 300\n! if(ch1.eq.'_' .or. ch1.eq.'-') then\n if(ch1.eq.'_') then\n! we can abbreviate up to \"_\" in full name\n200 continue\n if(jp.eq.maxl) goto 1000\n jp=jp+1\n if(lname2(jp:jp).eq.'_') goto 300\n if(lname2(jp:jp).eq.' ') goto 1000\n goto 200\n endif\n goto 1000\n300 continue\n jp=jp+1\n!310 continue\n enddo bigloop\n900 continue\n compare_abbrev=.TRUE.\n1000 continue\n return\n end function compare_abbrev\n\n!/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\/!\\\n\n!\\addtotable subroutine replacetab\n!\\begin{verbatim} %-\n subroutine replacetab(line,nl)\n! replaces TAB by space in line\n implicit none\n character line*(*)\n integer nl\n!\\end{verbatim}\n integer ip\n100 continue\n ip=index(line,char(9))\n if(ip.gt.0) then\n line(ip:ip)=' '\n nl=ip\n! write(*,*)'Replaced TAB by space on line ',nl\n goto 100\n endif\n!1000 continue\n return\n end subroutine replacetab\n\n!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/!\\!/\n\nEND MODULE METLIB\n" } ]